-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE CPP #-} -- for BUILD_DIR
{-# LANGUAGE MagicHash #-}
-- | REPL implementation that directly uses the GHC API.
--
-- https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/api
-- https://wiki.haskell.org/GHC/As_a_library
module Cmd.ReplGhc (
    Session(..), make_session
    , interpreter, interpret, complete
) where
import qualified Control.Concurrent.Chan as Chan
import qualified Control.Concurrent.MVar as MVar
import qualified Control.Exception as Exception

import qualified Data.IORef as IORef
import qualified Data.List as List
import qualified Data.Text as Text

import           System.FilePath ((</>))

-- GHC imports
import qualified GHC
import qualified GHC.Exts
import qualified GHC.Paths

#if GHC_VERSION >= 90201

import qualified Control.Monad.Catch as Catch
import qualified GHC.Utils.Outputable as Outputable
import qualified GHC.Driver.CmdLine as CmdLine
import qualified GHC.Utils.Logger as Logger
import           Global (liftIO)

#elif GHC_VERSION >= 90001

#error ghc 9.1 not supported

#elif GHC_VERSION >= 80401

import           GHC (gcatch)
import qualified CmdLineParser as CmdLine
import qualified DynFlags
import           MonadUtils (liftIO) -- Old GHC defines its own liftIO!
import qualified Outputable

#else

import           GHC (gcatch)
import qualified DynFlags
import           MonadUtils (liftIO)
import qualified Outputable

#endif

import qualified Util.Exceptions as Exceptions
import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Thread as Thread

import qualified Cmd.Cmd as Cmd
import qualified App.ReplProtocol as ReplProtocol
import           Global hiding (liftIO)


#if GHC_VERSION >= 90001
gcatch :: GHC.GhcT IO a -> (Catch.SomeException -> GHC.GhcT IO a)
    -> GHC.GhcT IO a
gcatch :: forall a. GhcT IO a -> (SomeException -> GhcT IO a) -> GhcT IO a
gcatch = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Catch.catch
#endif

-- | The base directory of this build.  Comes from CPP.
build_dir :: FilePath
build_dir :: String
build_dir = BUILD_DIR

ghci_flags :: FilePath
ghci_flags :: String
ghci_flags = String
build_dir String -> String -> String
</> String
"ghci-flags"

-- | The actual session runs in another thread, so this is the communication
-- channel.  @(expr, namespace, response_mvar)@
newtype Session = Session (Chan.Chan (Query, MVar.MVar Response))

data Query = QCommand !Text | QCompletion !Text
    deriving (Int -> Query -> String -> String
[Query] -> String -> String
Query -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Query] -> String -> String
$cshowList :: [Query] -> String -> String
show :: Query -> String
$cshow :: Query -> String
showsPrec :: Int -> Query -> String -> String
$cshowsPrec :: Int -> Query -> String -> String
Show)
data Response = RCommand !Cmd | RCompletion ![Text]
type Cmd = Cmd.CmdT IO ReplProtocol.CmdResult

type Ghc a = GHC.GhcT IO a

make_session :: IO Session
make_session :: IO Session
make_session = Chan (Query, MVar Response) -> Session
Session forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IO (Chan a)
Chan.newChan

interpret :: Session -> Text -> IO Cmd
interpret :: Session -> Text -> IO Cmd
interpret (Session Chan (Query, MVar Response)
chan) Text
expr = do
    MVar Response
mvar <- forall a. IO (MVar a)
MVar.newEmptyMVar
    forall a. Chan a -> a -> IO ()
Chan.writeChan Chan (Query, MVar Response)
chan (Text -> Query
QCommand Text
expr, MVar Response
mvar)
    Response
response <- forall a. MVar a -> IO a
MVar.takeMVar MVar Response
mvar
    case Response
response of
        RCommand Cmd
cmd -> forall (m :: * -> *) a. Monad m => a -> m a
return Cmd
cmd
        Response
_ -> forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO Text
"unexpected response to QCommand"

complete :: Session -> Text -> IO [Text]
complete :: Session -> Text -> IO [Text]
complete (Session Chan (Query, MVar Response)
chan) Text
prefix = do
    MVar Response
mvar <- forall a. IO (MVar a)
MVar.newEmptyMVar
    forall a. Chan a -> a -> IO ()
