dynamic-cabal (empty) → 0.1

raw patch · 14 files changed

+791/−0 lines, 14 filesdep +HUnitdep +basedep +containersbuild-type:Customsetup-changed

Dependencies added: HUnit, base, containers, directory, doctest, dynamic-cabal, filepath, ghc, ghc-paths, haskell-generate, haskell-src-exts, tasty, tasty-hunit, tasty-th, time, void

Files

• .ghci +1/−0
• .gitignore +15/−0
• .travis.yml +24/−0
• .vim.custom +31/−0
• LICENSE +30/−0
• README.md +25/−0
• Setup.hs +69/−0
• dynamic-cabal.cabal +75/−0
• src/Distribution/Client/Dynamic.hs +8/−0
• src/Distribution/Client/Dynamic/LocalBuildInfo.hs +45/−0
• src/Distribution/Client/Dynamic/PackageDescription.hs +197/−0
• src/Distribution/Client/Dynamic/Query.hs +174/−0
• tests/Main.hs +23/−0
• tests/doctests.hsc +74/−0

@@ -0,0 +1,1 @@+:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h

@@ -0,0 +1,15 @@+dist+docs+wiki+TAGS+tags+wip+.DS_Store+.*.swp+.*.swo+*.o+*.hi+*~+*#+.cabal-sandbox+cabal.sandbox.config

@@ -0,0 +1,24 @@+env:+ - GHCVER=7.4.2 CABALVER=1.16+ - GHCVER=7.6.3 CABALVER=1.18+ - GHCVER=head CABALVER=1.18 ++before_install:+ - sudo add-apt-repository -y ppa:hvr/ghc+ - sudo apt-get update+ - sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER hlint+ - cabal-$CABALVER update+ - cabal-$CABALVER install happy -j+ - export PATH=/opt/ghc/$GHCVER/bin:~/.cabal/bin:$PATH++install:+ - cabal-$CABALVER install --only-dependencies --enable-tests --enable-benchmarks -j++script:+ - travis/script.sh+ - hlint src++matrix:+  allow_failures:+   - env: GHCVER=head CABALVER=1.18+  fast_finish: true

@@ -0,0 +1,31 @@+" Add the following to your .vimrc to automatically load this on startup++" if filereadable(".vim.custom")+"     so .vim.custom+" endif++function StripTrailingWhitespace()+  let myline=line(".")+  let mycolumn = col(".")+  silent %s/  *$//+  call cursor(myline, mycolumn)+endfunction++" enable syntax highlighting+syntax on++" search for the tags file anywhere between here and /+set tags=TAGS;/++" highlight tabs and trailing spaces+set listchars=tab:‗‗,trail:‗+set list++" f2 runs hasktags+map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>++" strip trailing whitespace before saving+" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()++" rebuild hasktags after saving+au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"

