Add getGhcPath and getGhcLibDir

This is part of the work towards getting static binaries properly
working in ghcide and haskell-language-server. To do this we need to be
able to fetch the ghc library directory on the fly, as it will change
with each ghc installation. So we might as well have cradles report back
where their ghc binary is located, which we can then call --print-libdir
on.

getGhcLibDir however is a bit more robust, and searches three places,
falling back in this order:
1. the NIX_GHC_LIBDIR environment variable
2. ghc --print-libdir for whatever ghc the cradle is using
3. the libdir baked into ghc-paths

We want to avoid using ghc-paths if possible since it bakes the path
into the binary, which means it isn't portable in the static binary
sense.

hie-bios.cabal

@@ -144,6 +144,7 @@ Library
                         extra                >= 1.6.14 && < 1.8,
                         process              >= 1.6.1 && < 1.7,
                         ghc                  >= 8.4.1 && < 8.11,
+                        ghc-paths            >= 0.1 && < 0.2,
                         transformers         >= 0.5.2 && < 0.6,
                         temporary            >= 1.2 && < 1.4,
                         text                 >= 1.2.3 && < 1.3,

src/HIE/Bios/Cradle.hs

@@ -37,9 +37,10 @@ import Control.Monad
 import System.Info.Extra
 import Control.Monad.IO.Class
 import System.Environment
-import Control.Applicative ((<|>))
+import Control.Applicative ((<|>), optional)
 import System.IO.Temp
 import System.IO.Error (isPermissionError)
+import Data.Char
 import Data.List
 import Data.Ord (Down(..))
 
@@ -212,7 +213,9 @@ defaultCradle cur_dir =
     { cradleRootDir = cur_dir
     , cradleOptsProg = CradleAction
         { actionName = Types.Default
-        , runCradle = \_ _ -> return (CradleSuccess (ComponentOptions [] cur_dir []))
+        , runCradle = \_ _ ->
+            return (CradleSuccess (ComponentOptions [] cur_dir []))
+        , getGhcPath = findExecutable "ghc"
         }
     }
 
@@ -226,6 +229,7 @@ noneCradle cur_dir =
     , cradleOptsProg = CradleAction
         { actionName = Types.None
         , runCradle = \_ _ -> return CradleNone
+        , getGhcPath = pure Nothing
         }
     }
 
@@ -239,6 +243,14 @@ multiCradle buildCustomCradle cur_dir cs =
     , cradleOptsProg = CradleAction
         { actionName = multiActionName
         , runCradle  = \l fp -> canonicalizePath fp >>= multiAction buildCustomCradle cur_dir cs l
+        , getGhcPath =
+            -- We're being lazy here and just returning the ghc path for the
+            -- first non-none cradle. This shouldn't matter in practice: all
+            -- sub cradles should be using the same ghc version!
+            case filter (not . isNoneCradleConfig) $ map snd cs of
+              [] -> return Nothing
+              (cfg:_) -> getGhcPath $ cradleOptsProg $
+                getCradle buildCustomCradle (cfg, cur_dir)
         }
     }
   where
@@ -305,12 +317,14 @@ multiAction buildCustomCradle cur_dir cs l cur_fp =
 -------------------------------------------------------------------------
 
 directCradle :: FilePath -> [String] -> Cradle a
-directCradle wdir args  =
+directCradle wdir args =
   Cradle
     { cradleRootDir = wdir
     , cradleOptsProg = CradleAction
         { actionName = Types.Direct
-        , runCradle = \_ _ -> return (CradleSuccess (ComponentOptions args wdir []))
+        , runCradle = \_ _ ->
+            return (CradleSuccess (ComponentOptions args wdir []))
+        , getGhcPath = findExecutable "ghc"
         }
     }
 
@@ -326,6 +340,7 @@ biosCradle wdir biosCall biosDepsCall =
     , cradleOptsProg   = CradleAction
         { actionName = Types.Bios
         , runCradle = biosAction wdir biosCall biosDepsCall
+        , getGhcPath = findExecutable "ghc"
         }
     }
 
@@ -378,6 +393,9 @@ cabalCradle wdir mc =
     , cradleOptsProg   = CradleAction
         { actionName = Types.Cabal
         , runCradle = cabalAction wdir mc
+        , getGhcPath = optional $ fmap trim $
+            -- Need to pass -v0 otherwise we get "resolving dependencies..."
+            readProcess "cabal" ["v2-exec", "which", "-v0", "--", "ghc"] ""
         }
     }
 
