Add Loading Style option to 'runAction'

exe/Main.hs

@@ -16,6 +16,7 @@ import HIE.Bios
 import HIE.Bios.Ghc.Check
 import HIE.Bios.Ghc.Gap as Gap
 import HIE.Bios.Internal.Debug
+import HIE.Bios.Types (LoadStyle(SingleComponent))
 import Paths_hie_bios
 
 ----------------------------------------------------------------
@@ -84,7 +85,7 @@ main = do
         [] -> error "too few arguments"
         _ -> do
           res <- forM files $ \fp -> do
-                  res <- getCompilerOptions fp [] cradle
+                  res <- getCompilerOptions fp SingleComponent cradle
                   case res of
                       CradleFail (CradleError _deps _ex err) ->
                         return $ "Failed to show flags for \""

hie-bios.cabal

@@ -172,8 +172,8 @@ Library
                         exceptions           ^>= 0.10,
                         cryptohash-sha1      >= 0.11.100 && < 0.12,
                         directory            >= 1.3.0 && < 1.4,
-                        filepath             >= 1.4.1 && < 1.5,
-                        time                 >= 1.8.0 && < 1.13,
+                        filepath             >= 1.4.1 && < 1.6,
+                        time                 >= 1.8.0 && < 1.14,
                         extra                >= 1.6.14 && < 1.8,
                         prettyprinter        ^>= 1.6 || ^>= 1.7.0,
                         ghc                  >= 9.2.1 && < 9.9,

src/HIE/Bios/Cradle.hs

@@ -284,15 +284,22 @@ resolvedCradlesToCradle logger buildCustomCradle root cs = mdo
     notNoneType _ = True
 
 
-resolveCradleAction :: LogAction IO (WithSeverity Log) ->  (b -> CradleAction a) -> ResolvedCradles b -> FilePath -> ResolvedCradle b -> CradleAction a
-resolveCradleAction l buildCustomCradle cs root cradle =
+resolveCradleAction :: Show a => LogAction IO (WithSeverity Log) -> (b -> CradleAction a) -> ResolvedCradles b -> FilePath -> ResolvedCradle b -> CradleAction a
+resolveCradleAction l buildCustomCradle cs root cradle = addLoadStyleLogToCradleAction $
   case concreteCradle cradle of
     ConcreteCabal t -> cabalCradle 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
     ConcreteNone -> noneCradle
     ConcreteOther a -> buildCustomCradle a
+  where
+    -- Add a log message to each loading operation.
+    addLoadStyleLogToCradleAction crdlAct = crdlAct
+      { runCradle = \fp ls -> do
+          l <& LogCradleLoadStyle (T.pack $ show $ actionName crdlAct) ls `WithSeverity` Debug
+          runCradle crdlAct fp ls
+      }
 
 resolveCradleTree :: FilePath -> CradleConfig a -> [ResolvedCradle a]
 resolveCradleTree root (CradleConfig confDeps confTree) = go root confDeps confTree
@@ -480,7 +487,7 @@ biosCradle l wdir biosCall biosDepsCall mbGhc
 biosWorkDir :: FilePath -> MaybeT IO FilePath
 biosWorkDir = findFileUpwards (".hie-bios" ==)
 
-biosDepsAction :: LogAction IO (WithSeverity Log) -> FilePath -> Maybe Callable -> FilePath -> [FilePath] -> IO [FilePath]
+biosDepsAction :: LogAction IO (WithSeverity Log) -> FilePath -> Maybe Callable -> FilePath -> LoadStyle -> IO [FilePath]
 biosDepsAction l wdir (Just biosDepsCall) fp _prevs = do
   biosDeps' <- callableToProcess biosDepsCall (Just fp) -- TODO multi pass the previous files too
   (ex, sout, serr, [(_, args)]) <- readProcessWithOutputs [hie_bios_output] l wdir biosDeps'
@@ -495,16 +502,16 @@ biosAction
   -> Maybe Callable
   -> LogAction IO (WithSeverity Log)
   -> FilePath
-  -> [FilePath]
+  -> LoadStyle
   -> IO (CradleLoadResult ComponentOptions)
-biosAction wdir bios bios_deps l fp fps = do
+biosAction wdir bios bios_deps l fp loadStyle = do
   bios' <- callableToProcess bios (Just fp) -- TODO pass all the files instead of listToMaybe
   (ex, _stdo, std, [(_, res),(_, mb_deps)]) <-
     readProcessWithOutputs [hie_bios_output, hie_bios_deps] l wdir bios'
 
   deps <- case mb_deps of
     Just x  -> return x
