{-# LANGUAGE RecordWildCards, CPP #-}
module HIE.Bios.Environment (initSession, getRuntimeGhcLibDir, getRuntimeGhcVersion, makeDynFlagsAbsolute, makeTargetsAbsolute, getCacheDir, addCmdOpts) where
import GHC (GhcMonad)
import qualified GHC as G
import Control.Applicative
import Control.Monad (void)
import Control.Monad.IO.Class
import System.Directory
import System.FilePath
import System.Environment (lookupEnv)
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 Text.ParserCombinators.ReadP hiding (optional)
import HIE.Bios.Types
import qualified HIE.Bios.Ghc.Gap as Gap
initSession :: (GhcMonad m)
=> ComponentOptions
-> m [G.Target]
initSession :: forall (m :: * -> *). GhcMonad m => ComponentOptions -> m [Target]
initSession ComponentOptions {String
[String]
componentOptions :: [String]
componentRoot :: String
componentDependencies :: [String]
componentOptions :: ComponentOptions -> [String]
componentRoot :: ComponentOptions -> String
componentDependencies :: ComponentOptions -> [String]
..} = do
DynFlags
df <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
G.getSessionDynFlags
let opts_hash :: String
opts_hash = ByteString -> String
B.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Ctx -> ByteString
H.finalize (Ctx -> ByteString) -> Ctx -> ByteString
forall a b. (a -> b) -> a -> b
$ Ctx -> [ByteString] -> Ctx
H.updates Ctx
H.init ((String -> ByteString) -> [String] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map String -> ByteString
B.pack [String]
componentOptions)
String
cache_dir <- IO String -> m String
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
getCacheDir String
opts_hash
(DynFlags
df', [Target]
targets) <- [String] -> DynFlags -> m (DynFlags, [Target])
forall (m :: * -> *).
GhcMonad m =>
[String] -> DynFlags -> m (DynFlags, [Target])
addCmdOpts [String]
componentOptions DynFlags
df
let df'' :: DynFlags
df'' = String -> DynFlags -> DynFlags
makeDynFlagsAbsolute String
componentRoot DynFlags
df'
m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> m ()
forall (m :: * -> *).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
G.setSessionDynFlags
(DynFlags -> DynFlags
disableOptimisation
(DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> DynFlags
setIgnoreInterfacePragmas
(DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ Maybe String -> DynFlags -> DynFlags
writeInterfaceFiles (String -> Maybe String
forall a. a -> Maybe a
Just String
cache_dir)
(DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ Int -> DynFlags -> DynFlags
setVerbosity Int
0
(DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> DynFlags
Gap.setWayDynamicIfHostIsDynamic
(DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> DynFlags
setLinkerOptions DynFlags
df''
)
let targets' :: [Target]
targets' = String -> [Target] -> [Target]
makeTargetsAbsolute String
componentRoot [Target]
targets
m ()
forall (m :: * -> *). GhcMonad m => m ()
Gap.unsetLogAction
[Target] -> m [Target]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [Target]
targets'
makeTargetsAbsolute :: FilePath -> [G.Target] -> [G.Target]
makeTargetsAbsolute :: String -> [Target] -> [Target]
makeTargetsAbsolute String
wdir = (Target -> Target) -> [Target] -> [Target]
forall a b. (a -> b) -> [a] -> [b]
map (\Target
target -> Target
target {G.targetId = makeTargetIdAbsolute wdir (G.targetId target)})
makeTargetIdAbsolute :: FilePath -> G.TargetId -> G.TargetId
makeTargetIdAbsolute :: String -> TargetId -> TargetId
makeTargetIdAbsolute String
wdir (G.TargetFile String
fp Maybe Phase
phase) = String -> Maybe Phase -> TargetId
G.TargetFile (String
wdir String -> String -> String
</> String
fp) Maybe Phase
phase
makeTargetIdAbsolute String
_ TargetId
tid = TargetId
tid
getRuntimeGhcLibDir :: Cradle a
-> IO (CradleLoadResult FilePath)
getRuntimeGhcLibDir :: forall a. Cradle a -> IO (CradleLoadResult String)
getRuntimeGhcLibDir Cradle a
cradle = (CradleLoadResult String -> CradleLoadResult String)
-> IO (CradleLoadResult String) -> IO (CradleLoadResult String)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> String)
-> CradleLoadResult String -> CradleLoadResult String
forall a b. (a -> b) -> CradleLoadResult a -> CradleLoadResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
trim) (IO (CradleLoadResult String) -> IO (CradleLoadResult String))
-> IO (CradleLoadResult String) -> IO (CradleLoadResult String)
forall a b. (a -> b) -> a -> b
$
CradleAction a -> [String] -> IO (CradleLoadResult String)
forall a.
CradleAction a -> [String] -> IO (CradleLoadResult String)
runGhcCmd (Cradle a -> CradleAction a
forall a. Cradle a -> CradleAction a
cradleOptsProg Cradle a
cradle) [String
"--print-libdir"]
getRuntimeGhcVersion :: Cradle a
-> IO (CradleLoadResult String)
getRuntimeGhcVersion :: forall a. Cradle a -> IO (CradleLoadResult String)
getRuntimeGhcVersion Cradle a
cradle =
(CradleLoadResult String -> CradleLoadResult String)
-> IO (CradleLoadResult String) -> IO (CradleLoadResult String)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> String)
-> CradleLoadResult String -> CradleLoadResult String
forall a b. (a -> b) -> CradleLoadResult a -> CradleLoadResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
trim) (IO (CradleLoadResult String) -> IO (CradleLoadResult String))
-> IO (CradleLoadResult String) -> IO (CradleLoadResult String)
forall a b. (a -> b) -> a -> b
$ CradleAction a -> [String] -> IO (CradleLoadResult String)
forall a.
CradleAction a -> [String] -> IO (CradleLoadResult String)
runGhcCmd (Cradle a -> CradleAction a
forall a. Cradle a -> CradleAction a
cradleOptsProg Cradle a
cradle) [String
"--numeric-version"]
cacheDir :: String
cacheDir :: String
cacheDir = String
"hie-bios"
getCacheDir :: FilePath -> IO FilePath
getCacheDir :: String -> IO String
getCacheDir String
fp = do
Maybe String
mbEnvCacheDirectory <- String -> IO (Maybe String)
lookupEnv String
"HIE_BIOS_CACHE_DIR"
String
cacheBaseDir <- IO String -> (String -> IO String) -> Maybe String -> IO String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgCache String
cacheDir) String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
Maybe String
mbEnvCacheDirectory
String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
cacheBaseDir String -> String -> String
</> String
fp)
setLinkerOptions :: G.DynFlags -> G.DynFlags
setLinkerOptions :: DynFlags -> DynFlags
setLinkerOptions DynFlags
df = DynFlags -> DynFlags
Gap.setNoCode (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags
df {
G.ghcLink = G.LinkInMemory
, G.ghcMode = G.CompManager
}
setIgnoreInterfacePragmas :: G.DynFlags -> G.DynFlags
setIgnoreInterfacePragmas :: DynFlags -> DynFlags
setIgnoreInterfacePragmas DynFlags
df = DynFlags -> GeneralFlag -> DynFlags
Gap.gopt_set DynFlags
df GeneralFlag
G.Opt_IgnoreInterfacePragmas
setVerbosity :: Int -> G.DynFlags -> G.DynFlags
setVerbosity :: Int -> DynFlags -> DynFlags
setVerbosity Int
n DynFlags
df = DynFlags
df { G.verbosity = n }
writeInterfaceFiles :: Maybe FilePath -> G.DynFlags -> G.DynFlags
writeInterfaceFiles :: Maybe String -> DynFlags -> DynFlags
writeInterfaceFiles Maybe String
Nothing DynFlags
df = DynFlags
df
writeInterfaceFiles (Just String
hi_dir) DynFlags
df = String -> DynFlags -> DynFlags
setHiDir String
hi_dir (DynFlags -> GeneralFlag -> DynFlags
Gap.gopt_set DynFlags
df GeneralFlag
G.Opt_WriteInterface)
setHiDir :: FilePath -> G.DynFlags -> G.DynFlags
setHiDir :: String -> DynFlags -> DynFlags
setHiDir String
f DynFlags
d = DynFlags
d { G.hiDir = Just f}
addCmdOpts :: (GhcMonad m)
=> [String] -> G.DynFlags -> m (G.DynFlags, [G.Target])
addCmdOpts :: forall (m :: * -> *).
GhcMonad m =>
[String] -> DynFlags -> m (DynFlags, [Target])
addCmdOpts [String]
cmdOpts DynFlags
df1 = do
Logger
logger <- HscEnv -> Logger
Gap.getLogger (HscEnv -> Logger) -> m HscEnv -> m Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
G.getSession
(DynFlags
df2, [Located String]
leftovers', [Warn]
_warns) <- Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], [Warn])
Gap.parseDynamicFlags Logger
logger DynFlags
df1 ((String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map String -> Located String
forall e. e -> Located e
G.noLoc [String]
cmdOpts)
[String]
additionalTargets <- [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> m [[String]] -> m [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> m [String]) -> [String] -> m [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (IO [String] -> m [String]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> m [String])
-> (String -> IO [String]) -> String -> m [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO [String]
getTargetsFromGhciScript) (DynFlags -> [String]
G.ghciScripts DynFlags
df2)
let leftovers :: [String]
leftovers = (Located String -> String) -> [Located String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Located String -> String
forall l e. GenLocated l e -> e
G.unLoc [Located String]
leftovers' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
additionalTargets
let (DynFlags
df3, [(String, Maybe Phase)]
srcs, [String]
_objs) = DynFlags
-> [String] -> (DynFlags, [(String, Maybe Phase)], [String])
Gap.parseTargetFiles DynFlags
df2 [String]
leftovers
[Target]
ts <- ((String, Maybe Phase) -> m Target)
-> [(String, Maybe Phase)] -> m [Target]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(String
f, Maybe Phase
phase) -> String -> Maybe UnitId -> Maybe Phase -> m Target
forall (m :: * -> *).
GhcMonad m =>
String -> Maybe UnitId -> Maybe Phase -> m Target
Gap.guessTarget String
f (UnitId -> Maybe UnitId
forall a. a -> Maybe a
Just (UnitId -> Maybe UnitId) -> UnitId -> Maybe UnitId
forall a b. (a -> b) -> a -> b
$ DynFlags -> UnitId
Gap.homeUnitId_ DynFlags
df3) Maybe Phase
phase) [(String, Maybe Phase)]
srcs
(DynFlags, [Target]) -> m (DynFlags, [Target])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags
df3, [Target]
ts)
makeDynFlagsAbsolute :: FilePath -> G.DynFlags -> G.DynFlags
makeDynFlagsAbsolute :: String -> DynFlags -> DynFlags
makeDynFlagsAbsolute String
root DynFlags
df =
(String -> String) -> DynFlags -> DynFlags
Gap.mapOverIncludePaths String -> String
makeAbs
(DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags
df
{ G.importPaths = map makeAbs (G.importPaths df)
, G.packageDBFlags =
map (Gap.overPkgDbRef makeAbs) (G.packageDBFlags df)
}
where
makeAbs :: String -> String
makeAbs =
#if __GLASGOW_HASKELL__ >= 903
case DynFlags -> Maybe String
G.workingDirectory DynFlags
df of
Just String
fp -> ((String
root String -> String -> String
</> String
fp) String -> String -> String
</>)
Maybe String
Nothing ->
#endif
(String
root String -> String -> String
</>)
disableOptimisation :: G.DynFlags -> G.DynFlags
disableOptimisation :: DynFlags -> DynFlags
disableOptimisation DynFlags
df = Int -> DynFlags -> DynFlags
Gap.updOptLevel Int
0 DynFlags
df
getTargetsFromGhciScript :: FilePath -> IO [String]
getTargetsFromGhciScript :: String -> IO [String]
getTargetsFromGhciScript String
script = do
[String]
contents <- String -> [String]
lines (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
script
let parseGhciLine :: String -> [String]
parseGhciLine = (([String], String) -> [String])
-> [([String], String)] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([String], String) -> [String]
forall a b. (a, b) -> a
fst ([([String], String)] -> [String])
-> (String -> [([String], String)]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([String], String) -> Bool)
-> [([String], String)] -> [([String], String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool)
-> (([String], String) -> String) -> ([String], String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String], String) -> String
forall a b. (a, b) -> b
snd) ([([String], String)] -> [([String], String)])
-> (String -> [([String], String)])
-> String
-> [([String], String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadP [String] -> String -> [([String], String)]
forall a. ReadP a -> ReadS a
readP_to_S ReadP [String]
parser
[String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [String]
parseGhciLine [String]
contents
parser :: ReadP [String]
parser :: ReadP [String]
parser = do
String
_ <- String -> ReadP String
string String
":add" ReadP String -> ReadP String -> ReadP String
forall a b. ReadP a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP String
space1
ReadP String
scriptword ReadP String -> ReadP String -> ReadP [String]
forall a sep. ReadP a -> ReadP sep -> ReadP [a]
`sepBy` ReadP String
space1
space1 :: ReadP [Char]
space1 :: ReadP String
space1 = ReadP Char -> ReadP String
forall a. ReadP a -> ReadP [a]
many1 (Char -> ReadP Char
char Char
' ')
scriptword :: ReadP String
scriptword :: ReadP String
scriptword = ReadP String
quoted ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP String
value
quoted :: ReadP String
quoted :: ReadP String
quoted = do
Char
_ <- Char -> ReadP Char
char Char
'"'
ReadP Char -> ReadP Char -> ReadP String
forall a sep. ReadP a -> ReadP sep -> ReadP [a]
manyTill (Char -> ReadP Char
escaped Char
'"' ReadP Char -> ReadP Char -> ReadP Char
forall a. ReadP a -> ReadP a -> ReadP a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP Char
anyToken) (ReadP Char -> ReadP String) -> ReadP Char -> ReadP String
forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
char Char
'"'
escaped :: Char -> ReadP Char
escaped :: Char -> ReadP Char
escaped Char
c = Char
c Char -> ReadP String -> ReadP Char
forall a b. a -> ReadP b -> ReadP a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ReadP String
string (String
"\\" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Char
c])
value :: ReadP String
value :: ReadP String
value = ReadP Char -> ReadP String
forall a. ReadP a -> ReadP [a]
many1 ((Char -> Bool) -> ReadP Char
satisfy (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace))
anyToken :: ReadP Char
anyToken :: ReadP Char
anyToken = (Char -> Bool) -> ReadP Char
satisfy ((Char -> Bool) -> ReadP Char) -> (Char -> Bool) -> ReadP Char
forall a b. (a -> b) -> a -> b
$ Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True
trim :: String -> String
trim :: String -> String
trim String
s = case String -> [String]
lines String
s of
[] -> String
s
[String]
ls -> (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. HasCallStack => [a] -> a
last [String]
ls