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..c43d1f36 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,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,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. @@ -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 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 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 ()