@@ -0,0 +1,30 @@+Copyright 2013 Benno Fünfstück++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,25 @@+dynamic-cabal+=============++[![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.++## Usage++Currently, the library only allows two queries: Getting the targets (along with their dependencies, ghc options, etc) and the package databases. The first is easily achieved using the `targets` query provided by the library. To run the query, you can use the `runQuery` function, which takes the path to the setup-config file as an argument. For example, the following little program prints out the names of all test suites, when run in a configured cabal project root directory:++```haskell+import Distribution.Client.Dynamic++main :: IO ()+main = do+  tgs <- runQuery (on localPkgDesc targets) "dist/setup-config"+  mapM_ putStrLn [ n | TestSuite n <- map name tgs ]+```++Because `targets` works on a PackageDescription, `on localPkgDesc` is used to get the current PackageDescription.++## Contributing++At the moment, I only implemented the functions I need myself. If you have more functions you want to implement, just send a pull request or open an issue.

@@ -0,0 +1,69 @@+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++import Data.IORef+import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..), hsSourceDirs, libBuildInfo, buildInfo)+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, withExeLBI, ComponentLocalBuildInfo(), LocalBuildInfo(), componentPackageDeps )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag, buildDistPref, defaultDistPref, fromFlagOrDefault )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )+import Distribution.Verbosity ( Verbosity )+import System.Directory ( canonicalizePath )+import System.FilePath ( (</>) )++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+  { buildHook = \pkg lbi hooks flags -> do+     generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi flags+     buildHook simpleUserHooks pkg lbi hooks flags+  }++--  Very ad-hoc implementation of difference lists+singletonDL :: a -> [a] -> [a]+singletonDL = (:)++emptyDL :: [a] -> [a]+emptyDL = id++appendDL :: ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]+appendDL x y = x . y++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> BuildFlags -> IO ()+generateBuildModule verbosity pkg lbi flags = do+  let dir = autogenModulesDir lbi+  createDirectoryIfMissingVerbose verbosity True dir+  withTestLBI pkg lbi $ \suite suitelbi -> do+    srcDirs <- mapM canonicalizePath $ hsSourceDirs $ testBuildInfo suite+    distDir <- canonicalizePath $ fromFlagOrDefault defaultDistPref $ buildDistPref flags++    depsVar <- newIORef emptyDL+    withLibLBI pkg lbi $ \lib liblbi ->+      modifyIORef depsVar $ appendDL . singletonDL $ depsEntry (libBuildInfo lib) liblbi suitelbi+    withExeLBI pkg lbi $ \exe exelbi ->+      modifyIORef depsVar $ appendDL . singletonDL $ depsEntry (buildInfo exe) exelbi suitelbi+    deps <- fmap ($ []) $ readIORef depsVar++    rewriteFile (map fixchar $ dir </> "Build_" ++ testName suite ++ ".hs") $ unlines +      [ "module Build_" ++ map fixchar (testName suite) ++ " where"+      , "getDistDir :: FilePath"+      , "getDistDir = " ++ show distDir+      , "getSrcDirs :: [FilePath]"+      , "getSrcDirs = " ++ show srcDirs+      , "deps :: [([FilePath], [String])]"+      , "deps = " ++ show deps+      ]++  where+    formatdeps = map (formatone . snd)+    formatone p = case packageName p of+      PackageName n -> n ++ "-" ++ showVersion (packageVersion p)+    depsEntry targetbi targetlbi suitelbi = (hsSourceDirs targetbi, formatdeps $ testDeps targetlbi suitelbi)+    fixchar '-' = '_'+    fixchar c = c++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys

@@ -0,0 +1,75 @@+name:          dynamic-cabal+version:       0.1+license:       BSD3+category:      Distribution +cabal-version: >= 1.10+license-file:  LICENSE+author:        Benno Fünfstück+maintainer:    Benno Fünfstück <benno.fuenfstueck@gmail.com>+stability:     experimental+homepage:      http://github.com/bennofs/dynamic-cabal/+bug-reports:   http://github.com/bennofs/dynamic-cabal/issues+copyright:     Copyright (C) 2013 Benno Fünfstück+synopsis:      dynamic-cabal+description:   dynamic-cabal+build-type:    Custom++extra-source-files:+  .ghci+  .gitignore+  .travis.yml+  .vim.custom+  README.md++source-repository head+  type: git+  location: https://github.com/bennofs/dynamic-cabal.git++library+  hs-source-dirs: src+  default-language: Haskell2010+  ghc-options: -Wall+  build-depends:+      base >= 4.4 && < 5+    , ghc+    , ghc-paths+    , containers+    , time+    , haskell-generate+    , directory+    , filepath+    , haskell-src-exts+    , void+  exposed-modules:+      Distribution.Client.Dynamic+      Distribution.Client.Dynamic.Query+      Distribution.Client.Dynamic.LocalBuildInfo+      Distribution.Client.Dynamic.PackageDescription++test-suite dynamic-cabal-tests+  type:    exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs: tests+  build-depends:+      base+    , dynamic-cabal+    , tasty+    , tasty-hunit+    , HUnit+    , tasty-th+  ghc-options: -Wall+  default-language: Haskell2010++test-suite doctests+  type:    exitcode-stdio-1.0+  main-is: doctests.hs+  default-language: Haskell2010+  build-depends:+      base+    , directory >= 1.0+    , doctest >= 0.9.1+    , filepath+  ghc-options: -Wall -threaded+  if impl(ghc<7.6.1)+    ghc-options: -Werror+  hs-source-dirs: tests

