Allow users to specify whether to use cabal's multi-repl feature

cabal.project

@@ -8,7 +8,7 @@ packages:
          ./hls-plugin-api
          ./hls-test-utils
 
-index-state: 2024-03-09T08:17:00Z
+index-state: 2024-04-23T12:00:00Z
 
 tests: True
 test-show-details: direct

ghcide/ghcide.cabal

@@ -78,7 +78,7 @@ library
     , Glob
     , haddock-library              >=1.8      && <1.12
     , hashable
-    , hie-bios                     ==0.13.1
+    , hie-bios                     ^>=0.14.0
     , hie-compat                   ^>=0.3.0.0
     , hiedb                        ^>= 0.6.0.0
     , hls-graph                    == 2.7.0.0

ghcide/session-loader/Development/IDE/Session.hs

@@ -25,7 +25,7 @@
 import           Control.Concurrent.Strict
 import           Control.Exception.Safe               as Safe
 import           Control.Monad
-import           Control.Monad.Extra
+import           Control.Monad.Extra                  as Extra
 import           Control.Monad.IO.Class
 import qualified Crypto.Hash.SHA1                     as H
 import           Data.Aeson                           hiding (Error)
@@ -52,13 +52,13 @@
 import           Development.IDE.Core.Shake           hiding (Log, Priority,
                                                        knownTargets, withHieDb)
 import qualified Development.IDE.GHC.Compat           as Compat
-import qualified Development.IDE.GHC.Compat.Util      as Compat
 import           Development.IDE.GHC.Compat.Core      hiding (Target,
                                                        TargetFile, TargetModule,
                                                        Var, Warning, getOptions)
 import qualified Development.IDE.GHC.Compat.Core      as GHC
 import           Development.IDE.GHC.Compat.Env       hiding (Logger)
 import           Development.IDE.GHC.Compat.Units     (UnitId)
+import qualified Development.IDE.GHC.Compat.Util      as Compat
 import           Development.IDE.GHC.Util
 import           Development.IDE.Graph                (Action)
 import           Development.IDE.Session.VersionCheck
@@ -70,6 +70,7 @@
 import           Development.IDE.Types.Options
 import           GHC.Check
 import qualified HIE.Bios                             as HieBios
+import qualified HIE.Bios.Cradle                      as HieBios
 import           HIE.Bios.Environment                 hiding (getCacheDir)
 import           HIE.Bios.Types                       hiding (Log)
 import qualified HIE.Bios.Types                       as HieBios
@@ -80,6 +81,8 @@
                                                        nest,
                                                        toCologActionWithPrio,
                                                        vcat, viaShow, (<+>))
+import           Ide.Types                            (SessionLoadingPreferenceConfig (..),
+                                                       sessionLoading)
 import           Language.LSP.Protocol.Message
 import           Language.LSP.Server
 import           System.Directory
@@ -123,7 +126,8 @@
 import           GHC.Driver.Env                       (hsc_all_home_unit_ids)
 import           GHC.Driver.Errors.Types
 import           GHC.Driver.Make                      (checkHomeUnitsClosed)
-import           GHC.Types.Error                      (errMsgDiagnostic, singleMessage)
+import           GHC.Types.Error                      (errMsgDiagnostic,
+                                                       singleMessage)
 import           GHC.Unit.State
 #endif
 
@@ -149,6 +153,7 @@
   | LogNoneCradleFound FilePath
   | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
   | LogHieBios HieBios.Log
+  | LogSessionLoadingChanged
 deriving instance Show Log
 
 instance Pretty Log where
@@ -219,6 +224,8 @@
     LogNewComponentCache componentCache ->
       "New component cache HscEnvEq:" <+> viaShow componentCache
     LogHieBios msg -> pretty msg
+    LogSessionLoadingChanged ->
+      "Session Loading config changed, reloading the full session."
 
 -- | Bump this version number when making changes to the format of the data stored in hiedb
 hiedbDataVersion :: String
@@ -449,6 +456,7 @@
   filesMap <- newVar HM.empty :: IO (Var FilesMap)
   -- Version of the mappings above
   version <- newVar 0
+  biosSessionLoadingVar <- newVar Nothing :: IO (Var (Maybe SessionLoadingPreferenceConfig))
   let returnWithVersion fun = IdeGhcSession fun <$> liftIO (readVar version)
   -- This caches the mapping from Mod.hs -> hie.yaml
   cradleLoc <- liftIO $ memoIO $ \v -> do
@@ -463,6 +471,7 @@
   runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath])))
 
   return $ do
+    clientConfig <- getClientConfigAction
     extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv
                       } <- getShakeExtras
     let invalidateShakeCache :: IO ()
