From 3bd352f7be87f47b13181ea14d6ace809ac5383d Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Sun, 14 Jun 2020 15:47:55 +0100 Subject: [PATCH] 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 | 1 + src/HIE/Bios/Cradle.hs | 32 +++++++++++++++++--- src/HIE/Bios/Environment.hs | 53 +++++++++++++++++++++++++--------- src/HIE/Bios/Ghc/Api.hs | 27 +++++++---------- src/HIE/Bios/Ghc/Check.hs | 20 +++++++------ src/HIE/Bios/Ghc/Logger.hs | 2 +- src/HIE/Bios/Internal/Debug.hs | 20 ++++++------- src/HIE/Bios/Types.hs | 8 ++++- tests/BiosTests.hs | 5 ++-- 9 files changed, 110 insertions(+), 58 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..08d890a99 100644 --- a/src/HIE/Bios/Cradle.hs +++ b/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 diff --git a/src/HIE/Bios/Environment.hs b/src/HIE/Bios/Environment.hs index f93a19abe..323adb476 100644 --- a/src/HIE/Bios/Environment.hs +++ b/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 } diff --git a/src/HIE/Bios/Ghc/Api.hs b/src/HIE/Bios/Ghc/Api.hs index e7d2afcb8..6191512df 100644 --- a/src/HIE/Bios/Ghc/Api.hs +++ b/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,10 +31,13 @@ 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 @@ -43,18 +45,11 @@ withGHC file body = ghandle ignore $ withGHC' body 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 ---------------------------------------------------------------- diff --git a/src/HIE/Bios/Ghc/Check.hs b/src/HIE/Bios/Ghc/Check.hs index bc5863210..2f16726aa 100644 --- a/src/HIE/Bios/Ghc/Check.hs +++ b/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,7 +54,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 + topDir <- G.topDir <$> G.getDynFlags + withLogger (setAllWarningFlags topDir) $ setTargetFiles (map dup fileNames) dup :: a -> (a, a) dup x = (x, x) @@ -61,14 +64,13 @@ 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' \ 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..824de6a93 100644 --- a/src/HIE/Bios/Internal/Debug.hs +++ b/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" diff --git a/src/HIE/Bios/Types.hs b/src/HIE/Bios/Types.hs index 8f699f1f9..22891bc09 100644 --- a/src/HIE/Bios/Types.hs +++ b/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 ---------------------------------------------------------------- diff --git a/tests/BiosTests.hs b/tests/BiosTests.hs index f31505767..284a200e2 100644 --- a/tests/BiosTests.hs +++ b/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