From b8f9498f839c318ae94ceb11988c47e057f42d52 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 9 May 2014 20:35:13 +0200 Subject: [PATCH] Fix reading of older Cabal `setup-config`s --- Language/Haskell/GhcMod/Cabal16.hs | 13 +++ Language/Haskell/GhcMod/Cabal18.hs | 7 ++ Language/Haskell/GhcMod/CabalApi.hs | 93 +------------------ Language/Haskell/GhcMod/CabalConfig.hs | 118 +++++++++++++++++++++++++ ghc-mod.cabal | 3 + test/CabalApiSpec.hs | 7 -- 6 files changed, 145 insertions(+), 96 deletions(-) create mode 100644 Language/Haskell/GhcMod/Cabal16.hs create mode 100644 Language/Haskell/GhcMod/Cabal18.hs create mode 100644 Language/Haskell/GhcMod/CabalConfig.hs diff --git a/Language/Haskell/GhcMod/Cabal16.hs b/Language/Haskell/GhcMod/Cabal16.hs new file mode 100644 index 0000000..e2a65e6 --- /dev/null +++ b/Language/Haskell/GhcMod/Cabal16.hs @@ -0,0 +1,13 @@ +-- | ComponentLocalBuildInfo for Cabal <= 1.16 +module Language.Haskell.GhcMod.Cabal16 ( + ComponentLocalBuildInfo + , componentPackageDeps + ) where + +import Distribution.Package (InstalledPackageId, PackageIdentifier) + +-- From Cabal <= 1.16 +data ComponentLocalBuildInfo = ComponentLocalBuildInfo { + componentPackageDeps :: [(InstalledPackageId, PackageIdentifier)] + } + deriving (Read, Show) diff --git a/Language/Haskell/GhcMod/Cabal18.hs b/Language/Haskell/GhcMod/Cabal18.hs new file mode 100644 index 0000000..e30433a --- /dev/null +++ b/Language/Haskell/GhcMod/Cabal18.hs @@ -0,0 +1,7 @@ +-- | ComponentLocalBuildInfo for Cabal >= 1.18 +module Language.Haskell.GhcMod.Cabal18 ( + ComponentLocalBuildInfo + , componentPackageDeps + ) where + +import Distribution.Simple.LocalBuildInfo (ComponentLocalBuildInfo(..)) diff --git a/Language/Haskell/GhcMod/CabalApi.hs b/Language/Haskell/GhcMod/CabalApi.hs index 96b8508..ef44e8f 100644 --- a/Language/Haskell/GhcMod/CabalApi.hs +++ b/Language/Haskell/GhcMod/CabalApi.hs @@ -7,13 +7,12 @@ module Language.Haskell.GhcMod.CabalApi ( , cabalDependPackages , cabalSourceDirs , cabalAllTargets - , cabalGetConfig - , cabalConfigPath , cabalConfigDependencies ) where import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.GhcPkg +import Language.Haskell.GhcMod.CabalConfig import Language.Haskell.GhcMod.Utils import Control.Applicative ((<$>)) @@ -39,13 +38,14 @@ import Distribution.Simple.Program (ghcProgram) import Distribution.Simple.Program.Types (programName, programFindVersion) import Distribution.Simple.BuildPaths (defaultDistPref) import Distribution.Simple.Configure (localBuildInfoFile) -import Distribution.Simple.LocalBuildInfo (ComponentLocalBuildInfo(..), ComponentName) +import Distribution.Simple.LocalBuildInfo (ComponentName) import Distribution.System (buildPlatform) import Distribution.Text (display) import Distribution.Verbosity (silent) import Distribution.Version (Version) import System.Directory (doesFileExist) import System.FilePath (()) +import Text.Read (readMaybe) ---------------------------------------------------------------- -- | Getting necessary 'CompilerOptions' from three information sources. @@ -55,7 +55,7 @@ getCompilerOptions :: [GHCOption] -> IO CompilerOptions getCompilerOptions ghcopts cradle pkgDesc = do gopts <- getGHCOptions ghcopts cradle rdir $ head buildInfos - depPkgs <- cabalConfigDependencies (C.packageId pkgDesc) <$> cabalGetConfig cradle + depPkgs <- cabalConfigDependencies cradle (C.packageId pkgDesc) return $ CompilerOptions gopts idirs depPkgs where wdir = cradleCurrentDir cradle @@ -205,88 +205,3 @@ cabalAllTargets pd = do getExecutableTarget exe = do let maybeExes = [p e | p <- P.hsSourceDirs $ P.buildInfo exe, e <- [P.modulePath exe]] liftIO $ filterM doesFileExist maybeExes - ----------------------------------------------------------------- - -type CabalConfig = String - --- | Get file containing 'LocalBuildInfo' data. If it doesn't exist run @cabal --- configure@ i.e. configure with default options like @cabal build@ would do. -cabalGetConfig :: Cradle -> IO CabalConfig -cabalGetConfig cradle = - readFile path `E.catch` (\(SomeException _) -> configure >> readFile path) - where - prjDir = cradleRootDir cradle - path = prjDir cabalConfigPath - configure = - withDirectory_ prjDir $ readProcess' "cabal" ["configure"] - - --- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@ -cabalConfigPath :: FilePath -cabalConfigPath = localBuildInfoFile defaultDistPref - -cabalConfigDependencies :: PackageIdentifier -> CabalConfig -> [Package] -cabalConfigDependencies thisPkg config = cfgDepends - where - pids :: [InstalledPackageId] - pids = let - mps = map fst <$> (components18 thisPkg `mplus` components16 thisPkg) - in case mps of - Just ps -> ps - Nothing -> errorExtract - cfgDepends = filter (("inplace" /=) . pkgId) - $ fromInstalledPackageId <$> pids - - errorExtract = error $ - "cabalConfigDependencies: Error extracting dependencies from setup-config" - - -- Cabal 1.18 - components18 :: PackageIdentifier - -> Maybe [(InstalledPackageId,PackageIdentifier)] - components18 _ = - concatMap (componentPackageDeps . lbi) - <$> extractCabalSetupConfig config "componentsConfigs" - - lbi :: (ComponentName, ComponentLocalBuildInfo, [ComponentName]) - -> ComponentLocalBuildInfo - lbi (_,i,_) = i - - -- Cabal 1.16 and below - components16 :: PackageIdentifier - -> Maybe [(InstalledPackageId,PackageIdentifier)] - components16 thisPkg' = filter (not . internal . snd) . nub <$> do - cbi <- concat <$> sequence [ extract "executableConfigs" - , extract "testSuiteConfigs" - , extract "benchmarkConfigs" ] - :: Maybe [(String, ComponentLocalBuildInfo)] - - return $ maybe [] componentPackageDeps libraryConfig - ++ concatMap (componentPackageDeps . snd) cbi - where - -- True if this dependency is an internal one (depends on the library - -- defined in the same package). - internal pkgid = pkgid == thisPkg' - - libraryConfig :: Maybe ComponentLocalBuildInfo - libraryConfig = do - field <- find ("libraryConfig" `isPrefixOf`) (tails config) - clbi <- stripPrefix " = " field - if "Nothing" `isPrefixOf` clbi - then Nothing - else read <$> stripPrefix "Just " clbi - - extract :: Read r => String -> Maybe r - extract field = extractCabalSetupConfig config field - --- | Extract part of cabal's @setup-config@, this is done with a mix of manual --- string processing and use of 'read'. This way we can extract a field from --- 'LocalBuildInfo' without having to parse the whole thing which would mean --- depending on the exact version of Cabal used to configure the project as it --- is rather likley that some part of 'LocalBuildInfo' changed. --- --- Right now 'extractCabalSetupConfig' can only deal with Lists and Tuples in --- the field! -extractCabalSetupConfig :: (Read r) => CabalConfig -> String -> Maybe r -extractCabalSetupConfig config field = do - read <$> extractParens <$> find (field `isPrefixOf`) (tails config) diff --git a/Language/Haskell/GhcMod/CabalConfig.hs b/Language/Haskell/GhcMod/CabalConfig.hs new file mode 100644 index 0000000..f22b4df --- /dev/null +++ b/Language/Haskell/GhcMod/CabalConfig.hs @@ -0,0 +1,118 @@ +-- | Reading cabal @dist/setup-config@ +module Language.Haskell.GhcMod.CabalConfig ( + CabalConfig + , cabalConfigDependencies + ) where + +import Language.Haskell.GhcMod.GhcPkg +import Language.Haskell.GhcMod.Utils +import Language.Haskell.GhcMod.Types + +import qualified Language.Haskell.GhcMod.Cabal16 as C16 +import qualified Language.Haskell.GhcMod.Cabal18 as C18 + +import qualified Control.Exception as E +import Control.Applicative ((<$>)) +import Control.Monad (filterM,mplus) +import Control.Monad.Error () +import Data.Maybe () +import Data.Set () +import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix) +import Distribution.Package (PackageName(PackageName) + , InstalledPackageId(..) + , PackageIdentifier) +import qualified Distribution.Package as C +import Distribution.Simple.BuildPaths (defaultDistPref) +import Distribution.Simple.Configure (localBuildInfoFile) +import Distribution.Simple.LocalBuildInfo (ComponentName) +import System.FilePath (()) +import Text.Read (readMaybe) +---------------------------------------------------------------- + +type CabalConfig = String + +-- | Get file containing 'LocalBuildInfo' data. If it doesn't exist run @cabal +-- configure@ i.e. configure with default options like @cabal build@ would do. +getConfig :: Cradle -> IO CabalConfig +getConfig cradle = + readFile path `E.catch` (\(E.SomeException _) -> configure >> readFile path) + where + prjDir = cradleRootDir cradle + path = prjDir configPath + configure = + withDirectory_ prjDir $ readProcess' "cabal" ["configure"] + + +-- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@ +configPath :: FilePath +configPath = localBuildInfoFile defaultDistPref + +cabalConfigDependencies :: Cradle -> PackageIdentifier -> IO [Package] +cabalConfigDependencies cradle thisPkg = + configDependencies thisPkg <$> getConfig cradle + +configDependencies :: PackageIdentifier -> CabalConfig -> [Package] +configDependencies thisPkg config = map fromInstalledPackageId deps + where + deps :: [InstalledPackageId] + deps = case (deps18 `mplus` deps16) of + Right ps -> ps + Left msg -> error msg + +-- errorExtract = error $ +-- "cabalConfigDependencies: Error extracting dependencies from setup-config" + + -- Cabal >= 1.18 + deps18 :: Either String [InstalledPackageId] + deps18 = + concatMap (map fst . C18.componentPackageDeps . lbi) + <$> (readEither =<< extractField config "componentsConfigs") + + lbi :: (ComponentName, C18.ComponentLocalBuildInfo, [ComponentName]) + -> C18.ComponentLocalBuildInfo + lbi (_,i,_) = i + + -- Cabal 1.16 and below + deps16 :: Either String [InstalledPackageId] + deps16 = map fst <$> filter (not . internal . snd) . nub <$> do + cbi <- concat <$> sequence [ extract "executableConfigs" + , extract "testSuiteConfigs" + , extract "benchmarkConfigs" ] + :: Either String [(String, C16.ComponentLocalBuildInfo)] + + return $ maybe [] C16.componentPackageDeps libraryConfig + ++ concatMap (C16.componentPackageDeps . snd) cbi + where + -- True if this dependency is an internal one (depends on the library + -- defined in the same package). + internal pkgid = pkgid == thisPkg + + libraryConfig :: Maybe C16.ComponentLocalBuildInfo + libraryConfig = do + field <- find ("libraryConfig" `isPrefixOf`) (tails config) + clbi <- stripPrefix " = " field + if "Nothing" `isPrefixOf` clbi + then Nothing + else case readMaybe <$> stripPrefix "Just " clbi of + Just x -> x + Nothing -> error $ "reading libraryConfig failed\n" ++ show (stripPrefix "Just " clbi) + + extract :: String -> Either String [(String, C16.ComponentLocalBuildInfo)] + extract field = readConfigs field <$> extractField config field + + readConfigs :: String -> String -> [(String, C16.ComponentLocalBuildInfo)] + readConfigs f s = case readMaybe s of + Just x -> x + Nothing -> error $ "reading config " ++ f ++ " failed" + + +readEither :: Read r => String -> Either String r +readEither s = case readMaybe s of + Just x -> Right x + Nothing -> Left $ "read: failed on input:\n" ++ s + +extractField :: CabalConfig -> String -> Either String String +extractField config field = + case extractParens <$> find (field `isPrefixOf`) (tails config) of + Just f -> Right f + Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` config) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 77b2983..c043128 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -58,6 +58,9 @@ Library Other-Modules: Language.Haskell.GhcMod.Boot Language.Haskell.GhcMod.Browse Language.Haskell.GhcMod.CabalApi + Language.Haskell.GhcMod.CabalConfig + Language.Haskell.GhcMod.Cabal16 + Language.Haskell.GhcMod.Cabal18 Language.Haskell.GhcMod.Check Language.Haskell.GhcMod.Cradle Language.Haskell.GhcMod.Debug diff --git a/test/CabalApiSpec.hs b/test/CabalApiSpec.hs index 46b6b8e..d7b1d13 100644 --- a/test/CabalApiSpec.hs +++ b/test/CabalApiSpec.hs @@ -60,10 +60,3 @@ spec = do it "extracts build info" $ do info <- cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal" show info `shouldBe` "[BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\".\"], otherModules = [ModuleName [\"Browse\"],ModuleName [\"CabalApi\"],ModuleName [\"Cabal\"],ModuleName [\"CabalDev\"],ModuleName [\"Check\"],ModuleName [\"ErrMsg\"],ModuleName [\"Flag\"],ModuleName [\"GHCApi\"],ModuleName [\"GHCChoice\"],ModuleName [\"Gap\"],ModuleName [\"Info\"],ModuleName [\"Lang\"],ModuleName [\"Lint\"],ModuleName [\"List\"],ModuleName [\"Paths_ghc_mod\"],ModuleName [\"Types\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [(GHC,[\"-Wall\"])], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []}))),Dependency (PackageName \"template-haskell\") AnyVersion]},BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\"test\",\".\"], otherModules = [ModuleName [\"Expectation\"],ModuleName [\"BrowseSpec\"],ModuleName [\"CabalApiSpec\"],ModuleName [\"FlagSpec\"],ModuleName [\"LangSpec\"],ModuleName [\"LintSpec\"],ModuleName [\"ListSpec\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []})))]}]" - - describe "cabalGetConfig" $ do - it "can reconfigure a cabal package" $ do - withDirectory_ "test/data/check-test-subdir" $ do - cradle <- findCradle - cfg <- cabalGetConfig cradle - cfg `shouldSatisfy` not . null