@@ -0,0 +1,8 @@+module Distribution.Client.Dynamic+  ( module X+  ) where++import Distribution.Client.Dynamic.LocalBuildInfo as X+import Distribution.Client.Dynamic.PackageDescription as X+import Distribution.Client.Dynamic.Query as X+

@@ -0,0 +1,45 @@+module Distribution.Client.Dynamic.LocalBuildInfo where++import Distribution.Client.Dynamic.PackageDescription+import Distribution.Client.Dynamic.Query+import Language.Haskell.Exts.Syntax+import Language.Haskell.Generate+import Prelude hiding ((.), id)++-- | A package db is either the user package db (often at ~/.ghc/ghc-....), the global package+-- or a specific file or directory.+data PackageDB = UserDB | GlobalDB | SpecificDB FilePath deriving (Eq, Ord, Show, Read)++-- | Get the package dbs that ghc will use when compiling this package.+packageDBs :: Query LocalBuildInfo [PackageDB]+packageDBs = fmap (map deserialize) $ query packageDBStack+  where packageDBStack' :: ExpG (LocalBuildInfo -> [PackageDB])+        packageDBStack' = useValue "Distribution.Simple.LocalBuildInfo" $ Ident "withPackageDB"++        packageDBStack :: Selector LocalBuildInfo [Either Bool FilePath]+        packageDBStack = selector $ const $ applyE map' (expr serialize') <>. packageDBStack'++        serialize' :: ExpG PackageDB -> ExpG (Either Bool FilePath)+        serialize' db = do +          fileVar <- newName "file_"+          globalDB   <- useCon "Distribution.Simple.Compiler" $ Ident "GlobalPackageDB"+          userDB     <- useCon "Distribution.Simple.Compiler" $ Ident "UserPackageDB"+          specificDB <- useCon "Distribution.Simple.Compiler" $ Ident "SpecificPackageDB"+          caseE db+            [ (PApp globalDB [], left' <>$ true')+            , (PApp userDB []  , left' <>$ false')+            , (PApp specificDB [PVar fileVar], right' <>$ useVar fileVar)+            ]++        deserialize (Left isGlobal) | isGlobal  = GlobalDB+                                    | otherwise = UserDB+        deserialize (Right file) = SpecificDB file+++-- | Returns the builddir of a LocalBuildInfo. Often, this will just be "dist".+buildDir :: Selector LocalBuildInfo String+buildDir = selector $ const $ useValue "Distribution.Simple.LocalBuildInfo" $ Ident "buildDir"++-- | Returns the package description included in a local build info.+localPkgDesc :: Selector LocalBuildInfo PackageDescription+localPkgDesc = selector $ const $ useValue "Distribution.Simple.LocalBuildInfo" $ Ident "localPkgDescr"

