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..0dc339bcf 100644 --- a/src/HIE/Bios/Cradle.hs +++ b/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 } diff --git a/src/HIE/Bios/Environment.hs b/src/HIE/Bios/Environment.hs index f93a19abe..6fc7b502f 100644 --- a/src/HIE/Bios/Environment.hs +++ b/src/HIE/Bios/Environment.hs @@ -1,16 +1,18 @@ {-# LANGUAGE RecordWildCards, CPP #-} -module HIE.Bios.Environment (initSession, getSystemLibDir, makeDynFlagsAbsolute, getCacheDir, addCmdOpts) where +module HIE.Bios.Environment (initSession, getRuntimeGhcLibDir, 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 import System.FilePath import System.Environment (lookupEnv) @@ -20,8 +22,7 @@ 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 Text.ParserCombinators.ReadP hiding (optional) import HIE.Bios.Types import HIE.Bios.Ghc.Gap @@ -53,13 +54,31 @@ 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 ---------------------------------------------------------------- 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