{-# 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 Colog.Core (LogAction, WithSeverity)
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

-- | Start a GHC session and set some sensible options for tooling to use.
-- Creates a folder in the cache directory to cache interface files to make
-- reloading faster.
initSession :: (GhcMonad m)
    => ComponentOptions
    -> m [G.Target]
initSession :: forall (m :: * -> *). GhcMonad m => ComponentOptions -> m [Target]
initSession  ComponentOptions {String
[String]
componentDependencies :: ComponentOptions -> [String]
componentRoot :: ComponentOptions -> String
componentOptions :: ComponentOptions -> [String]
componentDependencies :: [String]
componentRoot :: String
componentOptions :: [String]
..} = do
    DynFlags
df <- forall (m :: * -> *). GhcMonad m => m DynFlags
G.getSessionDynFlags
    -- Create a unique folder per set of different GHC options, assuming that each different set of
    -- GHC options will create incompatible interface files.
    let opts_hash :: String
opts_hash = ByteString -> String
B.unpack forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
encode forall a b. (a -> b) -> a -> b
$ Ctx -> ByteString
H.finalize forall a b. (a -> b) -> a -> b
$ Ctx -> [ByteString] -> Ctx
H.updates Ctx
H.init (forall a b. (a -> b) -> [a] -> [b]
map String -> ByteString
B.pack [String]
componentOptions)
    String
cache_dir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO String
getCacheDir String
opts_hash
    -- Add the user specified options to a fresh GHC session.
    (DynFlags
df', [Target]
targets) <- 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'
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
G.setSessionDynFlags
        (DynFlags -> DynFlags
disableOptimisation -- Compile with -O0 as we are not going to produce object files.
        forall a b. (a -> b) -> a -> b
$ DynFlags -> DynFlags
setIgnoreInterfacePragmas            -- Ignore any non-essential information in interface files such as unfoldings changing.
        forall a b. (a -> b) -> a -> b
$ Maybe String -> DynFlags -> DynFlags
writeInterfaceFiles (forall a. a -> Maybe a
Just String
cache_dir) -- Write interface files to the cache
        forall a b. (a -> b) -> a -> b
$ Int -> DynFlags -> DynFlags
setVerbosity Int
0                       -- Set verbosity to zero just in case the user specified `-vx` in the options.
        forall a b. (a -> b) -> a -> b
$ DynFlags -> DynFlags
Gap.setWayDynamicIfHostIsDynamic     -- Add dynamic way if GHC is built with dynamic linking
        forall a b. (a -> b) -> a -> b
$ DynFlags -> DynFlags
setLinkerOptions DynFlags
df''                -- Set `-fno-code` to avoid generating object files, unless we have to.
        )

    let targets' :: [Target]
targets' = String -> [Target] -> [Target]
makeTargetsAbsolute String
componentRoot [Target]
targets
    -- Unset the default log action to avoid output going to stdout.
    forall (m :: * -> *). GhcMonad m => m ()
Gap.unsetLogAction
    forall (m :: * -> *) a. Monad m => a -> m a
return [Target]
targets'

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

makeTargetsAbsolute :: FilePath -> [G.Target] -> [G.Target]
makeTargetsAbsolute :: String -> [Target] -> [Target]
makeTargetsAbsolute String
wdir = forall a b. (a -> b) -> [a] -> [b]
map (\Target
target -> Target
target {targetId :: TargetId
G.targetId = String -> TargetId -> TargetId
makeTargetIdAbsolute String
wdir (Target -> TargetId
G.targetId Target
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@ will give you the ghc libDir:
-- __do not__ use 'runGhcCmd' directly.
--
--
-- Obtains libdir by calling 'runCradleGhc' on the provided cradle.
getRuntimeGhcLibDir :: LogAction IO (WithSeverity Log)
                    -> Cradle a
                    -> IO (CradleLoadResult FilePath)
getRuntimeGhcLibDir :: forall a.
LogAction IO (WithSeverity Log)
-> Cradle a -> IO (CradleLoadResult String)
getRuntimeGhcLibDir LogAction IO (WithSeverity Log)
l Cradle a
cradle = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
trim) forall a b. (a -> b) -> a -> b
$
      forall a.
CradleAction a
-> LogAction IO (WithSeverity Log)
-> [String]
-> IO (CradleLoadResult String)
runGhcCmd (forall a. Cradle a -> CradleAction a
cradleOptsProg Cradle a
cradle) LogAction IO (WithSeverity Log)
l [String
"--print-libdir"]

-- | 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
-- return a 'CradleError'
getRuntimeGhcVersion :: LogAction IO (WithSeverity Log)
                     -> Cradle a
                     -> IO (CradleLoadResult String)
getRuntimeGhcVersion :: forall a.
LogAction IO (WithSeverity Log)
-> Cradle a -> IO (CradleLoadResult String)
getRuntimeGhcVersion LogAction IO (WithSeverity Log)
l Cradle a
cradle =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
trim) forall a b. (a -> b) -> a -> b
$ forall a.
CradleAction a
-> LogAction IO (WithSeverity Log)
-> [String]
-> IO (CradleLoadResult String)
runGhcCmd (forall a. Cradle a -> CradleAction a
cradleOptsProg Cradle a
cradle) LogAction IO (WithSeverity Log)
l [String
"--numeric-version"]

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

-- | What to call the cache directory in the cache folder.
cacheDir :: String
cacheDir :: String
cacheDir = String
"hie-bios"

{- |
Back in the day we used to clear the cache at the start of each session,
however, it's not really necessary as
1. There is one cache dir for any change in options.
2. Interface files are resistent to bad option changes anyway.

> clearInterfaceCache :: FilePath -> IO ()
> clearInterfaceCache fp = do
>   cd <- getCacheDir fp
>   res <- doesPathExist cd
>   when res (removeDirectoryRecursive cd)
-}

-- | Prepends the cache directory used by the library to the supplied file path.
-- It tries to use the path under the environment variable `$HIE_BIOS_CACHE_DIR`
-- and falls back to the standard `$XDG_CACHE_HOME/hie-bios` if the former is not set
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 <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgCache String
cacheDir) forall (m :: * -> *) a. Monad m => a -> m a
return
                         Maybe String
mbEnvCacheDirectory
  forall (m :: * -> *) a. Monad m => a -> m a
return (String
cacheBaseDir String -> String -> String
</> String
fp)

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

-- we don't want to generate object code so we compile to bytecode
-- (HscInterpreted) which implies LinkInMemory
-- HscInterpreted
setLinkerOptions :: G.DynFlags -> G.DynFlags
setLinkerOptions :: DynFlags -> DynFlags
setLinkerOptions DynFlags
df = DynFlags -> DynFlags
Gap.setNoCode forall a b. (a -> b) -> a -> b
$ DynFlags
df {
    ghcLink :: GhcLink
G.ghcLink = GhcLink
G.LinkInMemory
  , ghcMode :: GhcMode
G.ghcMode = 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 { verbosity :: Int
G.verbosity = Int
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 { hiDir :: Maybe String
G.hiDir      = forall a. a -> Maybe a
Just String
f}


-- | Interpret and set the specific command line options.
-- A lot of this code is just copied from ghc/Main.hs
-- It would be good to move this code into a library module so we can just use it
-- rather than copy it.
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). GhcMonad m => m HscEnv
G.getSession
  (DynFlags
df2, [Located String]
leftovers', [Warn]
_warns) <- forall (m :: * -> *).
MonadIO m =>
Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], [Warn])
Gap.parseDynamicFlags Logger
logger DynFlags
df1 (forall a b. (a -> b) -> [a] -> [b]
map forall e. e -> Located e
G.noLoc [String]
cmdOpts)
  -- parse targets from ghci-scripts. Only extract targets that have been ":add"'ed.
  [String]
