Merge pull request #1496 from fendor/dont-depend-on-ghc-at-run-time

Find the libdir directory of ghc at run-time

haskell-ide-engine.cabal

@@ -247,6 +247,8 @@ test-suite plugin-dispatcher-test
   main-is:             Main.hs
   build-depends:       base
                      , data-default
+                     , directory
+                     , filepath
                      , haskell-ide-engine
                      , haskell-lsp-types
                      , hie-plugin-api
@@ -289,7 +291,7 @@ test-suite func-test
                      , data-default
                      , directory
                      , filepath
-                     , lsp-test >= 0.9.0.0
+                     , lsp-test >= 0.10.0.0
                      , haskell-ide-engine
                      , haskell-lsp-types == 0.19.*
                      , haskell-lsp == 0.19.*

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
 import           System.FilePath
 import           System.Directory (getCurrentDirectory, canonicalizePath, findExecutable)
 import           System.Exit
+import           System.Process (readCreateProcessWithExitCode, shell)
 
 -- | Find the cradle that the given File belongs to.
 --
@@ -57,6 +58,98 @@ 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
+
+-- | Execute @ghc@ that is based on the given cradle.
+-- Output must be a single line. If an error is raised, e.g. the command
+-- failed, a @Nothing@ is returned.
+-- The exact error is written to logs.
+--
+-- E.g. for a stack cradle, we use `stack ghc` and for a cabal cradle
+-- we are taking the @ghc@ that is on the path.
+execProjectGhc :: Cradle -> [String] -> IO (Maybe String)
+execProjectGhc crdl args = do
+  isStackInstalled <- isJust <$> findExecutable "stack"
+  -- isCabalInstalled <- isJust <$> findExecutable "cabal"
+  ghcOutput <- if isStackCradle crdl && isStackInstalled
+    then do
+      logm "Use Stack GHC"
+      catch (Just <$> tryCommand stackCmd) $ \(_ :: IOException) -> do
+        errorm $ "Command `" ++ stackCmd ++"` failed."
+        execWithGhc
+    -- The command `cabal v2-exec -v0 ghc` only works if the project has been
+    -- built already.
+    -- This command must work though before the project is build.
+    -- Therefore, fallback to "ghc" on the path.
+    --
+    -- else if isCabalCradle crdl && isCabalInstalled then do
+    --   let cmd = "cabal v2-exec -v0 ghc -- " ++ unwords args
+    --   catch (Just <$> tryCommand cmd) $ \(_ ::IOException) -> do
+    --     errorm $ "Command `" ++ cmd ++ "` failed."
+    --     return Nothing
+    else do
+      logm "Use Plain GHC"
+      execWithGhc
+  debugm $ "GHC Output: \"" ++ show ghcOutput ++ "\""
+  return ghcOutput
+  where
+    stackCmd = "stack ghc -- " ++ unwords args
+    plainCmd = "ghc " ++ unwords args
+
+    execWithGhc =
+      catch (Just <$> tryCommand plainCmd) $ \(_ :: IOException) -> do
+        errorm $ "Command `" ++ plainCmd ++"` failed."
+        return Nothing
+
+tryCommand :: String -> IO String
+tryCommand cmd = do
+  (code, sout, serr) <- readCreateProcessWithExitCode (shell cmd) ""
+  case code of
+    ExitFailure e -> do
+      let errmsg = concat
+            [ "`"
+            , cmd
+            , "`: Exit failure: "
+            , show e
+            , ", stdout: "
+            , sout
+            , ", stderr: "
+            , serr
+            ]
+      errorm errmsg
+      throwIO $ userError errmsg
+
+    ExitSuccess -> return $ T.unpack . T.strip . head . T.lines $ T.pack sout
+
+
+-- | Get the directory of the libdir based on the project ghc.
+getProjectGhcLibDir :: Cradle -> IO (Maybe FilePath)
+getProjectGhcLibDir crdl =
+  execProjectGhc crdl ["--print-libdir"] >>= \case
+    Nothing -> do
+      logm "Could not obtain the libdir."
+      return Nothing
+    mlibdir -> return mlibdir
+
+  -- ---------------------------------------------------------------------
+
+
 {- | 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,11 @@ 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
+     -- ^ Context in which the ghc thread is executed.
+     -- Neccessary to obtain the libdir, for example.
   -> IO ()
-runScheduler Scheduler {..} errorHandler callbackHandler mlf = do
+runScheduler Scheduler {..} errorHandler callbackHandler mlf mcrdl = do
   let dEnv = DispatcherEnv
         { cancelReqsTVar = requestsToCancel
         , wipReqsTVar    = requestsInProgress
@@ -158,7 +163,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

@@ -38,7 +38,8 @@ import qualified Data.SortedList as SL
 import qualified Data.Text as T
 import           Data.Text.Encoding
 import qualified Data.Yaml as Yaml
-import           Haskell.Ide.Engine.Cradle (findLocalCradle, cradleDisplay)
+import           Haskell.Ide.Engine.Cradle (findLocalCradle, cradleDisplay
+                                           , isCabalCradle)
 import           Haskell.Ide.Engine.Config
 import qualified Haskell.Ide.Engine.Ghc   as HIE
 import           Haskell.Ide.Engine.CodeActions
@@ -151,12 +152,64 @@ 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
+        let dummyCradleFile = fromMaybe currentDir lspRootDir </> "File.hs"
+        debugm $ "Dummy Cradle file result: " ++ dummyCradleFile
+        cradleRes <- liftIO $ E.try (findLocalCradle dummyCradleFile)
+        let sf = Core.sendFunc lf
+
+        case cradleRes of
+          Right cradle -> do
+            projGhcVersion <- liftIO $ getProjectGhcVersion cradle
+            when (projGhcVersion /= hieGhcVersion) $ do
+              let msg = T.pack $ "Mismatching GHC versions: " ++ cradleDisplay cradle ++
+                        " is " ++ projGhcVersion ++ ", HIE is " ++ hieGhcVersion
+                        ++ "\nYou may want to use hie-wrapper. Check the README for more information"
+              sf $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning msg
+              sf $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg
+
+              -- Check cabal is installed
+              when (isCabalCradle cradle) $ do
+                hasCabal <- liftIO checkCabalInstall
+                unless hasCabal $ do
+                  let cabalMsg = T.pack "cabal-install is not installed. Check the README for more information"
+                  sf $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning cabalMsg
+                  sf $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning cabalMsg
+
+          Left (e :: Yaml.ParseException) -> do
+            logm $ "Failed to parse `hie.yaml`: " ++ show e
+            sf $ NotShowMessage $ fmServerShowMessageNotification J.MtError ("Couldn't parse hie.yaml: \n" <> T.pack (show e))
+
+        let mcradle = case cradleRes of
+              Left _ -> Nothing
+              Right c -> Just c
+
         -- 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 "reactor" =<< (forkIO reactorFunc)
-        flip labelThread "diagnostics" =<< (forkIO $ diagnosticsQueue tr)
+        flip labelThread "scheduler" =<<
+            (forkIO (
+              Scheduler.runScheduler scheduler errorHandler callbackHandler (Just lf) mcradle
+              `E.catch` \(e :: E.SomeException) ->
+              (errorm $ "Scheduler thread exited unexpectedly: " ++ show e)
+            ))
+        flip labelThread "reactor" =<<
+            (forkIO (
+              reactorFunc
+              `E.catch` \(e :: E.SomeException) ->
+              (errorm $ "Reactor thread exited unexpectedly: " ++ show e)
+            ))
+        flip labelThread "diagnostics" =<<
+            (forkIO (
+              diagnosticsQueue tr
+              `E.catch` \(e :: E.SomeException) ->
+              (errorm $ "Diagnostic thread exited unexpectedly: " ++ show e)
+            ))
+
         return Nothing
 
       diagnosticProviders :: Map.Map DiagnosticTrigger [(PluginId,DiagnosticProviderFunc)]
@@ -396,35 +449,6 @@ reactor inp diagIn = do
           reactorSend $ NotLogMessage $
                   fmServerLogMessageNotification J.MtLog $ "Using hie version: " <> T.pack hieVersion
 
-          lspRootDir <- asksLspFuncs Core.rootPath
-          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"
-          cradleRes <- liftIO $ E.catch (Just <$> findLocalCradle dummyCradleFile) parseErrorHandler
-
-          case cradleRes of
-            Just cradle -> do
-              projGhcVersion <- liftIO $ getProjectGhcVersion cradle
-              when (projGhcVersion /= hieGhcVersion) $ do
-                let msg = T.pack $ "Mismatching GHC versions: " ++ cradleDisplay cradle ++
-                          " is " ++ projGhcVersion ++ ", HIE is " ++ hieGhcVersion
-                          ++ "\nYou may want to use hie-wrapper. Check the README for more information"
-                reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning msg
-                reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning msg
-
-                -- Check cabal is installed
-                -- TODO: only do this check if its a cabal cradle
-                hasCabal <- liftIO checkCabalInstall
-                unless hasCabal $ do
-                  let cabalMsg = T.pack "cabal-install is not installed. Check the README for more information"
-                  reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning cabalMsg
-                  reactorSend $ NotLogMessage $ fmServerLogMessageNotification J.MtWarning cabalMsg
-
-            Nothing -> return ()
-
           renv <- ask
           let hreq = GReq tn "init-hoogle" Nothing Nothing Nothing callback Nothing $ IdeResultOk <$> Hoogle.initializeHoogleDb
               callback Nothing = flip runReaderT renv $