Configuration for initial ghc lib dir (#1378)

* getInitialGhcLibDir

* Fix build and use Data.Default consistently

* Fix log line

* Fix build

* (unrelated) Honor the rules config in the setup tester

Author: pepeiborra

exe/Wrapper.hs

@@ -4,10 +4,11 @@
 module Main where
 
 import Control.Monad.Extra
+import Data.Default
 import Data.Foldable
 import Data.List
 import Data.Void
-import Development.IDE.Session (findCradle, defaultLoadingOptions)
+import Development.IDE.Session (findCradle)
 import HIE.Bios hiding (findCradle)
 import HIE.Bios.Environment
 import HIE.Bios.Types
@@ -140,7 +141,7 @@ getRuntimeGhcVersion' cradle = do
 -- of the project that may or may not be accurate.
 findLocalCradle :: FilePath -> IO (Cradle Void)
 findLocalCradle fp = do
-  cradleConf <- findCradle defaultLoadingOptions fp
+  cradleConf <- findCradle def fp
   crdl       <- case cradleConf of
     Just yaml -> do
       hPutStrLn stderr $ "Found \"" ++ yaml ++ "\" for \"" ++ fp ++ "\""

ghcide/exe/Main.hs

@@ -66,7 +66,7 @@ main = do
       DbCmd opts cmd -> do
         dir <- IO.getCurrentDirectory
         dbLoc <- getHieDbLoc dir
-        mlibdir <- setInitialDynFlags
+        mlibdir <- setInitialDynFlags def
         case mlibdir of
           Nothing -> exitWith $ ExitFailure 1
           Just libdir -> runCommand libdir opts{database = dbLoc} cmd
@@ -79,7 +79,7 @@ main = do
                 hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
               _ -> return ()
 
-          Main.defaultMain Main.defArguments
+          Main.defaultMain def
             {Main.argFiles = case argFilesOrCmd of
                 Typecheck x | not argLSP -> Just x
                 _ -> Nothing

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

@@ -8,7 +8,6 @@ The logic for setting up a ghcide session by tapping into hie-bios.
 module Development.IDE.Session
   (SessionLoadingOptions(..)
   ,CacheDirs(..)
-  ,defaultLoadingOptions
   ,loadSession
   ,loadSessionWithOptions
   ,setInitialDynFlags
@@ -34,6 +33,7 @@ import qualified Data.Text as T
 import Data.Aeson
 import Data.Bifunctor
 import qualified Data.ByteString.Base16 as B16
+import Data.Default
 import Data.Either.Extra
 import Data.Function
 import Data.Hashable
@@ -98,31 +98,38 @@ data SessionLoadingOptions = SessionLoadingOptions
   --   return the path for storing generated GHC artifacts,
   --   or 'Nothing' to respect the cradle setting
   , getCacheDirs :: String -> [String] -> IO CacheDirs
+  -- | Return the GHC lib dir to use for the 'unsafeGlobalDynFlags'
+  , getInitialGhcLibDir :: IO (Maybe LibDir)
   }
 
-defaultLoadingOptions :: SessionLoadingOptions
-defaultLoadingOptions = SessionLoadingOptions
-    {findCradle = HieBios.findCradle
-    ,loadCradle = HieBios.loadCradle
-    ,getCacheDirs = getCacheDirsDefault
-    }
+instance Default SessionLoadingOptions where
+    def = SessionLoadingOptions
+        {findCradle = HieBios.findCradle
+        ,loadCradle = HieBios.loadCradle
+        ,getCacheDirs = getCacheDirsDefault
+        ,getInitialGhcLibDir = getInitialGhcLibDirDefault
+        }
 
--- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir
-setInitialDynFlags :: IO (Maybe LibDir)
-setInitialDynFlags = do
+getInitialGhcLibDirDefault :: IO (Maybe LibDir)
+getInitialGhcLibDirDefault = do
   dir <- IO.getCurrentDirectory
   hieYaml <- runMaybeT $ yamlConfig dir
   cradle <- maybe (loadImplicitHieCradle $ addTrailingPathSeparator dir) HieBios.loadCradle hieYaml
   hPutStrLn stderr $ "setInitialDynFlags cradle: " ++ show cradle
   libDirRes <- getRuntimeGhcLibDir cradle
-  libdir <- case libDirRes of
+  case libDirRes of
       CradleSuccess libdir -> pure $ Just $ LibDir libdir
       CradleFail err -> do
         hPutStrLn stderr $ "Couldn't load cradle for libdir: " ++ show (err,dir,hieYaml,cradle)
         pure Nothing
       CradleNone -> do
         hPutStrLn stderr $ "Couldn't load cradle (CradleNone)"
         pure Nothing
+
+-- | Sets `unsafeGlobalDynFlags` on using the hie-bios cradle and returns the GHC libdir
+setInitialDynFlags :: SessionLoadingOptions -> IO (Maybe LibDir)
+setInitialDynFlags SessionLoadingOptions{..} = do
+  libdir <- getInitialGhcLibDir
   dynFlags <- mapM dynFlagsForPrinting libdir
   mapM_ setUnsafeGlobalDynFlags dynFlags
   pure libdir
@@ -177,7 +184,7 @@ getHieDbLoc dir = do
 -- components mapping to the same hie.yaml file are mapped to the same
 -- HscEnv which is updated as new components are discovered.
 loadSession :: FilePath -> IO (Action IdeGhcSession)
-loadSession = loadSessionWithOptions defaultLoadingOptions
+loadSession = loadSessionWithOptions def
 
 loadSessionWithOptions :: SessionLoadingOptions -> FilePath -> IO (Action IdeGhcSession)
 loadSessionWithOptions SessionLoadingOptions{..} dir = do
@@ -614,7 +621,7 @@ should be filtered out, such that we dont have to re-compile everything.
 -- For the exact reason, see Note [Avoiding bad interface files].
 setCacheDirs :: MonadIO m => Logger -> CacheDirs -> DynFlags -> m DynFlags
 setCacheDirs logger CacheDirs{..} dflags = do
-    liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack cacheDir
+    liftIO $ logInfo logger $ "Using interface files cache dir: " <> T.pack (fromMaybe cacheDir hiCacheDir)
     pure $ dflags
           & maybe id setHiDir hiCacheDir
           & maybe id setHieDir hieCacheDir

ghcide/src/Development/IDE/Main.hs

@@ -1,4 +1,4 @@
-module Development.IDE.Main (Arguments(..), defArguments, defaultMain) where
+module Development.IDE.Main (Arguments(..), defaultMain) where
 import Control.Concurrent.Extra (readVar)
 import Control.Exception.Safe (
     Exception (displayException),
@@ -47,7 +47,7 @@ import Development.IDE.Plugin (
     Plugin (pluginHandlers, pluginRules),
  )
 import Development.IDE.Plugin.HLS (asGhcIdePlugin)
-import Development.IDE.Session (SessionLoadingOptions, defaultLoadingOptions, loadSessionWithOptions, setInitialDynFlags, getHieDbLoc, runWithDb)
+import Development.IDE.Session (SessionLoadingOptions, loadSessionWithOptions, setInitialDynFlags, getHieDbLoc, runWithDb)
 import Development.IDE.Types.Location (toNormalizedFilePath')
 import Development.IDE.Types.Logger (Logger)
 import Development.IDE.Types.Options (
@@ -85,16 +85,15 @@ data Arguments = Arguments
     , argsGetHieDbLoc :: FilePath -> IO FilePath -- ^ Map project roots to the location of the hiedb for the project
     }
 
-defArguments :: Arguments
-defArguments =
-    Arguments
+instance Default Arguments where
+    def = Arguments
         { argsOTMemoryProfiling = False
         , argFiles = Nothing
         , argsLogger = noLogging
         , argsRules = mainRule >> action kick
         , argsGhcidePlugin = mempty
         , argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors
-        , argsSessionLoadingOptions = defaultLoadingOptions
+        , argsSessionLoadingOptions = def
         , argsIdeOptions = const defaultIdeOptions
         , argsLspOptions = def {LSP.completionTriggerCharacters = Just "."}
         , argsDefaultHlsConfig = def
@@ -110,6 +109,7 @@ defaultMain Arguments{..} = do
         plugins = hlsPlugin <> argsGhcidePlugin
         options = argsLspOptions { LSP.executeCommandCommands = Just hlsCommands }
         argsOnConfigChange _ide = pure . getConfigFromNotification argsDefaultHlsConfig
+        rules = argsRules >> pluginRules plugins
 
     case argFiles of
         Nothing -> do
@@ -127,15 +127,14 @@ defaultMain Arguments{..} = do
                 -- We do it here since haskell-lsp changes our working directory to the correct place ('rootPath')
                 -- before calling this function
                 _mlibdir <-
-                    setInitialDynFlags
+                    setInitialDynFlags argsSessionLoadingOptions
                         `catchAny` (\e -> (hPutStrLn stderr $ "setInitialDynFlags: " ++ displayException e) >> pure Nothing)
 
                 sessionLoader <- loadSessionWithOptions argsSessionLoadingOptions $ fromMaybe dir rootPath
                 config <- LSP.runLspT env LSP.getConfig
                 let options = (argsIdeOptions config sessionLoader)
                             { optReportProgress = clientSupportsProgress caps
                             }
-                    rules = argsRules >> pluginRules plugins
                     caps = LSP.resClientCapabilities env
                 debouncer <- newAsyncDebouncer
                 initialise
@@ -178,7 +177,7 @@ defaultMain Arguments{..} = do
                         { optCheckParents = pure NeverCheck
                         , optCheckProject = pure False
                         }
-            ide <- initialise mainRule Nothing argsLogger debouncer options vfs hiedb hieChan
+            ide <- initialise rules Nothing argsLogger debouncer options vfs hiedb hieChan
 
             putStrLn "\nStep 4/4: Type checking the files"
             setFilesOfInterest ide $ HashMap.fromList $ map ((,OnDisk) . toNormalizedFilePath') files

haskell-language-server.cabal

@@ -365,6 +365,7 @@ executable haskell-language-server-wrapper
     ghc-options: -Werror
 
   build-depends:
+    , data-default
     , ghc
     , ghc-paths
     , ghcide

src/Ide/Main.hs

@@ -31,6 +31,7 @@ import HieDb.Run
 import qualified Development.IDE.Main as Main
 import qualified Development.IDE.Types.Options as Ghcide
 import Development.Shake (ShakeOptions(shakeThreads))
+import Data.Default
 
 defaultMain :: Arguments -> IdePlugins IdeState -> IO ()
 defaultMain args idePlugins = do
@@ -55,7 +56,7 @@ defaultMain args idePlugins = do
           dir <- IO.getCurrentDirectory
           dbLoc <- getHieDbLoc dir
           hPutStrLn stderr $ "Using hiedb at: " ++ dbLoc
-          mlibdir <- setInitialDynFlags
+          mlibdir <- setInitialDynFlags def
           case mlibdir of
             Nothing -> exitWith $ ExitFailure 1
             Just libdir ->
@@ -93,7 +94,7 @@ runLspMode lspArgs@LspArguments{..} idePlugins = do
         hPutStrLn stderr $ "  in directory: " <> dir
         hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
 
-    Main.defaultMain Main.defArguments
+    Main.defaultMain def
       { Main.argFiles = if argLSP then Nothing else Just []
       , Main.argsHlsPlugins = idePlugins
       , Main.argsLogger = hlsLogger