{-# LANGUAGE 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,
logDiagnostics, printException,
WarnErrLogger, defaultWarnErrLogger
) where
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Env
import GHC.Driver.Errors ( printOrThrowDiagnostics, printMessages )
import GHC.Driver.Errors.Types
import GHC.Driver.Config.Diagnostic
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 a b. m a -> (a -> m b) -> m b
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 a. a -> m a
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 a b. m a -> m b -> m b
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
Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
putMsg Logger
logger SDoc
doc
putLogMsgM :: GhcMonad m => MessageClass -> SrcSpan -> SDoc -> m ()
putLogMsgM :: forall (m :: * -> *).
GhcMonad m =>
MessageClass -> SrcSpan -> SDoc -> m ()
putLogMsgM MessageClass
msg_class SrcSpan
loc SDoc
doc = do
Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> MessageClass -> SrcSpan -> SDoc -> IO ()
logMsg Logger
logger MessageClass
msg_class 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
Logger -> SDoc -> (b -> ()) -> m b -> m b
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger SDoc
doc b -> ()
force m b
action
logDiagnostics :: GhcMonad m => Messages GhcMessage -> m ()
logDiagnostics :: forall (m :: * -> *). GhcMonad m => Messages GhcMessage -> m ()
logDiagnostics Messages GhcMessage
warns = do
DynFlags
dflags <- m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
let !diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics Logger
logger DiagOpts
diag_opts Messages GhcMessage
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
$cfmap :: forall a b. (a -> b) -> Ghc a -> Ghc b
fmap :: forall a b. (a -> b) -> Ghc a -> Ghc b
$c<$ :: forall a b. a -> Ghc b -> Ghc a
<$ :: forall a b. a -> Ghc b -> Ghc a
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
$cthrowM :: forall e a. Exception e => e -> Ghc a
throwM :: 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
$ccatch :: forall e a. Exception e => Ghc a -> (e -> Ghc a) -> Ghc a
catch :: 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
$cmask :: 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
$cuninterruptibleMask :: forall b. ((forall a. Ghc a -> Ghc a) -> Ghc b) -> Ghc b
uninterruptibleMask :: forall b. ((forall a. Ghc a -> Ghc a) -> Ghc b) -> Ghc b
$cgeneralBracket :: forall a b c.
Ghc a -> (a -> ExitCase b -> Ghc c) -> (a -> Ghc b) -> Ghc (b, c)
generalBracket :: forall a b c.
Ghc a -> (a -> ExitCase b -> Ghc c) -> (a -> Ghc b) -> Ghc (b, c)
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 a. 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 a. a -> Ghc a
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 a. (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
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GhcT m a -> GhcT m b
fmap :: forall a b. (a -> b) -> GhcT m a -> GhcT m b
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> GhcT m b -> GhcT m a
<$ :: forall a b. a -> GhcT m b -> GhcT m a
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
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> GhcT m a
throwM :: forall e a. 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 :: * -> *}. MonadCatch m => MonadThrow (GhcT m)
forall (m :: * -> *) e a.
(MonadCatch m, 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
$ccatch :: 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
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
$cmask :: 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
$cuninterruptibleMask :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. GhcT m a -> GhcT m a) -> GhcT m b) -> GhcT m b
uninterruptibleMask :: forall b.
((forall a. GhcT m a -> GhcT m a) -> GhcT m b) -> GhcT m b
$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)
generalBracket :: forall a b c.
GhcT m a
-> (a -> ExitCase b -> GhcT m c)
-> (a -> GhcT m b)
-> GhcT m (b, c)
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 a. 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 a b. 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 a. 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 a. IO a -> m a
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 a. IO a -> m a
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 a. IO a -> m a
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 a. IO a -> m a
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 :: (HasLogger m, MonadIO m, HasDynFlags m) => SourceError -> m ()
printException :: forall (m :: * -> *).
(HasLogger m, MonadIO m, HasDynFlags m) =>
SourceError -> m ()
printException SourceError
err = do
DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- m Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
let !diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger -> DiagOpts -> Messages GhcMessage -> IO ()
forall a. Diagnostic a => Logger -> DiagOpts -> Messages a -> IO ()
printMessages Logger
logger DiagOpts
diag_opts (SourceError -> Messages GhcMessage
srcErrorMessages SourceError
err)
type WarnErrLogger = forall m. (HasDynFlags m , MonadIO m, HasLogger m) => Maybe SourceError -> m ()
defaultWarnErrLogger :: WarnErrLogger
defaultWarnErrLogger :: WarnErrLogger
defaultWarnErrLogger Maybe SourceError
Nothing = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
defaultWarnErrLogger (Just SourceError
e) = SourceError -> m ()
forall (m :: * -> *).
(HasLogger m, MonadIO m, HasDynFlags m) =>
SourceError -> m ()
printException SourceError
e