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 --- src/CabalHelper/Compiletime/Process.hs | 30 +++++++++++++++++--- .../Compiletime/Program/CabalInstall.hs | 33 +++++++++++++++++++++- src/CabalHelper/Compiletime/Program/Stack.hs | 2 +- src/CabalHelper/Compiletime/Types.hs | 18 ++++++++---- 4 files changed, 71 insertions(+), 12 deletions(-) (limited to 'src/CabalHelper') 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 -- cgit v1.2.3