{-# LANGUAGE CPP, DeriveFunctor, DerivingVia, RankNTypes #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
module GHC.Driver.Monad (
GhcMonad(..),
Ghc(..),
GhcT(..), liftGhcT,
reflectGhc, reifyGhc,
getSessionDynFlags,
liftIO,
Session(..), withSession, modifySession, modifySessionM,
withTempSession,
modifyLogger,
pushLogHookM,
popLogHookM,
putLogMsgM,
putMsgM,
withTimingM,
logWarnings, printException,
WarnErrLogger, defaultWarnErrLogger
) where
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Env
import GHC.Driver.Errors ( printOrThrowWarnings, printBagOfErrors )
import GHC.Utils.Monad
import GHC.Utils.Exception
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Types.SrcLoc
import GHC.Types.SourceError
import Control.Monad
import Control.Monad.Catch as MC
import Control.Monad.Trans.Reader
import Data.IORef
class (Functor m, ExceptionMonad m, HasDynFlags m, HasLogger m ) => GhcMonad m where
getSession :: m HscEnv
setSession :: HscEnv -> m ()
withSession :: GhcMonad m => (HscEnv -> m a) -> m a
withSession :: forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession HscEnv -> m a
f = m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession m HscEnv -> (HscEnv -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HscEnv -> m a
f
getSessionDynFlags :: GhcMonad m => m DynFlags
getSessionDynFlags :: forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags = (HscEnv -> m DynFlags) -> m DynFlags
forall (m :: * -> *) a. GhcMonad m => (HscEnv -> m a) -> m a
withSession (DynFlags -> m DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return (DynFlags -> m DynFlags)
-> (HscEnv -> DynFlags) -> HscEnv -> m DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> DynFlags
hsc_dflags)
modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession :: forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession HscEnv -> HscEnv
f = do HscEnv
h <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession (HscEnv -> m ()) -> HscEnv -> m ()
forall a b. (a -> b) -> a -> b
$! HscEnv -> HscEnv
f HscEnv
h
modifySessionM :: GhcMonad m => (HscEnv -> m HscEnv) -> m ()
modifySessionM :: forall (m :: * -> *). GhcMonad m => (HscEnv -> m HscEnv) -> m ()
modifySessionM HscEnv -> m HscEnv
f = do HscEnv
h <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
HscEnv
h' <- HscEnv -> m HscEnv
f HscEnv
h
HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession (HscEnv -> m ()) -> HscEnv -> m ()
forall a b. (a -> b) -> a -> b
$! HscEnv
h'
withSavedSession :: GhcMonad m => m a -> m a
withSavedSession :: forall (m :: * -> *) a. GhcMonad m => m a -> m a
withSavedSession m a
m = do
HscEnv
saved_session <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
m a
m m a -> m () -> m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`MC.finally` HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
saved_session
withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a
withTempSession :: forall (m :: * -> *) a.
GhcMonad m =>
(HscEnv -> HscEnv) -> m a -> m a
withTempSession HscEnv -> HscEnv
f m a
m =
m a -> m a
forall (m :: * -> *) a. GhcMonad m => m a -> m a
withSavedSession (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession HscEnv -> HscEnv
f m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
m
modifyLogger :: GhcMonad m => (Logger -> Logger) -> m ()
modifyLogger :: forall (m :: * -> *). GhcMonad m => (Logger -> Logger) -> m ()
modifyLogger Logger -> Logger
f = (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
hsc_env ->
HscEnv
hsc_env { hsc_logger :: Logger
hsc_logger = Logger -> Logger
f (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) }
pushLogHookM :: GhcMonad m => (LogAction -> LogAction) -> m ()
pushLogHookM :: forall (m :: * -> *).
GhcMonad m =>
(LogAction -> LogAction) -> m ()
pushLogHookM = (Logger -> Logger) -> m ()
forall (m :: * -> *). GhcMonad m => (Logger -> Logger) -> m ()
modifyLogger ((Logger -> Logger) -> m ())
-> ((LogAction -> LogAction) -> Logger -> Logger)
-> (LogAction -> LogAction)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogAction -> LogAction) -> Logger -> Logger
pushLogHook
popLogHookM :: GhcMonad m => m ()
popLogHookM :: forall (m :: * -> *). GhcMonad m => m ()
popLogHookM = (Logger -> Logger) -> m ()
forall (m :: * -> *). GhcMonad m => (Logger -> Logger) -> m ()
modifyLogger Logger -> Logger
popLogHook
putMsgM :: GhcMonad m => SDoc -> m ()
putMsgM :: forall (m :: * -> *). GhcMonad m => SDoc -> m ()
putMsgM SDoc
doc = do
DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger DynFlags
dflags SDoc
doc
putLogMsgM :: GhcMonad m => WarnReason -> Severity -> SrcSpan -> SDoc -> m ()
putLogMsgM :: forall (m :: * -> *).
GhcMonad m =>
WarnReason -> Severity -> SrcSpan -> SDoc -> m ()
putLogMsgM WarnReason
reason Severity
sev SrcSpan
loc SDoc
doc = do
DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> LogAction
putLogMsg Logger
logger DynFlags
dflags WarnReason
reason Severity
sev SrcSpan
loc SDoc
doc
withTimingM :: GhcMonad m => SDoc -> (b -> ()) -> m b -> m b
withTimingM :: forall (m :: * -> *) b.
GhcMonad m =>
SDoc -> (b -> ()) -> m b -> m b
withTimingM SDoc
doc b -> ()
force m b
action = do
Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger -> DynFlags -> SDoc -> (b -> ()) -> m b -> m b
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags SDoc
doc b -> ()
force m b
action
logWarnings :: GhcMonad m => WarningMessages -> m ()
logWarnings :: forall (m :: * -> *). GhcMonad m => WarningMessages -> m ()
logWarnings WarningMessages
warns = do
DynFlags
dflags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> WarningMessages -> IO ()
printOrThrowWarnings Logger
logger DynFlags
dflags WarningMessages
warns
newtype Ghc a = Ghc { forall a. Ghc a -> Session -> IO a
unGhc :: Session -> IO a }
deriving ((forall a b. (a -> b) -> Ghc a -> Ghc b)
-> (forall a b. a -> Ghc b -> Ghc a) -> Functor Ghc
forall a b. a -> Ghc b -> Ghc a
forall a b. (a -> b) -> Ghc a -> Ghc 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 -> Ghc b -> Ghc a
$c<$ :: forall a b. a -> Ghc b -> Ghc a
fmap :: forall a b. (a -> b) -> Ghc a -> Ghc b
$cfmap :: forall a b. (a -> b) -> Ghc a -> Ghc b
Functor)
deriving (Monad Ghc
Monad Ghc
-> (forall e a. Exception e => e -> Ghc a) -> MonadThrow Ghc
forall e a. Exception e => e -> Ghc a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: forall e a. Exception e => e -> Ghc a
$cthrowM :: forall e a. Exception e => e -> Ghc a
MonadThrow, MonadThrow Ghc
MonadThrow Ghc
-> (forall e a. Exception e => Ghc a -> (e -> Ghc a) -> Ghc a)
-> MonadCatch Ghc
forall e a. Exception e => Ghc a -> (e -> Ghc a) -> Ghc 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 => Ghc a -> (e -> Ghc a) -> Ghc a
$ccatch :: forall e a. Exception e => Ghc a -> (e -> Ghc a) -> Ghc a
MonadCatch, MonadCatch Ghc
MonadCatch Ghc
-> (forall b. ((forall a. Ghc a -> Ghc a) -> Ghc b) -> Ghc b)
-> (forall b. ((forall a. Ghc a -> Ghc a) -> Ghc b) -> Ghc b)
-> (forall a b c.
Ghc a -> (a -> ExitCase b -> Ghc c) -> (a -> Ghc b) -> Ghc (b, c))
-> MonadMask Ghc
forall b. ((forall a. Ghc a -> Ghc a) -> Ghc b) -> Ghc b
forall a b c.
Ghc a -> (a -> ExitCase b -> Ghc c) -> (a -> Ghc b) -> Ghc (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.
Ghc a -> (a -> ExitCase b -> Ghc c) -> (a -> Ghc b) -> Ghc (b, c)
$cgeneralBracket :: forall a b c.
Ghc a -> (a -> ExitCase b -> Ghc c) -> (a -> Ghc b) -> Ghc (b, c)
uninterruptibleMask :: forall b. ((forall a. Ghc a -> Ghc a) -> Ghc b) -> Ghc b
$cuninterruptibleMask :: forall b. ((forall a. Ghc a -> Ghc a) -> Ghc b) -> Ghc b
mask :: forall b. ((forall a. Ghc a -> Ghc a) -> Ghc b) -> Ghc b
$cmask :: forall b. ((forall a. Ghc a -> Ghc a) -> Ghc b) -> Ghc b
MonadMask) via (ReaderT Session IO)
data Session = Session !(IORef HscEnv)
instance Applicative Ghc where
pure :: forall a. a -> Ghc a
pure a
a = (Session -> IO a) -> Ghc a
forall a. (Session -> IO a) -> Ghc a
Ghc ((Session -> IO a) -> Ghc a) -> (Session -> IO a) -> Ghc a
forall a b. (a -> b) -> a -> b
$ \Session
_ -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
Ghc (a -> b)
g <*> :: forall a b. Ghc (a -> b) -> Ghc a -> Ghc b
<*> Ghc a
m = do a -> b
f <- Ghc (a -> b)
g; a
a <- Ghc a
m; b -> Ghc b
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f a
a)
instance Monad Ghc where
Ghc a
m >>= :: forall a b. Ghc a -> (a -> Ghc b) -> Ghc b
>>= a -> Ghc b
g = (Session -> IO b) -> Ghc b
forall a. (Session -> IO a) -> Ghc a
Ghc ((Session -> IO b) -> Ghc b) -> (Session -> IO b) -> Ghc b
forall a b. (a -> b) -> a -> b
$ \Session
s -> do a
a <- Ghc a -> Session -> IO a
forall a. Ghc a -> Session -> IO a
unGhc Ghc a
m Session
s; Ghc b -> Session -> IO b
forall a. Ghc a -> Session -> IO a
unGhc (a -> Ghc b
g a
a) Session
s
instance MonadIO Ghc where
liftIO :: forall a. IO a -> Ghc a
liftIO IO a
ioA = (Session -> IO a) -> Ghc a
forall a. (Session -> IO a) -> Ghc a
Ghc ((Session -> IO a) -> Ghc a) -> (Session -> IO a) -> Ghc a
forall a b. (a -> b) -> a -> b
$ \Session
_ -> IO a
ioA
instance MonadFix Ghc where
mfix :: forall a. (a -> Ghc a) -> Ghc a
mfix a -> Ghc a
f = (Session -> IO a) -> Ghc a
forall a. (Session -> IO a) -> Ghc a
Ghc ((Session -> IO a) -> Ghc a) -> (Session -> IO a) -> Ghc a
forall a b. (a -> b) -> a -> b
$ \Session
s -> (a -> IO a) -> IO a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (\a
x -> Ghc a -> Session -> IO a
forall a. Ghc a -> Session -> IO a
unGhc (a -> Ghc a
f a
x) Session
s)
instance HasDynFlags Ghc where
getDynFlags :: Ghc DynFlags
getDynFlags = Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
instance HasLogger Ghc where
getLogger :: Ghc Logger
getLogger = HscEnv -> Logger
hsc_logger (HscEnv -> Logger) -> Ghc HscEnv -> Ghc Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ghc HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
instance GhcMonad Ghc where
getSession :: Ghc HscEnv
getSession = (Session -> IO HscEnv) -> Ghc HscEnv
forall a. (Session -> IO a) -> Ghc a
Ghc ((Session -> IO HscEnv) -> Ghc HscEnv)
-> (Session -> IO HscEnv) -> Ghc HscEnv
forall a b. (a -> b) -> a -> b
$ \(Session IORef HscEnv
r) -> IORef HscEnv -> IO HscEnv
forall a. IORef a -> IO a
readIORef IORef HscEnv
r
setSession :: HscEnv -> Ghc ()
setSession HscEnv
s' = (Session -> IO ()) -> Ghc ()
forall a. (Session -> IO a) -> Ghc a
Ghc ((Session -> IO ()) -> Ghc ()) -> (Session -> IO ()) -> Ghc ()
forall a b. (a -> b) -> a -> b
$ \(Session IORef HscEnv
r) -> IORef HscEnv -> HscEnv -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef HscEnv
r HscEnv
s'
reflectGhc :: Ghc a -> Session -> IO a
reflectGhc :: forall a. Ghc a -> Session -> IO a
reflectGhc Ghc a
m = Ghc a -> Session -> IO a
forall a. Ghc a -> Session -> IO a
unGhc Ghc a
m
reifyGhc :: (Session -> IO a) -> Ghc a
reifyGhc :: forall a. (Session -> IO a) -> Ghc a
reifyGhc Session -> IO a
act = (Session -> IO a) -> Ghc a
forall a. (Session -> IO a) -> Ghc a
Ghc ((Session -> IO a) -> Ghc a) -> (Session -> IO a) -> Ghc a
forall a b. (a -> b) -> a -> b
$ Session -> IO a
act
newtype GhcT m a = GhcT { forall (m :: * -> *) a. GhcT m a -> Session -> m a
unGhcT :: Session -> m a }
deriving ((forall a b. (a -> b) -> GhcT m a -> GhcT m b)
-> (forall a b. a -> GhcT m b -> GhcT m a) -> Functor (GhcT m)
forall a b. a -> GhcT m b -> GhcT m a
forall a b. (a -> b) -> GhcT m a -> GhcT m b
forall (m :: * -> *) a b. Functor m => a -> GhcT m b -> GhcT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GhcT m a -> GhcT 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 -> GhcT m b -> GhcT m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> GhcT m b -> GhcT m a
fmap :: forall a b. (a -> b) -> GhcT m a -> GhcT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GhcT m a -> GhcT m b
Functor)
deriving (Monad (GhcT m)
Monad (GhcT m)
-> (forall e a. Exception e => e -> GhcT m a)
-> MonadThrow (GhcT m)
forall e a. Exception e => e -> GhcT m a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
forall {m :: * -> *}. MonadThrow m => Monad (GhcT m)
forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> GhcT m a
throwM :: forall e a. Exception e => e -> GhcT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> GhcT m a
MonadThrow, MonadThrow (GhcT m)
MonadThrow (GhcT m)
-> (forall e a.
Exception e =>
GhcT m a -> (e -> GhcT m a) -> GhcT m a)
-> MonadCatch (GhcT m)
forall e a. Exception e => GhcT m a -> (e -> GhcT m a) -> GhcT m a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
forall {m :: * -> *}. MonadCatch m => MonadThrow (GhcT m)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
GhcT m a -> (e -> GhcT m a) -> GhcT m a
catch :: forall e a. Exception e => GhcT m a -> (e -> GhcT m a) -> GhcT m a
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
GhcT m a -> (e -> GhcT m a) -> GhcT m a
MonadCatch, MonadCatch (GhcT m)
MonadCatch (GhcT m)
-> (forall b.
((forall a. GhcT m a -> GhcT m a) -> GhcT m b) -> GhcT m b)
-> (forall b.
((forall a. GhcT m a -> GhcT m a) -> GhcT m b) -> GhcT m b)
-> (forall a b c.
GhcT m a
-> (a -> ExitCase b -> GhcT m c)
-> (a -> GhcT m b)
-> GhcT m (b, c))
-> MonadMask (GhcT m)
forall b.
((forall a. GhcT m a -> GhcT m a) -> GhcT m b) -> GhcT m b
forall a b c.
GhcT m a
-> (a -> ExitCase b -> GhcT m c)
-> (a -> GhcT m b)
-> GhcT m (b, c)
forall {m :: * -> *}. MonadMask m => MonadCatch (GhcT m)
forall (m :: * -> *) b.
MonadMask m =>
((forall a. GhcT m a -> GhcT m a) -> GhcT m b) -> GhcT m b
forall (m :: * -> *) a b c.
MonadMask m =>
GhcT m a
-> (a -> ExitCase b -> GhcT m c)
-> (a -> GhcT m b)
-> GhcT 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.
GhcT m a
-> (a -> ExitCase b -> GhcT m c)
-> (a -> GhcT m b)
-> GhcT m (b, c)
$cgeneralBracket :: forall (m :: * -> *) a b c.
MonadMask m =>
GhcT m a
-> (a -> ExitCase b -> GhcT m c)
-> (a -> GhcT m b)
-> GhcT m (b, c)
uninterruptibleMask :: forall b.
((forall a. GhcT m a -> GhcT m a) -> GhcT m b) -> GhcT m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. GhcT m a -> GhcT m a) -> GhcT m b) -> GhcT m b
mask :: forall b.
((forall a. GhcT m a -> GhcT m a) -> GhcT m b) -> GhcT m b
$cmask :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. GhcT m a -> GhcT m a) -> GhcT m b) -> GhcT m b
MonadMask) via (ReaderT Session m)
liftGhcT :: m a -> GhcT m a
liftGhcT :: forall (m :: * -> *) a. m a -> GhcT m a
liftGhcT m a
m = (Session -> m a) -> GhcT m a
forall (m :: * -> *) a. (Session -> m a) -> GhcT m a
GhcT ((Session -> m a) -> GhcT m a) -> (Session -> m a) -> GhcT m a
forall a b. (a -> b) -> a -> b
$ \Session
_ -> m a
m
instance Applicative m => Applicative (GhcT m) where
pure :: forall a. a -> GhcT m a
pure a
x = (Session -> m a) -> GhcT m a
forall (m :: * -> *) a. (Session -> m a) -> GhcT m a
GhcT ((Session -> m a) -> GhcT m a) -> (Session -> m a) -> GhcT m a
forall a b. (a -> b) -> a -> b
$ \Session
_ -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
GhcT m (a -> b)
g <*> :: forall a b. GhcT m (a -> b) -> GhcT m a -> GhcT m b
<*> GhcT m a
m = (Session -> m b) -> GhcT m b
forall (m :: * -> *) a. (Session -> m a) -> GhcT m a
GhcT ((Session -> m b) -> GhcT m b) -> (Session -> m b) -> GhcT m b
forall a b. (a -> b) -> a -> b
$ \Session
s -> GhcT m (a -> b) -> Session -> m (a -> b)
forall (m :: * -> *) a. GhcT m a -> Session -> m a
unGhcT GhcT m (a -> b)
g Session
s m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GhcT m a -> Session -> m a
forall (m :: * -> *) a. GhcT m a -> Session -> m a
unGhcT GhcT m a
m Session
s
instance Monad m => Monad (GhcT m) where
GhcT m a
m >>= :: forall a b. GhcT m a -> (a -> GhcT m b) -> GhcT m b
>>= a -> GhcT m b
k = (Session -> m b) -> GhcT m b
forall (m :: * -> *) a. (Session -> m a) -> GhcT m a
GhcT ((Session -> m b) -> GhcT m b) -> (Session -> m b) -> GhcT m b
forall a b. (a -> b) -> a -> b
$ \Session
s -> do a
a <- GhcT m a -> Session -> m a
forall (m :: * -> *) a. GhcT m a -> Session -> m a
unGhcT GhcT m a
m Session
s; GhcT m b -> Session -> m b
forall (m :: * -> *) a. GhcT m a -> Session -> m a
unGhcT (a -> GhcT m b
k a
a) Session
s
instance MonadIO m => MonadIO (GhcT m) where
liftIO :: forall a. IO a -> GhcT m a
liftIO IO a
ioA = (Session -> m a) -> GhcT m a
forall (m :: * -> *) a. (Session -> m a) -> GhcT m a
GhcT ((Session -> m a) -> GhcT m a) -> (Session -> m a) -> GhcT m a
forall a b. (a -> b) -> a -> b
$ \Session
_ -> IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
ioA
instance MonadIO m => HasDynFlags (GhcT m) where
getDynFlags :: GhcT m DynFlags
getDynFlags = (Session -> m DynFlags) -> GhcT m DynFlags
forall (m :: * -> *) a. (Session -> m a) -> GhcT m a
GhcT ((Session -> m DynFlags) -> GhcT m DynFlags)
-> (Session -> m DynFlags) -> GhcT m DynFlags
forall a b. (a -> b) -> a -> b
$ \(Session IORef HscEnv
r) -> (HscEnv -> DynFlags) -> m HscEnv -> m DynFlags
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM HscEnv -> DynFlags
hsc_dflags (IO HscEnv -> m HscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> m HscEnv) -> IO HscEnv -> m HscEnv
forall a b. (a -> b) -> a -> b
$ IORef HscEnv -> IO HscEnv
forall a. IORef a -> IO a
readIORef IORef HscEnv
r)
instance MonadIO m => HasLogger (GhcT m) where
getLogger :: GhcT m Logger
getLogger = (Session -> m Logger) -> GhcT m Logger
forall (m :: * -> *) a. (Session -> m a) -> GhcT m a
GhcT ((Session -> m Logger) -> GhcT m Logger)
-> (Session -> m Logger) -> GhcT m Logger
forall a b. (a -> b) -> a -> b
$ \(Session IORef HscEnv
r) -> (HscEnv -> Logger) -> m HscEnv -> m Logger
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM HscEnv -> Logger
hsc_logger (IO HscEnv -> m HscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> m HscEnv) -> IO HscEnv -> m HscEnv
forall a b. (a -> b) -> a -> b
$ IORef HscEnv -> IO HscEnv
forall a. IORef a -> IO a
readIORef IORef HscEnv
r)
instance ExceptionMonad m => GhcMonad (GhcT m) where
getSession :: GhcT m HscEnv
getSession = (Session -> m HscEnv) -> GhcT m HscEnv
forall (m :: * -> *) a. (Session -> m a) -> GhcT m a
GhcT ((Session -> m HscEnv) -> GhcT m HscEnv)
-> (Session -> m HscEnv) -> GhcT m HscEnv
forall a b. (a -> b) -> a -> b
$ \(Session IORef HscEnv
r) -> IO HscEnv -> m HscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> m HscEnv) -> IO HscEnv -> m HscEnv
forall a b. (a -> b) -> a -> b
$ IORef HscEnv -> IO HscEnv
forall a. IORef a -> IO a
readIORef IORef HscEnv
r
setSession :: HscEnv -> GhcT m ()
setSession HscEnv
s' = (Session -> m ()) -> GhcT m ()
forall (m :: * -> *) a. (Session -> m a) -> GhcT m a
GhcT ((Session -> m ()) -> GhcT m ()) -> (Session -> m ()) -> GhcT m ()
forall a b. (a -> b) -> a -> b
$ \(Session IORef HscEnv
r) -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef HscEnv -> HscEnv -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef HscEnv
r HscEnv
s'
printException :: GhcMonad m => SourceError -> m ()
printException :: forall (m :: * -> *). GhcMonad m => SourceError -> m ()
printException SourceError
err = do
DynFlags
dflags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> WarningMessages -> IO ()
forall a.
RenderableDiagnostic a =>
Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO ()
printBagOfErrors Logger
logger DynFlags
dflags (SourceError -> WarningMessages
srcErrorMessages SourceError
err)
type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m ()
defaultWarnErrLogger :: WarnErrLogger
defaultWarnErrLogger :: WarnErrLogger
defaultWarnErrLogger Maybe SourceError
Nothing = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
defaultWarnErrLogger (Just SourceError
e) = SourceError -> m ()
forall (m :: * -> *). GhcMonad m => SourceError -> m ()
printException SourceError
e