Add progress reporting support to cabal building

exe/Main.hs

@@ -72,8 +72,8 @@ main = do
  cradle <-
  -- find cradle does a takeDirectory on the argument, so make it into a file
  findCradle (cwd </> "File.hs") >>= \case
- Just yaml -> loadCradle logger yaml
- Nothing -> loadImplicitCradle logger (cwd </> "File.hs")
+ Just yaml -> loadCradle Nothing logger yaml
+ Nothing -> loadImplicitCradle Nothing logger (cwd </> "File.hs")
 
  res <- case cmd of
  Check targetFiles -> checkSyntax logger cradle targetFiles

hie-bios.cabal

@@ -193,7 +193,7 @@ Executable hie-bios
  Default-Language: Haskell2010
  Main-Is: Main.hs
  Other-Modules: Paths_hie_bios
- GHC-Options: -Wall
+ GHC-Options: -Wall -threaded
  HS-Source-Dirs: exe
  Build-Depends: base >= 4.16 && < 5
  , co-log-core

src/HIE/Bios/Cradle.hs

@@ -25,6 +25,7 @@ module HIE.Bios.Cradle (
  , makeCradleResult
  -- | Cradle project configuration types
  , CradleProjectConfig(..)
+ , CompilationProgress(..)
  ) where
 
 import Control.Applicative ((<|>), optional)
@@ -45,6 +46,7 @@ import Control.Monad.IO.Class
 import Data.Conduit.Process
 import qualified Data.Conduit.Combinators as C
 import qualified Data.Conduit as C
+import qualified Data.Conduit.List as C (mapAccumM)
 import qualified Data.Conduit.Text as C
 import qualified Data.HashMap.Strict as Map
 import Data.Maybe (fromMaybe, maybeToList)
@@ -90,31 +92,31 @@ findCradle wfile = do
  runMaybeT (yamlConfig wdir)
 
 -- | Given root\/hie.yaml load the Cradle.
-loadCradle :: LogAction IO (WithSeverity Log) -> FilePath -> IO (Cradle Void)
-loadCradle l = loadCradleWithOpts l absurd
+loadCradle :: CompilationProgressReporter -> LogAction IO (WithSeverity Log) -> FilePath -> IO (Cradle Void)
+loadCradle cpr l = loadCradleWithOpts cpr l absurd
 
 -- | Given root\/foo\/bar.hs, load an implicit cradle
-loadImplicitCradle :: Show a => LogAction IO (WithSeverity Log) -> FilePath -> IO (Cradle a)
-loadImplicitCradle l wfile = do
+loadImplicitCradle :: Show a => CompilationProgressReporter -> LogAction IO (WithSeverity Log) -> FilePath -> IO (Cradle a)
+loadImplicitCradle cpr l wfile = do
  let wdir = takeDirectory wfile
  cfg <- runMaybeT (implicitConfig wdir)
  case cfg of
- Just bc -> getCradle l absurd bc
+ Just bc -> getCradle cpr l absurd bc
  Nothing -> return $ defaultCradle l wdir
 
 -- | Finding 'Cradle'.
 -- Find a cabal file by tracing ancestor directories.
 -- Find a sandbox according to a cabal sandbox config
 -- in a cabal directory.
-loadCradleWithOpts :: (Yaml.FromJSON b, Show a) => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> FilePath -> IO (Cradle a)
-loadCradleWithOpts l buildCustomCradle wfile = do
+loadCradleWithOpts :: (Yaml.FromJSON b, Show a) => CompilationProgressReporter -> LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> FilePath -> IO (Cradle a)
+loadCradleWithOpts cpr l buildCustomCradle wfile = do
  cradleConfig <- readCradleConfig wfile
- getCradle l buildCustomCradle (cradleConfig, takeDirectory wfile)
+ getCradle cpr l buildCustomCradle (cradleConfig, takeDirectory wfile)
 
-getCradle :: Show a => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> (CradleConfig b, FilePath) -> IO (Cradle a)
-getCradle l buildCustomCradle (cc, wdir) = do
+getCradle :: Show a => CompilationProgressReporter -> LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> (CradleConfig b, FilePath) -> IO (Cradle a)
+getCradle cpr l buildCustomCradle (cc, wdir) = do
  rcs <- canonicalizeResolvedCradles wdir cs
- resolvedCradlesToCradle l buildCustomCradle wdir rcs
+ resolvedCradlesToCradle cpr l buildCustomCradle wdir rcs
  where
  cs = resolveCradleTree wdir cc
 
@@ -212,8 +214,8 @@ addActionDeps deps =
  (\(ComponentOptions os' dir ds) -> CradleSuccess (ComponentOptions os' dir (ds `union` deps)))
 
 
