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)
 
 ----------------------------------------------------------------
 
@@ -123,12 +135,25 @@ setHiDir f d = d { hiDir      = Just f}
 addCmdOpts :: (GhcMonad m)
            => [String] -> DynFlags -> m (DynFlags, [G.Target])
 addCmdOpts cmdOpts df1 = do
-  (df2, leftovers', _warns) <- G.parseDynamicFlags df1 (map G.noLoc cmdOpts)
+  -- liftIO $ print cmdOpts
+  (df2, leftovers'', _warns) <- G.parseDynamicFlags df1 (map G.noLoc cmdOpts)
+
+  -- remove any RTS flags from the leftovers
+  let leftovers' = go False (G.unLoc <$> leftovers'')
+      go _     []          = []
+      go _     ("+RTS":xs) = go True xs
+      go True  ("-RTS":xs) = go False xs
+      go True  (_:xs)      = go True xs
+      go False (x:xs)      = x : go False xs
+
+  -- liftIO $ putStrLn "leftovers'':" >> print (G.unLoc <$> leftovers'')
+  -- liftIO $ putStrLn "leftovers':" >> print leftovers'
+
   -- parse targets from ghci-scripts. Only extract targets that have been ":add"'ed.
   additionalTargets <- concat <$> mapM (liftIO . getTargetsFromGhciScript) (ghciScripts df2)
 
   -- leftovers contains all Targets from the command line
-  let leftovers = leftovers' ++ map G.noLoc additionalTargets
+  let leftovers = leftovers' ++ additionalTargets
 
   let
      -- To simplify the handling of filepaths, we normalise all filepaths right
@@ -148,7 +173,7 @@ addCmdOpts cmdOpts df1 = do
 #endif
           cur_dir = '.' : [pathSeparator]
           nfp = normalise fp
-    normal_fileish_paths = map (normalise_hyp . G.unLoc) leftovers
+    normal_fileish_paths = map normalise_hyp leftovers
   let
    (srcs, objs) = partition_args normal_fileish_paths [] []
    df3 = df2 { ldInputs = map (FileOption "") objs ++ ldInputs df2 }

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)
 
@@ -84,6 +87,9 @@ data CradleError = CradleError
   -- the loading error.
   }
   deriving (Show, Eq)
+-- data CradleError = CradleFileError FilePath (Maybe (Int, Int)) String
+--                  | CradleGeneralError ExitCode [String]
+--   deriving (Show)
 
 instance Exception CradleError where
 ----------------------------------------------------------------