module Hint.InterpreterT (
    InterpreterT, Interpreter,
    runInterpreter, runInterpreterWithArgs, runInterpreterWithArgsLibdir,
    MultipleInstancesNotAllowed(..)
) where

import Control.Applicative
import Prelude

import Hint.Base
import Hint.Context
import Hint.Configuration
import Hint.Extension

import Control.Monad (ap, unless)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Catch as MC

import Data.Typeable (Typeable)
import Control.Concurrent.MVar
import System.IO.Unsafe (unsafePerformIO)

import Data.IORef
import Data.Maybe

import qualified GHC.Paths

import qualified Hint.GHC as GHC

type Interpreter = InterpreterT IO

newtype InterpreterT m a = InterpreterT {
                             forall (m :: * -> *) a.
InterpreterT m a -> ReaderT InterpreterSession (GhcT m) a
unInterpreterT :: ReaderT InterpreterSession (GHC.GhcT m) a
                           }
    deriving (forall a b. a -> InterpreterT m b -> InterpreterT m a
forall a b. (a -> b) -> InterpreterT m a -> InterpreterT m b
forall (m :: * -> *) a b.
Functor m =>
a -> InterpreterT m b -> InterpreterT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> InterpreterT m a -> InterpreterT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> InterpreterT m b -> InterpreterT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> InterpreterT m b -> InterpreterT m a
fmap :: forall a b. (a -> b) -> InterpreterT m a -> InterpreterT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> InterpreterT m a -> InterpreterT m b
Functor, forall a. a -> InterpreterT m a
forall a b.
InterpreterT m a -> InterpreterT m b -> InterpreterT m b
forall a b.
InterpreterT m a -> (a -> InterpreterT m b) -> InterpreterT m b
forall {m :: * -> *}. Monad m => Applicative (InterpreterT m)
forall (m :: * -> *) a. Monad m => a -> InterpreterT m a
forall (m :: * -> *) a b.
Monad m =>
InterpreterT m a -> InterpreterT m b -> InterpreterT m b
forall (m :: * -> *) a b.
Monad m =>
InterpreterT m a -> (a -> InterpreterT m b) -> InterpreterT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> InterpreterT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> InterpreterT m a
>> :: forall a b.
InterpreterT m a -> InterpreterT m b -> InterpreterT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
InterpreterT m a -> InterpreterT m b -> InterpreterT m b
>>= :: forall a b.
InterpreterT m a -> (a -> InterpreterT m b) -> InterpreterT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
InterpreterT m a -> (a -> InterpreterT m b) -> InterpreterT m b
Monad, forall a. IO a -> InterpreterT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (InterpreterT m)
forall (m :: * -> *) a. MonadIO m => IO a -> InterpreterT m a
liftIO :: forall a. IO a -> InterpreterT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> InterpreterT m a
MonadIO, forall e a. Exception e => e -> InterpreterT m a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
forall {m :: * -> *}. MonadCatch m => Monad (InterpreterT m)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
e -> InterpreterT m a
throwM :: forall e a. Exception e => e -> InterpreterT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
e -> InterpreterT m a
MonadThrow, forall e a.
Exception e =>
InterpreterT m a -> (e -> InterpreterT m a) -> InterpreterT m a
forall {m :: * -> *}.
(MonadIO m, MonadMask m) =>
MonadThrow (InterpreterT m)
forall (m :: * -> *) e a.
(MonadIO m, MonadMask m, Exception e) =>
InterpreterT m a -> (e -> InterpreterT m a) -> InterpreterT m a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: forall e a.
Exception e =>
InterpreterT m a -> (e -> InterpreterT m a) -> InterpreterT m a
$ccatch :: forall (m :: * -> *) e a.
(MonadIO m, MonadMask m, Exception e) =>
InterpreterT m a -> (e -> InterpreterT m a) -> InterpreterT m a
MonadCatch, forall b.
((forall a. InterpreterT m a -> InterpreterT m a)
 -> InterpreterT m b)
-> InterpreterT m b
forall a b c.
InterpreterT m a
-> (a -> ExitCase b -> InterpreterT m c)
-> (a -> InterpreterT m b)
-> InterpreterT m (b, c)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
MonadCatch (InterpreterT m)
forall (m :: * -> *) b.
(MonadIO m, MonadMask m) =>
((forall a. InterpreterT m a -> InterpreterT m a)
 -> InterpreterT m b)
-> InterpreterT m b
forall (m :: * -> *) a b c.
(MonadIO m, MonadMask m) =>
InterpreterT m a
-> (a -> ExitCase b -> InterpreterT m c)
-> (a -> InterpreterT m b)
-> InterpreterT m (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: forall a b c.
InterpreterT m a
-> (a -> ExitCase b -> InterpreterT m c)
-> (a -> InterpreterT m b)
-> InterpreterT m (b, c)
$cgeneralBracket :: forall (m :: * -> *) a b c.
(MonadIO m, MonadMask m) =>
InterpreterT m a
-> (a -> ExitCase b -> InterpreterT m c)
-> (a -> InterpreterT m b)
-> InterpreterT m (b, c)
uninterruptibleMask :: forall b.
((forall a. InterpreterT m a -> InterpreterT m a)
 -> InterpreterT m b)
-> InterpreterT m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
(MonadIO m, MonadMask m) =>
((forall a. InterpreterT m a -> InterpreterT m a)
 -> InterpreterT m b)
-> InterpreterT m b
mask :: forall b.
((forall a. InterpreterT m a -> InterpreterT m a)
 -> InterpreterT m b)
-> InterpreterT m b
$cmask :: forall (m :: * -> *) b.
(MonadIO m, MonadMask m) =>
((forall a. InterpreterT m a -> InterpreterT m a)
 -> InterpreterT m b)
-> InterpreterT m b
MonadMask)

execute :: (MonadIO m, MonadMask m)
        => String
        -> InterpreterSession
        -> InterpreterT m a
        -> m (Either InterpreterError a)
execute :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String
-> InterpreterSession
-> InterpreterT m a
-> m (Either InterpreterError a)
execute String
libdir InterpreterSession
s = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try
                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Maybe String -> GhcT m a -> m a
GHC.runGhcT (forall a. a -> Maybe a
Just String
libdir)
                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT InterpreterSession
s
                 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
InterpreterT m a -> ReaderT InterpreterSession (GhcT m) a
unInterpreterT

instance MonadTrans InterpreterT where
    lift :: forall (m :: * -> *) a. Monad m => m a -> InterpreterT m a
lift = forall (m :: * -> *) a.
ReaderT InterpreterSession (GhcT m) a -> InterpreterT m a
InterpreterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

runGhcImpl :: (MonadIO m, MonadMask m)
           => RunGhc (InterpreterT m) a
runGhcImpl :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RunGhc (InterpreterT m) a
runGhcImpl forall (n :: * -> *). (MonadIO n, MonadMask n) => GhcT n a
a =
  forall (m :: * -> *) a.
ReaderT InterpreterSession (GhcT m) a -> InterpreterT m a
InterpreterT (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (n :: * -> *). (MonadIO n, MonadMask n) => GhcT n a
a)
   forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, MonadCatch m) =>
