Obtain the GHC libdir at runtime (#696)

* Update to hie-bios 0.6.1

* Obtain the GHC libdir at runtime using hie-bios

This replaces hardcoding the GHC libdir path with ghc-paths and instead
gets it at runtime through the hie-bios cradle. This means that the
ghcide binary should be a bit more distributable now, since it won't
rely on paths baked at compile time that are local to the machine it was
compiled on. And we also no longer need the ghcLibCheck since we are
comparing the coompiled and runtime versions with the installationCheck
(ghcVersionChecker)

Co-authored-by: Fendor <power.walross@gmail.com>

exe/Main.hs

@@ -21,7 +21,6 @@ import Control.Monad.IO.Class
 import Data.Bifunctor (Bifunctor(second))
 import Data.Default
 import Data.Either
-import Data.Foldable (for_)
 import Data.Function
 import Data.List.Extra
 import Data.Maybe
@@ -52,12 +51,13 @@ import Data.Aeson (ToJSON(toJSON))
 import Development.IDE.LSP.LanguageServer
 import qualified System.Directory.Extra as IO
 import System.Environment
+import System.Info
 import System.IO
 import System.Exit
 import System.FilePath
 import System.Directory
 import System.Time.Extra
-import HIE.Bios.Environment (addCmdOpts, makeDynFlagsAbsolute)
+import HIE.Bios.Environment (addCmdOpts, makeDynFlagsAbsolute, getRuntimeGhcLibDir)
 import Paths_ghcide
 import Development.GitRev
 import Development.Shake (Action)
@@ -72,13 +72,15 @@ import GhcMonad
 import HscTypes (HscEnv(..), ic_dflags)
 import GHC hiding (def)
 import GHC.Check
+-- Only use this for checking against the compile time GHC libDir!
+-- Use getRuntimeGhcLibDir from hie-bios instead for everything else
+-- otherwise binaries will not be distributable since paths will be baked into them
+import qualified GHC.Paths
 import Data.Either.Extra
 
 import HIE.Bios.Cradle
 import HIE.Bios.Types
 
-import Utils
-
 ghcideVersion :: IO String
 ghcideVersion = do
   path <- getExecutablePath
@@ -192,21 +194,34 @@ showEvent lock e = withLock lock $ print e
 
 
 -- | Run the specific cradle on a specific FilePath via hie-bios.
-cradleToSessionOpts :: Cradle a -> FilePath -> IO (Either [CradleError] ComponentOptions)
-cradleToSessionOpts cradle file = do
-    let showLine s = putStrLn ("> " ++ s)
+-- 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 :: Show a => Cradle a -> FilePath
+                      -> IO (Either [CradleError] (ComponentOptions, FilePath))
+cradleToOptsAndLibDir cradle file = do
+    -- Start off by getting the session options
+    let showLine s = hPutStrLn stderr ("> " ++ s)
+    hPutStrLn stderr $ "Output from setting up the cradle " <> show cradle
     cradleRes <- runCradle (cradleOptsProg cradle) showLine file
     case cradleRes of
-        CradleSuccess r -> pure (Right r)
+        CradleSuccess r -> do
+            -- Now get the GHC lib dir
+            libDirRes <- getRuntimeGhcLibDir cradle
+            case libDirRes of
+                -- This is the successful path
+                CradleSuccess libDir -> pure (Right (r, libDir))
                 CradleFail err -> return (Left [err])
                 -- For the None cradle perhaps we still want to report an Info
                 -- message about the fact that the file is being ignored.
                 CradleNone -> return (Left [])
 
-emptyHscEnv :: IORef NameCache -> IO HscEnv
-emptyHscEnv nc = do
-    libdir <- getLibdir
-    env <- runGhc (Just libdir) getSession
+        CradleFail err -> return (Left [err])
+        -- Same here
+        CradleNone -> return (Left [])
+
+emptyHscEnv :: IORef NameCache -> FilePath -> IO HscEnv
+emptyHscEnv nc libDir = do
+    env <- runGhc (Just libDir) getSession
     initDynLinker env
     pure $ setNameCache nc env
 
@@ -250,18 +265,10 @@ loadSession dir = do
       res' <- traverse IO.makeAbsolute res
       return $ normalise <$> res'
 
-  libdir <- getLibdir
-  installationCheck <- ghcVersionChecker libdir
-
   dummyAs <- async $ return (error "Uninitialised")
   runningCradle <- newVar dummyAs :: IO (Var (Async (IdeResult HscEnvEq,[FilePath])))
 
-  case installationCheck of
-    InstallationNotFound{..} ->
-        error $ "GHC installation not found in libdir: " <> libdir
-    InstallationMismatch{..} ->
-        return $ returnWithVersion $ \fp -> return (([renderPackageSetupException compileTime fp GhcVersionMismatch{..}], Nothing),[])
-    InstallationChecked compileTime ghcLibCheck -> return $ do
+  return $ do
     ShakeExtras{logger, eventer, restartShakeSession, withIndefiniteProgress, ideNc} <- getShakeExtras
     IdeOptions{optTesting = IdeTesting optTesting} <- getIdeOptions
 
@@ -269,11 +276,11 @@ loadSession dir = do
     -- If the hieYaml file already has an HscEnv, the new component is
     -- combined with the components in the old HscEnv into a new HscEnv
     -- which contains the union.
-      let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions)
+    let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)
                      -> IO (HscEnv, ComponentInfo, [ComponentInfo])
