diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ [![Build Status](https://secure.travis-ci.org/bennofs/dynamic-cabal.png?branch=master)](http://travis-ci.org/bennofs/dynamic-cabal) -If you've ever used Cabal together with the GHC-API, you know the problem. Because GHC depends on a version of Cabal, which is often outdated, there is no way to parse the setup-config file generated by newer cabal versions. This library attemps to solve the problem by dynamically generting code that performs the action you want, and then compiling and loading that with GHC. With this method, you don't need to depend on Cabal at compile time and so you can use any version of Cabal. +If you've ever used Cabal together with the GHC-API, you know the problem. Because GHC depends on a version of Cabal, which is often outdated, there is no way to parse the setup-config file generated by newer cabal versions. This library attemps to solve the problem by dynamically generating code that performs the action you want, and then compiling and loading that with GHC. With this method, you don't need to depend on Cabal at compile time and so you can use any version of Cabal. ## Usage diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -47,7 +47,7 @@ modifyIORef depsVar $ appendDL . singletonDL $ depsEntry (buildInfo exe) exelbi suitelbi deps <- fmap ($ []) $ readIORef depsVar - rewriteFile (map fixchar $ dir "Build_" ++ testName suite ++ ".hs") $ unlines + rewriteFile (dir (map fixchar $ "Build_" ++ testName suite ++ ".hs")) $ unlines [ "module Build_" ++ map fixchar (testName suite) ++ " where" , "getDistDir :: FilePath" , "getDistDir = " ++ show distDir diff --git a/dynamic-cabal.cabal b/dynamic-cabal.cabal --- a/dynamic-cabal.cabal +++ b/dynamic-cabal.cabal @@ -1,5 +1,5 @@ name: dynamic-cabal -version: 0.1 +version: 0.2 license: BSD3 category: Distribution cabal-version: >= 1.10 @@ -13,7 +13,6 @@ synopsis: dynamic-cabal description: dynamic-cabal build-type: Custom - extra-source-files: .ghci .gitignore @@ -57,6 +56,8 @@ , tasty-hunit , HUnit , tasty-th + , containers + , directory ghc-options: -Wall default-language: Haskell2010 diff --git a/src/Distribution/Client/Dynamic/PackageDescription.hs b/src/Distribution/Client/Dynamic/PackageDescription.hs --- a/src/Distribution/Client/Dynamic/PackageDescription.hs +++ b/src/Distribution/Client/Dynamic/PackageDescription.hs @@ -2,9 +2,10 @@ -- to extract all targets along with their dependencies. module Distribution.Client.Dynamic.PackageDescription ( Target(..) - , TargetName(..) + , TargetInfo(..) , PackageDescription() , targets + , targetName, isLibrary, isExecutable, isTest, isBench ) where import Control.Applicative @@ -23,15 +24,21 @@ data CompilerFlavor data Extension data Dependency +data ModuleName instance Eq CompilerFlavor where _ == _ = undefined --- | The name of a target. Libraries don't have a name, they are always named after the package. -data TargetName = Library | Executable String | TestSuite String | BenchSuite String deriving (Show, Eq, Read, Ord) +-- | The specific information on a target, depending on the target type. +-- Libraries don't have a name, they are always named after the package, but other types do +data TargetInfo = Library [String] -- ^ contains the names of exposed modules + | Executable String FilePath -- ^ contains the name of the executable and the path to the Main module + | TestSuite String (Maybe FilePath) -- ^ contains the name of the test suite and the path to the Main module, for stdio tests + | BenchSuite String -- ^ contains the name of the benchmark + deriving (Show, Eq, Read, Ord) --- | A target is a single Library, an Excutable, a TestSuite or a Benchmark. +-- | A target is a single Library, an Executable, a TestSuite or a Benchmark. data Target = Target - { -- | The name of the target - name :: TargetName + { -- | The specific info of the target + info :: TargetInfo -- | All dependencies of the target, with their versions. If the version is not resolved yet, it'll be Nothing. -- That only happens when the target is not enabled, though. @@ -46,6 +53,9 @@ -- | Additional options to pass to GHC when compiling source files. , ghcOptions :: [String] + -- | Additional options to pass to CPP preprocessor when compiling source files. + , cppOptions :: [String] + -- | The extensions to enable/disable. The elements are like GHC's -X flags, a disabled extension -- is represented as the extension name prefixed by 'No'. -- Example value: extensions = ["ScopedTypeVariables", "NoMultiParamTypeClasses"] @@ -54,10 +64,48 @@ -- | The 'buildable' field in the package description. , buildable :: Bool + -- | other modules included in the target + , otherModules :: [String] + -- | Whether this target was enabled or not. This only matters for Benchmarks or Tests, Executables and Libraries are always enabled. , enabled :: Bool + + } deriving (Show, Eq, Read) + +-- | return the target name, or the empty string for the library target +targetName :: Target -> String +targetName t = case info t of + (Library _) -> "" + (Executable n _) -> n + (TestSuite n _) -> n + (BenchSuite n) -> n + +-- | is the target the library? +isLibrary :: Target -> Bool +isLibrary t = case info t of + (Library _) -> True + _ -> False + +-- | is the target an executable? +isExecutable :: Target -> Bool +isExecutable t = case info t of + (Executable _ _) -> True + _ -> False + +-- | is the target a test suite? +isTest :: Target -> Bool +isTest t = case info t of + (TestSuite _ _) -> True + _ -> False + +-- | is the target a benchmark? +isBench :: Target -> Bool +isBench t = case info t of + (BenchSuite _) -> True + _ -> False + buildable' :: Selector BuildInfo Bool buildable' = selector $ const $ useValue "Distribution.PackageDescription" $ Ident "buildable" @@ -71,16 +119,17 @@ -- | Get the names of the extensions to enable/disable for all source files in the package. If an extension should -- be disabled, it's name is prefixed by 'No'. This corresponds to the names of -X flags to pass to GHC. extensions' :: Selector BuildInfo [String] -extensions' = selector $ const $ expr $ \bi -> applyE2 map' display' $ append' <>$ applyE defaultExtensions' bi <>$ applyE oldExtensions' bi +extensions' = selector $ const $ expr $ \bi -> applyE2 map' display' $ applyE concat' $ expr $ map (<>$ bi) [defaultExtensions', oldExtensions', otherExtensions'] where display' :: ExpG (Extension -> String) display' = useValue "Distribution.Text" $ Ident "display" - defaultExtensions', oldExtensions' :: ExpG (BuildInfo -> [Extension]) + defaultExtensions', oldExtensions',otherExtensions' :: ExpG (BuildInfo -> [Extension]) defaultExtensions' = useValue "Distribution.PackageDescription" $ Ident "defaultExtensions" oldExtensions' = useValue "Distribution.PackageDescription" $ Ident "oldExtensions" + otherExtensions' = useValue "Distribution.PackageDescription" $ Ident "otherExtensions" -- | Get the options to pass to GHC for a given BuildInfo. -ghcOptions' :: Selector BuildInfo [FilePath] +ghcOptions' :: Selector BuildInfo [String] ghcOptions' = selector $ const $ concat' <>. applyE map' snd' <>. applyE filter' (applyE equal' ghc <>. fst') <>. options' where options' :: ExpG (BuildInfo -> [(CompilerFlavor, [String])]) options' = useValue "Distribution.PackageDescription" $ Ident "options" @@ -88,6 +137,21 @@ ghc :: ExpG CompilerFlavor ghc = useValue "Distribution.Compiler" $ Ident "GHC" +-- | Get the options to pass to GHC for a given BuildInfo. +cppOptions' :: Selector BuildInfo [String] +cppOptions' = selector $ const options' + where options' :: ExpG (BuildInfo -> [String]) + options' = useValue "Distribution.PackageDescription" $ Ident "cppOptions" + +-- | Get the non exposed modules. +otherModules' :: Selector BuildInfo [String] +otherModules' = selector $ const $ applyE map' display' <>. mods' + where display' :: ExpG (Distribution.Client.Dynamic.PackageDescription.ModuleName -> String) + display' = useValue "Distribution.Text" $ Ident "display" + mods' :: ExpG (BuildInfo -> [Distribution.Client.Dynamic.PackageDescription.ModuleName]) + mods' = useValue "Distribution.PackageDescription" $ Ident "otherModules" + + -- | Get the dependencies of the target and the version of the dependency if possible. If the dependencies version -- is not a specific version (this only happens when the target is not enabled), return Nothing. dependencies' :: Selector BuildInfo [(String, Maybe Version)] @@ -109,38 +173,55 @@ targetBuildDepends' = useValue "Distribution.PackageDescription" $ Ident "targetBuildDepends" -- | Construct a 'Target' from a buildInfo, a targetName and a Bool that is True if the target is enabled, false otherwise. -buildInfoTarget :: Query BuildInfo (TargetName -> Bool -> Target) -buildInfoTarget = (\d src inc opts exts ba n -> Target n d src inc opts exts ba) +buildInfoTarget :: Query BuildInfo (TargetInfo -> Bool -> Target) +buildInfoTarget = (\d src inc opts copts exts ba oths n-> Target n d src inc opts copts exts ba oths) <$> query dependencies' <*> query hsSourceDirs' <*> query includeDirs' <*> query ghcOptions' + <*> query cppOptions' <*> query extensions' <*> query buildable' + <*> query otherModules' --- | Get the buildInfo of the library in the package. If there is no library in the package, +-- | Get the buildInfo of the library in the package, and its exposed modules. If there is no library in the package, -- return the empty list. -library' :: ExpG (PackageDescription -> [BuildInfo]) +library' :: ExpG (PackageDescription -> [([String],BuildInfo)]) library' = applyE2 maybe' (returnE $ List []) serialize' <>. useValue "Distribution.PackageDescription" (Ident "library") - where serialize' = expr $ \lib -> expr [applyE buildInfo' lib] + where serialize' = expr $ \lib -> applyE2 cons (tuple2 <>$ applyE modNames' lib <>$ applyE buildInfo' lib) (returnE $ List []) + modNames'=applyE map' display' <>. mods' + display' = useValue "Distribution.Text" $ Ident "display" + mods' = useValue "Distribution.PackageDescription" $ Ident "exposedModules" buildInfo' = useValue "Distribution.PackageDescription" $ Ident "libBuildInfo" --- | Get the buildInfo and the name of each executable in the package. -executables' :: ExpG (PackageDescription -> [(String, BuildInfo)]) +-- | Get the buildInfo, the name and Main module path of each executable in the package. +executables' :: ExpG (PackageDescription -> [((String,FilePath), BuildInfo)]) executables'= applyE map' serialize' <>. useValue "Distribution.PackageDescription" (Ident "executables") - where serialize' = expr $ \exe -> tuple2 <>$ applyE exeName' exe <>$ applyE buildInfo' exe + where serialize' = expr $ \exe -> tuple2 <>$ applyE exeInfo exe <>$ applyE buildInfo' exe + exeInfo= expr $ \exe -> tuple2 <>$ applyE exeName' exe <>$ applyE modulePath' exe exeName' = useValue "Distribution.PackageDescription" $ Ident "exeName" + modulePath'= useValue "Distribution.PackageDescription" $ Ident "modulePath" buildInfo' = useValue "Distribution.PackageDescription" $ Ident "buildInfo" --- | Get the name, whether the target is enabled or not and the buildInfo of each testSuite in the package. -tests' :: ExpG (PackageDescription -> [((String, Bool), BuildInfo)]) + +-- | Get the name, whether the target is enabled or not, possibly the main module path and the buildInfo of each testSuite in the package. +tests' :: ExpG (PackageDescription -> [((String, Bool,Maybe FilePath), BuildInfo)]) tests' = applyE map' serialize' <>. useValue "Distribution.PackageDescription" (Ident "testSuites") where serialize' = expr $ \test -> tuple2 - <>$ applyE2 tuple2 (testName' <>$ test) (testEnabled' <>$ test) + <>$ applyE3 tuple3 (testName' <>$ test) (testEnabled' <>$ test) (testPath <>. testInterface' <>$ test) <>$ applyE buildInfo' test testName' = useValue "Distribution.PackageDescription" $ Ident "testName" testEnabled' = useValue "Distribution.PackageDescription" $ Ident "testEnabled" buildInfo' = useValue "Distribution.PackageDescription" $ Ident "testBuildInfo" + testInterface' = useValue "Distribution.PackageDescription" $ Ident "testInterface" + testPath=expr $ \ti->do + v10 <- useCon "Distribution.PackageDescription" $ Ident "TestSuiteExeV10" + versionVar <- newName "version" + fpVar <- newName "filepath" + caseE ti + [(PApp v10 [PVar versionVar,PVar fpVar],applyE just' (useVar fpVar)) + ,(PWildCard,nothing') + ] -- | Get the name, whether it's enabled or not and the buildInfo of each benchmark in the package. benchmarks' :: ExpG (PackageDescription -> [((String, Bool), BuildInfo)]) @@ -155,32 +236,32 @@ -- | Get the name of all targets and whether they are enabled (second field True) or not. -- The resulting list is in the same order and has the same length as the list returned -- by buildInfos. -targetInfos :: Query PackageDescription [(TargetName, Bool)] -targetInfos = build <$> query hasLib <*> query exeNames <*> query testInfo <*> query benchInfo - where hasLib :: Selector PackageDescription Bool - hasLib = selector $ const $ not' <>. null' <>. library' +targetInfos :: Query PackageDescription [(TargetInfo, Bool)] +targetInfos = build <$> query libMods <*> query exeNames <*> query testInfo <*> query benchInfo + where libMods :: Selector PackageDescription [[String]] + libMods = selector $ const $ applyE map' fst' <>. library' - exeNames :: Selector PackageDescription [String] + exeNames :: Selector PackageDescription [(String,FilePath)] exeNames = selector $ const $ applyE map' fst' <>. executables' - testInfo :: Selector PackageDescription [(String, Bool)] + testInfo :: Selector PackageDescription [(String, Bool,Maybe FilePath)] testInfo = selector $ const $ applyE map' fst' <>. tests' benchInfo :: Selector PackageDescription [(String, Bool)] benchInfo = selector $ const $ applyE map' fst' <>. benchmarks' build lib exe test bench = concat - [ [ (Library , True) | lib ] - , [ (Executable x , True) | x <- exe ] - , [ (TestSuite x , e) | (x,e) <- test ] - , [ (BenchSuite x , e) | (x,e) <- bench ] + [ [ (Library x , True) | x <- lib ] + , [ (Executable x mp, True) | (x,mp) <- exe ] + , [ (TestSuite x mp, e ) | (x,e,mp) <- test ] + , [ (BenchSuite x , e ) | (x,e) <- bench ] ] -- | Get the BuildInfo of all targets, even for disable or not buildable targets. buildInfos :: Selector PackageDescription [BuildInfo] buildInfos = selector $ const $ expr $ \bi -> applyE concat' $ expr $ map (<>$ bi) [libraryBI, exesBI, testsBI, benchsBI] where libraryBI :: ExpG (PackageDescription -> [BuildInfo]) - libraryBI = library' + libraryBI = applyE map' snd' <>. library' exesBI :: ExpG (PackageDescription -> [BuildInfo]) exesBI = applyE map' snd' <>. executables' diff --git a/src/Distribution/Client/Dynamic/Query.hs b/src/Distribution/Client/Dynamic/Query.hs --- a/src/Distribution/Client/Dynamic/Query.hs +++ b/src/Distribution/Client/Dynamic/Query.hs @@ -22,6 +22,8 @@ , fmapQ , on , runQuery + , runRawQuery + , getCabalVersion ) where import Control.Applicative @@ -140,9 +142,9 @@ setCurrentDirectory pwd res <$ removeDirectoryRecursive tmp -generateSource :: Selector LocalBuildInfo o -> String -> FilePath -> Version -> IO () +generateSource :: Selector LocalBuildInfo o -> String -> FilePath -> Version -> IO String generateSource (Selector s) modName setupConfig version = - writeFile (modName <.> "hs") $ flip generateModule modName $ do + return $ flip generateModule modName $ do getLBI <- addDecl (Ident "getLBI") $ applyE fmap' (read' <>. unlines' <>. applyE drop' 1 <>. lines' :: ExpG (String -> LocalBuildInfo)) <>$ applyE readFile' (expr setupConfig) @@ -153,10 +155,24 @@ runQuery :: Query LocalBuildInfo a -> FilePath -> IO a runQuery (Query s post) setupConfig = do setupConfig' <- canonicalizePath setupConfig + version <- getCabalVersion setupConfig' + src<- generateSource s "DynamicCabalQuery" setupConfig' version + runRawQuery' src setupConfig post + +-- | Run a raw query, getting the full source from the first parameter +-- the module must be DynamicCabalQuery and it must have a result declaration +runRawQuery :: Typeable a => String -> FilePath -> IO a +runRawQuery s setupConfig = runRawQuery' s setupConfig id + +-- | Run a raw query, getting the full source from the first parameter. +-- The module must be DynamicCabalQuery and it must have a result declaration. +-- The third argument is a function to apply to the result of running the query. +runRawQuery' :: Typeable i => String -> FilePath -> (i -> a) -> IO a +runRawQuery' s setupConfig post = do + setupConfig' <- canonicalizePath setupConfig withTempWorkingDir $ do version <- getCabalVersion setupConfig' - generateSource s "DynamicCabalQuery" setupConfig' version - + writeFile "DynamicCabalQuery.hs" s GHC.runGhc (Just GHC.Paths.libdir) $ do dflags <- GHC.getSessionDynFlags void $ GHC.setSessionDynFlags $ dflags @@ -172,3 +188,4 @@ void $ GHC.load GHC.LoadAllTargets GHC.setContext [GHC.IIDecl $ GHC.simpleImportDecl $ GHC.mkModuleName "DynamicCabalQuery"] GHC.dynCompileExpr "result" >>= maybe (fail "dynamic-cabal: runQuery: Result expression has wrong type") (MonadUtils.liftIO . fmap post) . fromDynamic + diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,14 +1,20 @@ -{-# LANGUAGE TemplateHaskell #-} -import Data.List -import Distribution.Client.Dynamic -import Test.HUnit -import Test.Tasty.HUnit -import Test.Tasty.TH +{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +import Data.List +import qualified Data.Map as DM +import Data.Version +import Distribution.Client.Dynamic +import System.Directory +import Test.HUnit +import Test.Tasty.HUnit +import Test.Tasty.TH case_targets :: Assertion case_targets = do tgs <- runQuery (on localPkgDesc targets) "dist/setup-config" - assertEqual "target names" (sort [Library, TestSuite "dynamic-cabal-tests", TestSuite "doctests"]) (sort $ map name tgs) + assertEqual "target names" (sort [Library ["Distribution.Client.Dynamic" + ,"Distribution.Client.Dynamic.Query" + ,"Distribution.Client.Dynamic.LocalBuildInfo" + ,"Distribution.Client.Dynamic.PackageDescription"], TestSuite "dynamic-cabal-tests" (Just "Main.hs"), TestSuite "doctests" (Just "doctests.hs")]) (sort $ map info tgs) assertEqual "source directories" (sort $ map sourceDirs tgs) $ sort $ map return ["src", "tests", "tests"] assertBool "ghc options" $ all (elem "-Wall" . ghcOptions) tgs assertBool "no extensions" $ all (null . extensions) tgs @@ -18,6 +24,52 @@ case_packageDBs = do dbs <- runQuery packageDBs "dist/setup-config" length dbs `seq` return () + +-- | test running raw query +case_raw :: Assertion +case_raw = do + s<-src + m::DM.Map String [String]<-runRawQuery s "dist/setup-config" + assertEqual "map size" 3 (DM.size m) + -- print m + +-- | the raw query source code +src :: IO String +src=do + setupConfig' <- canonicalizePath "dist/setup-config" + cv<-getCabalVersion setupConfig' + let optStr=if cv>=Version [1,15,0] [] + then " let opts=renderGhcOptions ((fst $ head $ readP_to_S parseVersion \"7.6.3\") :: Version) $ componentGhcOptions V.silent lbi b clbi \"dist/build\"" + else " let opts=ghcOptions lbi b clbi \"dist/build\"" + return $ unlines [ + "module DynamicCabalQuery where" + ,"import Distribution.PackageDescription" + ,"import Distribution.Simple.LocalBuildInfo" + ,"import Data.IORef" + ,"import qualified Data.Map as DM" + ,"import qualified Distribution.Verbosity as V" + ,"import Data.Version (parseVersion)" + ,"import Text.ParserCombinators.ReadP(readP_to_S)" + ,if cv>=Version [1,15,0] [] then "import Distribution.Simple.Program.GHC" else "" + ,"import Distribution.Simple.GHC" + ,"import Distribution.Version" + ,"import Control.Monad" + ,"" + ,"result :: IO (DM.Map String [String])" + ,"result=do" + ,"lbi<-liftM (read . Prelude.unlines . drop 1 . lines) $ Prelude.readFile \""++setupConfig' ++"\"" + ,"let pkg=localPkgDescr lbi" + ,"r<-newIORef DM.empty" + ,"withComponentsLBI pkg lbi (\\c clbi->do" + ," let b=foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo c" + ,optStr + ," let n=foldComponent (const \"\") exeName testName benchmarkName c" + ," modifyIORef r (DM.insert n opts)" + ," return ()" + ," )" + ,"readIORef r" ] + + main :: IO () main = $(defaultMainGenerator)