From 2628fe71d87ce02d5f8dd84c77eb78fc1b2d447d Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Sun, 14 Jun 2020 15:52:34 +0100 Subject: [PATCH] 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 | 1 + src/HIE/Bios/Cradle.hs | 49 +++++++++++++++++++++++-- src/HIE/Bios/Environment.hs | 67 +++++++++++++++++++++++++++------- src/HIE/Bios/Ghc/Api.hs | 38 +------------------ src/HIE/Bios/Ghc/Check.hs | 39 +++++++++++--------- src/HIE/Bios/Ghc/Logger.hs | 2 +- src/HIE/Bios/Internal/Debug.hs | 20 +++++----- src/HIE/Bios/Types.hs | 8 +++- tests/BiosTests.hs | 20 ++++++++-- 9 files changed, 156 insertions(+), 88 deletions(-) diff --git a/hie-bios.cabal b/hie-bios.cabal index e65855c1c..5ccd8e565 100644 --- a/hie-bios.cabal +++ b/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, diff --git a/src/HIE/Bios/Cradle.hs b/src/HIE/Bios/Cradle.hs index c248c605d..b6d17cec5 100644 --- a/src/HIE/Bios/Cradle.hs +++ b/src/HIE/Bios/Cradle.hs @@ -37,10 +37,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 +57,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 +215,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 +231,7 @@ noneCradle cur_dir = , cradleOptsProg = CradleAction { actionName = Types.None , runCradle = \_ _ -> return CradleNone + , runGhcLibDir = pure Nothing } } @@ -239,6 +245,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 +319,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 +342,7 @@ biosCradle wdir biosCall biosDepsCall = , cradleOptsProg = CradleAction { actionName = Types.Bios , runCradle = biosAction wdir biosCall biosDepsCall + , runGhcLibDir = getGhcOnPathLibDir wdir } } @@ -378,6 +395,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 +521,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 +725,16 @@ 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. +getGhcOnPathLibDir :: FilePath -> IO (Maybe FilePath) +getGhcOnPathLibDir wdir = optional $ + fmap trim $ readProcessWithCwd wdir "ghc" ["--print-libdir"] "" + +-- | 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 } diff --git a/src/HIE/Bios/Environment.hs b/src/HIE/Bios/Environment.hs index f93a19abe..dbad096cc 100644 --- a/src/HIE/Bios/Environment.hs +++ b/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 + ] ---------------------------------------------------------------- diff --git a/src/HIE/Bios/Ghc/Api.hs b/src/HIE/Bios/Ghc/Api.hs index e7d2afcb8..487e62d83 100644 --- a/src/HIE/Bios/Ghc/Api.hs +++ b/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 diff --git a/src/HIE/Bios/Ghc/Check.hs b/src/HIE/Bios/Ghc/Check.hs index bc5863210..2d6c9a3d4 100644 --- a/src/HIE/Bios/Ghc/Check.hs +++ b/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,7 +57,9 @@ 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) @@ -61,14 +67,13 @@ 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' \ No newline at end of file + return $ G.warningFlags df' diff --git a/src/HIE/Bios/Ghc/Logger.hs b/src/HIE/Bios/Ghc/Logger.hs index d6dfa0ce6..d55ac292e 100644 --- a/src/HIE/Bios/Ghc/Logger.hs +++ b/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) diff --git a/src/HIE/Bios/Internal/Debug.hs b/src/HIE/Bios/Internal/Debug.hs index 1bc114d65..20387d7fa 100644 --- a/src/HIE/Bios/Internal/Debug.hs +++ b/src/HIE/Bios/Internal/Debug.hs @@ -1,15 +1,13 @@ {-# 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 +import HIE.Bios.Environment import HIE.Bios.Types import HIE.Bios.Flags @@ -34,17 +32,17 @@ debugInfo fp cradle = unlines <$> do canonFp <- canonicalizePath fp conf <- findConfig canonFp crdl <- findCradle' canonFp + ghcLibDir <- getRuntimeGhcLibDir cradle False 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 library directory: " ++ show ghcLibDir + , "Config Location: " ++ conf + , "Cradle: " ++ crdl + , "Dependencies: " ++ unwords deps ] CradleFail (CradleError deps ext stderr) -> return ["Cradle failed to load" diff --git a/src/HIE/Bios/Types.hs b/src/HIE/Bios/Types.hs index 8f699f1f9..43a85065b 100644 --- a/src/HIE/Bios/Types.hs +++ b/src/HIE/Bios/Types.hs @@ -53,10 +53,14 @@ 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) + , runCradle :: LoggingFunction -> FilePath -> IO (CradleLoadResult ComponentOptions) -- ^ Options to compile the given file with. + , runGhcLibDir :: IO (Maybe FilePath) + -- ^ Try to find the path to /the libdir/ of the GHC that + -- this cradle uses to compile stuff normally. You don't + -- want to call this directly, use 'getGhcLibDir' instead. } deriving (Functor) diff --git a/tests/BiosTests.hs b/tests/BiosTests.hs index f31505767..20f8ae2dc 100644 --- a/tests/BiosTests.hs +++ b/tests/BiosTests.hs @@ -4,13 +4,17 @@ module Main where import Test.Tasty -import Test.Tasty.ExpectedFailure import Test.Tasty.HUnit import Test.Hspec.Expectations +#if __GLASGOW_HASKELL__ < 810 +import Test.Tasty.ExpectedFailure +#endif +import qualified GHC as G import HIE.Bios import HIE.Bios.Ghc.Api import HIE.Bios.Ghc.Load import HIE.Bios.Cradle +import HIE.Bios.Environment import HIE.Bios.Types import Control.Monad.IO.Class import Control.Monad ( forM_ ) @@ -100,9 +104,17 @@ testDirectory :: (Cradle Void -> Bool) -> FilePath -> (String -> IO ()) -> IO () testDirectory cradlePred fp step = do a_fp <- canonicalizePath fp crd <- initialiseCradle cradlePred a_fp step + step "Get GHC library directory" + testGetGhcLibDir crd step "Initialise Flags" testLoadFile crd a_fp step +-- Here we are testing that the cradle's method of obtaining the ghcLibDir +-- always works. +testGetGhcLibDir :: Cradle a -> IO () +testGetGhcLibDir crd = + runGhcLibDir (cradleOptsProg crd) `shouldNotReturn` Nothing + testDirectoryFail :: (Cradle Void -> Bool) -> FilePath -> (CradleError -> Expectation) -> (String -> IO ()) -> IO () testDirectoryFail cradlePred fp cradleFailPred step = do a_fp <- canonicalizePath fp @@ -124,8 +136,9 @@ initialiseCradle cradlePred a_fp step = do testLoadFile :: Cradle a -> FilePath -> (String -> IO ()) -> IO () testLoadFile crd fp step = do a_fp <- canonicalizePath fp + libDir <- getRuntimeGhcLibDir crd False withCurrentDirectory (cradleRootDir crd) $ - withGHC' $ do + G.runGhc libDir $ do let relFp = makeRelative (cradleRootDir crd) a_fp res <- initializeFlagsWithCradleWithMessage (Just (\_ n _ _ -> step (show n))) relFp crd case res of @@ -142,8 +155,9 @@ testLoadFile crd fp step = do testLoadFileCradleFail :: Cradle a -> FilePath -> (CradleError -> Expectation) -> (String -> IO ()) -> IO () testLoadFileCradleFail crd fp cradleErrorExpectation step = do a_fp <- canonicalizePath fp + libDir <- getRuntimeGhcLibDir crd False withCurrentDirectory (cradleRootDir crd) $ - withGHC' $ do + G.runGhc libDir $ do let relFp = makeRelative (cradleRootDir crd) a_fp res <- initializeFlagsWithCradleWithMessage (Just (\_ n _ _ -> step (show n))) relFp crd case res of