@@ -0,0 +1,197 @@+-- | This module contains queries that operate on a PackageDescription. It provides a function+-- to extract all targets along with their dependencies.+module Distribution.Client.Dynamic.PackageDescription+  ( Target(..)+  , TargetName(..)+  , PackageDescription()+  , targets+  ) where++import Control.Applicative+import Data.Version+import Distribution.Client.Dynamic.Query+import Language.Haskell.Exts.Syntax+import Language.Haskell.Generate++-- Type tags that we can use to make sure we don't accidently generate code that+-- use a function for a PackageDescription on a BuildInfo value.++-- | A package description type. This type has no constructors, and is only used +-- for type-safety purposes.+data PackageDescription+data BuildInfo+data CompilerFlavor+data Extension+data Dependency+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)++-- | A target is a single Library, an Excutable, a TestSuite or a Benchmark.+data Target = Target+  { -- | The name of the target+    name         :: TargetName++    -- | 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.+  , dependencies :: [(String, Maybe Version)]++    -- | Directories where to look for source files. +  , sourceDirs   :: [FilePath]++    -- | Directories where to look for header files.+  , includeDirs  :: [FilePath]++    -- | Additional options to pass to GHC when compiling source files.+  , ghcOptions   :: [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"]+  , extensions   :: [String]++    -- | The 'buildable' field in the package description.+  , buildable    :: Bool++    -- | 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)++buildable' :: Selector BuildInfo Bool+buildable' = selector $ const $ useValue "Distribution.PackageDescription" $ Ident "buildable"++hsSourceDirs' :: Selector BuildInfo [FilePath]+hsSourceDirs' = selector $ const $ useValue "Distribution.PackageDescription" $ Ident "hsSourceDirs"++-- | The include search path of a buildInfo. Same as the 'includeDir' field in Cabal's BuildInfo.+includeDirs' :: Selector BuildInfo [FilePath]+includeDirs' = selector $ const $ useValue "Distribution.PackageDescription" $ Ident "includeDirs"++-- | 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+  where display' :: ExpG (Extension -> String)+        display' = useValue "Distribution.Text" $ Ident "display"+        +        defaultExtensions', oldExtensions' :: ExpG (BuildInfo -> [Extension])+        defaultExtensions' = useValue "Distribution.PackageDescription" $ Ident "defaultExtensions"+        oldExtensions' = useValue "Distribution.PackageDescription" $ Ident "oldExtensions"++-- | Get the options to pass to GHC for a given BuildInfo.+ghcOptions' :: Selector BuildInfo [FilePath]+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"++        ghc :: ExpG CompilerFlavor+        ghc = useValue "Distribution.Compiler" $ Ident "GHC"++-- | 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)]+dependencies' = selector $ const $ applyE map' serializeDep <>. targetBuildDepends'+  where serializeDep :: ExpG (Dependency -> (String, Maybe Version))+        serializeDep = expr $ \dep -> do+          dependency  <- useCon "Distribution.Package" $ Ident "Dependency"+          packageName <- useCon "Distribution.Package" $ Ident "PackageName"+          let isSpecificVersion = useValue "Distribution.Version" $ Ident "isSpecificVersion"+          nameVar     <- newName "name"+          versionVar  <- newName "version"+          caseE dep+            [ ( PApp dependency [PApp packageName [PVar nameVar], PVar versionVar], +                  tuple2 <>$ useVar nameVar <>$ applyE isSpecificVersion (useVar versionVar)+              )+            ]++        targetBuildDepends' :: ExpG (BuildInfo -> [Dependency])+        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)+                 <$> query dependencies' +                 <*> query hsSourceDirs' +                 <*> query includeDirs' +                 <*> query ghcOptions'+                 <*> query extensions'+                 <*> query buildable'++-- | Get the buildInfo of the library in the package. If there is no library in the package, +-- return the empty list.+library' :: ExpG (PackageDescription -> [BuildInfo])+library' = applyE2 maybe' (returnE $ List []) serialize' <>. useValue "Distribution.PackageDescription" (Ident "library")+  where serialize' = expr $ \lib -> expr [applyE buildInfo' lib]+        buildInfo' = useValue "Distribution.PackageDescription" $ Ident "libBuildInfo"++-- | Get the buildInfo and the name of each executable in the package.+executables' :: ExpG (PackageDescription -> [(String, BuildInfo)])+executables'= applyE map' serialize' <>. useValue "Distribution.PackageDescription" (Ident "executables")+  where serialize' = expr $ \exe -> tuple2 <>$ applyE exeName' exe <>$ applyE buildInfo' exe+        exeName'   = useValue "Distribution.PackageDescription" $ Ident "exeName"+        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)])+tests' = applyE map' serialize' <>. useValue "Distribution.PackageDescription" (Ident "testSuites")+  where serialize' = expr $ \test -> tuple2 +                                    <>$ applyE2 tuple2 (testName' <>$ test) (testEnabled' <>$ test) +                                    <>$ applyE buildInfo' test+        testName'   = useValue "Distribution.PackageDescription" $ Ident "testName"+        testEnabled' = useValue "Distribution.PackageDescription" $ Ident "testEnabled"+        buildInfo' = useValue "Distribution.PackageDescription" $ Ident "testBuildInfo"++-- | Get the name, whether it's enabled or not and the buildInfo of each benchmark in the package.+benchmarks' :: ExpG (PackageDescription -> [((String, Bool), BuildInfo)])+benchmarks' = applyE map' serialize' <>. useValue "Distribution.PackageDescription" (Ident "benchmarks")+  where serialize' = expr $ \bench -> tuple2 +                                     <>$ applyE2 tuple2 (benchName' <>$ bench) (benchEnabled' <>$ bench)+                                     <>$ applyE buildInfo' bench+        benchName'   = useValue "Distribution.PackageDescription" $ Ident "benchmarkName"+        benchEnabled' = useValue "Distribution.PackageDescription" $ Ident "benchmarkEnabled"+        buildInfo' = useValue "Distribution.PackageDescription" $ Ident "benchmarkBuildInfo"++-- | 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'++        exeNames :: Selector PackageDescription [String]+        exeNames = selector $ const $ applyE map' fst' <>. executables'++        testInfo :: Selector PackageDescription [(String, Bool)]+        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 ]+          ]++-- | 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'+        +        exesBI    :: ExpG (PackageDescription -> [BuildInfo])+        exesBI    = applyE map' snd' <>. executables'+                     +        testsBI   :: ExpG (PackageDescription -> [BuildInfo])+        testsBI   = applyE map' snd' <>. tests'++        benchsBI  :: ExpG (PackageDescription -> [BuildInfo])+        benchsBI  = applyE map' snd' <>. benchmarks'++-- | Query the available targets. This will return all targets, even disabled ones. +-- If a package is disabled or not buildable, it's possible that not all dependencies have versions, some can be Nothing.+targets :: Query PackageDescription [Target]+targets = zipWith uncurry <$> on buildInfos (fmapQ buildInfoTarget) <*> targetInfos