@@ -653,7 +662,7 @@
               withTrace "Load cradle" $ \addTag -> do
                   addTag "file" lfp
                   old_files <- readIORef cradle_files
-                  res <- cradleToOptsAndLibDir recorder cradle cfp old_files
+                  res <- cradleToOptsAndLibDir recorder (sessionLoading clientConfig) cradle cfp old_files
                   addTag "result" (show res)
                   return res
 
@@ -669,7 +678,7 @@
                  InstallationMismatch{..} ->
                      return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[])
                  InstallationChecked _compileTime _ghcLibCheck -> do
                    atomicModifyIORef' cradle_files (\xs -> (cfp:xs,()))
                    session (hieYaml, toNormalizedFilePath' cfp, opts, libDir)
              -- Failure case, either a cradle error or the none cradle
              Left err -> do
@@ -681,11 +690,38 @@
                void $ modifyVar' filesMap $ HM.insert ncfp hieYaml
                return (res, maybe [] pure hieYaml ++ concatMap cradleErrorDependencies err)
 
+    let
+        -- | We allow users to specify a loading strategy.
+        -- Check whether this config was changed since the last time we have loaded
+        -- a session.
+        --
+        -- If the loading configuration changed, we likely should restart the session
+        -- in its entirety.
+        didSessionLoadingPreferenceConfigChange :: IO Bool
+        didSessionLoadingPreferenceConfigChange = do
+          mLoadingConfig <- readVar biosSessionLoadingVar
+          case mLoadingConfig of
+            Nothing -> do
+              writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig))
+              pure False
+            Just loadingConfig -> do
+              writeVar biosSessionLoadingVar (Just (sessionLoading clientConfig))
+              pure (loadingConfig /= sessionLoading clientConfig)
+
     -- This caches the mapping from hie.yaml + Mod.hs -> [String]
     -- Returns the Ghc session and the cradle dependencies
     let sessionOpts :: (Maybe FilePath, FilePath)
                     -> IO (IdeResult HscEnvEq, [FilePath])
         sessionOpts (hieYaml, file) = do
