aboutsummaryrefslogtreecommitdiff
path: root/Distribution
diff options
context:
space:
mode:
authorDaniel Gröber <dxld@darkboxed.org>2017-09-26 19:32:46 +0200
committerDaniel Gröber <dxld@darkboxed.org>2017-09-28 19:59:20 +0200
commit2deb4b3d9732887be3e18ad01e9505ac17eca104 (patch)
tree90cc5357cf730fbba82c4ea129c3b978091254e8 /Distribution
parent34dd91fc10c0fcd33aced8a658a90cd6a6734850 (diff)
Simplify Distribution.Helper API
Component queries are now done using Applicative (actually semigroupoids Apply) syntax, for example: runQuery _ $ components $ (,,) <$> ghcOptions <*> sourceDirs :: IO [([GhcOption], [SourceDir], ChComponentName)] Note that 'component' adds the 'ChComponentName' at the end.
Diffstat (limited to 'Distribution')
-rw-r--r--Distribution/Helper.hs300
1 files changed, 185 insertions, 115 deletions
diff --git a/Distribution/Helper.hs b/Distribution/Helper.hs
index 6fbba38..73ad668 100644
--- a/Distribution/Helper.hs
+++ b/Distribution/Helper.hs
@@ -14,8 +14,9 @@
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
-{-# LANGUAGE CPP, RecordWildCards, FlexibleContexts, ConstraintKinds #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveGeneric #-}
+{-# LANGUAGE CPP, RecordWildCards, FlexibleContexts, ConstraintKinds,
+ GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveGeneric, DeriveFunctor
+ #-}
{-|
Module : Distribution.Helper
@@ -25,36 +26,50 @@ Portability : POSIX
-}
module Distribution.Helper (
- Programs(..)
- , mkPrograms
+ -- * Running Queries
+ Query
+ , runQuery
+
+ -- * Queries against Cabal\'s on disk state
+
+ -- ** Package queries
+ , packageId
+ , packageDbStack
+ , packageFlags
+ , packageLicenses
+ , compilerVersion
+
+ , ghcMergedPkgOptions
+
+ -- ** cabal-install queries
+ , configFlags
+ , nonDefaultConfigFlags
+
+
+ -- ** Component queries
+ , ComponentQuery
+ , components
+
+ , ghcSrcOptions
+ , ghcPkgOptions
+ , ghcLangOptions
+ , ghcOptions
+ , sourceDirs
+ , entrypoints
+
+ -- * Query environment
, QueryEnv
+ , mkQueryEnv
, qeReadProcess
, qePrograms
, qeProjectDir
, qeDistDir
, qeCabalPkgDb
, qeCabalVer
- , mkQueryEnv
- -- * Running Queries
- , Query
- , runQuery
+ , Programs(..)
+ , defaultPrograms
- -- * Queries against Cabal\'s on disk state
- , packageDbStack
- , entrypoints
- , sourceDirs
- , ghcOptions
- , ghcSrcOptions
- , ghcPkgOptions
- , ghcMergedPkgOptions
- , ghcLangOptions
- , pkgLicenses
- , flags
- , configFlags
- , nonDefaultConfigFlags
- , packageId
- , compilerVersion
-- * Result types
, ChModuleName(..)
@@ -76,6 +91,9 @@ module Distribution.Helper (
-- * $libexec related error handling
, LibexecNotFoundError(..)
, libexecNotFoundError
+
+ -- * Reexports
+ , module Data.Functor.Apply
) where
import Control.Applicative
@@ -89,9 +107,11 @@ import Data.List
import Data.Maybe
import Data.Version
import Data.Typeable
+import Data.Functor.Apply
import Distribution.Simple.BuildPaths (exeExtension)
import System.Environment
-import System.FilePath
+import System.FilePath hiding ((<.>))
+import qualified System.FilePath as FP
import System.Directory
import System.Process
import System.IO.Unsafe
@@ -105,45 +125,64 @@ import CabalHelper.Shared.Sandbox
-- | Paths or names of various programs we need.
data Programs = Programs {
+ -- | The path to the @cabal@ program.
cabalProgram :: FilePath,
+
+ -- | The path to the @ghc@ program.
ghcProgram :: FilePath,
+
+ -- | The path to the @ghc-pkg@ program. If
+ -- not changed it will be derived from the path to 'ghcProgram'.
ghcPkgProgram :: FilePath
} deriving (Eq, Ord, Show, Read, Generic, Typeable)
-mkPrograms :: Programs
-mkPrograms = Programs "cabal" "ghc" "ghc-pkg"
+-- | Default all programs to their unqualified names, i.e. they will be searched
+-- for on @PATH@.
+defaultPrograms :: Programs
+defaultPrograms = Programs "cabal" "ghc" "ghc-pkg"
+-- | Environment for running a 'Query'. The real constructor is not exposed,
+-- the field accessors are however. See below. Use the 'mkQueryEnv' smart
+-- constructor to construct one.
data QueryEnv = QueryEnv {
- -- | How to start the cabal-helper process. Useful if you need to
- -- capture stderr output from the helper.
+ -- | Field accessor for 'QueryEnv'. Defines how to start the cabal-helper
+ -- process. Useful if you need to capture stderr output from the helper.
qeReadProcess :: FilePath -> [String] -> String -> IO String,
+ -- | Field accessor for 'QueryEnv'.
qePrograms :: Programs,
- -- | Path to project directory, i.e. the one containing the
- -- @project.cabal@ file
+ -- | Field accessor for 'QueryEnv'. Defines path to the project directory,
+ -- i.e. a directory containing a @project.cabal@ file
qeProjectDir :: FilePath,
- -- | Path to the @dist/@ directory
+
+ -- | Field accessor for 'QueryEnv'. Defines path to the @dist/@ directory,
+ -- /builddir/ in Cabal terminology.
qeDistDir :: FilePath,
- -- | Where to look for the Cabal library when linking the helper
+ -- | Field accessor for 'QueryEnv'. Defines where to look for the Cabal
+ -- library when linking the helper.
qeCabalPkgDb :: Maybe FilePath,
- -- | If @dist/setup-config@ wasn\'t written by this version of Cabal throw
- -- an error
+ -- | Field accessor for 'QueryEnv'. If @dist/setup-config@ wasn\'t written
+ -- by this version of Cabal an error is thrown when running the query.
qeCabalVer :: Maybe Version
}
+-- | @mkQueryEnv projdir distdir@. Smart constructor for 'QueryEnv'.
+-- Sets fields 'qeProjectDir' and 'qeDistDir' to @projdir@ and @distdir@
+-- respectively and provides sensible defaults for the other fields.
mkQueryEnv :: FilePath
- -- ^ Path to project directory, i.e. the one containing the
+ -- ^ Path to the project directory, i.e. the directory containing a
-- @project.cabal@ file
-> FilePath
- -- ^ Path to the @dist/@ directory
- -> QueryEnvgs
+ -- ^ Path to the @dist/@ directory, called /builddir/ in Cabal
+ -- terminology.
+ -> QueryEnv
mkQueryEnv projdir distdir = QueryEnv {
qeReadProcess = readProcess
- , qePrograms = mkPrograms
+ , qePrograms = defaultPrograms
, qeProjectDir = projdir
, qeDistDir = distdir
, qeCabalPkgDb = Nothing
@@ -152,23 +191,26 @@ mkQueryEnv projdir distdir = QueryEnv {
data SomeLocalBuildInfo = SomeLocalBuildInfo {
slbiPackageDbStack :: [ChPkgDb],
- slbiEntrypoints :: [(ChComponentName, ChEntrypoint)],
- slbiSourceDirs :: [(ChComponentName, [String])],
- slbiGhcOptions :: [(ChComponentName, [String])],
- slbiGhcSrcOptions :: [(ChComponentName, [String])],
- slbiGhcPkgOptions :: [(ChComponentName, [String])],
- slbiGhcMergedPkgOptions :: [String],
- slbiGhcLangOptions :: [(ChComponentName, [String])],
+ slbiPackageFlags :: [(String, Bool)],
slbiPkgLicenses :: [(String, [(String, Version)])],
- slbiFlags :: [(String, Bool)],
+ slbiCompilerVersion :: (String, Version),
+
+ slbiGhcMergedPkgOptions :: [String],
+
slbiConfigFlags :: [(String, Bool)],
slbiNonDefaultConfigFlags :: [(String, Bool)],
- slbiCompilerVersion :: (String, Version)
+
+ slbiGhcSrcOptions :: [(ChComponentName, [String])],
+ slbiGhcPkgOptions :: [(ChComponentName, [String])],
+ slbiGhcLangOptions :: [(ChComponentName, [String])],
+ slbiGhcOptions :: [(ChComponentName, [String])],
+
+ slbiSourceDirs :: [(ChComponentName, [String])],
+ slbiEntrypoints :: [(ChComponentName, ChEntrypoint)]
} deriving (Eq, Ord, Read, Show)
--- | Caches helper executable result so it doesn't have to be run more than once
--- as reading in Cabal's @LocalBuildInfo@ datatype from disk is very slow but
--- running all possible queries against it at once is cheap.
+-- | A lazy, cached, query against a package's Cabal configuration. Use
+-- 'runQuery' to execute it.
newtype Query m a = Query { unQuery :: StateT (Maybe SomeLocalBuildInfo)
(ReaderT QueryEnv m) a }
deriving (Functor, Applicative, Monad, MonadIO)
@@ -180,11 +222,29 @@ type MonadQuery m = ( MonadIO m
, MonadState (Maybe SomeLocalBuildInfo) m
, MonadReader QueryEnv m)
+-- | A 'Query' to run on all components of a package. Use 'components' to get a
+-- regular 'Query'.
+newtype ComponentQuery m a = ComponentQuery (Query m [(ChComponentName, a)])
+ deriving (Functor)
+
+instance Monad m => Apply (ComponentQuery m) where
+ ComponentQuery flab <.> ComponentQuery fla =
+ ComponentQuery $ liftM2 go flab fla
+ where
+ go :: [(ChComponentName, a -> b)]
+ -> [(ChComponentName, a)]
+ -> [(ChComponentName, b)]
+ go lab la =
+ [ (cn, ab a)
+ | (cn, ab) <- lab
+ , (cn', a) <- la
+ , cn == cn'
+ ]
+
run :: Monad m => QueryEnv -> Maybe SomeLocalBuildInfo -> Query m a -> m a
run e s action = flip runReaderT e (flip evalStateT s (unQuery action))
--- | @runQuery query distdir@. Run a 'Query'. @distdir@ is where Cabal's
--- @setup-config@ file is located.
+-- | @runQuery env query@. Run a 'Query' under a given 'QueryEnv'.
runQuery :: Monad m
=> QueryEnv
-> Query m a
@@ -204,35 +264,14 @@ getSlbi = do
-- | List of package databases to use.
packageDbStack :: MonadIO m => Query m [ChPkgDb]
--- | Modules or files Cabal would have the compiler build directly. Can be used
--- to compute the home module closure for a component.
-entrypoints :: MonadIO m => Query m [(ChComponentName, ChEntrypoint)]
-
--- | A component's @source-dirs@ field, beware as if this is empty implicit
--- behaviour in GHC kicks in.
-sourceDirs :: MonadIO m => Query m [(ChComponentName, [FilePath])]
-
--- | All options cabal would pass to GHC.
-ghcOptions :: MonadIO m => Query m [(ChComponentName, [String])]
-
--- | Only search path related GHC options.
-ghcSrcOptions :: MonadIO m => Query m [(ChComponentName, [String])]
-
--- | Only package related GHC options, sufficient for things don't need to
--- access any home modules.
-ghcPkgOptions :: MonadIO m => Query m [(ChComponentName, [String])]
-
-- | Like @ghcPkgOptions@ but for the whole package not just one component
ghcMergedPkgOptions :: MonadIO m => Query m [String]
--- | Only language related options, i.e. @-XSomeExtension@
-ghcLangOptions :: MonadIO m => Query m [(ChComponentName, [String])]
-
-- | Get the licenses of the packages the current project is linking against.
-pkgLicenses :: MonadIO m => Query m [(String, [(String, Version)])]
+packageLicenses :: MonadIO m => Query m [(String, [(String, Version)])]
-- | Flag definitions from cabal file
-flags :: MonadIO m => Query m [(String, Bool)]
+packageFlags :: MonadIO m => Query m [(String, Bool)]
-- | Flag assignments from setup-config
configFlags :: MonadIO m => Query m [(String, Bool)]
@@ -248,21 +287,46 @@ compilerVersion :: MonadIO m => Query m (String, Version)
-- | Package identifier, i.e. package name and version
packageId :: MonadIO m => Query m (String, Version)
+-- | Run a ComponentQuery on all components of the package.
+components :: Monad m => ComponentQuery m (ChComponentName -> b) -> Query m [b]
+components (ComponentQuery sc) = map (\(cn, f) -> f cn) <$> sc
+
+-- | Modules or files Cabal would have the compiler build directly. Can be used
+-- to compute the home module closure for a component.
+entrypoints :: MonadIO m => ComponentQuery m ChEntrypoint
+
+-- | A component's @source-dirs@ field, beware since if this is empty implicit
+-- behaviour in GHC kicks in.
+sourceDirs :: MonadIO m => ComponentQuery m [FilePath]
+
+-- | All options Cabal would pass to GHC.
+ghcOptions :: MonadIO m => ComponentQuery m [String]
-packageDbStack = Query $ slbiPackageDbStack `liftM` getSlbi
-entrypoints = Query $ slbiEntrypoints `liftM` getSlbi
-sourceDirs = Query $ slbiSourceDirs `liftM` getSlbi
-ghcOptions = Query $ slbiGhcOptions `liftM` getSlbi
-ghcSrcOptions = Query $ slbiGhcSrcOptions `liftM` getSlbi
-ghcPkgOptions = Query $ slbiGhcPkgOptions `liftM` getSlbi
-ghcMergedPkgOptions = Query $ slbiGhcMergedPkgOptions `liftM` getSlbi
-ghcLangOptions = Query $ slbiGhcLangOptions `liftM` getSlbi
-pkgLicenses = Query $ slbiPkgLicenses `liftM` getSlbi
-flags = Query $ slbiFlags `liftM` getSlbi
-configFlags = Query $ slbiConfigFlags `liftM` getSlbi
+-- | Only search path related GHC options.
+ghcSrcOptions :: MonadIO m => ComponentQuery m [String]
+
+-- | Only package related GHC options, sufficient for things don't need to
+-- access any home modules.
+ghcPkgOptions :: MonadIO m => ComponentQuery m [String]
+
+-- | Only language related options, i.e. @-XSomeExtension@
+ghcLangOptions :: MonadIO m => ComponentQuery m [String]
+
+packageId = Query $ getPackageId
+packageDbStack = Query $ slbiPackageDbStack `liftM` getSlbi
+packageFlags = Query $ slbiPackageFlags `liftM` getSlbi
+packageLicenses = Query $ slbiPkgLicenses `liftM` getSlbi
+compilerVersion = Query $ slbiCompilerVersion `liftM` getSlbi
+ghcMergedPkgOptions = Query $ slbiGhcMergedPkgOptions `liftM` getSlbi
+configFlags = Query $ slbiConfigFlags `liftM` getSlbi
nonDefaultConfigFlags = Query $ slbiNonDefaultConfigFlags `liftM` getSlbi
-compilerVersion = Query $ slbiCompilerVersion `liftM` getSlbi
-packageId = Query $ getPackageId
+
+ghcSrcOptions = ComponentQuery $ Query $ slbiGhcSrcOptions `liftM` getSlbi
+ghcPkgOptions = ComponentQuery $ Query $ slbiGhcPkgOptions `liftM` getSlbi
+ghcOptions = ComponentQuery $ Query $ slbiGhcOptions `liftM` getSlbi
+ghcLangOptions = ComponentQuery $ Query $ slbiGhcLangOptions `liftM` getSlbi
+sourceDirs = ComponentQuery $ Query $ slbiSourceDirs `liftM` getSlbi
+entrypoints = ComponentQuery $ Query $ slbiEntrypoints `liftM` getSlbi
-- | Run @cabal configure@
reconfigure :: MonadIO m
@@ -309,47 +373,53 @@ invokeHelper QueryEnv {..} args = do
, " failed"
]
-
getPackageId :: MonadQuery m => m (String, Version)
getPackageId = ask >>= \QueryEnv {..} -> do
[ Just (ChResponseVersion pkgName pkgVer) ] <- readHelper [ "package-id" ]
return (pkgName, pkgVer)
-
getSomeConfigState :: MonadQuery m => m SomeLocalBuildInfo
getSomeConfigState = ask >>= \QueryEnv {..} -> do
res <- readHelper
[ "package-db-stack"
- , "entrypoints"
- , "source-dirs"
- , "ghc-options"
- , "ghc-src-options"
- , "ghc-pkg-options"
- , "ghc-merged-pkg-options"
- , "ghc-lang-options"
- , "licenses"
, "flags"
+ , "licenses"
+ , "compiler-version"
+
+ , "ghc-merged-pkg-options"
+
, "config-flags"
, "non-default-config-flags"
- , "compiler-version"
+
+ , "ghc-src-options"
+ , "ghc-pkg-options"
+ , "ghc-lang-options"
+ , "ghc-options"
+
+ , "source-dirs"
+ , "entrypoints"
]
- let [ Just (ChResponsePkgDbs pkgDbs),
- Just (ChResponseEntrypoints eps),
- Just (ChResponseCompList srcDirs),
- Just (ChResponseCompList ghcOpts),
- Just (ChResponseCompList ghcSrcOpts),
- Just (ChResponseCompList ghcPkgOpts),
- Just (ChResponseList ghcMergedPkgOpts),
- Just (ChResponseCompList ghcLangOpts),
- Just (ChResponseLicenses pkgLics),
- Just (ChResponseFlags fls),
- Just (ChResponseFlags cfls),
- Just (ChResponseFlags ndcfls),
- Just (ChResponseVersion comp compVer)
+ let [ Just (ChResponsePkgDbs slbiPackageDbStack),
+ Just (ChResponseFlags slbiPackageFlags),
+ Just (ChResponseLicenses slbiPkgLicenses),
+ Just (ChResponseVersion comp compVer),
+
+ Just (ChResponseList slbiGhcMergedPkgOptions),
+
+ Just (ChResponseFlags slbiConfigFlags),
+ Just (ChResponseFlags slbiNonDefaultConfigFlags),
+
+ Just (ChResponseCompList slbiGhcSrcOptions),
+ Just (ChResponseCompList slbiGhcPkgOptions),
+ Just (ChResponseCompList slbiGhcLangOptions),
+ Just (ChResponseCompList slbiGhcOptions),
+
+ Just (ChResponseCompList slbiSourceDirs),
+ Just (ChResponseEntrypoints slbiEntrypoints)
] = res
+ slbiCompilerVersion = (comp, compVer)
+ return $ SomeLocalBuildInfo {..}
- return $ SomeLocalBuildInfo
- pkgDbs eps srcDirs ghcOpts ghcSrcOpts ghcPkgOpts ghcMergedPkgOpts ghcLangOpts pkgLics fls cfls ndcfls (comp, compVer)
-- | Make sure the appropriate helper executable for the given project is
-- installed and ready to run queries.
@@ -393,7 +463,7 @@ findLibexecExe :: IO FilePath
findLibexecExe = do
libexecdir <- getLibexecDir
let exeName = "cabal-helper-wrapper"
- exe = libexecdir </> exeName <.> exeExtension'
+ exe = libexecdir </> exeName FP.<.> exeExtension'
exists <- doesFileExist exe