diff options
Diffstat (limited to 'Distribution/Helper.hs')
| -rw-r--r-- | Distribution/Helper.hs | 109 |
1 files changed, 61 insertions, 48 deletions
diff --git a/Distribution/Helper.hs b/Distribution/Helper.hs index 38616a7..d2093ca 100644 --- a/Distribution/Helper.hs +++ b/Distribution/Helper.hs @@ -14,17 +14,24 @@ -- 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, FlexibleContexts, ConstraintKinds #-} +{-# LANGUAGE CPP, RecordWildCards, FlexibleContexts, ConstraintKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveGeneric #-} module Distribution.Helper ( Programs(..) + , defaultPrograms + , QueryEnv + , qeReadProcess + , qePrograms + , qeProjectDir + , qeDistDir + , qeCabalPkgDb + , qeCabalVer + , defaultQueryEnv -- * Running Queries , Query , runQuery - , runQuery' - , runQuery'' -- * Queries against Cabal\'s on disk state @@ -68,7 +75,6 @@ import Control.Monad.Reader import Control.Exception as E import Data.Char import Data.List -import Data.Default import Data.Version import Data.Typeable import Distribution.Simple.BuildPaths (exeExtension) @@ -92,8 +98,45 @@ data Programs = Programs { ghcPkgProgram :: FilePath } deriving (Eq, Ord, Show, Read, Generic, Typeable) -instance Default Programs where - def = Programs "cabal" "ghc" "ghc-pkg" +defaultPrograms :: Programs +defaultPrograms = Programs "cabal" "ghc" "ghc-pkg" + +data QueryEnv = QueryEnv { + -- | How to start the cabal-helper process. Useful if you need to + -- capture stderr output from the helper. + qeReadProcess :: FilePath -> [String] -> String -> IO String, + + qePrograms :: Programs, + + -- | Path to project directory, i.e. the one containing the + -- @project.cabal@ file + qeProjectDir :: FilePath, + + -- | Path to the @dist/@ directory + qeDistDir :: FilePath, + + -- | 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 + qeCabalVer :: Maybe Version + } + +defaultQueryEnv :: FilePath + -- ^ Path to project directory, i.e. the one containing the + -- @project.cabal@ file + -> FilePath + -- ^ Path to the @dist/@ directory + -> QueryEnv +defaultQueryEnv projdir distdir = QueryEnv { + qeReadProcess = readProcess + , qePrograms = defaultPrograms + , qeProjectDir = projdir + , qeDistDir = distdir + , qeCabalPkgDb = Nothing + , qeCabalVer = Nothing + } data SomeLocalBuildInfo = SomeLocalBuildInfo { slbiPackageDbStack :: [ChPkgDb], @@ -114,54 +157,20 @@ newtype Query m a = Query { unQuery :: StateT (Maybe SomeLocalBuildInfo) (ReaderT QueryEnv m) a } deriving (Functor, Applicative, Monad, MonadIO) -data QueryEnv = QueryEnv { - _qeReadProcess :: FilePath -> [String] -> String -> IO String, - _qeProgs :: Programs, - _qeProjectDir :: FilePath, - _qeDistDir :: FilePath - } - type MonadQuery m = ( MonadIO m , MonadState (Maybe SomeLocalBuildInfo) m , MonadReader QueryEnv m) -run :: Monad m - => QueryEnv -> Maybe SomeLocalBuildInfo -> Query m a -> m a +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 :: Monad m - => FilePath -- ^ Path to project directory, i.e. the one containing the - -- @project.cabal@ file - -> FilePath -- ^ Path to @dist/@ + => QueryEnv -> Query m a -> m a -runQuery pd dd action = run (QueryEnv readProcess def pd dd) Nothing action - -runQuery' :: Monad m - => Programs - -> FilePath -- ^ Path to project directory, i.e. the one containing the - -- @project.cabal@ file - -> FilePath -- ^ Path to @dist/@ - -> Query m a - -> m a -runQuery' progs pd dd action = - run (QueryEnv readProcess progs pd dd) Nothing action - -runQuery'' :: Monad m - => (FilePath -> [String] -> String -> IO String) - -- ^ How to start the cabal-helper process. Useful if you need to - -- capture stderr output from the helper. - -> Programs - -> FilePath -- ^ Path to project directory, i.e. the one containing the - -- @project.cabal@ file - -> FilePath -- ^ Path to @dist/@ - -> Query m a - -> m a -runQuery'' readProc progs pd dd action = - run (QueryEnv readProc progs pd dd) Nothing action - +runQuery qe action = run qe Nothing action getSlbi :: MonadQuery m => m SomeLocalBuildInfo getSlbi = do @@ -224,7 +233,7 @@ reconfigure readProc progs cabalOpts = do [ "--with-ghc=" ++ ghcProgram progs ] -- Only pass ghc-pkg if it was actually set otherwise we -- might break cabal's guessing logic - ++ if ghcPkgProgram progs /= ghcPkgProgram def + ++ if ghcPkgProgram progs /= "ghc-pkg" then [ "--with-ghc-pkg=" ++ ghcPkgProgram progs ] else [] ++ cabalOpts @@ -232,13 +241,17 @@ reconfigure readProc progs cabalOpts = do return () getSomeConfigState :: MonadQuery m => m SomeLocalBuildInfo -getSomeConfigState = ask >>= \(QueryEnv readProc progs projdir distdir) -> do - let progArgs = [ "--with-ghc=" ++ ghcProgram progs +getSomeConfigState = ask >>= \QueryEnv {..} -> do + let progs = qePrograms + projdir = qeProjectDir + distdir = qeDistDir + + progArgs = [ "--with-ghc=" ++ ghcProgram progs , "--with-ghc-pkg=" ++ ghcPkgProgram progs , "--with-cabal=" ++ cabalProgram progs ] - let args = [ "package-db-stack" + args = [ "package-db-stack" , "entrypoints" , "source-dirs" , "ghc-options" @@ -251,7 +264,7 @@ getSomeConfigState = ask >>= \(QueryEnv readProc progs projdir distdir) -> do res <- liftIO $ do exe <- findLibexecExe "cabal-helper-wrapper" - out <- readProc exe (progArgs ++ projdir:distdir:args) "" + out <- qeReadProcess exe (progArgs ++ projdir:distdir:args) "" evaluate (read out) `E.catch` \(SomeException _) -> error $ concat ["getSomeConfigState", ": ", exe, " " , intercalate " " (map show $ progArgs ++ projdir:distdir:args) |