+          Extra.whenM didSessionLoadingPreferenceConfigChange $ do
+            logWith recorder Info LogSessionLoadingChanged
+            -- If the dependencies are out of date then clear both caches and start
+            -- again.
+            modifyVar_ fileToFlags (const (return Map.empty))
+            modifyVar_ filesMap (const (return HM.empty))
+            -- Don't even keep the name cache, we start from scratch here!
+            modifyVar_ hscEnvs (const (return Map.empty))
+
           v <- Map.findWithDefault HM.empty hieYaml <$> readVar fileToFlags
           cfp <- makeAbsolute file
           case HM.lookup (toNormalizedFilePath' cfp) v of
@@ -696,6 +732,7 @@
                   -- If the dependencies are out of date then clear both caches and start
                   -- again.
                   modifyVar_ fileToFlags (const (return Map.empty))
+                  modifyVar_ filesMap (const (return HM.empty))
                   -- Keep the same name cache
                   modifyVar_ hscEnvs (return . Map.adjust (const []) hieYaml )
                   consultCradle hieYaml cfp
@@ -715,7 +752,7 @@
                 return (([renderPackageSetupException file e], Nothing), maybe [] pure hieYaml)
 
     returnWithVersion $ \file -> do
-      opts <- liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do
+      opts <- join $ mask_ $ modifyVar runningCradle $ \as -> do
         -- If the cradle is not finished, then wait for it to finish.
         void $ wait as
         asyncRes <- async $ getOptions file
@@ -725,14 +762,14 @@
 -- | Run the specific cradle on a specific FilePath via hie-bios.
 -- This then builds dependencies or whatever based on the cradle, gets the
 -- GHC options/dynflags needed for the session and the GHC library directory
-cradleToOptsAndLibDir :: Recorder (WithPriority Log) -> Cradle Void -> FilePath -> [FilePath]
+cradleToOptsAndLibDir :: Recorder (WithPriority Log) -> SessionLoadingPreferenceConfig -> Cradle Void -> FilePath -> [FilePath]
                       -> IO (Either [CradleError] (ComponentOptions, FilePath))
-cradleToOptsAndLibDir recorder cradle file old_files = do
+cradleToOptsAndLibDir recorder loadConfig cradle file old_fps = do
     -- let noneCradleFoundMessage :: FilePath -> T.Text
     --     noneCradleFoundMessage f = T.pack $ "none cradle found for " <> f <> ", ignoring the file"
     -- Start off by getting the session options
     logWith recorder Debug $ LogCradle cradle
-    cradleRes <- HieBios.getCompilerOptions file old_files cradle
+    cradleRes <- HieBios.getCompilerOptions file loadStyle cradle
     case cradleRes of
         CradleSuccess r -> do
             -- Now get the GHC lib dir
@@ -750,6 +787,11 @@
             logWith recorder Info $ LogNoneCradleFound file
             return (Left [])
 
+    where
+        loadStyle = case loadConfig of
+            PreferSingleComponentLoading -> LoadFile
+            PreferMultiComponentLoading  -> LoadWithContext old_fps
+
 #if MIN_VERSION_ghc(9,3,0)
 emptyHscEnv :: NameCache -> FilePath -> IO HscEnv
 #else
@@ -1150,7 +1192,7 @@
         -- component to be created. In case the cradle doesn't list all the targets for
         -- the component, in which case things will be horribly broken anyway.
         --
-        -- When we have a single component that is caused to be loaded due to a
+        -- When we have a singleComponent that is caused to be loaded due to a
         -- file, we assume the file is part of that component. This is useful
         -- for bare GHC sessions, such as many of the ones used in the testsuite
         --

ghcide/src/Development/IDE/Core/Rules.hs

@@ -701,9 +701,20 @@
     defineEarlyCutOffNoFile (cmapWithPrio LogShake recorder) $ \GhcSessionIO -> do
         alwaysRerun
         opts <- getIdeOptions
+        config <- getClientConfigAction
         res <- optGhcSession opts
 
-        let fingerprint = LBS.toStrict $ B.encode $ hash (sessionVersion res)
+        let fingerprint = LBS.toStrict $ LBS.concat
+                [ B.encode (hash (sessionVersion res))
+                -- When the session version changes, reload all session
+                -- hsc env sessions
+                , B.encode (show (sessionLoading config))
+                -- The loading config affects session loading.
+                -- Invalidate all build nodes.
+                -- Changing the session loading config will increment
+                -- the 'sessionVersion', thus we don't generate the same fingerprint
+                -- twice by accident.
+                ]
         return (fingerprint, res)
 
     defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \GhcSession file -> do
@@ -812,7 +823,7 @@
             { source_version = ver
             , old_value = m_old
             , get_file_version = use GetModificationTime_{missingFileDiagnostics = False}
             , get_linkable_hashes = \fs -> map (snd . fromJust . hirCoreFp) <$> uses_ GetModIface fs
             , regenerate = regenerateHiFile session f ms
             }
       r <- loadInterface (hscEnv session) ms linkableType recompInfo
@@ -1084,7 +1095,7 @@
             -- thus bump its modification time, forcing this rule to be rerun every time.
             exists <- liftIO $ doesFileExist obj_file
             mobj_time <- liftIO $
               if exists
               then Just <$> getModTime obj_file
               else pure Nothing
             case mobj_time of

haskell-language-server.cabal

@@ -822,7 +822,7 @@ test-suite hls-stan-plugin-tests
     , lens
     , lsp-types
     , text
- default-extensions:
+  default-extensions:
     OverloadedStrings
 
 -----------------------------

hls-plugin-api/src/Ide/Plugin/Config.hs

@@ -42,6 +42,7 @@ parseConfig idePlugins defValue = A.withObject "settings" $ \o ->
     <*> o .:? "formattingProvider"                      .!= formattingProvider defValue
     <*> o .:? "cabalFormattingProvider"                 .!= cabalFormattingProvider defValue
     <*> o .:? "maxCompletions"                          .!= maxCompletions defValue
+    <*> o .:? "sessionLoading"                          .!= sessionLoading defValue
     <*> A.explicitParseFieldMaybe (parsePlugins idePlugins) o "plugin" .!= plugins defValue
 
 -- | Parse the 'PluginConfig'.

hls-plugin-api/src/Ide/Types.hs

@@ -22,7 +22,7 @@ module Ide.Types
 , IdeNotification(..)
 , IdePlugins(IdePlugins, ipMap)
 , DynFlagsModifications(..)
-, Config(..), PluginConfig(..), CheckParents(..)
+, Config(..), PluginConfig(..), CheckParents(..), SessionLoadingPreferenceConfig(..)
 , ConfigDescriptor(..), defaultConfigDescriptor, configForPlugin
 , CustomConfig(..), mkCustomConfig
 , FallbackCodeActionParams(..)
@@ -65,6 +65,7 @@ import           Control.Monad.Error.Class     (MonadError (throwError))
 import           Control.Monad.Trans.Class     (MonadTrans (lift))
 import           Control.Monad.Trans.Except    (ExceptT, runExceptT)
 import           Data.Aeson                    hiding (Null, defaultOptions)
+import qualified Data.Aeson.Types              as A
 import           Data.Default
 import           Data.Dependent.Map            (DMap)
 import qualified Data.Dependent.Map            as DMap
@@ -170,6 +171,7 @@ data Config =
     , formattingProvider      :: !T.Text
     , cabalFormattingProvider :: !T.Text
     , maxCompletions          :: !Int
+    , sessionLoading          :: !SessionLoadingPreferenceConfig
     , plugins                 :: !(Map.Map PluginId PluginConfig)
     } deriving (Show,Eq)
 