additionalTargets <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO [String]
getTargetsFromGhciScript) (DynFlags -> [String]
G.ghciScripts DynFlags
df2)

  -- leftovers contains all Targets from the command line
  let leftovers :: [String]
leftovers = forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
G.unLoc [Located String]
leftovers' 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (\String
f Maybe Phase
phase -> forall (m :: * -> *) a.
GhcMonad m =>
String -> a -> Maybe Phase -> m Target
Gap.guessTarget String
f (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ DynFlags -> UnitId
Gap.homeUnitId_ DynFlags
df3) Maybe Phase
phase) ) [(String, Maybe Phase)]
srcs
  forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags
df3, [Target]
ts)

-- | Make filepaths in the given 'DynFlags' absolute.
-- This makes the 'DynFlags' independent of the current working directory.
makeDynFlagsAbsolute :: FilePath -> G.DynFlags -> G.DynFlags
makeDynFlagsAbsolute :: String -> DynFlags -> DynFlags
makeDynFlagsAbsolute String
root DynFlags
df =
  (String -> String) -> DynFlags -> DynFlags
Gap.mapOverIncludePaths String -> String
makeAbs
  forall a b. (a -> b) -> a -> b
$ DynFlags
df
    { importPaths :: [String]
G.importPaths = forall a b. (a -> b) -> [a] -> [b]
map String -> String
makeAbs (DynFlags -> [String]
G.importPaths DynFlags
df)
    , packageDBFlags :: [PackageDBFlag]
G.packageDBFlags =
        forall a b. (a -> b) -> [a] -> [b]
map ((String -> String) -> PackageDBFlag -> PackageDBFlag
Gap.overPkgDbRef String -> String
makeAbs) (DynFlags -> [PackageDBFlag]
G.packageDBFlags DynFlags
df)
    }
  where
    makeAbs :: String -> String