m a -> f (Handler m a) -> m a
`catches`
   [forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\(SourceError
e :: GHC.SourceError)  -> do
     DynFlags
dynFlags <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
     forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ DynFlags -> SourceError -> InterpreterError
compilationError DynFlags
dynFlags SourceError
e)
   ,forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\(GhcApiError
e :: GHC.GhcApiError)  -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> InterpreterError
GhcException forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show GhcApiError
e)
   ,forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\(GhcException
e :: GHC.GhcException) -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> InterpreterError
GhcException forall a b. (a -> b) -> a -> b
$ GhcException -> String
showGhcEx GhcException
e)
   ]
  where
    compilationError :: DynFlags -> SourceError -> InterpreterError
compilationError DynFlags
dynFlags
      = [GhcError] -> InterpreterError
WontCompile
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (String -> GhcError
GhcError forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> SDoc -> String
GHC.showSDoc DynFlags
dynFlags)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorMessages -> [SDoc]
GHC.pprErrorMessages
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceError -> ErrorMessages
GHC.srcErrorMessages

showGhcEx :: GHC.GhcException -> String
showGhcEx :: GhcException -> String
showGhcEx = forall a b c. (a -> b -> c) -> b -> a -> c
flip (SDocContext -> GhcException -> ShowS
GHC.showGhcException SDocContext
GHC.defaultSDocContext) String
""