@@ -0,0 +1,174 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}+#if __GLASGOW_HASKELL__ >= 707+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE KindSignatures #-}+#endif++-- | Functions for building queries on cabal's setup-config an evaluating them.+module Distribution.Client.Dynamic.Query +  ( Selector(), selector+  , Query(), query+  , LocalBuildInfo()+  , maybeDefault+  , (>>>=), (=<<<)+  , fmapS+  , fmapQ+  , on+  , runQuery+  ) where++import           Control.Applicative+import           Control.Category+import qualified Control.Exception as E+import           Control.Monad+import           Data.Dynamic+import           Data.Version+import           Data.Void+import qualified DynFlags+import qualified GHC+import qualified GHC.Paths+import           Language.Haskell.Exts.Syntax+import           Language.Haskell.Generate+import qualified MonadUtils+import           Prelude hiding (id, (.))+import           System.Directory+import           System.FilePath+import           System.IO.Error (isAlreadyExistsError)+import           Text.ParserCombinators.ReadP++#if __GLASGOW_HASKELL__ >= 707+type Typeable1 (f :: * -> *) = Typeable f+#endif ++-- | This is just a dummy type representing a LocalBuildInfo. You don't have to use+-- this type, it is just used to tag queries and make them more type-safe.+data LocalBuildInfo = LocalBuildInfo Void deriving (Typeable, Read)++-- | A selector is a generator for a function of type i -> o.+newtype Selector i o = Selector (Version -> ExpG (i -> o))++instance Category Selector where+  id = Selector $ const id'+  Selector a . Selector b = Selector $ liftA2 (<>.) a b++-- | Compose two selectors, monadically.+(=<<<) :: Monad m => Selector b (m c) -> Selector a (m b) -> Selector a (m c)+Selector s =<<< Selector t = Selector $ \v -> applyE (flip' <>$ bind') (s v) <>. t v++-- | The same as (=<<<), but flipped.+(>>>=) :: Monad m => Selector a (m b) -> Selector b (m c) -> Selector a (m c)+(>>>=) = flip (=<<<)++-- | Lift a selector to work on functorial inputs and outputs.+fmapS :: Functor m => Selector a b -> Selector (m a) (m b)+fmapS (Selector s) = Selector $ \v -> applyE fmap' (s v)++-- | Zip together two selector that work on the same input. This is the equavilent of liftA2 (,) for selectors.+zipSelector :: Selector i o -> Selector i p -> Selector i (o,p)+zipSelector (Selector s) (Selector t) = Selector $ \v -> expr $ \i -> applyE2 tuple2 (s v <>$ i) (t v <>$ i)++-- | A Selector to get something out of a Maybe if you supply a default value.+maybeDefault :: (GenExpType a ~ a, GenExp a) => a -> Selector (Maybe a) a+maybeDefault a = selector $ const $ applyE (flip' <>$ maybe' <>$ id') $ expr a++-- | Build a selector. The expression the selector generates can depend on the cabal version.+selector :: (Version -> ExpG (i -> o)) -> Selector i o+selector = Selector++-- | A query is like a Selector, but it cannot be composed any futher using a Category instance.+-- It can have a Functor and Applicative instance though. +-- To execute a query, you only need to run GHC once.+data Query s a = forall i. Typeable i => Query (Selector s i) (i -> a)++instance Functor (Query s) where+  fmap f (Query s x) = Query s $ f . x++instance Applicative (Query s) where+  pure = Query (selector $ const $ const' <>$ tuple0) . const+  Query f getF <*> Query a getA = Query (zipSelector f a) $ \(fv, av) -> getF fv $ getA av++-- | Build a query from a selector.+query :: Typeable a => Selector s a -> Query s a+query = flip Query id++-- | Lift a query to work over functors.+fmapQ :: (Functor f, Typeable1 f) => Query s a -> Query (f s) (f a)+fmapQ (Query s f) = Query (fmapS s) (fmap f)++-- | Use a selector to run a query in a bigger environment than it was defined in.+on :: Selector i o -> Query o r -> Query i r+on s (Query sq f) = Query (sq . s) f++getRunDirectory :: IO FilePath+getRunDirectory = getTemporaryDirectory >>= go 0+  where go :: Integer -> FilePath -> IO FilePath+        go !c dir = do +          let cdir = dir </> "dynamic-cabal" <.> show c+          res <- E.try $ createDirectory cdir+          case res of+            Left e | isAlreadyExistsError e -> go (c + 1) dir+                   | otherwise -> E.throwIO e+            Right () -> return cdir++getCabalVersion :: FilePath -> IO Version+getCabalVersion setupConfig = do+  versionString <- dropWhile (not . flip elem ['0'..'9']) . (!! 7) . words . head . lines <$> readFile setupConfig+  case filter (null . snd) $ readP_to_S parseVersion versionString of+    [(v,_)] -> return v+    _       -> E.throwIO $ userError "Couldn't parse version"++data LeftoverTempDir e = LeftoverTempDir FilePath e deriving Typeable++instance Show e => Show (LeftoverTempDir e) where+  show (LeftoverTempDir dir e) = "Left over temporary directory not removed: " ++ dir ++ "\n" ++ show e++instance E.Exception e => E.Exception (LeftoverTempDir e)++withTempWorkingDir :: IO a -> IO a+withTempWorkingDir act = do+  pwd <- getCurrentDirectory+  tmp <- getRunDirectory+  setCurrentDirectory tmp+  res <- act `E.catch` \(E.SomeException e) -> setCurrentDirectory pwd >> E.throwIO (LeftoverTempDir tmp e)+  setCurrentDirectory pwd+  res <$ removeDirectoryRecursive tmp++generateSource :: Selector LocalBuildInfo o -> String -> FilePath -> Version -> IO ()+generateSource (Selector s) modName setupConfig version = +  writeFile (modName <.> "hs") $ flip generateModule modName $ do+    getLBI <- addDecl (Ident "getLBI") $ +                   applyE fmap' (read' <>. unlines' <>. applyE drop' 1 <>. lines' :: ExpG (String -> LocalBuildInfo)) +               <>$ applyE readFile' (expr setupConfig)+    result <- addDecl (Ident "result") $ applyE fmap' (s version) <>$ expr getLBI+    return $ Just [exportFun result]++-- | Run a query. This will generate the source code for the query and then invoke GHC to run it.+runQuery :: Query LocalBuildInfo a -> FilePath -> IO a+runQuery (Query s post) setupConfig = do+  setupConfig' <- canonicalizePath setupConfig+  withTempWorkingDir $ do+    version <- getCabalVersion setupConfig'+    generateSource s "DynamicCabalQuery" setupConfig' version++    GHC.runGhc (Just GHC.Paths.libdir) $ do+      dflags <- GHC.getSessionDynFlags+      void $ GHC.setSessionDynFlags $ dflags+             { GHC.ghcLink = GHC.LinkInMemory+             , GHC.hscTarget = GHC.HscInterpreted+             , GHC.packageFlags = [DynFlags.ExposePackage $ "Cabal-" ++ showVersion version]+             }+      dflags' <- GHC.getSessionDynFlags++      GHC.defaultCleanupHandler dflags' $ do+        target <- GHC.guessTarget "DynamicCabalQuery.hs" Nothing+        GHC.setTargets [target]+        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