makeAbs =
#if __GLASGOW_HASKELL__ >= 903
      case G.workingDirectory df of
        Just fp -> ((root </> fp) </>)
        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

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

-- | Read a ghci script and extract all targets to load form it.
-- The ghci script is expected to have the following format:
-- @
--  :add Foo Bar Main.hs
-- @
--
-- We strip away ":add" and parse the Targets.
getTargetsFromGhciScript :: FilePath -> IO [String]
getTargetsFromGhciScript :: String -> IO [String]
getTargetsFromGhciScript String
script = do
  [String]
contents <- String -> [String]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
script
  let parseGhciLine :: String -> [String]
parseGhciLine = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ReadP a -> ReadS a
readP_to_S ReadP [String]
parser
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [String]
parseGhciLine [String]
contents

-- |This parser aims to parse targets and double-quoted filepaths that are separated by spaces
-- and prefixed with the literal ":add"
--
-- >>> filter (null . snd) $ readP_to_S parser ":add Lib Lib2"
-- [(["Lib","Lib2"],"")]
--
-- >>> filter (null . snd) $ readP_to_S parser ":add Lib Lib2 \"Test Example.hs\""
-- [(["Lib","Lib2","Test Example.hs"],"")]
--
-- >>> filter (null . snd) $ readP_to_S parser ":add Lib Lib2 \"Test Exa\\\"mple.hs\""
-- [(["Lib","Lib2","Test Exa\"mple.hs"],"")]
parser :: ReadP [String]
parser :: ReadP [String]
parser = do
  String
_ <- String -> ReadP String
string String
":add" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP String
space1
  ReadP String
scriptword forall a sep. ReadP a -> ReadP sep -> ReadP [a]
`sepBy` ReadP String
space1

space1 :: ReadP [Char]
space1 :: ReadP String
space1 = forall a. ReadP a -> ReadP [a]
many1 (Char -> ReadP Char
char Char
' ')

scriptword :: ReadP String
scriptword :: ReadP String
scriptword = ReadP String
quoted forall a. ReadP a -> ReadP a -> ReadP a
<++ ReadP String
value

-- | A balanced double-quoted string
quoted :: ReadP String
quoted :: ReadP String
quoted = do
    Char
_ <- Char -> ReadP Char
char Char
'"'
    forall a sep. ReadP a -> ReadP sep -> ReadP [a]
manyTill (Char -> ReadP Char
escaped Char
'"' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP Char
anyToken) 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 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ReadP String
string (String
"\\" forall a. Semigroup a => a -> a -> a
<> [Char
c])

value :: ReadP String
value :: ReadP String
value = forall a. ReadP a -> ReadP [a]
many1 ((Char -> Bool) -> ReadP Char
satisfy (Bool -> Bool
not 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 forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Bool
True

-- Used for clipping the trailing newlines on GHC output
-- Also only take the last line of output
-- (Stack's ghc output has a lot of preceding noise from 7zip etc)
trim :: String -> String
trim :: String -> String
trim String
s = case String -> [String]
lines String
s of
  [] -> String
s
  [String]
ls -> forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [String]
ls