-- ================= Executing the interpreter ==================

initialize :: (MonadIO m, MonadThrow m, MonadMask m, Functor m)
           => [String]
           -> InterpreterT m ()
initialize :: forall (m :: * -> *).
(MonadIO m, MonadThrow m, MonadMask m, Functor m) =>
[String] -> InterpreterT m ()
initialize [String]
args =
    do Logger
logger <- forall (m :: * -> *) a. MonadInterpreter m => FromSession m a
fromSession forall a. SessionData a -> Logger
ghcLogger
       -- Set a custom log handler, to intercept error messages :S
       DynFlags
df0 <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getSessionDynFlags

       let df1 :: DynFlags
df1 = DynFlags -> DynFlags
configureDynFlags DynFlags
df0
       (DynFlags
df2, [String]
extra) <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
GhcMonad m =>
Logger -> DynFlags -> [String] -> m (DynFlags, [String])
parseDynamicFlags Logger
logger DynFlags
df1 [String]
args
       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
extra) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> InterpreterError
UnknownError (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"flags: '"
                                          , [String] -> String
unwords [String]
extra
                                          , String
"' not recognized"])

       -- Observe that, setSessionDynFlags loads info on packages
       -- available; calling this function once is mandatory!
       forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => (Logger -> Logger) -> m ()
GHC.modifyLogger (forall a b. a -> b -> a
const Logger
logger)
       ()
_ <- forall (m :: * -> *) a. MonadInterpreter m => RunGhc m a
runGhc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
GHC.setSessionDynFlags DynFlags
df2

       let extMap :: [(String, Extension)]
extMap      = [ (forall flag. FlagSpec flag -> String
GHC.flagSpecName FlagSpec Extension
flagSpec, forall flag. FlagSpec flag -> flag
GHC.flagSpecFlag FlagSpec Extension
flagSpec)
                         | FlagSpec Extension
flagSpec <- [FlagSpec Extension]
GHC.xFlags
                         ]
       let toOpt :: String -> Extension
toOpt String
e     = let err :: a
err = forall a. HasCallStack => String -> a
error (String
"init error: unknown ext:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
e)
                         in forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
err (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
e [(String, Extension)]
extMap)
       let getOptVal :: String -> (Extension, Bool)
getOptVal String
e = (String -> Extension
asExtension String
e, Extension -> DynFlags -> Bool
GHC.xopt (String -> Extension
toOpt String
e) DynFlags
df2)
       let defExts :: [(Extension, Bool)]
defExts = forall a b. (a -> b) -> [a] -> [b]
map  String -> (Extension, Bool)
getOptVal [String]
supportedExtensions

       forall (m :: * -> *).
MonadInterpreter m =>
(InterpreterState -> InterpreterState) -> m ()
onState (\InterpreterState
s -> InterpreterState
s{defaultExts :: [(Extension, Bool)]
defaultExts = [(Extension, Bool)]
defExts})

       forall (m :: * -> *). MonadInterpreter m => m ()
reset

-- | Executes the interpreter. Returns @Left InterpreterError@ in case of error.
--
-- NB. In hint-0.7.0 and earlier, the underlying ghc was accidentally
-- overwriting certain signal handlers (SIGINT, SIGHUP, SIGTERM, SIGQUIT on
-- Posix systems, Ctrl-C handler on Windows).
runInterpreter :: (MonadIO m, MonadMask m)
               => InterpreterT m a
               -> m (Either InterpreterError a)
runInterpreter :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InterpreterT m a -> m (Either InterpreterError a)
runInterpreter = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[String] -> InterpreterT m a -> m (Either InterpreterError a)
runInterpreterWithArgs []

-- | Executes the interpreter, setting args passed in as though they
-- were command-line args. Returns @Left InterpreterError@ in case of
-- error.
runInterpreterWithArgs :: (MonadIO m, MonadMask m)
                       => [String]
                       -> InterpreterT m a
                       -> m (Either InterpreterError a)
