From aad828c48f26ea6febaabf37632b0e45868db895 Mon Sep 17 00:00:00 2001 From: Daniel Gröber Date: Tue, 6 Aug 2019 02:41:02 +0200 Subject: Add exported interface for running build-tools --- lib/Distribution/Helper.hs | 150 +++++++++++++-------- src/CabalHelper/Compiletime/Process.hs | 30 ++++- .../Compiletime/Program/CabalInstall.hs | 33 ++++- src/CabalHelper/Compiletime/Program/Stack.hs | 2 +- src/CabalHelper/Compiletime/Types.hs | 18 ++- tests/GhcSession.hs | 2 +- 6 files changed, 164 insertions(+), 71 deletions(-) diff --git a/lib/Distribution/Helper.hs b/lib/Distribution/Helper.hs index 3f56328..eb277d5 100644 --- a/lib/Distribution/Helper.hs +++ b/lib/Distribution/Helper.hs @@ -83,6 +83,7 @@ module Distribution.Helper ( -- * Programs , Programs(..) , defaultPrograms + , EnvOverride(..) -- * Query result types , ChComponentInfo(..) @@ -98,9 +99,11 @@ module Distribution.Helper ( -- * Legacy v1-build helpers , Distribution.Helper.getSandboxPkgDb - -- * Stateful helper actions + -- * Build actions , prepare , writeAutogenFiles + , buildProject + , buildUnit ) where import Cabal.Plan hiding (Unit, UnitId, uDistDir) @@ -205,12 +208,13 @@ mkQueryEnv mkQueryEnv projloc distdir = do cr <- newIORef $ QueryCache Nothing Map.empty return $ QueryEnv - { qeReadProcess = \stdin mcwd env exe args -> + { qeReadProcess = \stdin mcwd env exe args -> do + env' <- execEnvOverrides env let cp = (proc exe args) { cwd = mcwd - , env = if env == [] then Nothing else Just env + , env = if env == [] then Nothing else Just env' } - in readCreateProcess cp stdin + readCreateProcess cp stdin , qeCallProcess = \mcwd env exe args -> do let ?verbose = \_ -> False -- TODO: we should get this from env or -- something @@ -385,60 +389,82 @@ discardInactiveUnitInfos active_units uis0 = restrictKeysMap m s = Map.filterWithKey (\k _ -> Set.member k s) m --- | Regenerate project level information by calling the appropriate build +-- | Regenerate project-level information by calling the appropriate build -- system (@cabal@ or @stack@). shallowReconfigureProject :: QueryEnvI c pt -> IO () -shallowReconfigureProject QueryEnv - { qeProjLoc = _ - , qeDistDir = DistDirCabal SCV1 _distdirv1 } = - return () -shallowReconfigureProject QueryEnv - { qeProjLoc = ProjLocV2File projfile projdir - , qeDistDir = DistDirCabal SCV2 _distdirv2, .. } = do - _ <- qeCallProcess (Just projdir) [] (cabalProgram qePrograms) - ["new-build", "--dry-run", "--project-file="++projfile, "all"] - return () -shallowReconfigureProject QueryEnv - { qeProjLoc = ProjLocV2Dir projdir - , qeDistDir = DistDirCabal SCV2 _distdirv2, .. } = do - _ <- qeCallProcess (Just projdir) [] (cabalProgram qePrograms) - ["new-build", "--dry-run", "all"] - return () shallowReconfigureProject QueryEnv { qeProjLoc = ProjLocStackYaml _stack_yaml, .. } = do - -- In case we ever need to read the cabal files before the Unit stage, this - -- command regenerates them from package.yaml - -- - -- _ <- liftIO $ qeCallProcess (Just projdir) (stackProgram qePrograms) - -- ["build", "--dry-run"] "" + -- Stack's dry-run only generates the cabal file from package.yaml (or + -- well that's the only thing we care about that it + -- does). reconfigureUnit will take care of this though and we don't + -- need the cabal files before the Unit stage anyways. return () +shallowReconfigureProject qe = buildProjectTarget qe Nothing DryRun reconfigureUnit :: QueryEnvI c pt -> Unit pt -> IO () -reconfigureUnit QueryEnv{qeDistDir=(DistDirCabal SCV1 _), ..} Unit{} = do - return () -reconfigureUnit - QueryEnv{qeProjLoc=ProjLocV2File projfile _projdir, ..} - Unit{uPackage=Package{pSourceDir=pkgdir}, uImpl} - = do - _ <- qeCallProcess (Just pkgdir) [] (cabalProgram qePrograms) - (["new-build", "--project-file="++projfile] - ++ uiV2Components uImpl) - return () -reconfigureUnit - QueryEnv{qeProjLoc=ProjLocV2Dir{}, ..} - Unit{uPackage=Package{pSourceDir=pkgdir}, uImpl} - = do - _ <- qeCallProcess (Just pkgdir) [] (cabalProgram qePrograms) - (["new-build"] ++ uiV2Components uImpl) - -- TODO: version check for --only-configure - return () -reconfigureUnit - qe@QueryEnv{qeProjLoc=ProjLocStackYaml stack_yaml, ..} - Unit{uPackage=Package{pSourceDir=pkgdir}} - = do - _ <- Stack.callStackCmd qe (Just pkgdir) - ["--stack-yaml="++stack_yaml, "build", "--only-configure", "."] - return () +reconfigureUnit qe u = buildProjectTarget qe (Just u) OnlyCfg + +buildUnit :: QueryEnvI c pt -> Unit pt -> IO () +buildUnit qe u = buildProjectTarget qe (Just u) DoBuild + +buildProject :: QueryEnvI c pt -> IO () +buildProject qe = buildProjectTarget qe Nothing DoBuild + +data BuildStage = DryRun | OnlyCfg | DoBuild + +buildProjectTarget + :: QueryEnvI c pt -> Maybe (Unit pt) -> BuildStage -> IO () +buildProjectTarget qe mu stage = do + -- Stack and cabal just happen to have the same stage options, totally by + -- accident :) + stage_opts :: [String] <- return $ case stage of + DryRun -> ["--dry-run"] + OnlyCfg -> ["--only-configure"] + DoBuild -> [] + -- TODO: version check for cabal's --only-configure + case qe of + QueryEnv { qeDistDir = DistDirCabal cpt distdir, qeProjLoc } -> do + let projdir = plCabalProjectDir qeProjLoc + cmd <- return $ case stage of + DryRun | SCV1 <- cpt -> + CabalInstall.CIConfigure + OnlyCfg -> + CabalInstall.CIConfigure + _ -> + CabalInstall.CIBuild + CabalInstall.callCabalInstallCmd qe (Just projdir) cmd $ + case cpt of + SCV1 -> + [ "--builddir="++distdir ] + SCV2 -> do + targets <- return $ case mu of + Nothing -> ["all"] + Just Unit{uImpl} -> uiV2Components uImpl + case qeProjLoc of + ProjLocV2File {plCabalProjectFile} -> + [ "--project-file="++plCabalProjectFile + , "--builddir="++distdir + ] ++ stage_opts ++ targets + ProjLocV2Dir {} -> + [ "--builddir="++distdir + ] ++ stage_opts ++ targets + + QueryEnv { qeDistDir = DistDirStack mworkdir + , qeProjLoc = qeProjLoc@ProjLocStackYaml {plStackYaml} + } -> do + let projdir = plStackProjectDir qeProjLoc + let workdir_opts = Stack.workdirArg qe + case mu of + Just Unit{uPackage=Package{pSourceDir}} -> + Stack.callStackCmd qe (Just pSourceDir) $ + workdir_opts ++ + [ "--stack-yaml="++plStackYaml, "build", "." + ] ++ stage_opts + Nothing -> + Stack.callStackCmd qe (Just projdir) $ + workdir_opts ++ + [ "--stack-yaml="++plStackYaml, "build" + ] ++ stage_opts getFileModTime :: FilePath -> IO (FilePath, EpochTime) getFileModTime f = do @@ -636,7 +662,8 @@ withVerbosity act = do _ -> False act --- | Bring 'Programs' and 'CompPrograms' into scope as implicit parameters +-- | Fixup program paths as appropriate for current project-type and bring +-- 'Programs' into scope as an implicit parameter. withProgs :: Verbose => ProjInfoImpl pt -> QueryEnvI c pt -> (Env => IO a) -> IO a withProgs impl QueryEnv{..} f = do @@ -651,10 +678,7 @@ withProgs impl QueryEnv{..} f = do guessCompProgramPaths progs | same ghcProgram progs dprogs = return progs guessCompProgramPaths progs = do - let v | ?verbose 2 = normal - | ?verbose 3 = verbose - | ?verbose 4 = deafening - | otherwise = silent + let v = getCabalVerbosity mGhcPath0 | same ghcProgram progs dprogs = Nothing | otherwise = Just $ ghcProgram progs mGhcPkgPath0 | same ghcPkgProgram progs dprogs = Nothing @@ -668,9 +692,19 @@ withProgs impl QueryEnv{..} f = do let getProg p = ProgDb.programPath <$> ProgDb.lookupProgram p progdb mghcPath1 = getProg ProgDb.ghcProgram mghcPkgPath1 = getProg ProgDb.ghcPkgProgram + ghc = fromMaybe (ghcProgram progs) mghcPath1 + ghc_pkg = fromMaybe (ghcPkgProgram progs) mghcPkgPath1 return progs - { ghcProgram = fromMaybe (ghcProgram progs) mghcPath1 - , ghcPkgProgram = fromMaybe (ghcProgram progs) mghcPkgPath1 + { ghcProgram = ghc + , ghcPkgProgram = ghc_pkg + , stackEnv = stackEnv progs ++ + -- TODO: this is a cludge, need to make a symlink farm for + -- stack instead. Note: Haddock also has to be in the compiler + -- dir. + [("PATH", EnvPrepend $ takeDirectory ghc ++ [searchPathSeparator])] + , cabalUnitArgs = cabalUnitArgs progs ++ + maybeToList (("--with-ghc="++) <$> mghcPath1) ++ + maybeToList (("--with-ghc-pkg="++) <$> mghcPkgPath1) } same f o o' = f o == f o' diff --git a/src/CabalHelper/Compiletime/Process.hs b/src/CabalHelper/Compiletime/Process.hs index 5e9bbbd..948d455 100644 --- a/src/CabalHelper/Compiletime/Process.hs +++ b/src/CabalHelper/Compiletime/Process.hs @@ -25,11 +25,14 @@ module CabalHelper.Compiletime.Process , module System.Process ) where +import Control.Arrow (second) import Data.Char import Data.List +import qualified Data.Map.Strict as Map import GHC.IO.Exception (IOErrorType(OtherError)) import System.IO import System.IO.Error +import System.Environment import System.Exit import System.Process @@ -47,22 +50,41 @@ readProcess' exe args inp = do -- | Essentially 'System.Process.callProcess' but returns exit code, has -- additional options and logging to stderr when verbosity is enabled. callProcessStderr' - :: Verbose => Maybe FilePath -> [(String, String)] + :: Verbose => Maybe FilePath -> [(String, EnvOverride)] -> FilePath -> [String] -> IO ExitCode callProcessStderr' mwd env exe args = do let cd = case mwd of Nothing -> []; Just wd -> [ "cd", formatProcessArg wd++";" ] - vLog $ intercalate " " $ cd ++ map formatProcessArg (exe:args) + vLog $ intercalate " " $ + cd ++ map formatProcessArg (map (\(k,v) -> k ++ "=" ++ show v) env ++ exe:args) + + env' <- execEnvOverrides env (_, _, _, h) <- createProcess (proc exe args) { std_out = UseHandle stderr - , env = if env == [] then Nothing else Just env + , env = if env == [] then Nothing else Just env' , cwd = mwd } waitForProcess h +execEnvOverride :: EnvOverride -> String -> String +execEnvOverride (EnvPrepend x) y = x ++ y +execEnvOverride (EnvAppend y) x = x ++ y +execEnvOverride (EnvReplace x) _ = x + +execEnvOverrides :: [(String, EnvOverride)] -> IO [(String, String)] +execEnvOverrides overrides = do + envs <- getEnvironment + return $ do + (k,v) <- envs + case Map.lookup k overrides_map of + Just os -> return (k, foldr execEnvOverride v os) + Nothing -> return (k, v) + where + overrides_map = Map.fromListWith (++) $ map (second (:[])) overrides + -- | Essentially 'System.Process.callProcess' but with additional options -- and logging to stderr when verbosity is enabled. -callProcessStderr :: Verbose => Maybe FilePath -> [(String, String)] +callProcessStderr :: Verbose => Maybe FilePath -> [(String, EnvOverride)] -> FilePath -> [String] -> IO () callProcessStderr mwd env exe args = do rv <- callProcessStderr' mwd env exe args diff --git a/src/CabalHelper/Compiletime/Program/CabalInstall.hs b/src/CabalHelper/Compiletime/Program/CabalInstall.hs index 686743b..cce4364 100644 --- a/src/CabalHelper/Compiletime/Program/CabalInstall.hs +++ b/src/CabalHelper/Compiletime/Program/CabalInstall.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, MultiWayIf, TupleSections #-} +{-# LANGUAGE DataKinds, MultiWayIf, TupleSections, GADTs #-} -- cabal-helper: Simple interface to Cabal's configuration state -- Copyright (C) 2018 Daniel Gröber @@ -312,3 +312,34 @@ cpCompNameToChComponentName cn = (CP.CompNameExe name) -> ChExeName $ Text.unpack name (CP.CompNameTest name) -> ChTestName $ Text.unpack name (CP.CompNameBench name) -> ChBenchName $ Text.unpack name + +data CabalInstallCommand + = CIConfigure + | CIBuild + +doCabalInstallCmd + :: (QueryEnvI c ('Cabal cpt) -> CallProcessWithCwdAndEnv a) + -> QueryEnvI c ('Cabal cpt) + -> Maybe FilePath -> CabalInstallCommand -> [String] -> IO a +doCabalInstallCmd procfn qe mcwd cmd args = do + case (cmd, projTypeOfQueryEnv qe) of + (CIConfigure, SCabal SCV1) -> + run "v1-configure" cabalProjArgs cabalUnitArgs [] + (CIBuild, SCabal SCV1) -> + run "v1-build" cabalProjArgs [] [] + (_, SCabal SCV2) -> + run "v2-build" cabalProjArgs cabalUnitArgs [] + where + Programs{..} = qePrograms qe + run cmdarg before aftercmd after = procfn qe mcwd [] cabalProgram $ + before ++ [cmdarg] ++ aftercmd ++ args ++ after + +readCabalInstallCmd + :: QueryEnvI c ('Cabal cpt) + -> Maybe FilePath -> CabalInstallCommand -> [String] -> IO String +callCabalInstallCmd + :: QueryEnvI c ('Cabal cpt) + -> Maybe FilePath -> CabalInstallCommand -> [String] -> IO () + +readCabalInstallCmd = doCabalInstallCmd (\qe -> qeReadProcess qe "") +callCabalInstallCmd = doCabalInstallCmd qeCallProcess diff --git a/src/CabalHelper/Compiletime/Program/Stack.hs b/src/CabalHelper/Compiletime/Program/Stack.hs index 264050a..6f3365f 100644 --- a/src/CabalHelper/Compiletime/Program/Stack.hs +++ b/src/CabalHelper/Compiletime/Program/Stack.hs @@ -126,7 +126,7 @@ doStackCmd :: (QueryEnvI c 'Stack -> CallProcessWithCwdAndEnv a) doStackCmd procfn qe mcwd args = let Programs{..} = qePrograms qe in procfn qe mcwd stackEnv stackProgram $ - stackArgsBefore ++ args ++ stackArgsAfter + stackProjArgs ++ args ++ stackUnitArgs readStackCmd :: QueryEnvI c 'Stack -> Maybe FilePath -> [String] -> IO String callStackCmd :: QueryEnvI c 'Stack -> Maybe FilePath -> [String] -> IO () diff --git a/src/CabalHelper/Compiletime/Types.hs b/src/CabalHelper/Compiletime/Types.hs index 619538c..d206cf0 100644 --- a/src/CabalHelper/Compiletime/Types.hs +++ b/src/CabalHelper/Compiletime/Types.hs @@ -269,7 +269,7 @@ type ReadProcessWithCwdAndEnv = String -> CallProcessWithCwdAndEnv String type CallProcessWithCwdAndEnv a = - Maybe FilePath -> [(String, String)] -> FilePath -> [String] -> IO a + Maybe FilePath -> [(String, EnvOverride)] -> FilePath -> [String] -> IO a data QueryCache pt = QueryCache { qcProjInfo :: !(Maybe (ProjInfo pt)) @@ -484,14 +484,14 @@ type Progs = (?progs :: Programs) data Programs = Programs { cabalProgram :: !FilePath -- ^ The path to the @cabal@ program. - , cabalArgsBefore :: ![String] - , cabalArgsAfter :: ![String] + , cabalProjArgs :: ![String] + , cabalUnitArgs :: ![String] , stackProgram :: !FilePath -- ^ The path to the @stack@ program. - , stackArgsBefore :: ![String] - , stackArgsAfter :: ![String] - , stackEnv :: ![(String, String)] + , stackProjArgs :: ![String] + , stackUnitArgs :: ![String] + , stackEnv :: ![(String, EnvOverride)] -- ^ TODO: Stack doesn't support passing the compiler as a -- commandline option so we meddle with PATH instead. We should -- patch that upstream. @@ -509,6 +509,12 @@ data Programs = Programs defaultPrograms :: Programs defaultPrograms = Programs "cabal" [] [] "stack" [] [] [] "ghc" "ghc-pkg" +data EnvOverride + = EnvPrepend String + | EnvAppend String + | EnvReplace String + deriving (Eq, Ord, Show, Read, Generic, Typeable) + data CompileOptions = CompileOptions { oVerbose :: Bool , oCabalPkgDb :: Maybe PackageDbDir diff --git a/tests/GhcSession.hs b/tests/GhcSession.hs index 886ee82..91ae42a 100644 --- a/tests/GhcSession.hs +++ b/tests/GhcSession.hs @@ -499,7 +499,7 @@ stackProjSetup ghcVer = copyMuliPackageProject progs srcdir destdir copyStackYamls , psiQEmod = \qe -> qe { qePrograms = (qePrograms qe) - { stackArgsBefore = argsBefore + { stackProjArgs = argsBefore } } } -- cgit v1.2.3