@@ -495,6 +513,8 @@ stackCradle wdir mc =
     , cradleOptsProg   = CradleAction
         { actionName = Types.Stack
         , runCradle = stackAction wdir mc
+        , getGhcPath = optional $ fmap trim $
+            readProcess "stack" ["exec", "which", "--silent", "--", "ghc"] ""
         }
     }
 
@@ -697,3 +717,7 @@ makeCradleResult (ex, err, componentDir, gopts) deps =
     _ ->
         let compOpts = ComponentOptions gopts componentDir deps
         in CradleSuccess compOpts
+
+-- Used for clipping the trailing newlines on some commands
+trim :: String -> String
+trim = dropWhileEnd isSpace

src/HIE/Bios/Environment.hs

@@ -1,14 +1,17 @@
 {-# LANGUAGE RecordWildCards, CPP #-}
-module HIE.Bios.Environment (initSession, getSystemLibDir, makeDynFlagsAbsolute, getCacheDir, addCmdOpts) where
+module HIE.Bios.Environment (initSession, getGhcLibDir, makeDynFlagsAbsolute, getCacheDir, addCmdOpts) where
 
 import CoreMonad (liftIO)
-import GHC (DynFlags(..), GhcLink(..), HscTarget(..), GhcMonad)
+import GHC (GhcMonad)
 import qualified GHC as G
 import qualified DriverPhases as G
 import qualified Util as G
 import DynFlags
+import qualified GHC.Paths as Paths
 
+import Control.Applicative
 import Control.Monad (void)
+import Control.Monad.Trans.Maybe
 
 import System.Process (readProcess)
 import System.Directory
@@ -20,8 +23,8 @@ import qualified Data.ByteString.Char8 as B
 import Data.ByteString.Base16
 import Data.List
 import Data.Char (isSpace)
-import Control.Applicative ((<|>))
-import Text.ParserCombinators.ReadP
+import Data.Maybe
+import Text.ParserCombinators.ReadP hiding (optional)
 import HIE.Bios.Types
 import HIE.Bios.Ghc.Gap
 
@@ -53,13 +56,22 @@ initSession  ComponentOptions {..} = do
 
 ----------------------------------------------------------------
 
--- | Obtain the directory for system libraries.
-getSystemLibDir :: IO (Maybe FilePath)
-getSystemLibDir = do
-    res <- readProcess "ghc" ["--print-libdir"] []
-    return $ case res of
-        ""   -> Nothing
-        dirn -> Just (init dirn)
+-- | Obtain the directory for the ghc library directory.
+-- It tries this specific order of paths:
+-- 1. the NIX_GHC_LIBDIR if it is set
+-- 2. calling --print-libdir with the cradle's ghc
+-- 3. using ghc-paths
+-- Note that 3 will only work if we are running on the same machine that
+-- hie-bios compiled on, so we avoid using it unless we have to!
+getGhcLibDir :: Cradle a -> IO FilePath
+getGhcLibDir cradle =
+  fmap (fromMaybe Paths.libdir) $ runMaybeT $ fromNix <|> fromCradle
+  where
+    fromNix = MaybeT $ lookupEnv "NIX_GHC_LIBDIR"
+    fromCradle = do
+      ghc <- MaybeT $ getGhcPath (cradleOptsProg cradle)
+      libDir <- MaybeT $ optional $ readProcess ghc ["--print-libdir"] []
+      return (dropWhileEnd isSpace libDir)
 
 ----------------------------------------------------------------
 

src/HIE/Bios/Ghc/Api.hs

@@ -6,9 +6,8 @@ module HIE.Bios.Ghc.Api (
   , G.SuccessFlag(..)
   -- * Utility functions for running the GHC monad and implementing internal utilities
   , withGHC
-  , withGHC'
   , withGhcT
-  , getSystemLibDir
+  , getGhcLibDir
   , withDynFlags
   ) where
 
@@ -32,29 +31,25 @@ import HIE.Bios.Flags
 ----------------------------------------------------------------
 
 -- | Converting the 'Ghc' monad to the 'IO' monad. All exceptions are ignored and logged.
-withGHC :: FilePath  -- ^ A target file displayed in an error message.
+withGHC :: Cradle c  -- ^ The cradle to use for resolving the lib dir
+        -> FilePath  -- ^ A target file displayed in an error message.
         -> Ghc a -- ^ 'Ghc' actions created by the Ghc utilities.
         -> IO a
-withGHC file body = ghandle ignore $ withGHC' body
+withGHC cradle file body = do
+    libDir <- getGhcLibDir cradle
+    ghandle ignore (G.runGhc (Just libDir) body)
   where
     ignore :: SomeException -> IO a
     ignore e = do
         Log.logm $ file ++ ":0:0:Error:"
         Log.logm (show e)
         exitSuccess
 
--- | Run a Ghc monad computation with an automatically discovered libdir.
--- It calculates the lib dir by calling ghc with the `--print-libdir` flag.
-withGHC' :: Ghc a -> IO a
-withGHC' body = do
-    -- TODO: Why is this not using ghc-paths?
-    mlibdir <- getSystemLibDir
-    G.runGhc mlibdir body
-
-withGhcT :: (Exception.ExceptionMonad m, G.MonadIO m, Monad m) => GhcT m a -> m a
-withGhcT body = do
-  mlibdir <- G.liftIO $ getSystemLibDir
-  G.runGhcT mlibdir body
+withGhcT :: (Exception.ExceptionMonad m, G.MonadIO m, Monad m)
+         => Cradle c -> GhcT m a -> m a
+withGhcT cradle body = do
+  libDir <- liftIO $ getGhcLibDir cradle
+  G.runGhcT (Just libDir) body
 
 ----------------------------------------------------------------
 

src/HIE/Bios/Ghc/Check.hs

@@ -16,6 +16,7 @@ import Control.Monad.IO.Class
 import System.IO.Unsafe (unsafePerformIO)
 import qualified HIE.Bios.Ghc.Gap as Gap
 
+import qualified DynFlags as G
 import qualified GHC as G
 import HIE.Bios.Environment
 
@@ -28,7 +29,7 @@ checkSyntax :: Show a
             -> [FilePath]  -- ^ The target files.
             -> IO String
 checkSyntax _      []    = return ""
-checkSyntax cradle files = withGhcT $ do
+checkSyntax cradle files = withGhcT cradle $ do
     Log.debugm $ "Cradle: " ++ show cradle
     res <- initializeFlagsWithCradle (head files) cradle
     case res of
@@ -53,22 +54,23 @@ checkSyntax cradle files = withGhcT $ do
 check :: (GhcMonad m)
       => [FilePath]  -- ^ The target files.
       -> m (Either String String)
-check fileNames = withLogger setAllWarningFlags $ setTargetFiles (map dup fileNames)
+check fileNames = do
+  topDir <- G.topDir <$> G.getDynFlags
+  withLogger (setAllWarningFlags topDir) $ setTargetFiles (map dup fileNames)
 
 dup :: a -> (a, a)
 dup x = (x, x)
 
 ----------------------------------------------------------------
 
 -- | Set 'DynFlags' equivalent to "-Wall".
-setAllWarningFlags :: DynFlags -> DynFlags
-setAllWarningFlags df = df { warningFlags = allWarningFlags }
+setAllWarningFlags :: FilePath -> DynFlags -> DynFlags
+setAllWarningFlags topDir df = df { warningFlags = allWarningFlags topDir }
 
 {-# NOINLINE allWarningFlags #-}
-allWarningFlags :: Gap.WarnFlags
-allWarningFlags = unsafePerformIO $ do
-    mlibdir <- getSystemLibDir
-    G.runGhcT mlibdir $ do
+allWarningFlags :: FilePath -> Gap.WarnFlags
+allWarningFlags topDir = unsafePerformIO $
+    G.runGhcT (Just topDir) $ do
         df <- G.getSessionDynFlags
         (df', _) <- addCmdOpts ["-Wall"] df
-        return $ G.warningFlags df'
+        return $ G.warningFlags df'

src/HIE/Bios/Ghc/Logger.hs

@@ -10,7 +10,7 @@ import DynFlags (LogAction, dopt, DumpFlag(Opt_D_dump_splices))
 import ErrUtils
 import Exception (ghandle)
 import FastString (unpackFS)
-import GHC (DynFlags(..), SrcSpan(..), Severity(SevError), GhcMonad)
+import GHC (DynFlags(..), SrcSpan(..), GhcMonad)
 import qualified GHC as G
 import HscTypes (SourceError, srcErrorMessages)
 import Outputable (PprStyle, SDoc)

src/HIE/Bios/Internal/Debug.hs

@@ -1,12 +1,10 @@
 {-# LANGUAGE LambdaCase #-}
 module HIE.Bios.Internal.Debug (debugInfo, rootInfo, configInfo, cradleInfo) where
 
-import Control.Monad.IO.Class (liftIO)
 import Control.Monad
 import Data.Void
 
 import qualified Data.Char as Char
-import Data.Maybe (fromMaybe)
 
 import HIE.Bios.Ghc.Api
 import HIE.Bios.Cradle
@@ -34,17 +32,19 @@ debugInfo fp cradle = unlines <$> do
     canonFp <- canonicalizePath fp
     conf <- findConfig canonFp
     crdl <- findCradle' canonFp
+    ghcPath <- getGhcPath (cradleOptsProg cradle)
+    ghcLibDir <- getGhcLibDir cradle
     case res of
       CradleSuccess (ComponentOptions gopts croot deps) -> do
-        mglibdir <- liftIO getSystemLibDir
         return [
-            "Root directory:      " ++ rootDir
-          , "Component directory: " ++ croot
-          , "GHC options:         " ++ unwords (map quoteIfNeeded gopts)
-          , "System libraries:    " ++ fromMaybe "" mglibdir
-          , "Config Location:     " ++ conf
-          , "Cradle:              " ++ crdl
-          , "Dependencies:        " ++ unwords deps
+            "Root directory:        " ++ rootDir
+          , "Component directory:   " ++ croot
+          , "GHC options:           " ++ unwords (map quoteIfNeeded gopts)
+          , "GHC path:              " ++ show ghcPath
+          , "GHC library directory: " ++ ghcLibDir
+          , "Config Location:       " ++ conf
+          , "Cradle:                " ++ crdl
+          , "Dependencies:          " ++ unwords deps
           ]
       CradleFail (CradleError deps ext stderr) ->
         return ["Cradle failed to load"

src/HIE/Bios/Types.hs

@@ -53,10 +53,13 @@ data ActionName a
   deriving (Show, Eq, Ord, Functor)
 
 data CradleAction a = CradleAction {
-                      actionName :: ActionName a
+                        actionName :: ActionName a
                       -- ^ Name of the action.
                       , runCradle :: LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions)
                       -- ^ Options to compile the given file with.
+                      , getGhcPath :: IO (Maybe FilePath)
+                      -- ^ Try to find the path to the GHC that this cradle uses
+                      -- to compile stuff normally.
                       }
   deriving (Functor)
 

tests/BiosTests.hs

@@ -4,7 +4,6 @@
 module Main where
 
 import Test.Tasty
-import Test.Tasty.ExpectedFailure
 import Test.Tasty.HUnit
 import Test.Hspec.Expectations
 import HIE.Bios
@@ -125,7 +124,7 @@ testLoadFile :: Cradle a -> FilePath -> (String -> IO ()) -> IO ()
 testLoadFile crd fp step = do
   a_fp <- canonicalizePath fp
   withCurrentDirectory (cradleRootDir crd) $
-    withGHC' $ do
+    withGHC crd fp $ do
       let relFp = makeRelative (cradleRootDir crd) a_fp
       res <- initializeFlagsWithCradleWithMessage (Just (\_ n _ _ -> step (show n))) relFp crd
       case res of
@@ -143,7 +142,7 @@ testLoadFileCradleFail :: Cradle a -> FilePath -> (CradleError -> Expectation) -
 testLoadFileCradleFail crd fp cradleErrorExpectation step = do
   a_fp <- canonicalizePath fp
   withCurrentDirectory (cradleRootDir crd) $
-    withGHC' $ do
+    withGHC crd fp $ do
       let relFp = makeRelative (cradleRootDir crd) a_fp
       res <- initializeFlagsWithCradleWithMessage (Just (\_ n _ _ -> step (show n))) relFp crd
       case res of