{-# 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

-- | 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 {FilePath
[FilePath]
componentDependencies :: ComponentOptions -> [FilePath]
componentRoot :: ComponentOptions -> FilePath
componentOptions :: ComponentOptions -> [FilePath]
componentDependencies :: [FilePath]
componentRoot :: FilePath
componentOptions :: [FilePath]
..} = 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.
    (DynFlags
df', [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 Int
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
$ DynFlags -> DynFlags
Gap.setWayDynamicIfHostIsDynamic     -- 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 ()
Gap.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 FilePath
wdir = (Target -> Target) -> [Target] -> [Target]
forall a b. (a -> b) -> [a] -> [b]
map (\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 FilePath
wdir (G.TargetFile FilePath
fp Maybe Phase
phase) = FilePath -> Maybe Phase -> TargetId
G.TargetFile (FilePath
wdir FilePath -> FilePath -> FilePath
</> FilePath
fp) Maybe Phase
phase
makeTargetIdAbsolute FilePath
_ 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 :: Cradle a
                    -> IO (CradleLoadResult FilePath)
getRuntimeGhcLibDir :: Cradle a -> IO (CradleLoadResult FilePath)
getRuntimeGhcLibDir 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) [FilePath
"--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 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) [FilePath
"--numeric-version"]

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

-- | What to call the cache directory in the cache folder.
cacheDir :: String
cacheDir :: FilePath
cacheDir = FilePath
"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 FilePath
fp = do
  Maybe FilePath
mbEnvCacheDirectory <- FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"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 :: 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 {
    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 FilePath -> DynFlags -> DynFlags
writeInterfaceFiles Maybe FilePath
Nothing DynFlags
df = DynFlags
df
writeInterfaceFiles (Just FilePath
hi_dir) DynFlags
df = FilePath -> DynFlags -> DynFlags
setHiDir FilePath
hi_dir (DynFlags -> GeneralFlag -> DynFlags
Gap.gopt_set DynFlags
df GeneralFlag
G.Opt_WriteInterface)

setHiDir :: FilePath -> G.DynFlags -> G.DynFlags
setHiDir :: FilePath -> DynFlags -> DynFlags
setHiDir FilePath
f DynFlags
d = DynFlags
d { hiDir :: Maybe FilePath
G.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] -> G.DynFlags -> m (G.DynFlags, [G.Target])
addCmdOpts :: [FilePath] -> DynFlags -> m (DynFlags, [Target])
addCmdOpts [FilePath]
cmdOpts DynFlags
df1 = do
  ()
logger <- HscEnv -> ()
Gap.getLogger (HscEnv -> ()) -> m HscEnv -> m ()
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 FilePath]
leftovers', [Warn]
_warns) <- ()
-> DynFlags
-> [Located FilePath]
-> m (DynFlags, [Located FilePath], [Warn])
forall (m :: * -> *).
MonadIO m =>
()
-> DynFlags
-> [Located FilePath]
-> m (DynFlags, [Located FilePath], [Warn])
Gap.parseDynamicFlags ()
logger 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]
G.ghciScripts DynFlags
df2)

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

  let (DynFlags
df3, [(FilePath, Maybe Phase)]
srcs, [FilePath]
_objs) = DynFlags
-> [FilePath] -> (DynFlags, [(FilePath, Maybe Phase)], [FilePath])
Gap.parseTargetFiles DynFlags
df2 [FilePath]
leftovers
  [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
f Maybe Phase
phase -> FilePath -> Maybe () -> Maybe Phase -> m Target
forall (m :: * -> *) a.
GhcMonad m =>
FilePath -> a -> Maybe Phase -> m Target
Gap.guessTarget FilePath
f (() -> Maybe ()
forall a. a -> Maybe a
Just (() -> Maybe ()) -> () -> Maybe ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> ()
forall a. a -> ()
Gap.homeUnitId_ DynFlags
df3) Maybe Phase
phase) ) [(FilePath, Maybe Phase)]
srcs
  (DynFlags, [Target]) -> m (DynFlags, [Target])
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 :: FilePath -> DynFlags -> DynFlags
makeDynFlagsAbsolute FilePath
work_dir DynFlags
df =
  (FilePath -> FilePath) -> DynFlags -> DynFlags
Gap.mapOverIncludePaths FilePath -> FilePath
makeAbs
  (DynFlags -> DynFlags) -> DynFlags -> DynFlags
forall a b. (a -> b) -> a -> b
$ DynFlags
df
    { importPaths :: [FilePath]
G.importPaths = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
makeAbs (DynFlags -> [FilePath]
G.importPaths DynFlags
df)
    , packageDBFlags :: [PackageDBFlag]
G.packageDBFlags =
        (PackageDBFlag -> PackageDBFlag)
-> [PackageDBFlag] -> [PackageDBFlag]
forall a b. (a -> b) -> [a] -> [b]
map ((FilePath -> FilePath) -> PackageDBFlag -> PackageDBFlag
Gap.overPkgDbRef FilePath -> FilePath
makeAbs) (DynFlags -> [PackageDBFlag]
G.packageDBFlags DynFlags
df)
    }
  where
    makeAbs :: FilePath -> FilePath
makeAbs = (FilePath
work_dir FilePath -> FilePath -> FilePath
</>)

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

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 :: FilePath -> IO [FilePath]
getTargetsFromGhciScript 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 FilePath
":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 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 Char
'"'
    ReadP Char -> ReadP Char -> ReadP FilePath
forall a sep. ReadP a -> ReadP sep -> ReadP [a]
manyTill (Char -> ReadP Char
escaped Char
'"' 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 Char
'"'

escaped :: Char -> ReadP Char
escaped :: Char -> ReadP Char
escaped 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 -> 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 FilePath
s = case FilePath -> [FilePath]
lines FilePath
s of
  [] -> FilePath
s
  [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