-resolvedCradlesToCradle :: Show a => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> FilePath -> [ResolvedCradle b] -> IO (Cradle a)
-resolvedCradlesToCradle logger buildCustomCradle root cs = mdo
+resolvedCradlesToCradle :: Show a => CompilationProgressReporter -> LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> FilePath -> [ResolvedCradle b] -> IO (Cradle a)
+resolvedCradlesToCradle cpr logger buildCustomCradle root cs = mdo
  let run_ghc_cmd args =
  -- We're being lazy here and just returning the ghc path for the
  -- first non-none cradle. This shouldn't matter in practice: all
@@ -226,7 +228,7 @@ resolvedCradlesToCradle logger buildCustomCradle root cs = mdo
  args
  versions <- makeVersions logger root run_ghc_cmd
  let rcs = ResolvedCradles root cs versions
- cradleActions = [ (c, resolveCradleAction logger buildCustomCradle rcs root c) | c <- cs ]
+ cradleActions = [ (c, resolveCradleAction cpr logger buildCustomCradle rcs root c) | c <- cs ]
  err_msg fp
  = ["Multi Cradle: No prefixes matched"
  , "pwd: " ++ root
@@ -284,10 +286,10 @@ resolvedCradlesToCradle logger buildCustomCradle root cs = mdo
  notNoneType _ = True
 
 
-resolveCradleAction :: Show a => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> ResolvedCradles b -> FilePath -> ResolvedCradle b -> CradleAction a
-resolveCradleAction l buildCustomCradle cs root cradle = addLoadStyleLogToCradleAction $
+resolveCradleAction :: Show a => CompilationProgressReporter -> LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> ResolvedCradles b -> FilePath -> ResolvedCradle b -> CradleAction a
+resolveCradleAction cpr l buildCustomCradle cs root cradle = addLoadStyleLogToCradleAction $
  case concreteCradle cradle of
- ConcreteCabal t -> cabalCradle l cs root (cabalComponent t) (projectConfigFromMaybe root (cabalProjectFile t))
+ ConcreteCabal t -> cabalCradle cpr l cs root (cabalComponent t) (projectConfigFromMaybe root (cabalProjectFile t))
  ConcreteStack t -> stackCradle l root (stackComponent t) (projectConfigFromMaybe root (stackYaml t))
  ConcreteBios bios deps mbGhc -> biosCradle l root bios deps mbGhc
  ConcreteDirect xs -> directCradle l root xs
@@ -541,11 +543,11 @@ projectLocationOrDefault = \case
 
 -- |Cabal Cradle
 -- Works for new-build by invoking `v2-repl`.
-cabalCradle :: LogAction IO (WithSeverity Log) -> ResolvedCradles b -> FilePath -> Maybe String -> CradleProjectConfig -> CradleAction a
-cabalCradle l cs wdir mc projectFile
+cabalCradle :: CompilationProgressReporter -> LogAction IO (WithSeverity Log) -> ResolvedCradles b -> FilePath -> Maybe String -> CradleProjectConfig -> CradleAction a
+cabalCradle cpr l cs wdir mc projectFile
  = CradleAction
  { actionName = Types.Cabal
- , runCradle = \fp -> runCradleResultT . cabalAction cs wdir mc l projectFile fp
+ , runCradle = \fp -> runCradleResultT . cabalAction cpr cs wdir mc l projectFile fp
  , runGhcCmd = \args -> runCradleResultT $ do
  buildDir <- liftIO $ cabalBuildDir wdir
  -- Workaround for a cabal-install bug on 3.0.0.0:
@@ -556,6 +558,11 @@ cabalCradle l cs wdir mc projectFile
  readProcessWithCwd' l cabalProc ""
  }
 
+data CompilationProgress = CompilationProgress { numPackagesToCompile :: Int
+ , numPackagesCompiled :: Int
+ }
+
+type CompilationProgressReporter = Maybe (CompilationProgress -> IO ())
 
 -- | Execute a cabal process in our custom cache-build directory configured
 -- with the custom ghc executable.
@@ -789,15 +796,16 @@ cabalGhcDirs l cabalProject workDir = do
  projectFileArgs = projectFileProcessArgs cabalProject
 
 cabalAction
- :: ResolvedCradles a
+ :: CompilationProgressReporter
+ -> ResolvedCradles a
  -> FilePath
  -> Maybe String
  -> LogAction IO (WithSeverity Log)
  -> CradleProjectConfig
  -> FilePath
  -> LoadStyle
  -> CradleLoadResultT IO ComponentOptions
-cabalAction (ResolvedCradles root cs vs) workDir mc l projectFile fp loadStyle = do
+cabalAction cpr (ResolvedCradles root cs vs) workDir mc l projectFile fp loadStyle = do
  cabal_version <- liftIO $ runCachedIO $ cabalVersion vs
  ghc_version <- liftIO $ runCachedIO $ ghcVersion vs
  -- determine which load style is supported by this cabal cradle.
@@ -843,7 +851,7 @@ cabalAction (ResolvedCradles root cs vs) workDir mc l projectFile fp loadStyle =
  deps <- cabalCradleDependencies projectFile workDir workDir
  pure $ err { cradleErrorDependencies = cradleErrorDependencies err ++ deps }
 
- (ex, output, stde, [(_, maybeArgs)]) <- liftIO $ readProcessWithOutputs [hie_bios_output] l workDir cabalProc
+ (ex, output, stde, [(_, maybeArgs)]) <- liftIO $ readCabalWithOutputsAndProgress cpr [hie_bios_output] l workDir cabalProc
  let args = fromMaybe [] maybeArgs
 
  let errorDetails =
@@ -1158,19 +1166,19 @@ getCleanEnvironment = do
 type Outputs = [OutputName]
 type OutputName = String
 
--- | Call a given process with temp files for the process to write to.
--- * The process can discover the temp files paths by reading the environment.
--- * The contents of the temp files are returned by this function, if any.
--- * The logging function is called every time the process emits anything to stdout or stderr.
--- it can be used to report progress of the process to a user.
--- * The process is executed in the given directory.
-readProcessWithOutputs
- :: Outputs  -- ^ Names of the outputs produced by this process
+data CabalParserState = CabalParserToBuild { numPackagesDeclared :: Int }
+ | CabalParserBuilding { numPackagesCompleted :: Int, numPackagesToBuild :: Int }
+
+-- | Same as 'readProcessWithOutputs' but reports process when running cabal build
+readAndFollowProcess
+ :: Maybe (String -> state -> IO state, state)
+ -- ^ Monitor function that takes a line of output and a state and returns a new state
+ -> Outputs -- ^ Names of the outputs produced by this process
  -> LogAction IO (WithSeverity Log) -- ^ Output of the process is emitted as logs.
  -> FilePath -- ^ Working directory. Process is executed in this directory.
  -> CreateProcess -- ^ Parameters for the process to be executed.
  -> IO (ExitCode, [String], [String], [(OutputName, Maybe [String])])
-readProcessWithOutputs outputNames l workDir cp = flip runContT return $ do
+readAndFollowProcess mMonitorFunc outputNames l workDir cp = flip runContT return $ do
  old_env <- liftIO getCleanEnvironment
  output_files <- traverse (withOutput old_env) outputNames
 
@@ -1179,17 +1187,30 @@ readProcessWithOutputs outputNames l workDir cp = flip runContT return $ do
  }
 
  -- Windows line endings are not converted so you have to filter out `'r` characters
