Add runGhcLibDir and getRuntimeGhcLibDir

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.

getRuntimeGhcLibDir is what client code should use to obtain the libdir,
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. So if True is passed for the second argument, it will avoid
falling back on ghc-paths, which can be useful when distributing static
binaries etc.

From the library directory we can also get the path to the ghc binary
used, which we can then use to get the cradle ghc version via
getRuntimeGhcVersion

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

@@ -2,6 +2,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
 module HIE.Bios.Cradle (
       findCradle
     , loadCradle
@@ -37,10 +38,12 @@ 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.Foldable
 import Data.Ord (Down(..))
 
 import System.PosixCompat.Files
@@ -55,6 +58,7 @@ import qualified Data.Conduit.Text as C
 import qualified Data.Text as T
 import           Data.Maybe (fromMaybe, maybeToList)
 import           GHC.Fingerprint (fingerprintString)
+
 ----------------------------------------------------------------
 
 -- | Given root\/foo\/bar.hs, return root\/hie.yaml, or wherever the yaml file was found.
@@ -212,7 +216,9 @@ defaultCradle cur_dir =
     { cradleRootDir = cur_dir
     , cradleOptsProg = CradleAction
         { actionName = Types.Default
-        , runCradle = \_ _ -> return (CradleSuccess (ComponentOptions [] cur_dir []))
+        , runCradle = \_ _ ->
+            return (CradleSuccess (ComponentOptions [] cur_dir []))
+        , runGhcLibDir = getGhcOnPathLibDir cur_dir
         }
     }
 
@@ -226,6 +232,7 @@ noneCradle cur_dir =
     , cradleOptsProg = CradleAction
         { actionName = Types.None
         , runCradle = \_ _ -> return CradleNone
+        , runGhcLibDir = pure Nothing
         }
     }
 
@@ -239,6 +246,14 @@ multiCradle buildCustomCradle cur_dir cs =
     , cradleOptsProg = CradleAction
         { actionName = multiActionName
         , runCradle  = \l fp -> canonicalizePath fp >>= multiAction buildCustomCradle cur_dir cs l
+        , runGhcLibDir =
+            -- 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:_) -> runGhcLibDir $ cradleOptsProg $
+                getCradle buildCustomCradle (cfg, cur_dir)
         }
     }
   where
@@ -305,12 +320,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 []))
+        , runGhcLibDir = getGhcOnPathLibDir wdir
         }
     }
 
@@ -326,6 +343,7 @@ biosCradle wdir biosCall biosDepsCall =
     , cradleOptsProg   = CradleAction
         { actionName = Types.Bios
         , runCradle = biosAction wdir biosCall biosDepsCall
+        , runGhcLibDir = getGhcOnPathLibDir wdir
         }
     }
 
@@ -378,6 +396,15 @@ cabalCradle wdir mc =
     , cradleOptsProg   = CradleAction
         { actionName = Types.Cabal
         , runCradle = cabalAction wdir mc
+        , runGhcLibDir = optional $ fmap trim $ do
+            -- Workaround for a cabal-install bug on 3.0.0.0:
+            -- ./dist-newstyle/tmp/environment.-24811: createDirectory: does not exist (No such file or directory)
+            -- (It's ok to pass 'dist-newstyle' here, as it can only be changed
+            -- with the --builddir flag and not cabal.project, which we aren't
+            -- using in our call to v2-exec)
+            createDirectoryIfMissing True (wdir </> "dist-newstyle" </> "tmp")
+            -- Need to pass -v0 otherwise we get "resolving dependencies..."
+            readProcessWithCwd wdir "cabal" ["v2-exec", "ghc", "-v0", "--", "--print-libdir"] ""
         }
     }
 
@@ -495,6 +522,8 @@ stackCradle wdir mc =
     , cradleOptsProg   = CradleAction
         { actionName = Types.Stack
         , runCradle = stackAction wdir mc
+        , runGhcLibDir = optional $ fmap trim $
+            readProcessWithCwd wdir "stack" ["exec", "--silent", "ghc", "--", "--print-libdir"] ""
         }
     }
 
