aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/Distribution/Helper.hs150
-rw-r--r--src/CabalHelper/Compiletime/Process.hs30
-rw-r--r--src/CabalHelper/Compiletime/Program/CabalInstall.hs33
-rw-r--r--src/CabalHelper/Compiletime/Program/Stack.hs2
-rw-r--r--src/CabalHelper/Compiletime/Types.hs18
-rw-r--r--tests/GhcSession.hs2
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 <cabal-helper@dxld.at>
@@ -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
}
}
}
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-24 03:38:56 +0000