Chan.writeChan Chan (Query, MVar Response)
chan (Text -> Query
QCompletion Text
prefix, MVar Response
mvar)
    Response
response <- forall a. MVar a -> IO a
MVar.takeMVar MVar Response
mvar
    case Response
response of
        RCompletion [Text]
words -> forall (m :: * -> *) a. Monad m => a -> m a
return [Text]
words
        Response
_ -> forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO Text
"unexpected response to QCompletion"

-- | Initialize the GHC API and run the interpreter loop.
interpreter :: Session -> IO ()
interpreter :: Session -> IO ()
interpreter (Session Chan (Query, MVar Response)
chan) = do
#if GHC_VERSION < 80200
    GHC.parseStaticFlags [] -- not sure if this is necessary
#endif
    Either IOError String
flags <- forall a. IO a -> IO (Either IOError a)
Exceptions.tryIO (String -> IO String
readFile String
ghci_flags)
    [String]
args <- case Either IOError String
flags of
        Left IOError
exc -> do
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.error forall a b. (a -> b) -> a -> b
$ Text
"error reading ghci flags from "
                forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt String
ghci_flags forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt IOError
exc
                forall a. Semigroup a => a -> a -> a
<> Text
", the REPL is probably not going to work"
            forall (m :: * -> *) a. Monad m => a -> m a
return []
        Right String
flags -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
flags

    forall (m :: * -> *) a.
ExceptionMonad m =>
Maybe String -> GhcT m a -> m a
GHC.runGhcT (forall a. a -> Maybe a
Just String
GHC.Paths.libdir) forall a b. (a -> b) -> a -> b
$ do
        [String] -> GhcT IO ()
parse_flags [String]
args
        -- obj_allowed must be False, otherwise I get
        -- Cannot add module Cmd.Repl.Environ to context: not interpreted
        forall (m :: * -> *). GhcMonad m => [Target] -> m ()
GHC.setTargets forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Bool -> String -> Target
make_target Bool
False) [String]
toplevel_modules
        ((Either String (CmdL Result)
result, [String]
logs, [String]
warns), Text
time_msg) <-
            forall (m :: * -> *) a. MonadIO m => m a -> m (a, Text)
Thread.timeActionText ([String] -> Ghc (Result (CmdL Result))
reload [String]
toplevel_modules)
        let expected :: [String]
expected = forall a b. (a -> b) -> [a] -> [b]
map ((forall a. [a] -> [a] -> [a]
++ String
".hs, interpreted") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => a -> [a] -> [a] -> [a]
Lists.replace1 Char
'.' String
"/")
                ([String]
toplevel_modules forall a. [a] -> [a] -> [a]
++ [String]
expected_reloads)
        [String]