@@ -697,3 +726,31 @@ 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
+
+-- | Calls @ghc --print-libdir@, with just whatever's on the PATH.  It looks
+-- for @ghc-VERSION_ghc@ first, then just @ghc@, and always makes sure that the
+-- ghc matches up with the version hie-bios was compiled with. Otherwise
+-- returns 'Nothing'
+getGhcOnPathLibDir :: FilePath -> IO (Maybe FilePath)
+getGhcOnPathLibDir wdir = runMaybeT $ asum $ fmap go
+    [ compilerName <> "-" <> VERSION_ghc -- ghc-8.10.1, ghc-8.8.3 etc
+    , compilerName                       -- ghc
+    ]
+  where
+    go ghc = MaybeT $ do
+      -- do a sanity check to make sure the ghc is the same version as what we
+      -- have compiled with
+      actualVer <- optional $
+       fmap trim $ readProcessWithCwd wdir ghc ["--numeric-version"] ""
+      if (actualVer == Just VERSION_ghc)
+      then optional $
+        fmap trim $ readProcessWithCwd wdir ghc ["--print-libdir"] ""
+      else pure Nothing
+
+-- | Wrapper around 'readCreateProcess' that sets the working directory
+readProcessWithCwd :: FilePath -> FilePath -> [String] -> String -> IO String
+readProcessWithCwd dir cmd args = readCreateProcess (proc cmd args) { cwd = Just dir }

src/HIE/Bios/Environment.hs

