Keep track of not loaded files for cabal (#453)

When we fail to load some files X, we want to know exactly what files Y we actually did try to load. Where Y ⊆ X.

In the context of HLS, X is the set of files which we already tried to load with the file that we want to additionally load into our HLS session.
Y is a subset of X, chosen based on the Cradle type (bios and stack cradles do not support loading a component with the context information), and GHC and cabal-install version. 
In particular, cabal cradles can make use of the full set of X for initialising a session if and only if the GHC and cabal-install version is recent enough, *and* the user explicitly requested a multi-repl session.

By tracking which files we have actually tried to load, HLS can then try to reduce the number of files we put into sequential loading loop once batch load is failed for haskell/haskell-language-server#4445

Author: soulomoon

exe/Main.hs

@@ -87,7 +87,7 @@ main = do
           res <- forM files $ \fp -> do
                   res <- getCompilerOptions fp LoadFile cradle
                   case res of
-                      CradleFail (CradleError _deps _ex err) ->
+                      CradleFail (CradleError _deps _ex err _fps) ->
                         return $ "Failed to show flags for \""
                                                   ++ fp
                                                   ++ "\": " ++ show err

hie-bios.cabal

@@ -138,6 +138,11 @@ Extra-Source-Files:     README.md
                         tests/projects/stack-with-yaml/hie.yaml
                         tests/projects/stack-with-yaml/stack-with-yaml.cabal
                         tests/projects/stack-with-yaml/src/Lib.hs
+                        tests/projects/failing-multi-repl-cabal-project/multi-repl-cabal-fail/app/Main.hs
+                        tests/projects/failing-multi-repl-cabal-project/multi-repl-cabal-fail/multi-repl-cabal-fail.cabal
+                        tests/projects/failing-multi-repl-cabal-project/multi-repl-cabal-fail/src/Fail.hs
+                        tests/projects/failing-multi-repl-cabal-project/multi-repl-cabal-fail/src/Lib.hs
+                        tests/projects/failing-multi-repl-cabal-project/NotInPath.hs
 
 tested-with: GHC ==9.2.8 || ==9.4.8 || ==9.6.5 || ==9.8.2 || ==9.10.1 || ==9.12.1
 

src/HIE/Bios/Cradle.hs

@@ -25,6 +25,11 @@ module HIE.Bios.Cradle (
     , makeCradleResult
     -- | Cradle project configuration types
     , CradleProjectConfig(..)
+
+    -- expose to tests
+    , makeVersions
+    , isCabalMultipleCompSupported
+    , ProgramVersions
   ) where
 
 import Control.Applicative ((<|>), optional)
@@ -47,9 +52,10 @@ import qualified Data.Conduit.Combinators as C
 import qualified Data.Conduit as C
 import qualified Data.Conduit.Text as C
 import qualified Data.HashMap.Strict as Map
+import qualified Data.HashSet as S
 import Data.Maybe (fromMaybe, maybeToList)
 import Data.List
-import Data.List.Extra (trimEnd)
+import Data.List.Extra (trimEnd, nubOrd)
 import Data.Ord (Down(..))
 import qualified Data.Text as T
 import System.Environment
@@ -73,6 +79,7 @@ import GHC.ResponseFile (escapeArgs)
 import Data.Version
 import Data.IORef
 import Text.ParserCombinators.ReadP (readP_to_S)
+import Data.Tuple.Extra (fst3, snd3, thd3)
 
 ----------------------------------------------------------------
 
@@ -129,6 +136,7 @@ data ConcreteCradle a
   | ConcreteOther a
   deriving Show
 
+
 -- | ConcreteCradle augmented with information on which file the
 -- cradle applies
 data ResolvedCradle a
@@ -243,7 +251,7 @@ resolvedCradlesToCradle logger buildCustomCradle root cs = mdo
           case selectCradle (prefix . fst) absfp cradleActions of
             Just (rc, act) -> do
               addActionDeps (cradleDeps rc) <$> runCradle act fp prev
-            Nothing -> return $ CradleFail $ CradleError [] ExitSuccess (err_msg fp)
+            Nothing -> return $ CradleFail $ CradleError [] ExitSuccess (err_msg fp) [fp]
       , runGhcCmd = run_ghc_cmd
       }
     }
@@ -518,7 +526,7 @@ biosAction wdir bios bios_deps l fp loadStyle = do
         -- delimited by newlines.
         -- Execute the bios action and add dependencies of the cradle.
         -- Removes all duplicates.
-  return $ makeCradleResult (ex, std, wdir, fromMaybe [] res) deps
+  return $ makeCradleResult (ex, std, wdir, fromMaybe [] res) deps [fp]
 
 callableToProcess :: Callable -> Maybe String -> IO CreateProcess
 callableToProcess (Command shellCommand) file = do