-          packageSetup (hieYaml, cfp, opts) = do
+        packageSetup (hieYaml, cfp, opts, libDir) = do
           -- Parse DynFlags for the newly discovered component
-            hscEnv <- emptyHscEnv ideNc
+          hscEnv <- emptyHscEnv ideNc libDir
           (df, targets) <- evalGhcEnv hscEnv $
               setOptions opts (hsc_dflags hscEnv)
           let deps = componentDependencies opts ++ maybeToList hieYaml
@@ -317,12 +324,11 @@ loadSession dir = do
               -- It's important to keep the same NameCache though for reasons
               -- that I do not fully understand
               logInfo logger (T.pack ("Making new HscEnv" ++ show inplace))
-                hscEnv <- emptyHscEnv ideNc
+              hscEnv <- emptyHscEnv ideNc libDir
               newHscEnv <-
                 -- Add the options for the current component to the HscEnv
                 evalGhcEnv hscEnv $ do
                   _ <- setSessionDynFlags df
-                    checkSession logger ghcLibCheck
                   getSession
 
               -- Modify the map so the hieYaml now maps to the newly created
@@ -336,9 +342,10 @@ loadSession dir = do
               pure (Map.insert hieYaml (newHscEnv, new_deps) m, (newHscEnv, head new_deps', tail new_deps'))
 
 
-      let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> IO (IdeResult HscEnvEq,[FilePath])
-          session (hieYaml, cfp, opts) = do
-            (hscEnv, new, old_deps) <- packageSetup (hieYaml, cfp, opts)
+    let session :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)
+                -> IO (IdeResult HscEnvEq,[FilePath])
+        session args@(hieYaml, _cfp, _opts, _libDir) = do
+          (hscEnv, new, old_deps) <- packageSetup args
           -- Make a map from unit-id to DynFlags, this is used when trying to
           -- resolve imports. (especially PackageImports)
           let uids = map (\ci -> (componentUnitId ci, componentDynFlags ci)) (new : old_deps)
@@ -371,15 +378,25 @@ loadSession dir = do
            -- Display a user friendly progress message here: They probably don't know what a
            -- cradle is
            let progMsg = "Setting up project " <> T.pack (takeBaseName (cradleRootDir cradle))
+
+
+
            eopts <- withIndefiniteProgress progMsg LSP.NotCancellable $
-               cradleToSessionOpts cradle cfp
+             cradleToOptsAndLibDir cradle cfp
 
            logDebug logger $ T.pack ("Session loading result: " <> show eopts)
            case eopts of
              -- The cradle gave us some options so get to work turning them
              -- into and HscEnv.