@@ -1,27 +1,30 @@
 {-# LANGUAGE RecordWildCards, CPP #-}
-module HIE.Bios.Environment (initSession, getSystemLibDir, makeDynFlagsAbsolute, getCacheDir, addCmdOpts) where
+module HIE.Bios.Environment (initSession, getRuntimeGhcLibDir, getRuntimeGhcVersion, 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.Monad (void)
+import Control.Applicative
+import Control.Monad (msum, void)
+import Control.Monad.Trans.Maybe
 
-import System.Process (readProcess)
 import System.Directory
 import System.FilePath
 import System.Environment (lookupEnv)
+import System.Process
 
 import qualified Crypto.Hash.SHA1 as H
 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,51 @@ 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)
+-- | @getRuntimeGhcLibDir cradle avoidHardcoding@ will give you the ghc libDir:
+-- __do not__ use 'runGhcLibDir' directly.
+-- This will also perform additional lookups and fallbacks to try and get a
+-- reliable library directory.
+--
+-- It tries this specific order of paths:
+--
+-- 1. the @NIX_GHC_LIBDIR@ if it is set
+-- 2. calling 'runCradleGhc' on the provided cradle
+-- 3. using @ghc-paths@
+--
+-- If @avoidHardcoding@ is 'True', then 'getRuntimeGhcLibDir' will __not__ fall
+-- back on @ghc-paths@. Set this to 'False' whenever you are planning on
+-- distributing the resulting binary you are compiling, otherwise paths from
+-- the system you were compiling on will be baked in!
+getRuntimeGhcLibDir :: Cradle a
+                    -> Bool -- ^ If 'True', avoid hardcoding the paths.
+                    -> IO (Maybe FilePath)
+getRuntimeGhcLibDir cradle avoidHardcoding =
+  runMaybeT $ fromNix <|> fromCradle <|> fromGhcPaths
+  where
+    fromNix = MaybeT $ lookupEnv "NIX_GHC_LIBDIR"
+    fromCradle = MaybeT $ runGhcLibDir $ cradleOptsProg cradle
+    fromGhcPaths = MaybeT $ pure $
+      if avoidHardcoding then Just Paths.libdir else Nothing
+
+-- | Gets the version of ghc used when compiling the cradle. It is based off of
+-- 'getRuntimeGhcLibDir'. If it can't work out the verison reliably, it will
+-- fall back to the version of ghc used to compile hie-bios.
+getRuntimeGhcVersion :: Cradle a
+                     -> IO String
+getRuntimeGhcVersion cradle = fmap (fromMaybe VERSION_ghc) $ runMaybeT $ do
+  libDir <- MaybeT $ getRuntimeGhcLibDir cradle True
+  let possibleExes = guessExecutablePathFromLibdir libDir
+  MaybeT $ msum (fmap getGhcVersion possibleExes)
+  where
+    getGhcVersion :: FilePath -> IO (Maybe String)
+    getGhcVersion ghc = (Just <$> readProcess ghc ["--numeric-version"] "")
+                    <|> (pure Nothing)
+    -- Taken from ghc-check GHC.Check.Executable
+    guessExecutablePathFromLibdir :: FilePath -> [FilePath]
+    guessExecutablePathFromLibdir fp =
+        [ fp </> "bin" </> "ghc"               -- Linux
+        , fp </> ".." </> "bin" </> "ghc.exe"  -- Windows
+        ]
 
 ----------------------------------------------------------------
 

src/HIE/Bios/Ghc/Api.hs

@@ -4,60 +4,24 @@ module HIE.Bios.Ghc.Api (
     initializeFlagsWithCradle
   , initializeFlagsWithCradleWithMessage
   , G.SuccessFlag(..)
-  -- * Utility functions for running the GHC monad and implementing internal utilities
-  , withGHC
-  , withGHC'
-  , withGhcT
-  , getSystemLibDir
   , withDynFlags
   ) where
 
 import CoreMonad (liftIO)
-import Exception (ghandle, SomeException(..), ExceptionMonad(..))
-import GHC (Ghc, LoadHowMuch(..), GhcMonad, GhcT)
+import GHC (LoadHowMuch(..), GhcMonad)
 import DynFlags
 
 import qualified GHC as G
-import qualified MonadUtils as G
 import qualified HscMain as G
 import qualified GhcMake as G
 
 import Control.Monad (void)
-import System.Exit (exitSuccess)
 import HIE.Bios.Types
-import qualified HIE.Bios.Internal.Log as Log
 import HIE.Bios.Environment
 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.
-        -> Ghc a -- ^ 'Ghc' actions created by the Ghc utilities.
-        -> IO a
-withGHC file body = ghandle ignore $ withGHC' 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
-
-----------------------------------------------------------------
-
 -- | Initialize a GHC session by loading a given file into a given cradle.
 initializeFlagsWithCradle ::
     GhcMonad m

src/HIE/Bios/Ghc/Check.hs

@@ -6,6 +6,7 @@ module HIE.Bios.Ghc.Check (
 import GHC (DynFlags(..), GhcMonad)
 import Exception
 
+import HIE.Bios.Environment
 import HIE.Bios.Ghc.Api
 import HIE.Bios.Ghc.Logger
 import qualified HIE.Bios.Internal.Log as Log
@@ -16,6 +17,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,15 +30,17 @@ checkSyntax :: Show a
             -> [FilePath]  -- ^ The target files.
             -> IO String
 checkSyntax _      []    = return ""
-checkSyntax cradle files = withGhcT $ do
-    Log.debugm $ "Cradle: " ++ show cradle
-    res <- initializeFlagsWithCradle (head files) cradle
-    case res of
-      CradleSuccess (ini, _) -> do
-        _sf <- ini
-        either id id <$> check files
-      CradleFail ce -> liftIO $ throwIO ce
-      CradleNone -> return "No cradle"
+checkSyntax cradle files = do
+    libDir <- getRuntimeGhcLibDir cradle False
+    G.runGhcT libDir $ do
+      Log.debugm $ "Cradle: " ++ show cradle
+      res <- initializeFlagsWithCradle (head files) cradle
+      case res of
+        CradleSuccess (ini, _) -> do
+          _sf <- ini
+          either id id <$> check files
+        CradleFail ce -> liftIO $ throwIO ce
+        CradleNone -> return "No cradle"
 
 
   where
@@ -53,22 +57,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
+  libDir <- G.topDir <$> G.getDynFlags
+  withLogger (setAllWarningFlags libDir) $ 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 libDir df = df { warningFlags = allWarningFlags libDir }
 
 {-# NOINLINE allWarningFlags #-}
-allWarningFlags :: Gap.WarnFlags
-allWarningFlags = unsafePerformIO $ do
-    mlibdir <- getSystemLibDir
-    G.runGhcT mlibdir $ do
+allWarningFlags :: FilePath -> Gap.WarnFlags
+allWarningFlags libDir = unsafePerformIO $
+    G.runGhcT (Just libDir) $ 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)