runInterpreterWithArgs :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[String] -> InterpreterT m a -> m (Either InterpreterError a)
runInterpreterWithArgs [String]
args = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[String]
-> String -> InterpreterT m a -> m (Either InterpreterError a)
runInterpreterWithArgsLibdir [String]
args String
GHC.Paths.libdir

runInterpreterWithArgsLibdir :: (MonadIO m, MonadMask m)
                             => [String]
                             -> String
                             -> InterpreterT m a
                             -> m (Either InterpreterError a)
runInterpreterWithArgsLibdir :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[String]
-> String -> InterpreterT m a -> m (Either InterpreterError a)
runInterpreterWithArgsLibdir [String]
args String
libdir InterpreterT m a
action =
#ifndef THREAD_SAFE_LINKER
  ifInterpreterNotRunning $
#endif
    do InterpreterSession
s <- m InterpreterSession
newInterpreterSession forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`MC.catch` forall {a}. GhcException -> m a
rethrowGhcException
       forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String
-> InterpreterSession
-> InterpreterT m a
-> m (Either InterpreterError a)
execute String
libdir InterpreterSession
s (forall (m :: * -> *).
(MonadIO m, MonadThrow m, MonadMask m, Functor m) =>
[String] -> InterpreterT m ()
initialize [String]
args forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> InterpreterT m a
action forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` InterpreterT m ()
cleanSession)
    where rethrowGhcException :: GhcException -> m a
rethrowGhcException   = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> InterpreterError
GhcException forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhcException -> String
showGhcEx
          newInterpreterSession :: m InterpreterSession
newInterpreterSession = forall (m :: * -> *) a. MonadIO m => a -> m (SessionData a)
newSessionData ()
          cleanSession :: InterpreterT m ()
cleanSession = forall (m :: * -> *). MonadInterpreter m => m ()
cleanPhantomModules

#ifndef THREAD_SAFE_LINKER
{-# NOINLINE uniqueToken #-}
uniqueToken :: MVar ()
uniqueToken = unsafePerformIO $ newMVar ()

ifInterpreterNotRunning :: (MonadIO m, MonadMask m) => m a -> m a
ifInterpreterNotRunning action = liftIO (tryTakeMVar uniqueToken) >>= \ case
    Nothing -> throwM MultipleInstancesNotAllowed
    Just x  -> action `finally` liftIO (putMVar uniqueToken x)
#endif

-- | The installed version of ghc is not thread-safe. This exception
--   is thrown whenever you try to execute @runInterpreter@ while another
--   instance is already running.
data MultipleInstancesNotAllowed = MultipleInstancesNotAllowed deriving Typeable

instance Exception MultipleInstancesNotAllowed

instance Show MultipleInstancesNotAllowed where
    show :: MultipleInstancesNotAllowed -> String
show MultipleInstancesNotAllowed
_ = String
"This version of GHC is not thread-safe," forall a. [a] -> [a] -> [a]
++
             String
"can't safely run two instances of the interpreter simultaneously"

initialState :: InterpreterState
initialState :: InterpreterState
initialState = St {
                   activePhantoms :: [PhantomModule]
activePhantoms    = [],
                   zombiePhantoms :: [PhantomModule]
zombiePhantoms    = [],
                   phantomDirectory :: Maybe String
phantomDirectory  = forall a. Maybe a
Nothing,
                   hintSupportModule :: PhantomModule
hintSupportModule = forall a. HasCallStack => String -> a
error String
"No support module loaded!",
                   importQualHackMod :: Maybe PhantomModule
importQualHackMod = forall a. Maybe a
Nothing,
                   qualImports :: [ModuleImport]
qualImports       = [],
                   defaultExts :: [(Extension, Bool)]
defaultExts       = forall a. HasCallStack => String -> a
error String
"defaultExts missing!",
                   configuration :: InterpreterConfiguration
configuration     = InterpreterConfiguration
defaultConf
                  }

newSessionData :: MonadIO m => a -> m (SessionData a)
newSessionData :: forall (m :: * -> *) a. MonadIO m => a -> m (SessionData a)
newSessionData a
a =
    do IORef InterpreterState
initial_state    <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef InterpreterState
initialState
       IORef [GhcError]
ghc_err_list_ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef []
       Logger
logger           <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO Logger
GHC.initLogger
       forall (m :: * -> *) a. Monad m => a -> m a
return SessionData {
         internalState :: IORef InterpreterState
internalState   = IORef InterpreterState
initial_state,
         versionSpecific :: a
versionSpecific = a
a,
         ghcErrListRef :: IORef [GhcError]
ghcErrListRef   = IORef [GhcError]
ghc_err_list_ref,
         ghcLogger :: Logger
ghcLogger       = (LogAction -> LogAction) -> Logger -> Logger
GHC.pushLogHook (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ IORef [GhcError] -> LogAction
mkLogAction IORef [GhcError]
ghc_err_list_ref) Logger
logger
       }

mkLogAction :: IORef [GhcError] -> GHC.LogAction
mkLogAction :: IORef [GhcError] -> LogAction
mkLogAction IORef [GhcError]
r = forall {t} {t} {t} {t} {a} {t} {t}.
(t -> t -> t -> t -> (a -> a) -> t -> t)
-> t -> t -> t -> t -> t -> t
mkLogAction' forall a b. (a -> b) -> a -> b
$ \DynFlags
df WarnReason
_ Severity
_ SrcSpan
src SDoc -> SDoc
withStyle SDoc
msg ->
    let renderErrMsg :: SDoc -> String
renderErrMsg = DynFlags -> SDoc -> String
GHC.showSDoc DynFlags
df forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> SDoc
withStyle
        errorEntry :: GhcError
errorEntry = (SDoc -> String) -> SrcSpan -> SDoc -> GhcError
mkGhcError SDoc -> String
renderErrMsg SrcSpan
src SDoc
msg
    in forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [GhcError]
r (GhcError
errorEntry forall a. a -> [a] -> [a]
:)
    where
        mkLogAction' :: (t -> t -> t -> t -> (a -> a) -> t -> t)
-> t -> t -> t -> t -> t -> t
mkLogAction' t -> t -> t -> t -> (a -> a) -> t -> t
f =
#if MIN_VERSION_ghc(9,0,0)
            \t
df t
wr t
sev t
src t
msg -> t -> t -> t -> t -> (a -> a) -> t -> t
f t
df t
wr t
sev t
src forall a. a -> a
id t
msg
#else
            \df wr sev src style msg -> f df wr sev src (GHC.withPprStyle style) msg
#endif

mkGhcError :: (GHC.SDoc -> String) -> GHC.SrcSpan -> GHC.Message -> GhcError
mkGhcError :: (SDoc -> String) -> SrcSpan -> SDoc -> GhcError
mkGhcError SDoc -> String
render SrcSpan
src_span SDoc
msg = GhcError{errMsg :: String
errMsg = String
niceErrMsg}
    where niceErrMsg :: String
niceErrMsg = SDoc -> String
render forall a b. (a -> b) -> a -> b
$ Severity -> SrcSpan -> SDoc -> SDoc
GHC.mkLocMessage Severity
GHC.SevError SrcSpan
src_span SDoc
msg

-- The MonadInterpreter instance

instance (MonadIO m, MonadMask m, Functor m) => MonadInterpreter (InterpreterT m) where
    fromSession :: forall a. FromSession (InterpreterT m) a
fromSession InterpreterSession -> a
f = forall (m :: * -> *) a.
ReaderT InterpreterSession (GhcT m) a -> InterpreterT m a
InterpreterT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks InterpreterSession -> a
f
    --
    modifySessionRef :: forall a. ModifySessionRef (InterpreterT m) a
modifySessionRef InterpreterSession -> IORef a
target a -> a
f =
        do IORef a
ref <- forall (m :: * -> *) a. MonadInterpreter m => FromSession m a
fromSession InterpreterSession -> IORef a
target
           forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef a
ref (\a
a -> (a -> a
f a
a, a
a))
    --
    runGhc :: forall a. RunGhc (InterpreterT m) a
runGhc = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RunGhc (InterpreterT m) a
runGhcImpl

instance (Monad m) => Applicative (InterpreterT m) where
    pure :: forall a. a -> InterpreterT m a
pure  = forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: forall a b.
InterpreterT m (a -> b) -> InterpreterT m a -> InterpreterT m b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap