-- 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.Log as Log
import qualified Util.Seq as Seq
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 = GhcT IO a -> (SomeException -> GhcT IO a) -> GhcT IO a
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
(Int -> Query -> String -> String)
-> (Query -> String) -> ([Query] -> String -> String) -> Show Query
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 (Chan (Query, MVar Response) -> Session)
-> IO (Chan (Query, MVar Response)) -> IO Session
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Chan (Query, MVar Response))
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 <- IO (MVar Response)
forall a. IO (MVar a)
MVar.newEmptyMVar
    Chan (Query, MVar Response) -> (Query, MVar Response) -> IO ()
forall a. Chan a -> a -> IO ()
Chan.writeChan Chan (Query, MVar Response)
chan (Text -> Query
QCommand Text
expr, MVar Response
mvar)
    Response
response <- MVar Response -> IO Response
forall a. MVar a -> IO a
MVar.takeMVar MVar Response
mvar
    case Response
response of
        RCommand Cmd
cmd -> Cmd -> IO Cmd
forall (m :: * -> *) a. Monad m => a -> m a
return Cmd
cmd
        Response
_ -> Text -> IO Cmd
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 <- IO (MVar Response)
forall a. IO (MVar a)
MVar.newEmptyMVar
    Chan (Query, MVar Response) -> (Query, MVar Response) -> IO ()
forall a. Chan a -> a -> IO ()
Chan.writeChan Chan (Query, MVar Response)
chan (Text -> Query
QCompletion Text
prefix, MVar Response
mvar)
    Response
response <- MVar Response -> IO Response
forall a. MVar a -> IO a
MVar.takeMVar MVar Response
mvar
    case Response
response of
        RCompletion [Text]
words -> [Text] -> IO [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text]
words
        Response
_ -> Text -> IO [Text]
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 <- IO String -> IO (Either IOError String)
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
            Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.error (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"error reading ghci flags from "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. Show a => a -> Text
showt String
ghci_flags Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IOError -> Text
forall a. Show a => a -> Text
showt IOError
exc
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", the REPL is probably not going to work"
            [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        Right String
flags -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
flags

    Maybe String -> GhcT IO () -> IO ()
forall (m :: * -> *) a.
ExceptionMonad m =>
Maybe String -> GhcT m a -> m a
GHC.runGhcT (String -> Maybe String
forall a. a -> Maybe a
Just String
GHC.Paths.libdir) (GhcT IO () -> IO ()) -> GhcT IO () -> IO ()
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
        [Target] -> GhcT IO ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
GHC.setTargets ([Target] -> GhcT IO ()) -> [Target] -> GhcT IO ()
forall a b. (a -> b) -> a -> b
$ (String -> Target) -> [String] -> [Target]
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) <-
            GhcT IO (Result (CmdL Result))
-> GhcT IO (Result (CmdL Result), Text)
forall (m :: * -> *) a. MonadIO m => m a -> m (a, Text)
Thread.timeActionText ([String] -> GhcT IO (Result (CmdL Result))
reload [String]
toplevel_modules)
        let expected :: [String]
expected = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".hs, interpreted") (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String -> String
forall a. Eq a => a -> [a] -> [a] -> [a]
Seq.replace1 Char
'.' String
"/")
                ([String]
toplevel_modules [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
expected_reloads)
        [String]
logs <- [String] -> GhcT IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> GhcT IO [String]) -> [String] -> GhcT IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter
            (\String
log -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ((String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` String
log) [String]
expected)) [String]
logs
        IO () -> GhcT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> GhcT IO ()) -> IO () -> GhcT IO ()
forall a b. (a -> b) -> a -> b
$ do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
logs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"unexpected logs from reload: "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"; " ((String -> Text) -> [String] -> [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.
                Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
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."
                    ]
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
warns) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"warnings from reload: "
                    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"; " ((String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
txt [String]
warns)
            Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"loaded modules for repl: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
time_msg
            case Either String (CmdL Result)
result of
                Left String
err -> Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"error loading REPL modules: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
txt String
err
                Either String (CmdL Result)
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        GhcT IO () -> GhcT IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (GhcT IO () -> GhcT IO ()) -> GhcT IO () -> GhcT IO ()
forall a b. (a -> b) -> a -> b
$ do
            (Query
query, MVar Response
return_mvar) <- IO (Query, MVar Response) -> GhcT IO (Query, MVar Response)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Query, MVar Response) -> GhcT IO (Query, MVar Response))
-> IO (Query, MVar Response) -> GhcT IO (Query, MVar Response)
forall a b. (a -> b) -> a -> b
$ Chan (Query, MVar Response) -> IO (Query, MVar Response)
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
            IO () -> GhcT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> GhcT IO ()) -> IO () -> GhcT IO ()
forall a b. (a -> b) -> a -> b
$ MVar Response -> Response -> IO ()
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 (Cmd -> Response) -> GhcT IO Cmd -> GhcT IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if
    -- Emitted via :r from the repl.
    | Text
expr Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
":reload" -> Result (CmdL Result) -> Cmd
make_response (Result (CmdL Result) -> Cmd)
-> GhcT IO (Result (CmdL Result)) -> GhcT IO Cmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String] -> GhcT IO (Result (CmdL Result))
reload [String]
toplevel_modules
    | Bool
otherwise -> (GhcT IO Cmd -> (SomeException -> GhcT IO Cmd) -> GhcT IO Cmd
forall a. GhcT IO a -> (SomeException -> GhcT IO a) -> GhcT IO a
`gcatch` SomeException -> GhcT IO Cmd
forall {m :: * -> *} {m :: * -> *}.
(Monad m, Monad m) =>
SomeException -> m (m CmdResult)
catch) (GhcT IO Cmd -> GhcT IO Cmd) -> GhcT IO Cmd -> GhcT IO Cmd
forall a b. (a -> b) -> a -> b
$ Result (CmdL Result) -> Cmd
make_response (Result (CmdL Result) -> Cmd)
-> GhcT IO (Result (CmdL Result)) -> GhcT IO Cmd
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> GhcT IO (Result (CmdL Result))
compile (Text -> String
untxt Text
expr)
    where
    catch :: SomeException -> m (m CmdResult)
catch (SomeException
exc :: Exception.SomeException) =
        m CmdResult -> m (m CmdResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (m CmdResult -> m (m CmdResult)) -> m CmdResult -> m (m CmdResult)
forall a b. (a -> b) -> a -> b
$ CmdResult -> m CmdResult
forall (m :: * -> *) a. Monad m => a -> m a
return (CmdResult -> m CmdResult) -> CmdResult -> m CmdResult
forall a b. (a -> b) -> a -> b
$ Text -> CmdResult
ReplProtocol.error_result (Text -> CmdResult) -> Text -> CmdResult
forall a b. (a -> b) -> a -> b
$ Text
"Exception: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall a. Show a => a -> Text
showt SomeException
exc
respond [String]
_ (QCompletion Text
prefix) = [Text] -> Response
RCompletion ([Text] -> Response) -> GhcT IO [Text] -> GhcT IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    -- Don't bother with 50 zillion completions.
    if Text
prefix Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"" then [Text] -> GhcT IO [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return [] else do
        [RdrName]
rdrs <- GhcT IO [RdrName]
forall (m :: * -> *). GhcMonad m => m [RdrName]
GHC.getRdrNamesInScope
        DynFlags
dflags <- GhcT IO DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
        [Text] -> GhcT IO [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> GhcT IO [Text]) -> [Text] -> GhcT IO [Text]
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text
prefix `Text.isPrefixOf`) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
            [Text] -> [Text]
forall a. Ord a => [a] -> [a]
Seq.unique_sort ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (RdrName -> Text) -> [RdrName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
txt (String -> Text) -> (RdrName -> String) -> RdrName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> RdrName -> String
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
_ = a -> String
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 -> CmdResult -> Cmd
forall (m :: * -> *) a. Monad m => a -> m a
return (CmdResult -> Cmd) -> CmdResult -> Cmd
forall a b. (a -> b) -> a -> b
$ Result -> [Msg] -> CmdResult
ReplProtocol.CmdResult
        (Text -> Result
ReplProtocol.Raw (Text
"compile error: " Text -> Text -> Text
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
        CmdResult -> Cmd
forall (m :: * -> *) a. Monad m => a -> m a
return (CmdResult -> Cmd) -> CmdResult -> Cmd
forall a b. (a -> b) -> a -> b
$ Result -> [Msg] -> CmdResult
ReplProtocol.CmdResult Result
result [Msg]
all_logs
    where
    all_logs :: [Msg]
all_logs = (String -> Msg) -> [String] -> [Msg]
forall a b. (a -> b) -> [a] -> [b]
map (Stack => Priority -> Maybe Stack -> Text -> Msg
Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Notice Maybe Stack
forall a. Maybe a
Nothing (Text -> Msg) -> (String -> Text) -> String -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
txt) [String]
logs
        [Msg] -> [Msg] -> [Msg]
forall a. [a] -> [a] -> [a]
++ (String -> Msg) -> [String] -> [Msg]
forall a b. (a -> b) -> [a] -> [b]
map (Stack => Priority -> Maybe Stack -> Text -> Msg
Priority -> Maybe Stack -> Text -> Msg
Log.msg Priority
Log.Warn Maybe Stack
forall a. Maybe a
Nothing (Text -> Msg) -> (String -> Text) -> String -> Msg
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] -> GhcT IO (Result (CmdL Result))
reload [String]
toplevel_modules = do
    (Either String SuccessFlag
result, [String]
logs, [String]
warns) <- Ghc SuccessFlag
-> Ghc (Either String SuccessFlag, [String], [String])
forall a. Ghc a -> Ghc (Result a)
collect_logs (Ghc SuccessFlag
 -> Ghc (Either String SuccessFlag, [String], [String]))
-> Ghc SuccessFlag
-> Ghc (Either String SuccessFlag, [String], [String])
forall a b. (a -> b) -> a -> b
$
        LoadHowMuch -> Ghc SuccessFlag
forall (m :: * -> *). GhcMonad m => LoadHowMuch -> m SuccessFlag
GHC.load LoadHowMuch
GHC.LoadAllTargets Ghc SuccessFlag -> GhcT IO () -> Ghc SuccessFlag
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* [String] -> GhcT IO ()
set_context [String]
toplevel_modules
    Result (CmdL Result) -> GhcT IO (Result (CmdL Result))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String SuccessFlag -> Either String (CmdL Result)
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 = m Result -> Either a (m Result)
forall a b. b -> Either a b
Right (Result -> m Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> m Result) -> Result -> m Result
forall a b. (a -> b) -> a -> b
$ Text -> Result
ReplProtocol.Raw Text
"reloaded")
        | Bool
otherwise = a -> Either a (m Result)
forall a b. a -> Either a b
Left a
"reload failed"
    mkcmd (Left a
err) = a -> Either a (m Result)
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 -> GhcT IO (Result (CmdL Result))
compile String
expr = do
    (Either String HValue
hval, [String]
logs, [String]
warns) <- Ghc HValue -> Ghc (Either String HValue, [String], [String])
forall a. Ghc a -> Ghc (Result a)
collect_logs (Ghc HValue -> Ghc (Either String HValue, [String], [String]))
-> Ghc HValue -> Ghc (Either String HValue, [String], [String])
forall a b. (a -> b) -> a -> b
$ String -> Ghc HValue
forall (m :: * -> *). GhcMonad m => String -> m HValue
GHC.compileExpr String
typed_expr
    Result (CmdL Result) -> GhcT IO (Result (CmdL Result))
forall (m :: * -> *) a. Monad m => a -> m a
return ((HValue -> CmdL Result)
-> Either String HValue -> Either String (CmdL Result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HValue -> CmdL Result
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 (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
expr String -> String -> String
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 = a -> CmdL Result
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")
    [InteractiveImport] -> GhcT IO ()
forall (m :: * -> *). GhcMonad m => [InteractiveImport] -> m ()
GHC.setContext ([InteractiveImport] -> GhcT IO ())
-> [InteractiveImport] -> GhcT IO ()
forall a b. (a -> b) -> a -> b
$ ImportDecl GhcPs -> InteractiveImport
GHC.IIDecl ImportDecl GhcPs
prelude
        InteractiveImport -> [InteractiveImport] -> [InteractiveImport]
forall a. a -> [a] -> [a]
: (String -> InteractiveImport) -> [String] -> [InteractiveImport]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> InteractiveImport
GHC.IIModule (ModuleName -> InteractiveImport)
-> (String -> ModuleName) -> String -> InteractiveImport
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 <- IO (IORef [String]) -> GhcT IO (IORef [String])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [String]) -> GhcT IO (IORef [String]))
-> IO (IORef [String]) -> GhcT IO (IORef [String])
forall a b. (a -> b) -> a -> b
$ [String] -> IO (IORef [String])
forall a. a -> IO (IORef a)
IORef.newIORef []
    (LogAction -> LogAction) -> GhcT IO ()
forall (m :: * -> *).
GhcMonad m =>
(LogAction -> LogAction) -> m ()
GHC.pushLogHookM ((LogAction -> LogAction) -> GhcT IO ())
-> (LogAction -> LogAction) -> GhcT IO ()
forall a b. (a -> b) -> a -> b
$ LogAction -> LogAction -> LogAction
forall a b. a -> b -> a
const (IORef [String] -> LogAction
log_action IORef [String]
logs)
    Either String a
val <- (a -> Either String a) -> Ghc a -> GhcT IO (Either String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either String a
forall a b. b -> Either a b
Right Ghc a
action
        GhcT IO (Either String a)
-> (SomeException -> GhcT IO (Either String a))
-> GhcT IO (Either String a)
forall a. GhcT IO a -> (SomeException -> GhcT IO a) -> GhcT IO a
`gcatch` \(SomeException
exc :: Exception.SomeException) -> Either String a -> GhcT IO (Either String a)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String a
forall a b. a -> Either a b
Left (SomeException -> String
forall a. Show a => a -> String
show SomeException
exc))
    GhcT IO ()
forall (m :: * -> *). GhcMonad m => m ()
GHC.popLogHookM
    [String]
logs <- IO [String] -> GhcT IO [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> GhcT IO [String])
-> IO [String] -> GhcT IO [String]
forall a b. (a -> b) -> a -> b
$ IORef [String] -> IO [String]
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 = []
    Result a -> Ghc (Result a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String a
val, [String] -> [String]
forall a. [a] -> [a]
reverse [String]
logs, [String]
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 =
    IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef [String] -> ([String] -> [String]) -> IO ()
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 <- GhcT IO DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
#if GHC_VERSION >= 90201
    Logger
logger <- GhcT IO Logger
forall (m :: * -> *). HasLogger m => m Logger
GHC.getLogger
    (DynFlags
dflags, [Located String]
args_left, [Warn]
warns) <- Logger
-> DynFlags
-> [Located String]
-> GhcT IO (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
Logger
-> DynFlags
-> [Located String]
-> m (DynFlags, [Located String], [Warn])
GHC.parseDynamicFlags Logger
logger DynFlags
dflags
        ((String -> Located String) -> [String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Located String
forall e. String -> e -> Located e
GHC.mkGeneralLocated String
"cmdline") [String]
args)
    let un_msg :: CmdLine.Warn -> String
        un_msg :: Warn -> String
un_msg = Located String -> String
forall l e. GenLocated l e -> e
GHC.unLoc (Located String -> String)
-> (Warn -> Located String) -> Warn -> String
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
    Bool -> GhcT IO () -> GhcT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Warn] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Warn]
warns) (GhcT IO () -> GhcT IO ()) -> GhcT IO () -> GhcT IO ()
forall a b. (a -> b) -> a -> b
$
        IO () -> GhcT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> GhcT IO ()) -> IO () -> GhcT IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"warnings parsing flags " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [String] -> Text
forall a. Show a => a -> Text
showt [String]
args Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [String] -> Text
forall a. Show a => a -> Text
showt ((Warn -> String) -> [Warn] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Warn -> String
un_msg [Warn]
warns)
    Bool -> GhcT IO () -> GhcT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Located String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located String]
args_left) (GhcT IO () -> GhcT IO ()) -> GhcT IO () -> GhcT IO ()
forall a b. (a -> b) -> a -> b
$
        IO () -> GhcT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> GhcT IO ()) -> IO () -> GhcT IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
            Text
"ignoring unparsed args: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [String] -> Text
forall a. Show a => a -> Text
showt ((Located String -> String) -> [Located String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Located String -> String
forall l e. GenLocated l e -> e
GHC.unLoc [Located String]
args_left)
    GhcT IO () -> GhcT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (GhcT IO () -> GhcT IO ()) -> GhcT IO () -> GhcT IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> GhcT IO ()
forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
GHC.setSessionDynFlags (DynFlags -> GhcT IO ()) -> DynFlags -> GhcT IO ()
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 = Maybe (InputFileBuffer, UTCTime)
forall a. Maybe a
Nothing
    }