- let loggingConduit = C.decodeUtf8 C..| C.lines C..| C.filterE (/= '\r')
- C..| C.map T.unpack C..| C.iterM (\msg -> l <& LogProcessOutput msg `WithSeverity` Debug) C..| C.sinkList
+ let baseConduit = C.decodeUtf8 C..| C.lines C..| C.filterE (/= '\r')
+ C..| C.map T.unpack C..| C.iterM (\msg -> l <& LogProcessOutput msg `WithSeverity` Debug)
+ loggingOnlyConduit = baseConduit C..| C.sinkList
+ loggingAndMaybeMonitoringConduit =
+ case mMonitorFunc of
+ Nothing -> loggingOnlyConduit
+ Just (monitorFunc, acc0) -> baseConduit
+ C..| void (C.mapAccumM (wrapConduit monitorFunc) acc0)
+ C..| C.sinkList
  liftIO $ l <& LogCreateProcessRun process `WithSeverity` Info
- (ex, stdo, stde) <- liftIO $ sourceProcessWithStreams process mempty loggingConduit loggingConduit
-
+ (ex, stdo, stde) <- liftIO $ sourceProcessWithStreams process mempty loggingAndMaybeMonitoringConduit
+ loggingOnlyConduit
+
  res <- forM output_files $ \(name,path) ->
  liftIO $ (name,) <$> readOutput path
 
  return (ex, stdo, stde, res)
 
  where
