From 8971532fa38ac854feece77136780b328c2edbc9 Mon Sep 17 00:00:00 2001 From: Pablo Lamela Seijas Date: Mon, 10 Jun 2024 12:22:34 +0200 Subject: [PATCH 1/4] Add progress reporting support to cabal building --- exe/Main.hs | 4 +- hie-bios.cabal | 2 +- src/HIE/Bios/Cradle.hs | 132 +++++++++++++++++++++++---------- src/HIE/Bios/Internal/Debug.hs | 4 +- 4 files changed, 97 insertions(+), 45 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index 28871682..f7245bdc 100644 --- a/exe/Main.hs +++ b/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 diff --git a/hie-bios.cabal b/hie-bios.cabal index e76ccf99..1f900117 100644 --- a/hie-bios.cabal +++ b/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 diff --git a/src/HIE/Bios/Cradle.hs b/src/HIE/Bios/Cradle.hs index b9cd3f9b..c81276b4 100644 --- a/src/HIE/Bios/Cradle.hs +++ b/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,21 +543,26 @@ 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: -- ./dist-newstyle/tmp/environment.-24811: createDirectory: does not exist (No such file or directory) liftIO $ createDirectoryIfMissing True (buildDir "tmp") -- Need to pass -v0 otherwise we get "resolving dependencies..." - cabalProc <- cabalProcess l projectFile wdir "v2-exec" $ ["ghc", "-v0", "--"] ++ args + cabalProc <- cabalProcess cpr l projectFile wdir "v2-exec" $ ["ghc", "-v0", "--"] ++ args 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. @@ -566,8 +573,8 @@ cabalCradle l cs wdir mc projectFile -- to the custom ghc wrapper via 'hie_bios_ghc' environment variable which -- the custom ghc wrapper may use as a fallback if it can not respond to certain -- queries, such as ghc version or location of the libdir. -cabalProcess :: LogAction IO (WithSeverity Log) -> CradleProjectConfig -> FilePath -> String -> [String] -> CradleLoadResultT IO CreateProcess -cabalProcess l cabalProject workDir command args = do +cabalProcess :: CompilationProgressReporter -> LogAction IO (WithSeverity Log) -> CradleProjectConfig -> FilePath -> String -> [String] -> CradleLoadResultT IO CreateProcess +cabalProcess _ l cabalProject workDir command args = do ghcDirs <- cabalGhcDirs l cabalProject workDir newEnvironment <- liftIO $ setupEnvironment ghcDirs cabalProc <- liftIO $ setupCabalCommand ghcDirs @@ -789,7 +796,8 @@ cabalGhcDirs l cabalProject workDir = do projectFileArgs = projectFileProcessArgs cabalProject cabalAction - :: ResolvedCradles a + :: CompilationProgressReporter + -> ResolvedCradles a -> FilePath -> Maybe String -> LogAction IO (WithSeverity Log) @@ -797,7 +805,7 @@ cabalAction -> 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. @@ -839,11 +847,11 @@ cabalAction (ResolvedCradles root cs vs) workDir mc l projectFile fp loadStyle = let cabalCommand = "v2-repl" - cabalProc <- cabalProcess l projectFile workDir cabalCommand cabalArgs `modCradleError` \err -> do + cabalProc <- cabalProcess cpr l projectFile workDir cabalCommand cabalArgs `modCradleError` \err -> do 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 $ readCabalProcessWithProgress cpr [hie_bios_output] l workDir cabalProc let args = fromMaybe [] maybeArgs let errorDetails = @@ -1158,19 +1166,18 @@ 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 +readCabalProcessWithProgress + :: 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])]) -readProcessWithOutputs outputNames l workDir cp = flip runContT return $ do +readCabalProcessWithProgress cpr outputNames l workDir cp = flip runContT return $ do old_env <- liftIO getCleanEnvironment output_files <- traverse (withOutput old_env) outputNames @@ -1179,11 +1186,19 @@ 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 + loggingReportingConduit = baseConduit + C..| void ((C.mapAccumM (reportProgress cpr) (CabalParserToBuild 0))) + C..| C.sinkList + loggingAndMaybeReportingConduit = case cpr of + Nothing -> loggingOnlyConduit + Just _ -> loggingReportingConduit liftIO $ l <& LogCreateProcessRun process `WithSeverity` Info - (ex, stdo, stde) <- liftIO $ sourceProcessWithStreams process mempty loggingConduit loggingConduit - + (ex, stdo, stde) <- liftIO $ sourceProcessWithStreams process mempty loggingAndMaybeReportingConduit + loggingOnlyConduit + res <- forM output_files $ \(name,path) -> liftIO $ (name,) <$> readOutput path @@ -1212,6 +1227,43 @@ readProcessWithOutputs outputNames l workDir cp = flip runContT return $ do removeFileIfExists file action (name, file) + reportProgress :: CompilationProgressReporter -> String -> CabalParserState -> IO (CabalParserState, String) + reportProgress Nothing str cps = pure (cps, str) + reportProgress (Just reporter) str cps@(CabalParserToBuild { numPackagesDeclared = numPackages }) = do + let startBuilding = do reporter (CompilationProgress { numPackagesToCompile = numPackages + , numPackagesCompiled = 0 + }) + pure (CabalParserBuilding { numPackagesCompleted = 0, numPackagesToBuild = numPackages }, str) + case str of + ' ':'-':' ':_ -> pure (cps { numPackagesDeclared = numPackages + 1 }, str) + 'S':'t':'a':'r':'t':'i':'n':'g':' ':' ':' ':' ':' ':_ -> startBuilding + _ -> pure (cps, str) + reportProgress (Just 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 }, str) + _ -> pure (cps, str) + +-- | 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 outputNames l workDir cp = + readCabalProcessWithProgress Nothing outputNames l workDir cp + removeFileIfExists :: FilePath -> IO () removeFileIfExists f = do yes <- doesFileExist f diff --git a/src/HIE/Bios/Internal/Debug.hs b/src/HIE/Bios/Internal/Debug.hs index 85ba048a..12aca278 100644 --- a/src/HIE/Bios/Internal/Debug.hs +++ b/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 From 92a2359ab0c13e9f6106d2e4db5c70e29b0591cd Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Wed, 17 Jul 2024 22:08:17 +0200 Subject: [PATCH 2/4] Remove unnecessary parameter in `cabalProcess` --- src/HIE/Bios/Cradle.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/HIE/Bios/Cradle.hs b/src/HIE/Bios/Cradle.hs index c81276b4..fbff09e9 100644 --- a/src/HIE/Bios/Cradle.hs +++ b/src/HIE/Bios/Cradle.hs @@ -554,7 +554,7 @@ cabalCradle cpr l cs wdir mc projectFile -- ./dist-newstyle/tmp/environment.-24811: createDirectory: does not exist (No such file or directory) liftIO $ createDirectoryIfMissing True (buildDir "tmp") -- Need to pass -v0 otherwise we get "resolving dependencies..." - cabalProc <- cabalProcess cpr l projectFile wdir "v2-exec" $ ["ghc", "-v0", "--"] ++ args + cabalProc <- cabalProcess l projectFile wdir "v2-exec" $ ["ghc", "-v0", "--"] ++ args readProcessWithCwd' l cabalProc "" } @@ -573,8 +573,8 @@ type CompilationProgressReporter = Maybe (CompilationProgress -> IO ()) -- to the custom ghc wrapper via 'hie_bios_ghc' environment variable which -- the custom ghc wrapper may use as a fallback if it can not respond to certain -- queries, such as ghc version or location of the libdir. -cabalProcess :: CompilationProgressReporter -> LogAction IO (WithSeverity Log) -> CradleProjectConfig -> FilePath -> String -> [String] -> CradleLoadResultT IO CreateProcess -cabalProcess _ l cabalProject workDir command args = do +cabalProcess :: LogAction IO (WithSeverity Log) -> CradleProjectConfig -> FilePath -> String -> [String] -> CradleLoadResultT IO CreateProcess +cabalProcess l cabalProject workDir command args = do ghcDirs <- cabalGhcDirs l cabalProject workDir newEnvironment <- liftIO $ setupEnvironment ghcDirs cabalProc <- liftIO $ setupCabalCommand ghcDirs @@ -847,7 +847,7 @@ cabalAction cpr (ResolvedCradles root cs vs) workDir mc l projectFile fp loadSty let cabalCommand = "v2-repl" - cabalProc <- cabalProcess cpr l projectFile workDir cabalCommand cabalArgs `modCradleError` \err -> do + cabalProc <- cabalProcess l projectFile workDir cabalCommand cabalArgs `modCradleError` \err -> do deps <- cabalCradleDependencies projectFile workDir workDir pure $ err { cradleErrorDependencies = cradleErrorDependencies err ++ deps } From 6d71b932eab6b38c6f07d6b4a648cdea7e866fe2 Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Wed, 17 Jul 2024 22:49:27 +0200 Subject: [PATCH 3/4] Decouple cabal process monitoring function --- src/HIE/Bios/Cradle.hs | 87 +++++++++++++++++++++++++----------------- 1 file changed, 51 insertions(+), 36 deletions(-) diff --git a/src/HIE/Bios/Cradle.hs b/src/HIE/Bios/Cradle.hs index fbff09e9..c43d1f36 100644 --- a/src/HIE/Bios/Cradle.hs +++ b/src/HIE/Bios/Cradle.hs @@ -851,7 +851,7 @@ cabalAction cpr (ResolvedCradles root cs vs) workDir mc l projectFile fp loadSty deps <- cabalCradleDependencies projectFile workDir workDir pure $ err { cradleErrorDependencies = cradleErrorDependencies err ++ deps } - (ex, output, stde, [(_, maybeArgs)]) <- liftIO $ readCabalProcessWithProgress cpr [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 = @@ -1170,14 +1170,15 @@ data CabalParserState = CabalParserToBuild { numPackagesDeclared :: Int } | CabalParserBuilding { numPackagesCompleted :: Int, numPackagesToBuild :: Int } -- | Same as 'readProcessWithOutputs' but reports process when running cabal build -readCabalProcessWithProgress - :: CompilationProgressReporter -- ^ Reporter function for the compilation process - -> Outputs -- ^ Names of the outputs produced by this process +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])]) -readCabalProcessWithProgress cpr 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 @@ -1189,14 +1190,14 @@ readCabalProcessWithProgress cpr outputNames l workDir cp = flip runContT return 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 - loggingReportingConduit = baseConduit - C..| void ((C.mapAccumM (reportProgress cpr) (CabalParserToBuild 0))) - C..| C.sinkList - loggingAndMaybeReportingConduit = case cpr of - Nothing -> loggingOnlyConduit - Just _ -> loggingReportingConduit + 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 loggingAndMaybeReportingConduit + (ex, stdo, stde) <- liftIO $ sourceProcessWithStreams process mempty loggingAndMaybeMonitoringConduit loggingOnlyConduit res <- forM output_files $ \(name,path) -> @@ -1205,6 +1206,11 @@ readCabalProcessWithProgress cpr outputNames l workDir cp = flip runContT return 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 @@ -1227,28 +1233,6 @@ readCabalProcessWithProgress cpr outputNames l workDir cp = flip runContT return removeFileIfExists file action (name, file) - reportProgress :: CompilationProgressReporter -> String -> CabalParserState -> IO (CabalParserState, String) - reportProgress Nothing str cps = pure (cps, str) - reportProgress (Just reporter) str cps@(CabalParserToBuild { numPackagesDeclared = numPackages }) = do - let startBuilding = do reporter (CompilationProgress { numPackagesToCompile = numPackages - , numPackagesCompiled = 0 - }) - pure (CabalParserBuilding { numPackagesCompleted = 0, numPackagesToBuild = numPackages }, str) - case str of - ' ':'-':' ':_ -> pure (cps { numPackagesDeclared = numPackages + 1 }, str) - 'S':'t':'a':'r':'t':'i':'n':'g':' ':' ':' ':' ':' ':_ -> startBuilding - _ -> pure (cps, str) - reportProgress (Just 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 }, str) - _ -> pure (cps, str) - -- | 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. @@ -1261,8 +1245,39 @@ readProcessWithOutputs -> 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 = - readCabalProcessWithProgress Nothing outputNames l workDir cp +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 From 6a7e8b630f71b517987092291d3a311069bb0e86 Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Fri, 19 Jul 2024 00:57:10 +0200 Subject: [PATCH 4/4] Update tests --- tests/Utils.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/Utils.hs b/tests/Utils.hs index bbe600ff..4c7d3442 100644 --- a/tests/Utils.hs +++ b/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 ()