logs <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter
            (\String
log -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` String
log) [String]
expected)) [String]
logs
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
logs) forall a b. (a -> b) -> a -> b
$ do
                forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"unexpected logs from reload: "
                    forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"; " (forall a b. (a -> b) -> [a] -> [b]
map String -> Text
txt [String]
logs)
                -- This module uses CPP, so I can't use backslash continuation.
                forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
                    [ Text
"Sometimes ghc thinks a module should be recompiled"
                    , Text
" but the shakefile doesn't. I'm not sure what causes"
                    , Text
" it, but it means all the modules have to be compiled."
                    , Text
" Delete and rebuild to fix."
                    ]
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
warns) forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"warnings from reload: "
                    forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"; " (forall a b. (a -> b) -> [a] -> [b]
map String -> Text
txt [String]
warns)
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ Text
"loaded modules for repl: " forall a. Semigroup a => a -> a -> a
<> Text
time_msg
            case Either String (CmdL Result)
result of
                Left String
err -> forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"error loading REPL modules: " forall a. Semigroup a => a -> a -> a
<> String -> Text
txt String
err
                Either String (CmdL Result)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
            (Query
query, MVar Response
return_mvar) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Chan a -> IO a
Chan.readChan Chan (Query, MVar Response)
chan
            Response
result <- [String] -> Query -> GhcT IO Response
respond [String]
toplevel_modules Query
query
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
MVar.putMVar MVar Response
return_mvar Response
result
    where
    expected_reloads :: [String]
expected_reloads = [String
"User.Elaforge.Repl"] -- TODO should be User.*.Repl
    toplevel_modules :: [String]
toplevel_modules = [String
"Cmd.Repl.Environ", String
"Local.Repl"]

respond :: [String] -> Query -> GHC.GhcT IO Response
respond :: [String] -> Query -> GhcT IO Response
respond [String]
toplevel_modules (QCommand Text
expr) = Cmd -> Response
RCommand forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if
    -- Emitted via :r from the repl.
    | Text
expr forall a. Eq a => a -> a -> Bool
== Text
":reload" -> Result (CmdL Result) -> Cmd
make_response forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> Ghc (Result (CmdL Result))
reload [String]
toplevel_modules
    | Bool
otherwise -> (forall a. GhcT IO a -> (SomeException -> GhcT IO a) -> GhcT IO a
`gcatch` forall {m :: * -> *} {m :: * -> *}.
(Monad m, Monad m) =>
SomeException -> m (m CmdResult)
catch) forall a b. (a -> b) -> a -> b
$ Result (CmdL Result) -> Cmd
make_response forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Ghc (Result (CmdL Result))
compile (Text -> String
untxt Text
expr)
    where
    catch :: SomeException -> m (m CmdResult)
catch (SomeException
exc :: Exception.SomeException) =
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> CmdResult
ReplProtocol.error_result forall a b. (a -> b) -> a -> b
$ Text
"Exception: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt SomeException
exc
respond [String]
_ (QCompletion Text
prefix) = [Text] -> Response
RCompletion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    -- Don't bother with 50 zillion completions.
    if Text
prefix forall a. Eq a => a -> a -> Bool
== Text
"" then forall (m :: * -> *) a. Monad m => a -> m a
return [] else do
        [RdrName]
rdrs <- forall (m :: * -> *). GhcMonad m => m [RdrName]
GHC.getRdrNamesInScope
        DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Text
prefix `Text.isPrefixOf`) forall a b. (a -> b) -> a -> b
$
            forall a. Ord a => [a] -> [a]
Lists.uniqueSort forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
txt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags) [RdrName]
rdrs

showPpr :: Outputable.Outputable a => GHC.DynFlags -> a -> String
#if GHC_VERSION >= 90201
showPpr :: forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
_ = forall a. Outputable a => a -> String
Outputable.showPprUnsafe
#else
showPpr = Outputable.showPpr
#endif

make_response :: Result (Cmd.CmdL ReplProtocol.Result) -> Cmd
make_response :: Result (CmdL Result) -> Cmd
make_response (Either String (CmdL Result)
val, [String]
logs, [String]
warns) = case Either String (CmdL Result)
val of
    Left String
err -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Result -> [Msg] -> CmdResult
ReplProtocol.CmdResult
        (Text -> Result
ReplProtocol.Raw (Text
"compile error: " forall a. Semigroup a => a -> a -> a
<> String -> Text
txt String
err)) [Msg]
all_logs
    Right CmdL Result
cmd -> do
        Result
result <- CmdL Result
cmd
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Result -> [Msg] -> CmdResult
ReplProtocol.CmdResult Result
result [Msg]
all_logs
    where
    all_logs :: [Msg]
all_logs = forall a b. (a -> b) -> [a] -> [b]
map (Stack => Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Notice forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
txt) [String]
logs
        forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (Stack => Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Warn forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
txt) [String]
warns

-- * implementation

-- | (Either error cmd, logs, warns)
type Result a = (Either String a, [String], [String])

-- | Load or reload the target modules.  Return errors if the load failed.
reload :: [String] -> Ghc (Result (Cmd.CmdL ReplProtocol.Result))
reload :: [String] -> Ghc (Result (CmdL Result))
reload [String]
toplevel_modules = do
    (Either String SuccessFlag
result, [String]
logs, [String]
warns) <- forall a. Ghc a -> Ghc (Result a)
collect_logs forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
GHC.load LoadHowMuch
GHC.LoadAllTargets forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* [String] -> GhcT IO ()
set_context [String]
toplevel_modules
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall {m :: * -> *} {a}.
(Monad m, IsString a) =>
Either a SuccessFlag -> Either a (m Result)
mkcmd Either String SuccessFlag
result, [String]
logs, [String]
warns)
    where
    mkcmd :: Either a SuccessFlag -> Either a (m Result)
mkcmd (Right SuccessFlag
ok)
        | SuccessFlag -> Bool
GHC.succeeded SuccessFlag
ok = forall a b. b -> Either a b
Right (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> Result
ReplProtocol.Raw Text
"reloaded")
        | Bool
otherwise = forall a b. a -> Either a b
Left a
"reload failed"
    mkcmd (Left a
err) = forall a b. a -> Either a b
Left a
err
    -- Set the module loaded callback to print out modules as they are loaded.
    -- module_load_callback = HscTypes.withLocalCallbacks $ \cbs ->
    --     cbs { GHC.reportModuleCompilationResult = load_callback }
    -- load_callback mod_summary maybe_err = do
    --     liftIO $ putStrLn $ show_ppr (HscTypes.ms_mod mod_summary)
    --     GHC.defaultWarnErrLogger maybe_err
    -- show_ppr :: (Outputable.Outputable a) => a -> String
    -- show_ppr = Outputable.showSDoc . Outputable.ppr

compile :: String -> Ghc (Result (Cmd.CmdL ReplProtocol.Result))
compile :: String -> Ghc (Result (CmdL Result))
compile String
expr = do
    (Either String HValue
hval, [String]
logs, [String]
warns) <- forall a. Ghc a -> Ghc (Result a)
collect_logs forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => String -> m HValue
GHC.compileExpr String
typed_expr
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a}. a -> CmdL Result
coerce Either String HValue
hval, [String]
logs, [String]
warns)
    where
    -- The _to_result method is defined in "Cmd.Repl.Global".
    typed_expr :: String
typed_expr =
        String
"fmap _to_result (" forall a. [a] -> [a] -> [a]
++ String
expr forall a. [a] -> [a] -> [a]
++ String
") :: Cmd.CmdL ReplProtocol.Result"
    -- This should be safe because I just asserted the the type above.
    coerce :: a -> CmdL Result
coerce a
val = unsafeCoerce# :: forall a b. a -> b
GHC.Exts.unsafeCoerce# a
val :: Cmd.CmdL ReplProtocol.Result

set_context :: [String] -> Ghc ()
set_context :: [String] -> GhcT IO ()
set_context [String]
mod_names = do
    let prelude :: ImportDecl GhcPs
prelude = ModuleName -> ImportDecl GhcPs
GHC.simpleImportDecl (String -> ModuleName
GHC.mkModuleName String
"Prelude")
    forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
GHC.setContext forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> InteractiveImport
GHC.IIDecl ImportDecl GhcPs
prelude
        forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> InteractiveImport
GHC.IIModule forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ModuleName
GHC.mkModuleName) [String]
mod_names

-- in Logger
-- 8e2f85f6b4662676f0d7addaff9bf2c7d751bb63

#if GHC_VERSION >= 90201

collect_logs :: Ghc a -> Ghc (Result a)
collect_logs :: forall a. Ghc a -> Ghc (Result a)
collect_logs Ghc a
action = do
    IORef [String]
logs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
IORef.newIORef []
    forall (m :: * -> *).
GhcMonad m =>
(LogAction -> LogAction) -> m ()
GHC.pushLogHookM forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (IORef [String] -> LogAction
log_action IORef [String]
logs)
    Either String a
val <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right Ghc a
action
        forall a. GhcT IO a -> (SomeException -> GhcT IO a) -> GhcT IO a
`gcatch` \(SomeException
exc :: Exception.SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show SomeException
exc))
    forall (m :: * -> *). GhcMonad m => m ()
GHC.popLogHookM
    [String]
logs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
IORef.readIORef IORef [String]
logs
    -- GHC.getWarnings is gone, apparently replaced by either printing directly
    -- or throwing an exception, e.g.
    -- compiler/main/HscTypes.lhs:handleFlagWarnings.
    let warns :: [a]
warns = []
    forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a
val, forall a. [a] -> [a]
reverse [String]
logs, forall a. [a]
warns)

-- type LogAction = DynFlags -> WarnReason -> Severity -> SrcSpan
--               -> SDoc -> IO ()
log_action :: IORef.IORef [String] -> Logger.LogAction
log_action :: IORef [String] -> LogAction
log_action IORef [String]
logs DynFlags
_ WarnReason
_ Severity
_ SrcSpan
_ SDoc
msg =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef IORef [String]
logs (String
formatted:)
    where formatted :: String
formatted = SDoc -> String
Outputable.showSDocUnsafe SDoc
msg

#else

-- | Run a Ghc action and collect logs and warns.
collect_logs :: Ghc a -> Ghc (Result a)
collect_logs action = do
    logs <- liftIO $ IORef.newIORef []
    val <- fmap Right (catch_logs logs >> action) `gcatch`
        \(exc :: Exception.SomeException) -> return (Left (show exc))
    logs <- liftIO $ IORef.readIORef logs
    -- GHC.getWarnings is gone, apparently replaced by either printing directly
    -- or throwing an exception, e.g.
    -- compiler/main/HscTypes.lhs:handleFlagWarnings.
    let warns = []
    return (val, reverse logs, warns)
    where
    catch_logs logs = modify_flags $ \flags ->
        flags { GHC.log_action = log_action logs }
    modify_flags :: (GHC.DynFlags -> GHC.DynFlags) -> Ghc ()
    modify_flags f = do
        dflags <- GHC.getSessionDynFlags
        void $ GHC.setSessionDynFlags $! f dflags

log_action :: IORef.IORef [String]
    -> GHC.DynFlags -> DynFlags.WarnReason -> GHC.Severity -> GHC.SrcSpan
    -> Outputable.PprStyle -> Outputable.SDoc -> IO ()
log_action logs dflags _warn_reason _severity _span style msg =
    liftIO $ IORef.modifyIORef logs (formatted:)
    where
    formatted = Outputable.showSDoc dflags $
        Outputable.withPprStyle style msg

#endif

parse_flags :: [String] -> Ghc ()
parse_flags :: [String] -> GhcT IO ()
parse_flags [String]
args = do
    DynFlags
dflags <- forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
#if GHC_VERSION >= 90201
    Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
GHC.getLogger
    (DynFlags
dflags, [Located String]
args_left, [Warn]
warns) <- forall (m :: * -> *).
MonadIO m =>
Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], [Warn])
GHC.parseDynamicFlags Logger
logger DynFlags
dflags
        (forall a b. (a -> b) -> [a] -> [b]
map (forall e. String -> e -> Located e
GHC.mkGeneralLocated String
"cmdline") [String]
args)
    let un_msg :: CmdLine.Warn -> String
        un_msg :: Warn -> String
un_msg = forall l e. GenLocated l e -> e
GHC.unLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. Warn -> Located String
CmdLine.warnMsg
#elif GHC_VERSION >= 80401
    (dflags, args_left, warns) <- GHC.parseDynamicFlags dflags
        (map (GHC.mkGeneralLocated "cmdline") args)
    let un_msg = GHC.unLoc . CmdLine.warnMsg
#else
    (dflags, args_left, warns) <- GHC.parseDynamicFlags dflags
        (map (GHC.mkGeneralLocated "cmdline") args)
    let un_msg = GHC.unLoc
#endif
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Warn]
warns) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"warnings parsing flags " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt [String]
args forall a. Semigroup a => a -> a -> a
<> Text
": "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall a b. (a -> b) -> [a] -> [b]
map Warn -> String
un_msg [Warn]
warns)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located String]
args_left) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$
            Text
"ignoring unparsed args: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
GHC.unLoc [Located String]
args_left)
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
GHC.setSessionDynFlags forall a b. (a -> b) -> a -> b
$ DynFlags
dflags
        { ghcMode :: GhcMode
GHC.ghcMode = GhcMode
GHC.CompManager
        , ghcLink :: GhcLink
GHC.ghcLink = GhcLink
GHC.LinkInMemory
#if GHC_VERSION >= 90201
        , backend :: Backend
GHC.backend = Backend
GHC.Interpreter
#else
        , GHC.hscTarget = GHC.HscInterpreted
#endif
        , verbosity :: Int
GHC.verbosity = Int
1
        }

make_target :: Bool -> String -> GHC.Target
make_target :: Bool -> String -> Target
make_target Bool
obj_allowed String
module_name = GHC.Target
    { targetId :: TargetId
GHC.targetId = ModuleName -> TargetId
GHC.TargetModule (String -> ModuleName
GHC.mkModuleName String
module_name)
    -- ghci unsets this if the module name starts with *, so I guess it means
    -- you can load the .o or must interpret.
    , targetAllowObjCode :: Bool
GHC.targetAllowObjCode = Bool
obj_allowed
    , targetContents :: Maybe (InputFileBuffer, UTCTime)
GHC.targetContents = forall a. Maybe a
Nothing
    }