Allow users to specify whether to use cabal's multi-repl feature (#4179)

We add an option to `Config` that allows clients to specify how HLS
should load components.

We support two loading strategies:

* SessionLoadSingleComponent: Always load only a single component
    when a new component is discovered.
* SessionLoadMultipleComponents: Always allow the cradle to load
    multiple components at once. This might not be always possible,
    e.g., if the tool doesn't support multiple components loading.
    The cradle decides how to handle these situations.

By default, we use the conservative `SessionLoadSingleComponent` mode.

Additionally, changing the config at run-time leads to a reload of the
GHC session, allowing users to switch between the modes without
restarting the full server.

Author: fendor

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.Async
 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.RuleTypes
 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.Location
 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 @@ import           Ide.Logger                           (Pretty (pretty),
                                                        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.Data.Bag
 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 @@ data Log
   | LogNoneCradleFound FilePath
   | LogNewComponentCache !(([FileDiagnostic], Maybe HscEnvEq), DependencyInfo)
   | LogHieBios HieBios.Log
+  | LogSessionLoadingChanged
 deriving instance Show Log
 
 instance Pretty Log where
@@ -219,6 +224,8 @@ instance Pretty Log where
     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 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
   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 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
   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 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
               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
 
@@ -681,11 +690,38 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
                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 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
                   -- 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 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
                 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 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
 -- | 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 @@ cradleToOptsAndLibDir recorder cradle file old_files = do
             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 @@ setOptions cfp (ComponentOptions theOpts compRoot _) dflags = do
         -- 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 @@ loadGhcSession recorder ghcSessionDepsConfig = do
     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

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"
 }