@@ -788,6 +796,15 @@ cabalGhcDirs l cabalProject workDir = do
   where
     projectFileArgs = projectFileProcessArgs cabalProject
 
+isCabalMultipleCompSupported :: MonadIO m => ProgramVersions -> m Bool
+isCabalMultipleCompSupported vs = do
+  cabal_version <- liftIO $ runCachedIO $ cabalVersion vs
+  ghc_version <- liftIO $ runCachedIO $ ghcVersion vs
+  -- determine which load style is supported by this cabal cradle.
+  case (cabal_version, ghc_version) of
+    (Just cabal, Just ghc) -> pure $ ghc >= makeVersion [9, 4] && cabal >= makeVersion [3, 11]
+    _ -> pure False
+
 cabalAction
   :: ResolvedCradles a
   -> FilePath
@@ -798,84 +815,84 @@ cabalAction
   -> LoadStyle
   -> CradleLoadResultT IO ComponentOptions
 cabalAction (ResolvedCradles root cs vs) workDir mc l projectFile fp loadStyle = do
-  cabal_version <- liftIO $ runCachedIO $ cabalVersion vs
-  ghc_version   <- liftIO $ runCachedIO $ ghcVersion vs
+  multiCompSupport <- isCabalMultipleCompSupported 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
-            ]
-          ]
+  determinedLoadStyle <- case loadStyle of
+    LoadWithContext _ | not multiCompSupport -> 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 loadStyle
+
+  let fpModule = fromMaybe (fixTargetPath fp) mc
+  let (cabalArgs, loadingFiles, extraDeps) = case determinedLoadStyle of
+        LoadFile -> ([fpModule], [fp], [])
+        LoadWithContext fps ->
+          let allModulesFpsDeps = ((fpModule, fp, []) : moduleFilesFromSameProject fps)
+              allModules = nubOrd $ fst3 <$> allModulesFpsDeps
+              allFiles = nubOrd $ snd3 <$> allModulesFpsDeps
+              allFpsDeps = nubOrd $ concatMap thd3 allModulesFpsDeps
+           in (["--keep-temp-files", "--enable-multi-repl"] ++ allModules, allFiles, allFpsDeps)
 
   liftIO $ l <& LogComputedCradleLoadStyle "cabal" determinedLoadStyle `WithSeverity` Info
+  liftIO $ l <& LogCabalLoad fp mc (prefix <$> cs) loadingFiles `WithSeverity` Debug
 
-  let
-    cabalCommand = "v2-repl"
+  let cabalCommand = "v2-repl"
 
-  cabalProc <- cabalProcess 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 }
+      pure $ err {cradleErrorDependencies = cradleErrorDependencies err ++ deps}
 
   (ex, output, stde, [(_, maybeArgs)]) <- liftIO $ readProcessWithOutputs [hie_bios_output] l workDir cabalProc
   let args = fromMaybe [] maybeArgs
 
   let errorDetails =
-        ["Failed command: " <> prettyCmdSpec (cmdspec cabalProc)
-        , unlines output
-        , unlines stde
-        , unlines $ args
-        , "Process Environment:"]
-        <> prettyProcessEnv cabalProc
+        [ "Failed command: " <> prettyCmdSpec (cmdspec cabalProc),
+          unlines output,
+          unlines stde,
+          unlines args,
+          "Process Environment:"
+        ]
+          <> prettyProcessEnv cabalProc
 
   when (ex /= ExitSuccess) $ do
     deps <- liftIO $ cabalCradleDependencies projectFile workDir workDir
     let cmd = show (["cabal", cabalCommand] <> cabalArgs)
     let errorMsg = "Failed to run " <> cmd <> " in directory \"" <> workDir <> "\". Consult the logs for full command and error."
-    throwCE (CradleError deps ex ([errorMsg] <> errorDetails))
+    throwCE (CradleError deps ex ([errorMsg] <> errorDetails) loadingFiles)
 
   case processCabalWrapperArgs args of
     Nothing -> do
       -- Provide some dependencies an IDE can look for to trigger a reload.
       -- 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 <> extraDeps) ex (["Failed to parse result of calling cabal"] <> errorDetails) loadingFiles)
     Just (componentDir, final_args) -> do
       deps <- liftIO $ cabalCradleDependencies projectFile workDir componentDir
-      CradleLoadResultT $ pure $ makeCradleResult (ex, stde, componentDir, final_args) deps
+      CradleLoadResultT $ pure $ makeCradleResult (ex, stde, componentDir, final_args) (deps <> extraDeps) loadingFiles
   where
     -- Need to make relative on Windows, due to a Cabal bug with how it
