Skip to content

Commit

Permalink
Add runGhcLibDir and getRuntimeGhcLibDir
Browse files Browse the repository at this point in the history
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
  • Loading branch information
lukel97 committed Jun 18, 2020
1 parent f530d87 commit 6e45b12
Show file tree
Hide file tree
Showing 9 changed files with 172 additions and 88 deletions.
1 change: 1 addition & 0 deletions hie-bios.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand Down
65 changes: 61 additions & 4 deletions src/HIE/Bios/Cradle.hs
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
module HIE.Bios.Cradle (
findCradle
, loadCradle
Expand Down Expand Up @@ -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
Expand All @@ -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.
Expand Down Expand Up @@ -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
}
}

Expand All @@ -226,6 +232,7 @@ noneCradle cur_dir =
, cradleOptsProg = CradleAction
{ actionName = Types.None
, runCradle = \_ _ -> return CradleNone
, runGhcLibDir = pure Nothing
}
}

Expand All @@ -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
Expand Down Expand Up @@ -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
}
}

Expand All @@ -326,6 +343,7 @@ biosCradle wdir biosCall biosDepsCall =
, cradleOptsProg = CradleAction
{ actionName = Types.Bios
, runCradle = biosAction wdir biosCall biosDepsCall
, runGhcLibDir = getGhcOnPathLibDir wdir
}
}

Expand Down Expand Up @@ -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"] ""
}
}

Expand Down Expand Up @@ -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"] ""
}
}

Expand Down Expand Up @@ -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 }
67 changes: 54 additions & 13 deletions src/HIE/Bios/Environment.hs
Original file line number Diff line number Diff line change
@@ -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

Expand Down Expand Up @@ -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
]

----------------------------------------------------------------

Expand Down
38 changes: 1 addition & 37 deletions src/HIE/Bios/Ghc/Api.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
39 changes: 22 additions & 17 deletions src/HIE/Bios/Ghc/Check.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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

Expand All @@ -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
Expand All @@ -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'
2 changes: 1 addition & 1 deletion src/HIE/Bios/Ghc/Logger.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
Loading

0 comments on commit 6e45b12

Please sign in to comment.