Add Loading Style option to runAction (#433)

Allows users to decide at run-time whether they would like to use
experimental features, such as `cabal`'s `multi-repl` feature that
will be released in 3.12.

The `LoadStyle` can not always be honoured by the respective cradle.
For example, if the ghc version or cabal version isn't recent enough.

Author: fendor

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(LoadFile))
 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 LoadFile 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 <& LogRequestedCradleLoadStyle (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
@@ -458,7 +465,8 @@ directCradle :: LogAction IO (WithSeverity Log) -> FilePath -> [String] -> Cradl
 directCradle l wdir args
   = CradleAction
       { actionName = Types.Direct
-      , runCradle = \_ _ ->
+      , runCradle = \_ loadStyle -> do
+          logCradleHasNoSupportForLoadWithContext l loadStyle "direct"
           return (CradleSuccess (ComponentOptions (args ++ argDynamic) wdir []))
       , runGhcCmd = runGhcCmdOnPath l wdir
       }
@@ -480,7 +488,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 +503,17 @@ 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
+  logCradleHasNoSupportForLoadWithContext l loadStyle "bios"
   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.
@@ -779,42 +788,56 @@ cabalGhcDirs l cabalProject workDir = do
   where
     projectFileArgs = projectFileProcessArgs cabalProject
 
-
 cabalAction
   :: ResolvedCradles a
   -> FilePath
   -> Maybe String
   -> 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
+  -- determine which load style is supported by this cabal cradle.
+  determinedLoadStyle <- case (cabal_version, ghc_version) of
+    (Just cabal, Just ghc)
+      -- Multi-component supported from cabal-install 3.11
+      -- and ghc 9.4
+      | LoadWithContext _ <- loadStyle ->
+          if ghc >= makeVersion [9,4] && cabal >= makeVersion [3,11]
+            then pure loadStyle
+            else do
+              liftIO $ l <& WithSeverity
+                (LogLoadWithContextUnsupported "cabal"
+                  $ Just "cabal or ghc version is too old. We require `cabal >= 3.11` and `ghc >= 9.4`"
+                )
+                Warning
+              pure LoadFile
+    _ -> pure LoadFile
+
+  let cabalArgs = case determinedLoadStyle of
+        LoadFile -> [fromMaybe (fixTargetPath fp) mc]
+        LoadWithContext fps -> 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
+            ]
+          ]
+
+  liftIO $ l <& LogComputedCradleLoadStyle "cabal" determinedLoadStyle `WithSeverity` Info
+
   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]
 
   cabalProc <- cabalProcess l projectFile workDir cabalCommand cabalArgs `modCradleError` \err -> do
       deps <- cabalCradleDependencies projectFile workDir workDir
@@ -843,8 +866,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,9 +985,10 @@ stackAction
   -> CradleProjectConfig
   -> LogAction IO (WithSeverity Log)
   -> FilePath
-  -> [FilePath]
+  -> LoadStyle
   -> IO (CradleLoadResult ComponentOptions)
-stackAction workDir mc syaml l _fp _fps = do
+stackAction workDir mc syaml l _fp loadStyle = do
+  logCradleHasNoSupportForLoadWithContext l loadStyle "stack"
   let ghcProcArgs = ("stack", stackYamlProcessArgs syaml <> ["exec", "ghc", "--"])
   -- Same wrapper works as with cabal
   wrapper_fp <- withGhcWrapperTool l ghcProcArgs workDir
@@ -1234,3 +1257,14 @@ readProcessWithCwd' l createdProcess stdin = do
     Nothing -> throwCE $
       CradleError [] ExitSuccess $
         ["Couldn't execute " <> cmdString] <> prettyProcessEnv createdProcess
+
+-- | Log that the cradle has no supported for loading with context, if and only if
+-- 'LoadWithContext' was requested.
+logCradleHasNoSupportForLoadWithContext :: Applicative m => LogAction m (WithSeverity Log) -> LoadStyle -> T.Text -> m ()
+logCradleHasNoSupportForLoadWithContext l (LoadWithContext _) crdlName =
+  l <& WithSeverity
+        (LogLoadWithContextUnsupported crdlName
+          $ Just $ crdlName <> " doesn't support loading multiple components at once"
+        )
+        Info
+logCradleHasNoSupportForLoadWithContext _ _ _ = pure ()

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 LoadFile 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 LoadFile 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.
@@ -91,11 +92,14 @@ data ActionName a
   deriving (Show, Eq, Ord, Functor)
 
 data Log
-  = LogAny String
+  = LogAny !T.Text
   | LogProcessOutput String
   | LogCreateProcessRun CreateProcess
   | LogProcessRun FilePath [FilePath]
-  deriving Show
+  | LogRequestedCradleLoadStyle !T.Text !LoadStyle
+  | LogComputedCradleLoadStyle !T.Text !LoadStyle
+  | LogLoadWithContextUnsupported !T.Text !(Maybe T.Text)
+  deriving (Show)
 
 instance Pretty Log where
   pretty (LogAny s) = pretty s
@@ -116,11 +120,45 @@ instance Pretty Log where
           ]
     where
       envText = map (indent 2 . pretty) $ prettyProcessEnv cp
+  pretty (LogRequestedCradleLoadStyle crdlName ls) =
+    "Requested to load" <+> pretty crdlName <+> "cradle" <+> case ls of
+      LoadFile -> "using single file mode"
+      LoadWithContext fps -> "using all files (multi-components):" <> line <> indent 4 (pretty fps)
+  pretty (LogComputedCradleLoadStyle crdlName ls) =
+    "Load" <+> pretty crdlName <+> "cradle" <+> case ls of
+      LoadFile -> "using single file"
+      LoadWithContext _ -> "using all files (multi-components)"
+
+  pretty (LogLoadWithContextUnsupported crdlName mReason) =
+    pretty crdlName <+> "cradle doesn't support loading using all files (multi-components)" <>
+      case mReason of
+        Nothing -> "."
+        Just reason -> ", because:" <+> pretty reason <> "."
+      <+> "Falling back loading to single file mode."
+
+-- | The 'LoadStyle' instructs a cradle on how to load a given file target.
+data LoadStyle
+  = LoadFile
+  -- ^ Instruct the cradle to load the given file target.
+  --
+  -- What this entails depends on the cradle. For example, the 'cabal' cradle
+  -- will configure the whole component the file target belongs to, and produce
+  -- component options to load the component, which is the minimal unit of code in cabal repl.
+  -- A 'default' cradle, on the other hand, will only load the given filepath.
+  | LoadWithContext [FilePath]
+  -- ^ Give a cradle additional context for loading a file target.
+  --
+  -- The context instructs the cradle to load the file target, while also loading
+  -- the given filepaths.
+  -- This is useful for cradles that support loading multiple code units at once,
+  -- e.g. cabal cradles can use the 'multi-repl' feature to set up a multiple home unit
+  -- session in GHC.
+  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

tests/Utils.hs

@@ -269,7 +269,7 @@ loadComponentOptions fp = do
   a_fp <- normFile fp
   crd <- askCradle
   step $ "Initialise flags for: " <> fp
-  clr <- liftIO $ getCompilerOptions a_fp [] crd
+  clr <- liftIO $ getCompilerOptions a_fp LoadFile crd
   setLoadResult clr
 
 loadRuntimeGhcLibDir :: TestM ()