{-# LANGUAGE RecordWildCards, CPP #-}
module HIE.Bios.Environment (initSession, getRuntimeGhcLibDir, getRuntimeGhcVersion, makeDynFlagsAbsolute, makeTargetsAbsolute, getCacheDir, addCmdOpts) where

import CoreMonad (liftIO)
import GHC (GhcMonad)
import qualified GHC as G
import qualified DriverPhases as G
import qualified Util as G
import DynFlags

import Control.Applicative
import Control.Monad (void)

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 HIE.Bios.Ghc.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 :: ComponentOptions -> m [Target]
initSession  ComponentOptions {..} = do
    DynFlags
df <- m DynFlags
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 :: FilePath
opts_hash = ByteString -> FilePath
B.unpack (ByteString -> FilePath) -> ByteString -> FilePath
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 ((FilePath -> ByteString) -> [FilePath] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> ByteString
B.pack [FilePath]
componentOptions)
    FilePath
cache_dir <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
getCacheDir FilePath
opts_hash
    -- Add the user specified options to a fresh GHC session.
    (df' :: DynFlags
df', targets :: [Target]
targets) <- [FilePath] -> DynFlags -> m (DynFlags, [Target])
forall (m :: * -> *).
GhcMonad m =>
[FilePath] -> DynFlags -> m (DynFlags, [Target])
addCmdOpts [FilePath]
componentOptions DynFlags
df
    let df'' :: DynFlags
df'' = FilePath -> DynFlags -> DynFlags
makeDynFlagsAbsolute FilePath
componentRoot DynFlags
df'
    m [InstalledUnitId] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [InstalledUnitId] -> m ()) -> m [InstalledUnitId] -> m ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> m [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
G.setSessionDynFlags
        (DynFlags -> DynFlags
disableOptimisation -- Compile with -O0 as we are not going to produce object files.
        (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags -> DynFlags
setIgnoreInterfacePragmas            -- Ignore any non-essential information in interface files such as unfoldings changing.
        (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> DynFlags -> DynFlags
writeInterfaceFiles (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
cache_dir) -- Write interface files to the cache
        (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ Int -> DynFlags -> DynFlags
setVerbosity 0                       -- Set verbosity to zero just in case the user specified `-vx` in the options.
        (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ (if Bool
dynamicGhc then DynFlags -> DynFlags
updateWays (DynFlags -> DynFlags)
-> (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Way -> DynFlags -> DynFlags
addWay' Way
WayDyn else DynFlags -> DynFlags
forall a. a -> a
id) -- Add dynamic way if GHC is built with dynamic linking 
        (DynFlags -> DynFlags) -> DynFlags -> DynFlags
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' = FilePath -> [Target] -> [Target]
makeTargetsAbsolute FilePath
componentRoot [Target]
targets
    -- Unset the default log action to avoid output going to stdout.
    m ()
forall (m :: * -> *). GhcMonad m => m ()
unsetLogAction
    [Target] -> m [Target]
forall (m :: * -> *) a. Monad m => a -> m a
return [Target]
targets'

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

makeTargetsAbsolute :: FilePath -> [G.Target] -> [G.Target]
makeTargetsAbsolute :: FilePath -> [Target] -> [Target]
makeTargetsAbsolute wdir :: FilePath
wdir = (Target -> Target) -> [Target] -> [Target]
forall a b. (a -> b) -> [a] -> [b]
map (\target :: Target
target -> Target
target {targetId :: TargetId
G.targetId = FilePath -> TargetId -> TargetId
makeTargetIdAbsolute FilePath
wdir (Target -> TargetId
G.targetId Target
target)})

makeTargetIdAbsolute :: FilePath -> G.TargetId -> G.TargetId
makeTargetIdAbsolute :: FilePath -> TargetId -> TargetId
makeTargetIdAbsolute wdir :: FilePath
wdir (G.TargetFile fp :: FilePath
fp phase :: Maybe Phase
phase) = FilePath -> Maybe Phase -> TargetId
G.TargetFile (FilePath
wdir FilePath -> FilePath -> FilePath
</> FilePath
fp) Maybe Phase
phase
makeTargetIdAbsolute _ tid :: TargetId
tid = TargetId
tid

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

-- | @getRuntimeGhcLibDir cradle@ will give you the ghc libDir:
-- __do not__ use 'runGhcCmd' 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
getRuntimeGhcLibDir :: Cradle a
                    -> IO (CradleLoadResult FilePath)
getRuntimeGhcLibDir :: Cradle a -> IO (CradleLoadResult FilePath)
getRuntimeGhcLibDir cradle :: Cradle a
cradle = do
  Maybe FilePath
maybeNixLibDir <- FilePath -> IO (Maybe FilePath)
lookupEnv "NIX_GHC_LIBDIR"
  case Maybe FilePath
maybeNixLibDir of
    Just ld :: FilePath
ld -> CradleLoadResult FilePath -> IO (CradleLoadResult FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> CradleLoadResult FilePath
forall r. r -> CradleLoadResult r
CradleSuccess FilePath
ld)
    Nothing -> (CradleLoadResult FilePath -> CradleLoadResult FilePath)
-> IO (CradleLoadResult FilePath) -> IO (CradleLoadResult FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath -> FilePath)
-> CradleLoadResult FilePath -> CradleLoadResult FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> FilePath
trim) (IO (CradleLoadResult FilePath) -> IO (CradleLoadResult FilePath))
-> IO (CradleLoadResult FilePath) -> IO (CradleLoadResult FilePath)
forall a b. (a -> b) -> a -> b
$
      CradleAction a -> [FilePath] -> IO (CradleLoadResult FilePath)
forall a.
CradleAction a -> [FilePath] -> IO (CradleLoadResult FilePath)
runGhcCmd (Cradle a -> CradleAction a
forall a. Cradle a -> CradleAction a
cradleOptsProg Cradle a
cradle) ["--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 :: Cradle a
                     -> IO (CradleLoadResult String)
getRuntimeGhcVersion :: Cradle a -> IO (CradleLoadResult FilePath)
getRuntimeGhcVersion cradle :: Cradle a
cradle =
  (CradleLoadResult FilePath -> CradleLoadResult FilePath)
-> IO (CradleLoadResult FilePath) -> IO (CradleLoadResult FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath -> FilePath)
-> CradleLoadResult FilePath -> CradleLoadResult FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> FilePath
trim) (IO (CradleLoadResult FilePath) -> IO (CradleLoadResult FilePath))
-> IO (CradleLoadResult FilePath) -> IO (CradleLoadResult FilePath)
forall a b. (a -> b) -> a -> b
$ CradleAction a -> [FilePath] -> IO (CradleLoadResult FilePath)
forall a.
CradleAction a -> [FilePath] -> IO (CradleLoadResult FilePath)
runGhcCmd (Cradle a -> CradleAction a
forall a. Cradle a -> CradleAction a
cradleOptsProg Cradle a
cradle) ["--numeric-version"]

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

-- | What to call the cache directory in the cache folder.
cacheDir :: String
cacheDir :: FilePath
cacheDir = "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 :: FilePath -> IO FilePath
getCacheDir fp :: FilePath
fp = do
  Maybe FilePath
mbEnvCacheDirectory <- FilePath -> IO (Maybe FilePath)
lookupEnv "HIE_BIOS_CACHE_DIR"
  FilePath
cacheBaseDir <- IO FilePath
-> (FilePath -> IO FilePath) -> Maybe FilePath -> IO FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (XdgDirectory -> FilePath -> IO FilePath
getXdgDirectory XdgDirectory
XdgCache FilePath
cacheDir) FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return
                         Maybe FilePath
mbEnvCacheDirectory
  FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
cacheBaseDir FilePath -> FilePath -> FilePath
</> FilePath
fp)

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

-- we don't want to generate object code so we compile to bytecode
-- (HscInterpreted) which implies LinkInMemory
-- HscInterpreted
setLinkerOptions :: DynFlags -> DynFlags
setLinkerOptions :: DynFlags -> DynFlags
setLinkerOptions df :: DynFlags
df = DynFlags
df {
    ghcLink :: GhcLink
ghcLink   = GhcLink
LinkInMemory
  , hscTarget :: HscTarget
hscTarget = HscTarget
HscNothing
  , ghcMode :: GhcMode
ghcMode = GhcMode
CompManager
  }

setIgnoreInterfacePragmas :: DynFlags -> DynFlags
setIgnoreInterfacePragmas :: DynFlags -> DynFlags
setIgnoreInterfacePragmas df :: DynFlags
df = DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
df GeneralFlag
Opt_IgnoreInterfacePragmas

setVerbosity :: Int -> DynFlags -> DynFlags
setVerbosity :: Int -> DynFlags -> DynFlags
setVerbosity n :: Int
n df :: DynFlags
df = DynFlags
df { verbosity :: Int
verbosity = Int
n }

writeInterfaceFiles :: Maybe FilePath -> DynFlags -> DynFlags
writeInterfaceFiles :: Maybe FilePath -> DynFlags -> DynFlags
writeInterfaceFiles Nothing df :: DynFlags
df = DynFlags
df
writeInterfaceFiles (Just hi_dir :: FilePath
hi_dir) df :: DynFlags
df = FilePath -> DynFlags -> DynFlags
setHiDir FilePath
hi_dir (DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
df GeneralFlag
Opt_WriteInterface)

setHiDir :: FilePath -> DynFlags -> DynFlags
setHiDir :: FilePath -> DynFlags -> DynFlags
setHiDir f :: FilePath
f d :: DynFlags
d = DynFlags
d { hiDir :: Maybe FilePath
hiDir      = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
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] -> DynFlags -> m (DynFlags, [G.Target])
addCmdOpts :: [FilePath] -> DynFlags -> m (DynFlags, [Target])
addCmdOpts cmdOpts :: [FilePath]
cmdOpts df1 :: DynFlags
df1 = do
  (df2 :: DynFlags
df2, leftovers' :: [Located FilePath]
leftovers', _warns :: [Warn]
_warns) <- DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located FilePath] -> m (DynFlags, [Located FilePath], [Warn])
G.parseDynamicFlags DynFlags
df1 ((FilePath -> Located FilePath) -> [FilePath] -> [Located FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Located FilePath
forall a. HasSrcSpan a => SrcSpanLess a -> a
G.noLoc [FilePath]
cmdOpts)
  -- parse targets from ghci-scripts. Only extract targets that have been ":add"'ed.
  [FilePath]
additionalTargets <- [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]] -> [FilePath]) -> m [[FilePath]] -> m [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> m [FilePath]) -> [FilePath] -> m [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO [FilePath] -> m [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath])
-> (FilePath -> IO [FilePath]) -> FilePath -> m [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO [FilePath]
getTargetsFromGhciScript) (DynFlags -> [FilePath]
ghciScripts DynFlags
df2)

  -- leftovers contains all Targets from the command line
  let leftovers :: [Located FilePath]
leftovers = [Located FilePath]
leftovers' [Located FilePath] -> [Located FilePath] -> [Located FilePath]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Located FilePath) -> [FilePath] -> [Located FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Located FilePath
forall a. HasSrcSpan a => SrcSpanLess a -> a
G.noLoc [FilePath]
additionalTargets

  let
     -- To simplify the handling of filepaths, we normalise all filepaths right
     -- away. Note the asymmetry of FilePath.normalise:
     --    Linux:   p/q -> p/q; p\q -> p\q
     --    Windows: p/q -> p\q; p\q -> p\q
     -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs
     -- to -foo.hs. We have to re-prepend the current directory.
    normalise_hyp :: FilePath -> FilePath
normalise_hyp fp :: FilePath
fp
        | Bool
strt_dot_sl Bool -> Bool -> Bool
&& "-" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
nfp = FilePath
cur_dir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
nfp
        | Bool
otherwise                           = FilePath
nfp
        where
#if defined(mingw32_HOST_OS)
          strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp
#else
          strt_dot_sl :: Bool
strt_dot_sl = "./" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
fp
#endif
          cur_dir :: FilePath
cur_dir = '.' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: [Char
pathSeparator]
          nfp :: FilePath
nfp = FilePath -> FilePath
normalise FilePath
fp
    normal_fileish_paths :: [FilePath]
normal_fileish_paths = (Located FilePath -> FilePath) -> [Located FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath
normalise_hyp (FilePath -> FilePath)
-> (Located FilePath -> FilePath) -> Located FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located FilePath -> FilePath
forall a. HasSrcSpan a => a -> SrcSpanLess a
G.unLoc) [Located FilePath]
leftovers
  let
   (srcs :: [(FilePath, Maybe Phase)]
srcs, objs :: [FilePath]
objs) = [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [FilePath]
normal_fileish_paths [] []
   df3 :: DynFlags
df3 = DynFlags
df2 { ldInputs :: [Option]
ldInputs = (FilePath -> Option) -> [FilePath] -> [Option]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> Option
FileOption "") [FilePath]
objs [Option] -> [Option] -> [Option]
forall a. [a] -> [a] -> [a]
++ DynFlags -> [Option]
ldInputs DynFlags
df2 }
  [Target]
ts <- ((FilePath, Maybe Phase) -> m Target)
-> [(FilePath, Maybe Phase)] -> m [Target]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((FilePath -> Maybe Phase -> m Target)
-> (FilePath, Maybe Phase) -> m Target
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FilePath -> Maybe Phase -> m Target
forall (m :: * -> *).
GhcMonad m =>
FilePath -> Maybe Phase -> m Target
G.guessTarget) [(FilePath, Maybe Phase)]
srcs
  (DynFlags, [Target]) -> m (DynFlags, [Target])
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags
df3, [Target]
ts)
    -- TODO: Need to handle these as well
    -- Ideally it requires refactoring to work in GHCi monad rather than
    -- Ghc monad and then can just use newDynFlags.
    {-
    liftIO $ G.handleFlagWarnings idflags1 warns
    when (not $ null leftovers)
        (throwGhcException . CmdLineError
         $ "Some flags have not been recognized: "
         ++ (concat . intersperse ", " $ map unLoc leftovers))
    when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do
       liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"
    -}

-- | Make filepaths in the given 'DynFlags' absolute.
-- This makes the 'DynFlags' independent of the current working directory.
makeDynFlagsAbsolute :: FilePath -> DynFlags -> DynFlags
makeDynFlagsAbsolute :: FilePath -> DynFlags -> DynFlags
makeDynFlagsAbsolute work_dir :: FilePath
work_dir df :: DynFlags
df =
  (FilePath -> FilePath) -> DynFlags -> DynFlags
mapOverIncludePaths (FilePath
work_dir FilePath -> FilePath -> FilePath
</>)
  (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags
df
    { importPaths :: [FilePath]
importPaths = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
work_dir FilePath -> FilePath -> FilePath
</>) (DynFlags -> [FilePath]
importPaths DynFlags
df)
    , packageDBFlags :: [PackageDBFlag]
packageDBFlags =
        let makePackageDbAbsolute :: PackageDBFlag -> PackageDBFlag
makePackageDbAbsolute (PackageDB pkgConfRef :: PkgConfRef
pkgConfRef) = PkgConfRef -> PackageDBFlag
PackageDB
              (PkgConfRef -> PackageDBFlag) -> PkgConfRef -> PackageDBFlag
forall a b. (a -> b) -> a -> b
$ case PkgConfRef
pkgConfRef of
                PkgConfFile fp :: FilePath
fp -> FilePath -> PkgConfRef
PkgConfFile (FilePath
work_dir FilePath -> FilePath -> FilePath
</> FilePath
fp)
                conf :: PkgConfRef
conf -> PkgConfRef
conf
            makePackageDbAbsolute db :: PackageDBFlag
db = PackageDBFlag
db
        in (PackageDBFlag -> PackageDBFlag)
-> [PackageDBFlag] -> [PackageDBFlag]
forall a b. (a -> b) -> [a] -> [b]
map PackageDBFlag -> PackageDBFlag
makePackageDbAbsolute (DynFlags -> [PackageDBFlag]
packageDBFlags DynFlags
df)
    }

-- partition_args, along with some of the other code in this file,
-- was copied from ghc/Main.hs
-- -----------------------------------------------------------------------------
-- Splitting arguments into source files and object files.  This is where we
-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
-- file indicating the phase specified by the -x option in force, if any.
partition_args :: [String] -> [(String, Maybe G.Phase)] -> [String]
               -> ([(String, Maybe G.Phase)], [String])
partition_args :: [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [] srcs :: [(FilePath, Maybe Phase)]
srcs objs :: [FilePath]
objs = ([(FilePath, Maybe Phase)] -> [(FilePath, Maybe Phase)]
forall a. [a] -> [a]
reverse [(FilePath, Maybe Phase)]
srcs, [FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse [FilePath]
objs)
partition_args ("-x":suff :: FilePath
suff:args :: [FilePath]
args) srcs :: [(FilePath, Maybe Phase)]
srcs objs :: [FilePath]
objs
  | FilePath
"none" <- FilePath
suff      = [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [FilePath]
args [(FilePath, Maybe Phase)]
srcs [FilePath]
objs
  | Phase
G.StopLn <- Phase
phase     = [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [FilePath]
args [(FilePath, Maybe Phase)]
srcs ([FilePath]
slurp [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
objs)
  | Bool
otherwise           = [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [FilePath]
rest ([(FilePath, Maybe Phase)]
these_srcs [(FilePath, Maybe Phase)]
-> [(FilePath, Maybe Phase)] -> [(FilePath, Maybe Phase)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, Maybe Phase)]
srcs) [FilePath]
objs
        where phase :: Phase
phase = FilePath -> Phase
G.startPhase FilePath
suff
              (slurp :: [FilePath]
slurp,rest :: [FilePath]
rest) = (FilePath -> Bool) -> [FilePath] -> ([FilePath], [FilePath])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "-x") [FilePath]
args
              these_srcs :: [(FilePath, Maybe Phase)]
these_srcs = [FilePath] -> [Maybe Phase] -> [(FilePath, Maybe Phase)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FilePath]
slurp (Maybe Phase -> [Maybe Phase]
forall a. a -> [a]
repeat (Phase -> Maybe Phase
forall a. a -> Maybe a
Just Phase
phase))
partition_args (arg :: FilePath
arg:args :: [FilePath]
args) srcs :: [(FilePath, Maybe Phase)]
srcs objs :: [FilePath]
objs
  | FilePath -> Bool
looks_like_an_input FilePath
arg = [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [FilePath]
args ((FilePath
arg,Maybe Phase
forall a. Maybe a
Nothing)(FilePath, Maybe Phase)
-> [(FilePath, Maybe Phase)] -> [(FilePath, Maybe Phase)]
forall a. a -> [a] -> [a]
:[(FilePath, Maybe Phase)]
srcs) [FilePath]
objs
  | Bool
otherwise               = [FilePath]
-> [(FilePath, Maybe Phase)]
-> [FilePath]
-> ([(FilePath, Maybe Phase)], [FilePath])
partition_args [FilePath]
args [(FilePath, Maybe Phase)]
srcs (FilePath
argFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
objs)

    {-
      We split out the object files (.o, .dll) and add them
      to ldInputs for use by the linker.
      The following things should be considered compilation manager inputs:
       - haskell source files (strings ending in .hs, .lhs or other
         haskellish extension),
       - module names (not forgetting hierarchical module names),
       - things beginning with '-' are flags that were not recognised by
         the flag parser, and we want them to generate errors later in
         checkOptions, so we class them as source files (#5921)
       - and finally we consider everything without an extension to be
         a comp manager input, as shorthand for a .hs or .lhs filename.
      Everything else is considered to be a linker object, and passed
      straight through to the linker.
    -}
looks_like_an_input :: String -> Bool
looks_like_an_input :: FilePath -> Bool
looks_like_an_input m :: FilePath
m =  FilePath -> Bool
G.isSourceFilename FilePath
m
                      Bool -> Bool -> Bool
|| FilePath -> Bool
G.looksLikeModuleName FilePath
m
                      Bool -> Bool -> Bool
|| "-" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
m
                      Bool -> Bool -> Bool
|| Bool -> Bool
not (FilePath -> Bool
hasExtension FilePath
m)

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

disableOptimisation :: DynFlags -> DynFlags
disableOptimisation :: DynFlags -> DynFlags
disableOptimisation df :: DynFlags
df = Int -> DynFlags -> DynFlags
updOptLevel 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 :: FilePath -> IO [FilePath]
getTargetsFromGhciScript script :: FilePath
script = do
  [FilePath]
contents <- FilePath -> [FilePath]
lines (FilePath -> [FilePath]) -> IO FilePath -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
readFile FilePath
script
  let parseGhciLine :: FilePath -> [FilePath]
parseGhciLine = (([FilePath], FilePath) -> [FilePath])
-> [([FilePath], FilePath)] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([FilePath], FilePath) -> [FilePath]
forall a b. (a, b) -> a
fst ([([FilePath], FilePath)] -> [FilePath])
-> (FilePath -> [([FilePath], FilePath)]) -> FilePath -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([FilePath], FilePath) -> Bool)
-> [([FilePath], FilePath)] -> [([FilePath], FilePath)]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (FilePath -> Bool)
-> (([FilePath], FilePath) -> FilePath)
-> ([FilePath], FilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FilePath], FilePath) -> FilePath
forall a b. (a, b) -> b
snd) ([([FilePath], FilePath)] -> [([FilePath], FilePath)])
-> (FilePath -> [([FilePath], FilePath)])
-> FilePath
-> [([FilePath], FilePath)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadP [FilePath] -> FilePath -> [([FilePath], FilePath)]
forall a. ReadP a -> ReadS a
readP_to_S ReadP [FilePath]
parser
  [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> [FilePath]) -> [FilePath] -> [FilePath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FilePath -> [FilePath]
parseGhciLine [FilePath]
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 [FilePath]
parser = do
  FilePath
_ <- FilePath -> ReadP FilePath
string ":add" ReadP FilePath -> ReadP FilePath -> ReadP FilePath
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP FilePath
space1
  ReadP FilePath
scriptword ReadP FilePath -> ReadP FilePath -> ReadP [FilePath]
forall a sep. ReadP a -> ReadP sep -> ReadP [a]
`sepBy` ReadP FilePath
space1

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

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

-- | A balanced double-quoted string
quoted :: ReadP String
quoted :: ReadP FilePath
quoted = do
    Char
_ <- Char -> ReadP Char
char '"'
    ReadP Char -> ReadP Char -> ReadP FilePath
forall a sep. ReadP a -> ReadP sep -> ReadP [a]
manyTill (Char -> ReadP Char
escaped '"' ReadP Char -> ReadP Char -> ReadP Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadP Char
anyToken) (ReadP Char -> ReadP FilePath) -> ReadP Char -> ReadP FilePath
forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
char '"'

escaped :: Char -> ReadP Char
escaped :: Char -> ReadP Char
escaped c :: Char
c = Char
c Char -> ReadP FilePath -> ReadP Char
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FilePath -> ReadP FilePath
string ("\\" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [Char
c])

value :: ReadP String
value :: ReadP FilePath
value = ReadP Char -> ReadP FilePath
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

-- 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 :: FilePath -> FilePath
trim s :: FilePath
s = case FilePath -> [FilePath]
lines FilePath
s of
  [] -> FilePath
s
  ls :: [FilePath]
ls -> (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall a. [a] -> a
last [FilePath]
ls