+ wrapConduit :: (String -> state -> IO state) -> String -> state -> IO (state, String)
+ wrapConduit f str acc = do
+ acc' <- f str acc
+ return (acc', str)
+
  readOutput :: FilePath -> IO (Maybe [String])
  readOutput path = do
  haveFile <- doesFileExist path
@@ -1212,6 +1233,52 @@ readProcessWithOutputs outputNames l workDir cp = flip runContT return $ do
  removeFileIfExists file
  action (name, file)
 
+-- | Call a given process with temp files for the process to write to.
+-- * The process can discover the temp files paths by reading the environment.
+-- * The contents of the temp files are returned by this function, if any.
+-- * The logging function is called every time the process emits anything to stdout or stderr.
+-- it can be used to report progress of the process to a user.
+-- * The process is executed in the given directory.
+readProcessWithOutputs
+ :: Outputs -- ^ Names of the outputs produced by this process
+ -> LogAction IO (WithSeverity Log) -- ^ Output of the process is emitted as logs.
+ -> FilePath -- ^ Working directory. Process is executed in this directory.
+ -> CreateProcess -- ^ Parameters for the process to be executed.
+ -> IO (ExitCode, [String], [String], [(OutputName, Maybe [String])])
+readProcessWithOutputs = readAndFollowProcess Nothing
+
+-- | Same as 'readProcessWithOutputs' but reports process when running cabal build
+readCabalWithOutputsAndProgress
+ :: CompilationProgressReporter -- ^ Reporter function for the compilation process
+ -> Outputs -- ^ Names of the outputs produced by this process
+ -> LogAction IO (WithSeverity Log) -- ^ Output of the process is emitted as logs.
+ -> FilePath -- ^ Working directory. Process is executed in this directory.
+ -> CreateProcess -- ^ Parameters for the process to be executed.
+ -> IO (ExitCode, [String], [String], [(OutputName, Maybe [String])])
+readCabalWithOutputsAndProgress Nothing = readAndFollowProcess Nothing
+readCabalWithOutputsAndProgress (Just cpr) = readAndFollowProcess (Just (reportProgress cpr, (CabalParserToBuild 0)))
+ where
+ reportProgress :: (CompilationProgress -> IO ()) -> String -> CabalParserState -> IO CabalParserState
+ reportProgress reporter str cps@(CabalParserToBuild { numPackagesDeclared = numPackages }) = do
+ let startBuilding = do reporter (CompilationProgress { numPackagesToCompile = numPackages
+ , numPackagesCompiled = 0
+ })
+ pure $ CabalParserBuilding { numPackagesCompleted = 0, numPackagesToBuild = numPackages }
+ case str of
+ ' ':'-':' ':_ -> pure $ cps { numPackagesDeclared = numPackages + 1 }
+ 'S':'t':'a':'r':'t':'i':'n':'g':' ':' ':' ':' ':' ':_ -> startBuilding
+ _ -> pure cps
+ reportProgress reporter str cps@(CabalParserBuilding { numPackagesCompleted = numPackages
+ , numPackagesToBuild = totalPackages
+ }) =
+ case str of
+ 'C':'o':'m':'p':'l':'e':'t':'e':'d':' ':' ':' ':' ':_ -> do
+ reporter $ CompilationProgress { numPackagesToCompile = totalPackages
+ , numPackagesCompiled = numPackages + 1
+ }
+ pure $ cps { numPackagesCompleted = numPackages + 1 }
+ _ -> pure cps
+
 removeFileIfExists :: FilePath -> IO ()
 removeFileIfExists f = do
  yes <- doesFileExist f

src/HIE/Bios/Internal/Debug.hs

@@ -95,8 +95,8 @@ findCradle' :: LogAction IO (WithSeverity Log) -> FilePath -> IO String
 findCradle' l fp =
  findCradle fp >>= \case
  Just yaml -> do
- crdl <- loadCradle l yaml
+ crdl <- loadCradle Nothing l yaml
  return $ show crdl
  Nothing -> do
- crdl <- loadImplicitCradle l fp :: IO (Cradle Void)
+ crdl <- loadImplicitCradle Nothing l fp :: IO (Cradle Void)
  return $ show crdl

tests/Utils.hs

@@ -253,15 +253,15 @@ initCradle fp = do
  relMcfg <- traverse relFile mcfg
  step $ "Loading Cradle: " <> show relMcfg
  crd <- case mcfg of
- Just cfg -> liftIO $ loadCradle testLogger cfg
- Nothing -> liftIO $ loadImplicitCradle testLogger a_fp
+ Just cfg -> liftIO $ loadCradle Nothing testLogger cfg
+ Nothing -> liftIO $ loadImplicitCradle Nothing testLogger a_fp
  setCradle crd
 
 initImplicitCradle :: FilePath -> TestM ()
 initImplicitCradle fp = do
  a_fp <- normFile fp
  step $ "Loading implicit Cradle for: " <> fp
- crd <- liftIO $ loadImplicitCradle testLogger a_fp
+ crd <- liftIO $ loadImplicitCradle Nothing testLogger a_fp
  setCradle crd
 
 loadComponentOptions :: FilePath -> TestM ()