-    -- parses file targets with a C: drive in it
+    -- parses file targets with a C: drive in it. So we decide to make
+    -- the paths relative to the working directory.
     fixTargetPath x
       | isWindows && hasDrive x = makeRelative workDir x
       | otherwise = x
+    moduleFilesFromSameProject fps =
+      [ (fromMaybe (fixTargetPath file) old_mc, file, deps)
+      | file <- fps,
+        -- Lookup the component for the old file
+        Just (ResolvedCradle {concreteCradle = ConcreteCabal ct, cradleDeps = deps}) <- [selectCradle prefix file cs],
+        -- Only include this file if the old component is in the same project
+        (projectConfigFromMaybe root (cabalProjectFile ct)) == projectFile,
+        let old_mc = cabalComponent ct
+      ]
 
 removeInteractive :: [String] -> [String]
 removeInteractive = filter (/= "--interactive")
@@ -928,7 +945,7 @@ cabalWorkDir wdir =
 data CradleProjectConfig
   = NoExplicitConfig
   | ExplicitConfig FilePath
-  deriving Eq
+  deriving (Eq, Show)
 
 -- | Create an explicit project configuration. Expects a working directory
 -- followed by an optional name of the project configuration.
@@ -987,7 +1004,7 @@ stackAction
   -> FilePath
   -> LoadStyle
   -> IO (CradleLoadResult ComponentOptions)
-stackAction workDir mc syaml l _fp loadStyle = 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
@@ -1011,10 +1028,11 @@ stackAction workDir mc syaml l _fp loadStyle = do
         -- the root of the component, so we are right in trivial cases at least.
         deps <- stackCradleDependencies workDir workDir syaml
         pure $ CradleFail
-                  (CradleError deps ex1 $
-                    [ "Failed to parse result of calling stack" ]
+                  (CradleError deps ex1
+                    ([ "Failed to parse result of calling stack" ]
                     ++ stde
-                    ++ args
+                    ++ args)
+                    [fp]
                   )
 
       Just (componentDir, ghc_args) -> do
@@ -1025,6 +1043,7 @@ stackAction workDir mc syaml l _fp loadStyle = do
                   , ghc_args ++ pkg_ghc_args
                   )
                   deps
+                  [fp]
 
 stackProcess :: CradleProjectConfig -> [String] -> CreateProcess
 stackProcess syaml args = proc "stack" $ stackYamlProcessArgs syaml <> args
@@ -1217,10 +1236,10 @@ removeFileIfExists f = do
   yes <- doesFileExist f
   when yes (removeFile f)
 
-makeCradleResult :: (ExitCode, [String], FilePath, [String]) -> [FilePath] -> CradleLoadResult ComponentOptions
-makeCradleResult (ex, err, componentDir, gopts) deps =
+makeCradleResult :: (ExitCode, [String], FilePath, [String]) -> [FilePath] -> [FilePath] -> CradleLoadResult ComponentOptions
+makeCradleResult (ex, err, componentDir, gopts) deps loadingFiles =
   case ex of
-    ExitFailure _ -> CradleFail (CradleError deps ex err)
+    ExitFailure _ -> CradleFail (CradleError deps ex err loadingFiles)
     _ ->
         let compOpts = ComponentOptions gopts componentDir deps
         in CradleSuccess compOpts
@@ -1252,11 +1271,13 @@ readProcessWithCwd' l createdProcess stdin = do
   case mResult of
     Just (ExitSuccess, stdo, _) -> pure stdo
     Just (exitCode, stdo, stde) -> throwCE $
-      CradleError [] exitCode $
-        ["Error when calling " <> cmdString, stdo, stde] <> prettyProcessEnv createdProcess
+      CradleError [] exitCode
+        (["Error when calling " <> cmdString, stdo, stde] <> prettyProcessEnv createdProcess)
+        []
     Nothing -> throwCE $
-      CradleError [] ExitSuccess $
-        ["Couldn't execute " <> cmdString] <> prettyProcessEnv createdProcess
+      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.

src/HIE/Bios/Internal/Debug.hs

@@ -48,11 +48,13 @@ debugInfo fp cradle = unlines <$> do
           , "Cradle:                " ++ crdl
           , "Dependencies:          " ++ unwords deps
           ]
-      CradleFail (CradleError deps ext stderr) ->
+      CradleFail (CradleError deps ext stderr extraFiles) ->
         return ["Cradle failed to load"
                , "Deps: " ++ show deps
                , "Exit Code: " ++ show ext
-               , "Stderr: " ++ unlines stderr]
+               , "Stderr: " ++ unlines stderr
+               , "Failed: " ++ unlines extraFiles
+               ]
       CradleNone ->
         return ["No cradle"]
   where

src/HIE/Bios/Types.hs

