Add exported interface for running build-tools

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
                }
              }
       }