-    Nothing -> biosDepsAction l wdir bios_deps fp fps
+    Nothing -> biosDepsAction l wdir bios_deps fp loadStyle
         -- Output from the program should be written to the output file and
         -- delimited by newlines.
         -- Execute the bios action and add dependencies of the cradle.
@@ -787,34 +794,39 @@ cabalAction
   -> LogAction IO (WithSeverity Log)
   -> CradleProjectConfig
   -> FilePath
-  -> [FilePath]
+  -> LoadStyle
   -> CradleLoadResultT IO ComponentOptions
-cabalAction (ResolvedCradles root cs vs) workDir mc l projectFile fp fps = do
+cabalAction (ResolvedCradles root cs vs) workDir mc l projectFile fp loadStyle = do
   cabal_version <- liftIO $ runCachedIO $ cabalVersion vs
   ghc_version   <- liftIO $ runCachedIO $ ghcVersion vs
   let
     cabalCommand = "v2-repl"
-    cabalArgs = case (cabal_version, ghc_version) of
-      (Just cabal, Just ghc)
-        -- Multi-component supported from cabal-install 3.11
-        -- and ghc 9.4
-        | ghc   >= makeVersion [9,4]
-        , cabal >= makeVersion [3,11]
-        -> case fps of
-          [] -> [fromMaybe (fixTargetPath fp) mc]
-          -- Start a multi-component session with all the old files
-          _ -> "--keep-temp-files"
-             : "--enable-multi-repl"
-             : fromMaybe (fixTargetPath fp) mc
-             : [fromMaybe (fixTargetPath old_fp) old_mc
-               | old_fp <- fps
-               -- Lookup the component for the old file
-               , Just (ResolvedCradle{concreteCradle = ConcreteCabal ct}) <- [selectCradle prefix old_fp cs]
-               -- Only include this file if the old component is in the same project
-               , (projectConfigFromMaybe root (cabalProjectFile ct)) == projectFile
-               , let old_mc = cabalComponent ct
-               ]
-      _ -> [fromMaybe (fixTargetPath fp) mc]
+  cabalArgs <- case (cabal_version, ghc_version) of
+    (Just cabal, Just ghc)
+      -- Multi-component supported from cabal-install 3.11
+      -- and ghc 9.4
+      | ghc   >= makeVersion [9,4]
+      , cabal >= makeVersion [3,11]
+      -> case loadStyle of
+        SingleComponent -> pure [fromMaybe (fixTargetPath fp) mc]
+        -- Start a multi-component session with all the old files
+        LoadWithContext fps -> do
+          liftIO $ l <& LogCabalMultiComponentSupport `WithSeverity` Info
+          pure $ concat
+            [ [ "--keep-temp-files"
+              , "--enable-multi-repl"
+              , fromMaybe (fixTargetPath fp) mc
+              ]
+            , [fromMaybe (fixTargetPath old_fp) old_mc
+              | old_fp <- fps
+              -- Lookup the component for the old file
+              , Just (ResolvedCradle{concreteCradle = ConcreteCabal ct}) <- [selectCradle prefix old_fp cs]
+              -- Only include this file if the old component is in the same project
+              , (projectConfigFromMaybe root (cabalProjectFile ct)) == projectFile
+              , let old_mc = cabalComponent ct
+              ]
+            ]
+    _ -> pure [fromMaybe (fixTargetPath fp) mc]
 
   cabalProc <- cabalProcess l projectFile workDir cabalCommand cabalArgs `modCradleError` \err -> do
       deps <- cabalCradleDependencies projectFile workDir workDir
@@ -843,8 +855,7 @@ cabalAction (ResolvedCradles root cs vs) workDir mc l projectFile fp fps = do
       -- Best effort. Assume the working directory is the
       -- root of the component, so we are right in trivial cases at least.
       deps <- liftIO $ cabalCradleDependencies projectFile workDir workDir
-      throwCE (CradleError deps ex $
-                (["Failed to parse result of calling cabal" ] <> errorDetails))
+      throwCE (CradleError deps ex $ ["Failed to parse result of calling cabal" ] <> errorDetails)
     Just (componentDir, final_args) -> do
       deps <- liftIO $ cabalCradleDependencies projectFile workDir componentDir
       CradleLoadResultT $ pure $ makeCradleResult (ex, stde, componentDir, final_args) deps
@@ -963,7 +974,7 @@ stackAction
   -> CradleProjectConfig
   -> LogAction IO (WithSeverity Log)
   -> FilePath