@@ -99,6 +99,7 @@ data Log
   | LogRequestedCradleLoadStyle !T.Text !LoadStyle
   | LogComputedCradleLoadStyle !T.Text !LoadStyle
   | LogLoadWithContextUnsupported !T.Text !(Maybe T.Text)
+  | LogCabalLoad !FilePath !(Maybe String) ![FilePath] ![FilePath]
   deriving (Show)
 
 instance Pretty Log where
@@ -135,6 +136,11 @@ instance Pretty Log where
         Nothing -> "."
         Just reason -> ", because:" <+> pretty reason <> "."
       <+> "Falling back loading to single file mode."
+  pretty (LogCabalLoad file prefixes projectFile crs) =
+    "Cabal Loading file" <+> pretty file
+          <> line <> indent 4 "from project: " <+> pretty projectFile
+          <> line <> indent 4 "with prefixes:" <+> pretty prefixes
+          <> line <> indent 4 "with actual loading files:" <+> pretty crs
 
 -- | The 'LoadStyle' instructs a cradle on how to load a given file target.
 data LoadStyle
@@ -266,6 +272,10 @@ data CradleError = CradleError
   , cradleErrorStderr :: [String]
   -- ^ Standard error output that can be shown to users to explain
   -- the loading error.
+  , cradleErrorLoadingFiles :: [FilePath]
+  -- ^ files that were attempted to be loaded by the cradle.
+  -- This can be useful if we are loading multiple files at once,
+  -- e.g. in a cabal cradle with the multi-repl feature.
   }
   deriving (Show, Eq)
 

tests/BiosTests.hs

@@ -19,7 +19,7 @@ import Control.Monad ( forM_ )
 import Data.List ( sort, isPrefixOf )
 import Data.Typeable
 import System.Directory
-import System.FilePath ((</>))
+import System.FilePath ((</>), makeRelative)
 import System.Exit (ExitCode(ExitSuccess, ExitFailure))
 import Control.Monad.Extra (unlessM)
 import qualified HIE.Bios.Ghc.Gap as Gap
@@ -138,11 +138,25 @@ biosTestCases =
 
 cabalTestCases :: ToolDependency -> [TestTree]
 cabalTestCases extraGhcDep =
-  [ testCaseSteps "failing-cabal" $ runTestEnv "./failing-cabal" $ do
+  [
+    testCaseSteps "failing-cabal" $ runTestEnv "./failing-cabal" $ do
       cabalAttemptLoad "MyLib.hs"
       assertCradleError (\CradleError {..} -> do
         cradleErrorExitCode @?= ExitFailure 1
         cradleErrorDependencies `shouldMatchList` ["failing-cabal.cabal", "cabal.project", "cabal.project.local"])
+  , testCaseSteps "failing-cabal-multi-repl-with-shrink-error-files" $ runTestEnv "./failing-multi-repl-cabal-project" $ do
+      cabalAttemptLoadFiles "multi-repl-cabal-fail/app/Main.hs" ["multi-repl-cabal-fail/src/Lib.hs", "multi-repl-cabal-fail/src/Fail.hs", "NotInPath.hs"]
+      root <- askRoot
+      multiSupported <- isCabalMultipleCompSupported'
+      if multiSupported
+        then
+          assertCradleError (\CradleError {..} -> do
+            cradleErrorExitCode @?= ExitFailure 1
+            cradleErrorDependencies `shouldMatchList` ["cabal.project","cabal.project.local","multi-repl-cabal-fail.cabal"]
+            -- NotInPath.hs does not match the cradle for `app/Main.hs`, so it should not be tried.
+            (makeRelative root <$> cradleErrorLoadingFiles) `shouldMatchList` ["multi-repl-cabal-fail/app/Main.hs","multi-repl-cabal-fail/src/Fail.hs","multi-repl-cabal-fail/src/Lib.hs"])
+        else assertLoadSuccess >>= \ComponentOptions {} -> do
+          return ()
   , testCaseSteps "simple-cabal" $ runTestEnv "./simple-cabal" $ do
       testDirectoryM isCabalCradle "B.hs"
   , testCaseSteps "nested-cabal" $ runTestEnv "./nested-cabal" $ do
@@ -224,6 +238,12 @@ cabalTestCases extraGhcDep =
       assertCradle isCabalCradle
       loadComponentOptions fp
 
+    cabalAttemptLoadFiles :: FilePath -> [FilePath] -> TestM ()
+    cabalAttemptLoadFiles fp fps = do
+      initCradle fp
+      assertCradle isCabalCradle
+      loadComponentOptionsMultiStyle fp fps
+
     cabalLoadOptions :: FilePath -> TestM ComponentOptions
     cabalLoadOptions fp = do
       initCradle fp