@@ -0,0 +1,23 @@+{-# LANGUAGE TemplateHaskell #-}+import Data.List+import Distribution.Client.Dynamic+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 "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+  assertBool  "everything buildable" $ all buildable tgs++case_packageDBs :: Assertion+case_packageDBs = do+  dbs <- runQuery packageDBs "dist/setup-config"+  length dbs `seq` return ()++main :: IO ()+main = $(defaultMainGenerator)

@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- Copyright   :  (C) 2012-13 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  provisional+-- Portability :  portable+--+-- This module provides doctests for a project based on the actual versions+-- of the packages it was built with. It requires a corresponding Setup.lhs+-- to be added to the project+-----------------------------------------------------------------------------+module Main where++import Build_doctests (deps)+import Control.Applicative+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import Test.DocTest++##ifdef mingw32_HOST_ARCH+##ifdef i386_HOST_ARCH+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##elif defined(x86_64_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##endif+##endif++-- | Run in a modified codepage where we can print UTF-8 values on Windows.+withUnicode :: IO a -> IO a+##ifdef USE_CP+withUnicode m = do+  cp <- c_GetConsoleCP+  (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp+##else+withUnicode m = m+##endif++main :: IO ()+main = withUnicode $ forM_ deps $ \(dirs, dep) -> do+    putStrLn $ ":: Running doctests for source directories: " ++ intercalate " " dirs+    mapM getSources dirs >>= \sources -> doctest $+        "-idist/build/autogen"+      : "-optP-include"+      : "-optPdist/build/autogen/cabal_macros.h"+      : "-hide-all-packages"+      : map ("-package="++) dep+        ++ map ("-i"++) dirs +        ++ join sources ++getSources :: FilePath -> IO [FilePath]+getSources d = filter (isSuffixOf ".hs") <$> go d+  where+    go dir = do+      (dirs, files) <- getFilesAndDirectories dir+      (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+  c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+  (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c