-  -> [FilePath]
+  -> LoadStyle
   -> IO (CradleLoadResult ComponentOptions)
 stackAction workDir mc syaml l _fp _fps = do
   let ghcProcArgs = ("stack", stackYamlProcessArgs syaml <> ["exec", "ghc", "--"])

src/HIE/Bios/Flags.hs

@@ -8,9 +8,9 @@ import Colog.Core (WithSeverity (..), Severity (..), (<&))
 -- file or GHC session according to the provided 'Cradle'.
 getCompilerOptions
   :: FilePath -- ^ The file we are loading it because of
-  -> [FilePath] -- ^ previous files we might want to include in the build
+  -> LoadStyle -- ^ previous files we might want to include in the build
   -> Cradle a
   -> IO (CradleLoadResult ComponentOptions)
-getCompilerOptions fp fps cradle = do
+getCompilerOptions fp loadStyle cradle = do
   (cradleLogger cradle) <& LogProcessOutput "invoking build tool to determine build flags (this may take some time depending on the cache)" `WithSeverity` Info
-  runCradle (cradleOptsProg cradle) fp fps
+  runCradle (cradleOptsProg cradle) fp loadStyle

src/HIE/Bios/Ghc/Api.hs

@@ -39,7 +39,7 @@ initializeFlagsWithCradleWithMessage ::
   -> Cradle a  -- ^ The cradle we want to load
   -> m (CradleLoadResult (m G.SuccessFlag, ComponentOptions)) -- ^ Whether we actually loaded the cradle or not.
 initializeFlagsWithCradleWithMessage msg fp cradle =
-    fmap (initSessionWithMessage msg) <$> liftIO (getCompilerOptions fp [] cradle)
+    fmap (initSessionWithMessage msg) <$> liftIO (getCompilerOptions fp SingleComponent cradle)
 
 -- | Actually perform the initialisation of the session. Initialising the session corresponds to
 -- parsing the command line flags, setting the targets for the session and then attempting to load

src/HIE/Bios/Internal/Debug.hs

@@ -30,7 +30,7 @@ debugInfo :: Show a
           -> IO String
 debugInfo fp cradle = unlines <$> do
     let logger = cradleLogger cradle
-    res <- getCompilerOptions fp [] cradle
+    res <- getCompilerOptions fp SingleComponent cradle
     canonFp <- canonicalizePath fp
     conf <- findConfig canonFp
     crdl <- findCradle' logger canonFp

src/HIE/Bios/Types.hs

@@ -13,9 +13,10 @@ import           Control.Monad.Trans.Class
 #if MIN_VERSION_base(4,9,0)
 import qualified Control.Monad.Fail as Fail
 #endif
-import Prettyprinter
-import System.Process.Extra (CreateProcess (env, cmdspec), CmdSpec (..))
-import Data.Maybe (fromMaybe)
+import           Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import           Prettyprinter
+import           System.Process.Extra (CreateProcess (env, cmdspec), CmdSpec (..))
 
 ----------------------------------------------------------------
 -- Environment variables used by hie-bios.
@@ -95,6 +96,8 @@ data Log
   | LogProcessOutput String
   | LogCreateProcessRun CreateProcess
   | LogProcessRun FilePath [FilePath]
+  | LogCradleLoadStyle !T.Text !LoadStyle
+  | LogCabalMultiComponentSupport
   deriving Show
 
 instance Pretty Log where
@@ -116,11 +119,21 @@ instance Pretty Log where
           ]
     where
       envText = map (indent 2 . pretty) $ prettyProcessEnv cp
+  pretty (LogCradleLoadStyle crdlName ls) =
+    "Loading" <+> pretty crdlName <+> "using" <+> case ls of
+      SingleComponent -> "Single Component Strategy"
+      LoadWithContext fps -> "Multiple Components Strategy:" <> line <> indent 4 (pretty fps)
+  pretty LogCabalMultiComponentSupport = "Cabal cradle uses 'multi-repl' support."
+
+data LoadStyle
+  = SingleComponent
+  | LoadWithContext [FilePath]
+  deriving (Show, Eq, Ord)
 
 data CradleAction a = CradleAction {
                         actionName    :: ActionName a
                       -- ^ Name of the action.
-                      , runCradle     :: FilePath -> [FilePath] -> IO (CradleLoadResult ComponentOptions)
+                      , runCradle     :: FilePath -> LoadStyle -> IO (CradleLoadResult ComponentOptions)
                       -- ^ Options to compile the given file with.
                       , runGhcCmd     :: [String] -> IO (CradleLoadResult String)
                       -- ^ Executes the @ghc@ binary that is usually used to