Find the libdir directory of ghc at run-time

Author: fendor

hie-plugin-api/Haskell/Ide/Engine/Cradle.hs

@@ -17,19 +17,20 @@ import           Distribution.Helper (Package, projectPackages, pUnits,
 import           Distribution.Helper.Discover (findProjects, getDefaultDistDir)
 import           Data.Char (toLower)
 import           Data.Function ((&))
-import           Data.List (isPrefixOf, isInfixOf)
+import           Data.List (isPrefixOf, isInfixOf, sortOn, find)
 import qualified Data.List.NonEmpty as NonEmpty
 import           Data.List.NonEmpty (NonEmpty)
 import qualified Data.Map as M
-import           Data.List (sortOn, find)
 import           Data.Maybe (listToMaybe, mapMaybe, isJust)
 import           Data.Ord (Down(..))
 import           Data.String (IsString(..))
+import qualified Data.Text as T
 import           Data.Foldable (toList)
-import           Control.Exception (IOException, try)
+import           Control.Exception (IOException, try, catch)
 import           System.FilePath
 import           System.Directory (getCurrentDirectory, canonicalizePath, findExecutable)
 import           System.Exit
+import           System.Process (readCreateProcess, shell)
 
 -- | Find the cradle that the given File belongs to.
 --
@@ -57,6 +58,54 @@ isStackCradle = (`elem` ["stack", "Cabal-Helper-Stack", "Cabal-Helper-Stack-None
   . BIOS.actionName
   . BIOS.cradleOptsProg
 
+  -- | Check if the given cradle is a cabal cradle.
+-- This might be used to determine the GHC version to use on the project.
+-- If it is a stack-cradle, we have to use `stack path --compiler-exe`
+-- otherwise we may ask `ghc` directly what version it is.
+isCabalCradle :: Cradle -> Bool
+isCabalCradle =
+  (`elem`
+    ["cabal"
+    , "Cabal-Helper-Cabal-V1"
+    , "Cabal-Helper-Cabal-V2"
+    , "Cabal-Helper-Cabal-V1-Dir"
+    , "Cabal-Helper-Cabal-V2-Dir"
+    , "Cabal-Helper-Cabal-None"
+    ]
+  )
+  . BIOS.actionName
+  . BIOS.cradleOptsProg
+
+
+getProjectGhcPath :: Cradle -> IO (Maybe FilePath)
+getProjectGhcPath crdl = do
+  isStackInstalled <- isJust <$> findExecutable "stack"
+  isCabalInstalled <- isJust <$> findExecutable "cabal"
+  if isStackCradle crdl && isStackInstalled
+    then
+      catch (Just <$> tryCommand "stack path --compiler-exe") $ \(_ :: IOException) ->
+        return Nothing
+    else if isCabalCradle crdl && isCabalInstalled then do
+      Just ghcCabalVersion <- catch (Just <$> tryCommand "cabal v2-exec ghc -- --numeric-version") $ \(_ ::IOException) ->
+        return Nothing
+      findExecutable ("ghc-" ++ ghcCabalVersion)
+    else
+      findExecutable "ghc"
+
+tryCommand :: String -> IO String
+tryCommand cmd =
+  T.unpack . T.strip .T.pack <$> readCreateProcess (shell cmd) ""
+
+getProjectGhcLibDir :: Cradle -> IO (Maybe FilePath)
+getProjectGhcLibDir crdl = do
+  mGhcPath <- getProjectGhcPath crdl
+  case mGhcPath of
+    Nothing -> return Nothing
+    Just ghcPath -> catch (Just <$> tryCommand (ghcPath ++ " --print-libdir")) $ \(_ :: IOException) -> return Nothing
+
+  -- ---------------------------------------------------------------------
+
+
 {- | Finds a Cabal v2-project, Cabal v1-project or a Stack project
 relative to the given FilePath.
 Cabal v2-project and Stack have priority over Cabal v1-project.

hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs

@@ -120,9 +120,8 @@ import           Data.Typeable                  ( TypeRep
                                                 )
 import System.Directory
 import GhcMonad
-import qualified HIE.Bios.Ghc.Api as BIOS
 import           GHC.Generics
-import           GHC                            ( HscEnv )
+import           GHC                            ( HscEnv, runGhcT )
 import Exception
 
 import           Haskell.Ide.Engine.Compat
@@ -345,10 +344,10 @@ getDiagnosticProvidersConfig c = Map.fromList [("applyrefact",hlintOn c)
 type IdeGhcM = GhcT IdeM
 
 -- | Run an IdeGhcM with Cradle found from the current directory
-runIdeGhcM :: IdePlugins -> Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeGhcM a -> IO a
-runIdeGhcM plugins mlf stateVar f = do
+runIdeGhcM :: Maybe FilePath -> IdePlugins -> Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeGhcM a -> IO a
+runIdeGhcM mlibdir plugins mlf stateVar f = do
   env <- IdeEnv <$> pure mlf <*> getProcessID <*> pure plugins
-  flip runReaderT stateVar $ flip runReaderT env $ BIOS.withGhcT f
+  flip runReaderT stateVar $ flip runReaderT env $ runGhcT mlibdir f
 
 -- | A computation that is deferred until the module is cached.
 -- Note that the module may not typecheck, in which case 'UriCacheFailed' is passed

hie-plugin-api/hie-plugin-api.cabal

@@ -56,6 +56,7 @@ library
                      , unliftio
                      , monad-control
                      , mtl
+                     , process
                      , stm
                      , syb
                      , text

src/Haskell/Ide/Engine/Scheduler.hs

@@ -41,7 +41,9 @@ import qualified Language.Haskell.LSP.Core     as Core
 import qualified Language.Haskell.LSP.Types    as J
 import           GhcMonad
 
+import qualified HIE.Bios.Types as Bios
 import           Haskell.Ide.Engine.GhcModuleCache
+import qualified Haskell.Ide.Engine.Cradle as Bios
 import           Haskell.Ide.Engine.Config
 import qualified Haskell.Ide.Engine.Channel    as Channel
 import           Haskell.Ide.Engine.PluginsIdeMonads
@@ -143,8 +145,9 @@ runScheduler
      -- ^ A handler to run the requests' callback in your monad of choosing.
   -> Maybe (Core.LspFuncs Config)
      -- ^ The LspFuncs provided by haskell-lsp, if using LSP.
+  -> Maybe Bios.Cradle
   -> IO ()
-runScheduler Scheduler {..} errorHandler callbackHandler mlf = do
+runScheduler Scheduler {..} errorHandler callbackHandler mlf mcrdl = do
   let dEnv = DispatcherEnv
         { cancelReqsTVar = requestsToCancel
         , wipReqsTVar    = requestsInProgress
@@ -158,7 +161,11 @@ runScheduler Scheduler {..} errorHandler callbackHandler mlf = do
 
   stateVar <- STM.newTVarIO initialState
 
-  let runGhcDisp = runIdeGhcM plugins mlf stateVar $
+  mlibdir <- case mcrdl of
+    Nothing -> return Nothing
+    Just crdl -> Bios.getProjectGhcLibDir crdl
+
+  let runGhcDisp = runIdeGhcM mlibdir plugins mlf stateVar $
                     ghcDispatcher dEnv errorHandler callbackHandler ghcChanOut
       runIdeDisp = runIdeM plugins mlf stateVar $
                     ideDispatcher dEnv errorHandler callbackHandler ideChanOut

src/Haskell/Ide/Engine/Server.hs

@@ -151,10 +151,20 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do
           (Debounce.forMonoid $ react . dispatchDiagnostics)
           (Debounce.def { Debounce.delay = debounceDuration, Debounce.alwaysResetTimer = True })
 
+
+        let lspRootDir = Core.rootPath lf
+        currentDir <- liftIO getCurrentDirectory
+
+        -- Check for mismatching GHC versions
+        -- Ignore hie.yaml parse errors. They get reported in ModuleCache.hs
+        let parseErrorHandler (_ :: Yaml.ParseException) = return Nothing
+            dummyCradleFile = (fromMaybe currentDir lspRootDir) </> "File.hs"
+        mcradle <- liftIO $ E.catch (Just <$> findLocalCradle dummyCradleFile) parseErrorHandler
+
         -- haskell lsp sets the current directory to the project root in the InitializeRequest
         -- We launch the dispatcher after that so that the default cradle is
         -- recognized properly by ghc-mod
-        flip labelThread "scheduler" =<< (forkIO $ Scheduler.runScheduler scheduler errorHandler callbackHandler (Just lf))
+        flip labelThread "scheduler" =<< (forkIO $ Scheduler.runScheduler scheduler errorHandler callbackHandler (Just lf) mcradle)
         flip labelThread "reactor" =<< (forkIO reactorFunc)
         flip labelThread "diagnostics" =<< (forkIO $ diagnosticsQueue tr)
         return Nothing

test/dispatcher/Main.hs

@@ -77,6 +77,7 @@ startServer = do
       (\lid errCode e -> logToChan logChan ("received an error", Left (lid, errCode, e)))
       (\g x -> g x)
       def
+      Nothing
 
   return (scheduler, logChan, dispatcher)
 

test/plugin-dispatcher/Main.hs

@@ -46,6 +46,7 @@ newPluginSpec = do
                               (\_ _ _ -> return ())
                               (\f x -> f x)
                               def
+                              Nothing
 
       updateDocument scheduler (filePathToUri "test") 3
       sendRequest scheduler req0

test/utils/TestUtils.hs

@@ -74,7 +74,7 @@ makeRequest plugin com arg = runPluginCommand plugin com (toJSON arg)
 runIGM :: IdePlugins -> IdeGhcM a -> IO a
 runIGM testPlugins f = do
   stateVar <- newTVarIO $ IdeState emptyModuleCache Map.empty Map.empty Nothing
-  runIdeGhcM testPlugins Nothing stateVar f
+  runIdeGhcM Nothing testPlugins Nothing stateVar f
 
 withFileLogging :: FilePath -> IO a -> IO a
 withFileLogging logFile f = do