@@ -180,6 +182,7 @@ instance ToJSON Config where
            , "formattingProvider"          .= formattingProvider
            , "cabalFormattingProvider"     .= cabalFormattingProvider
            , "maxCompletions"              .= maxCompletions
+           , "sessionLoading"              .= sessionLoading
            , "plugin"                      .= Map.mapKeysMonotonic (\(PluginId p) -> p) plugins
            ]
 
@@ -194,6 +197,7 @@ instance Default Config where
     -- , cabalFormattingProvider     = "cabal-fmt"
     -- this string value needs to kept in sync with the value provided in HlsPlugins
     , maxCompletions              = 40
+    , sessionLoading              = PreferSingleComponentLoading
     , plugins                     = mempty
     }
 
@@ -206,6 +210,39 @@ data CheckParents
   deriving stock (Eq, Ord, Show, Generic)
   deriving anyclass (FromJSON, ToJSON)
 
+
+data SessionLoadingPreferenceConfig
+    = PreferSingleComponentLoading
+    -- ^ Always load only a singleComponent when a new component
+    -- is discovered.
+    | PreferMultiComponentLoading
+    -- ^ Always prefer loading multiple components in the cradle
+    -- at once. This might not be always possible, if the tool doesn't
+    -- support multiple components loading.
+    --
+    -- The cradle can decide how to handle these situations, and whether
+    -- to honour the preference at all.
+  deriving stock (Eq, Ord, Show, Generic)
+
+instance Pretty SessionLoadingPreferenceConfig where
+    pretty PreferSingleComponentLoading = "Prefer Single Component Loading"
+    pretty PreferMultiComponentLoading  = "Prefer Multiple Components Loading"
+
+instance ToJSON SessionLoadingPreferenceConfig where
+    toJSON PreferSingleComponentLoading =
+        String "singleComponent"
+    toJSON PreferMultiComponentLoading =
+        String "multipleComponents"
+
+instance FromJSON SessionLoadingPreferenceConfig where
+    parseJSON (String val) = case val of
+        "singleComponent"    -> pure PreferSingleComponentLoading
+        "multipleComponents" -> pure PreferMultiComponentLoading
+        _ -> A.prependFailure "parsing SessionLoadingPreferenceConfig failed, "
+            (A.parseFail $ "Expected one of \"singleComponent\" or \"multipleComponents\" but got " <> T.unpack val )
+    parseJSON o = A.prependFailure "parsing SessionLoadingPreferenceConfig failed, "
+            (A.typeMismatch "String" o)
+
 -- | A PluginConfig is a generic configuration for a given HLS plugin.  It
 -- provides a "big switch" to turn it on or off as a whole, as well as small
 -- switches per feature, and a slot for custom config.

stack-lts21.yaml

@@ -18,7 +18,7 @@ allow-newer: true
 extra-deps:
 - floskell-0.11.1
 - hiedb-0.6.0.0
-- hie-bios-0.13.1
+- hie-bios-0.14.0
 - implicit-hie-0.1.4.0
 - monad-dijkstra-0.1.1.3
 - retrie-1.2.2

stack.yaml

@@ -18,6 +18,7 @@ extra-deps:
 - floskell-0.11.1
 - retrie-1.2.2
 - hiedb-0.6.0.0
+- hie-bios-0.14.0
 - implicit-hie-0.1.4.0
 - lsp-2.4.0.0
 - lsp-test-0.17.0.0

test/testdata/schema/ghc92/default-config.golden.json

@@ -148,5 +148,6 @@
         "splice": {
             "globalOn": true
         }
-    }
+    },
+    "sessionLoading": "singleComponent"
 }

test/testdata/schema/ghc94/default-config.golden.json

@@ -151,5 +151,6 @@
         "stan": {
             "globalOn": false
         }
-    }
+    },
+    "sessionLoading": "singleComponent"
 }

test/testdata/schema/ghc96/default-config.golden.json

@@ -151,5 +151,6 @@
         "stan": {
             "globalOn": false
         }
-    }
+    },
+    "sessionLoading": "singleComponent"
 }

test/testdata/schema/ghc98/default-config.golden.json

@@ -151,5 +151,6 @@
         "stan": {
             "globalOn": false
         }
-    }
+    },
+    "sessionLoading": "singleComponent"
 }