-               Right opts -> do
-                 session (hieYaml, toNormalizedFilePath' cfp, opts)
+             Right (opts, libDir) -> do
+               installationCheck <- ghcVersionChecker libDir
+               case installationCheck of
+                 InstallationNotFound{..} ->
+                     error $ "GHC installation not found in libdir: " <> libdir
+                 InstallationMismatch{..} ->
+                     return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[])
+                 InstallationChecked _compileTime _ghcLibCheck ->
+                   session (hieYaml, toNormalizedFilePath' cfp, opts, libDir)
              -- Failure case, either a cradle error or the none cradle
              Left err -> do
                dep_info <- getDependencyInfo (maybeToList hieYaml)
@@ -417,7 +434,7 @@ loadSession dir = do
         getOptions file = do
             hieYaml <- cradleLoc file
             sessionOpts (hieYaml, file) `catch` \e ->
-                  return (([renderPackageSetupException compileTime file e], Nothing),[])
+                return (([renderPackageSetupException file e], Nothing),[])
 
     returnWithVersion $ \file -> do
       liftIO $ join $ mask_ $ modifyVar runningCradle $ \as -> do
@@ -692,16 +709,7 @@ cradleLoadedMethod = "ghcide/cradle/loaded"
 ----------------------------------------------------------------------------------------------------
 
 ghcVersionChecker :: GhcVersionChecker
-ghcVersionChecker = $$(makeGhcVersionChecker getLibdir)
-
--- | Throws a 'PackageSetupException' if the 'Session' cannot be used by ghcide
-checkSession :: Logger -> Ghc PackageCheckResult -> Ghc ()
-checkSession logger ghcLibCheck =
-    ghcLibCheck >>= \res -> case guessCompatibility res of
-        ProbablyCompatible mbWarning ->
-            for_ mbWarning $ liftIO . logInfo logger . T.pack
-        NotCompatible err ->
-            liftIO $ throwIO $ PackageCheckFailed err
+ghcVersionChecker = $$(makeGhcVersionChecker (fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"))
 
 data PackageSetupException
     = PackageSetupException
@@ -722,31 +730,31 @@ wrapPackageSetupException = handleAny $ \case
   e | Just (pkgE :: PackageSetupException) <- fromException e -> throwIO pkgE
   e -> (throwIO . PackageSetupException . show) e
 
-showPackageSetupException :: Version -> PackageSetupException -> String
-showPackageSetupException _ GhcVersionMismatch{..} = unwords
+showPackageSetupException :: PackageSetupException -> String
+showPackageSetupException GhcVersionMismatch{..} = unwords
     ["ghcide compiled against GHC"
     ,showVersion compileTime
     ,"but currently using"
     ,showVersion runTime
     ,"\nThis is unsupported, ghcide must be compiled with the same GHC version as the project."
     ]
-showPackageSetupException compileTime PackageSetupException{..} = unwords
-    [ "ghcide compiled by GHC", showVersion compileTime
+showPackageSetupException PackageSetupException{..} = unwords
+    [ "ghcide compiled by GHC", showVersion compilerVersion
     , "failed to load packages:", message <> "."
     , "\nPlease ensure that ghcide is compiled with the same GHC installation as the project."]
-showPackageSetupException _ (PackageCheckFailed PackageVersionMismatch{..}) = unwords
+showPackageSetupException (PackageCheckFailed PackageVersionMismatch{..}) = unwords
     ["ghcide compiled with package "
     , packageName <> "-" <> showVersion compileTime
     ,"but project uses package"
     , packageName <> "-" <> showVersion runTime
     ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project."
     ]
-showPackageSetupException _ (PackageCheckFailed BasePackageAbiMismatch{..}) = unwords
+showPackageSetupException (PackageCheckFailed BasePackageAbiMismatch{..}) = unwords
     ["ghcide compiled with base-" <> showVersion compileTime <> "-" <> compileTimeAbi
     ,"but project uses base-" <> showVersion compileTime <> "-" <> runTimeAbi
     ,"\nThis is unsupported, ghcide must be compiled with the same GHC installation as the project."
     ]
 
-renderPackageSetupException :: Version -> FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic)
-renderPackageSetupException compileTime fp e =
-    ideErrorWithSource (Just "cradle") (Just DsError) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException compileTime e)
+renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic)
+renderPackageSetupException fp e =
+    ideErrorWithSource (Just "cradle") (Just DsError) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e)

exe/Utils.hs

@@ -1,9 +0,0 @@
-module Utils (getLibdir) where
-
-import qualified GHC.Paths
-import System.Environment
-import Data.Maybe
-
--- Set the GHC libdir to the nix libdir if it's present.
-getLibdir :: IO FilePath
-getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR"

ghcide.cabal

@@ -267,7 +267,6 @@ executable ghcide
         text,
         unordered-containers
     other-modules:
-        Utils
         Arguments
         Paths_ghcide
 

test/exe/Main.hs

@@ -40,7 +40,8 @@ import Language.Haskell.LSP.VFS (applyChange)
 import Network.URI
 import System.Environment.Blank (getEnv, setEnv, unsetEnv)
 import System.FilePath
-import System.IO.Extra
+import System.IO.Extra hiding (withTempDir)
+import qualified System.IO.Extra
 import System.Directory
 import System.Exit (ExitCode(ExitSuccess))
 import System.Process.Extra (readCreateProcessWithExitCode, CreateProcess(cwd), proc)
@@ -3010,3 +3011,11 @@ getWatchedFilesSubscriptionsUntil = do
             | Just RequestMessage{_params = RegistrationParams (List regs)} <- msgs
             , Registration _id WorkspaceDidChangeWatchedFiles args <- regs
             ]
+
+-- | Version of 'System.IO.Extra.withTempDir' that canonicalizes the path
+-- Which we need to do on macOS since the $TMPDIR can be in @/private/var@ or
+-- @/var@
+withTempDir :: (FilePath -> IO a) -> IO a
+withTempDir f = System.IO.Extra.withTempDir $ \dir -> do
+  dir' <- canonicalizePath dir
+  f dir'