{-# LANGUAGE DeriveFunctor, DerivingVia, RankNTypes #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow, 2010
--
-- The Session type and related functionality
--
-- -----------------------------------------------------------------------------

module GHC.Driver.Monad (
        -- * 'Ghc' monad stuff
        GhcMonad(..),
        Ghc(..),
        GhcT(..), liftGhcT,
        reflectGhc, reifyGhc,
        getSessionDynFlags,
        liftIO,
        Session(..), withSession, modifySession, modifySessionM,
        withTempSession,

        -- * Logger
        modifyLogger,
        pushLogHookM,
        popLogHookM,
        putLogMsgM,
        putMsgM,
        withTimingM,

        -- ** Diagnostics
        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

-- -----------------------------------------------------------------------------
-- | A monad that has all the features needed by GHC API calls.
--
-- In short, a GHC monad
--
--   - allows embedding of IO actions,
--
--   - can log warnings,
--
--   - allows handling of (extensible) exceptions, and
--
--   - maintains a current session.
--
-- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad'
-- before any call to the GHC API functions can occur.
--
class (Functor m, ExceptionMonad m, HasDynFlags m, HasLogger m ) => GhcMonad m where
  getSession :: m HscEnv
  setSession :: HscEnv -> m ()

-- | Call the argument with the current session.
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

-- | Grabs the DynFlags from the Session
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)

-- | Set the current session to the result of applying the current session to
-- the argument.
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

-- | Set the current session to the result of applying the current session to
-- the argument.
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.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`MC.finally` HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
saved_session

-- | Call an action with a temporarily modified 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

----------------------------------------
-- Logging
----------------------------------------

-- | Modify the logger
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 = f (hsc_logger hsc_env) }

-- | Push a log hook on the stack
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

-- | Pop a log hook from the stack
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

-- | Put a log message
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

-- | Put a log message
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

-- | Time an action
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

-- -----------------------------------------------------------------------------
-- | A monad that allows logging of diagnostics.

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
      !print_config :: DiagnosticOpts GhcMessage
print_config = DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig 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
-> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics Logger
logger DiagnosticOpts GhcMessage
GhcMessageOpts
print_config DiagOpts
diag_opts Messages GhcMessage
warns

-- -----------------------------------------------------------------------------
-- | A minimal implementation of a 'GhcMonad'.  If you need a custom monad,
-- e.g., to maintain additional state consider wrapping this monad or using
-- 'GhcT'.
newtype Ghc a = Ghc { forall a. Ghc a -> Session -> IO a
unGhc :: Session -> IO a }
  deriving stock ((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 (Functor Ghc
Functor Ghc =>
(forall a. a -> Ghc a)
-> (forall a b. Ghc (a -> b) -> Ghc a -> Ghc b)
-> (forall a b c. (a -> b -> c) -> Ghc a -> Ghc b -> Ghc c)
-> (forall a b. Ghc a -> Ghc b -> Ghc b)
-> (forall a b. Ghc a -> Ghc b -> Ghc a)
-> Applicative Ghc
forall a. a -> Ghc a
forall a b. Ghc a -> Ghc b -> Ghc a
forall a b. Ghc a -> Ghc b -> Ghc b
forall a b. Ghc (a -> b) -> Ghc a -> Ghc b
forall a b c. (a -> b -> c) -> Ghc a -> Ghc b -> Ghc c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Ghc a
pure :: forall a. a -> Ghc a
$c<*> :: forall a b. Ghc (a -> b) -> Ghc a -> Ghc b
<*> :: forall a b. Ghc (a -> b) -> Ghc a -> Ghc b
$cliftA2 :: forall a b c. (a -> b -> c) -> Ghc a -> Ghc b -> Ghc c
liftA2 :: forall a b c. (a -> b -> c) -> Ghc a -> Ghc b -> Ghc c
$c*> :: forall a b. Ghc a -> Ghc b -> Ghc b
*> :: forall a b. Ghc a -> Ghc b -> Ghc b
$c<* :: forall a b. Ghc a -> Ghc b -> Ghc a
<* :: forall a b. Ghc a -> Ghc b -> Ghc a
Applicative, Applicative Ghc
Applicative Ghc =>
(forall a b. Ghc a -> (a -> Ghc b) -> Ghc b)
-> (forall a b. Ghc a -> Ghc b -> Ghc b)
-> (forall a. a -> Ghc a)
-> Monad Ghc
forall a. a -> Ghc a
forall a b. Ghc a -> Ghc b -> Ghc b
forall a b. Ghc a -> (a -> Ghc b) -> Ghc 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
$c>>= :: forall a b. Ghc a -> (a -> Ghc b) -> Ghc b
>>= :: forall a b. Ghc a -> (a -> Ghc b) -> Ghc b
$c>> :: forall a b. Ghc a -> Ghc b -> Ghc b
>> :: forall a b. Ghc a -> Ghc b -> Ghc b
$creturn :: forall a. a -> Ghc a
return :: forall a. a -> Ghc a
Monad, Monad Ghc
Monad Ghc => (forall a. String -> Ghc a) -> MonadFail Ghc
forall a. String -> Ghc a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
$cfail :: forall a. String -> Ghc a
fail :: forall a. String -> Ghc a
MonadFail, Monad Ghc
Monad Ghc => (forall a. (a -> Ghc a) -> Ghc a) -> MonadFix Ghc
forall a. (a -> Ghc a) -> Ghc a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
$cmfix :: forall a. (a -> Ghc a) -> Ghc a
mfix :: forall a. (a -> Ghc a) -> Ghc a
MonadFix, Monad Ghc
Monad Ghc =>
(forall e a. (HasCallStack, Exception e) => e -> Ghc a)
-> MonadThrow Ghc
forall e a. (HasCallStack, Exception e) => e -> Ghc a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e a. (HasCallStack, Exception e) => e -> Ghc a
throwM :: forall e a. (HasCallStack, Exception e) => e -> Ghc a
MonadThrow, MonadThrow Ghc
MonadThrow Ghc =>
(forall e a.
 (HasCallStack, Exception e) =>
 Ghc a -> (e -> Ghc a) -> Ghc a)
-> MonadCatch Ghc
forall e a.
(HasCallStack, Exception e) =>
Ghc a -> (e -> Ghc a) -> Ghc a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall e a.
(HasCallStack, Exception e) =>
Ghc a -> (e -> Ghc a) -> Ghc a
catch :: forall e a.
(HasCallStack, Exception e) =>
Ghc a -> (e -> Ghc a) -> Ghc a
MonadCatch, MonadCatch Ghc
MonadCatch Ghc =>
(forall b.
 HasCallStack =>
 ((forall a. Ghc a -> Ghc a) -> Ghc b) -> Ghc b)
-> (forall b.
    HasCallStack =>
    ((forall a. Ghc a -> Ghc a) -> Ghc b) -> Ghc b)
-> (forall a b c.
    HasCallStack =>
    Ghc a -> (a -> ExitCase b -> Ghc c) -> (a -> Ghc b) -> Ghc (b, c))
-> MonadMask Ghc
forall b.
HasCallStack =>
((forall a. Ghc a -> Ghc a) -> Ghc b) -> Ghc b
forall a b c.
HasCallStack =>
Ghc a -> (a -> ExitCase b -> Ghc c) -> (a -> Ghc b) -> Ghc (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall b.
HasCallStack =>
((forall a. Ghc a -> Ghc a) -> Ghc b) -> Ghc b
mask :: forall b.
HasCallStack =>
((forall a. Ghc a -> Ghc a) -> Ghc b) -> Ghc b
$cuninterruptibleMask :: forall b.
HasCallStack =>
((forall a. Ghc a -> Ghc a) -> Ghc b) -> Ghc b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. Ghc a -> Ghc a) -> Ghc b) -> Ghc b
$cgeneralBracket :: forall a b c.
HasCallStack =>
Ghc a -> (a -> ExitCase b -> Ghc c) -> (a -> Ghc b) -> Ghc (b, c)
generalBracket :: forall a b c.
HasCallStack =>
Ghc a -> (a -> ExitCase b -> Ghc c) -> (a -> Ghc b) -> Ghc (b, c)
MonadMask, Monad Ghc
Monad Ghc => (forall a. IO a -> Ghc a) -> MonadIO Ghc
forall a. IO a -> Ghc a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> Ghc a
liftIO :: forall a. IO a -> Ghc a
MonadIO) via (ReaderT Session IO)

-- | The Session is a handle to the complete state of a compilation
-- session.  A compilation session consists of a set of modules
-- constituting the current program or library, the context for
-- interactive evaluation, and various caches.
data Session = Session !(IORef HscEnv)

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'

-- | Reflect a computation in the 'Ghc' monad into the 'IO' monad.
--
-- You can use this to call functions returning an action in the 'Ghc' monad
-- inside an 'IO' action.  This is needed for some (too restrictive) callback
-- arguments of some library functions:
--
-- > libFunc :: String -> (Int -> IO a) -> IO a
-- > ghcFunc :: Int -> Ghc a
-- >
-- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a
-- > ghcFuncUsingLibFunc str =
-- >   reifyGhc $ \s ->
-- >     libFunc $ \i -> do
-- >       reflectGhc (ghcFunc i) 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

-- > Dual to 'reflectGhc'.  See its documentation.
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

-- -----------------------------------------------------------------------------
-- | A monad transformer to add GHC specific features to another monad.
--
-- Note that the wrapped monad must support IO and handling of exceptions.
newtype GhcT m a = GhcT { forall (m :: * -> *) a. GhcT m a -> Session -> m a
unGhcT :: Session -> m a }
  deriving stock ((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 (Functor (GhcT m)
Functor (GhcT m) =>
(forall a. a -> GhcT m a)
-> (forall a b. GhcT m (a -> b) -> GhcT m a -> GhcT m b)
-> (forall a b c.
    (a -> b -> c) -> GhcT m a -> GhcT m b -> GhcT m c)
-> (forall a b. GhcT m a -> GhcT m b -> GhcT m b)
-> (forall a b. GhcT m a -> GhcT m b -> GhcT m a)
-> Applicative (GhcT m)
forall a. a -> GhcT m a
forall a b. GhcT m a -> GhcT m b -> GhcT m a
forall a b. GhcT m a -> GhcT m b -> GhcT m b
forall a b. GhcT m (a -> b) -> GhcT m a -> GhcT m b
forall a b c. (a -> b -> c) -> GhcT m a -> GhcT m b -> GhcT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (GhcT m)
forall (m :: * -> *) a. Applicative m => a -> GhcT m a
forall (m :: * -> *) a b.
Applicative m =>
GhcT m a -> GhcT m b -> GhcT m a
forall (m :: * -> *) a b.
Applicative m =>
GhcT m a -> GhcT m b -> GhcT m b
forall (m :: * -> *) a b.
Applicative m =>
GhcT m (a -> b) -> GhcT m a -> GhcT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> GhcT m a -> GhcT m b -> GhcT m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> GhcT m a
pure :: forall a. a -> GhcT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
GhcT m (a -> b) -> GhcT m a -> GhcT m b
<*> :: forall a b. GhcT m (a -> b) -> GhcT m a -> GhcT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> GhcT m a -> GhcT m b -> GhcT m c
liftA2 :: forall a b c. (a -> b -> c) -> GhcT m a -> GhcT m b -> GhcT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
GhcT m a -> GhcT m b -> GhcT m b
*> :: forall a b. GhcT m a -> GhcT m b -> GhcT m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
GhcT m a -> GhcT m b -> GhcT m a
<* :: forall a b. GhcT m a -> GhcT m b -> GhcT m a
Applicative, Applicative (GhcT m)
Applicative (GhcT m) =>
(forall a b. GhcT m a -> (a -> GhcT m b) -> GhcT m b)
-> (forall a b. GhcT m a -> GhcT m b -> GhcT m b)
-> (forall a. a -> GhcT m a)
-> Monad (GhcT m)
forall a. a -> GhcT m a
forall a b. GhcT m a -> GhcT m b -> GhcT m b
forall a b. GhcT m a -> (a -> GhcT m b) -> GhcT m b
forall (m :: * -> *). Monad m => Applicative (GhcT m)
forall (m :: * -> *) a. Monad m => a -> GhcT m a
forall (m :: * -> *) a b.
Monad m =>
GhcT m a -> GhcT m b -> GhcT m b
forall (m :: * -> *) a b.
Monad m =>
GhcT m a -> (a -> GhcT m b) -> GhcT 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
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
GhcT m a -> (a -> GhcT m b) -> GhcT m b
>>= :: forall a b. GhcT m a -> (a -> GhcT m b) -> GhcT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
GhcT m a -> GhcT m b -> GhcT m b
>> :: forall a b. GhcT m a -> GhcT m b -> GhcT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> GhcT m a
return :: forall a. a -> GhcT m a
Monad, Monad (GhcT m)
Monad (GhcT m) =>
(forall a. String -> GhcT m a) -> MonadFail (GhcT m)
forall a. String -> GhcT m a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
forall (m :: * -> *). MonadFail m => Monad (GhcT m)
forall (m :: * -> *) a. MonadFail m => String -> GhcT m a
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> GhcT m a
fail :: forall a. String -> GhcT m a
MonadFail, Monad (GhcT m)
Monad (GhcT m) =>
(forall a. (a -> GhcT m a) -> GhcT m a) -> MonadFix (GhcT m)
forall a. (a -> GhcT m a) -> GhcT m a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
forall (m :: * -> *). MonadFix m => Monad (GhcT m)
forall (m :: * -> *) a. MonadFix m => (a -> GhcT m a) -> GhcT m a
$cmfix :: forall (m :: * -> *) a. MonadFix m => (a -> GhcT m a) -> GhcT m a
mfix :: forall a. (a -> GhcT m a) -> GhcT m a
MonadFix, Monad (GhcT m)
Monad (GhcT m) =>
(forall e a. (HasCallStack, Exception e) => e -> GhcT m a)
-> MonadThrow (GhcT m)
forall e a. (HasCallStack, Exception e) => e -> GhcT m a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
forall (m :: * -> *). MonadThrow m => Monad (GhcT m)
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> GhcT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> GhcT m a
throwM :: forall e a. (HasCallStack, Exception e) => e -> GhcT m a
MonadThrow, MonadThrow (GhcT m)
MonadThrow (GhcT m) =>
(forall e a.
 (HasCallStack, Exception e) =>
 GhcT m a -> (e -> GhcT m a) -> GhcT m a)
-> MonadCatch (GhcT m)
forall e a.
(HasCallStack, 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, HasCallStack, Exception e) =>
GhcT m a -> (e -> GhcT m a) -> GhcT m a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
GhcT m a -> (e -> GhcT m a) -> GhcT m a
catch :: forall e a.
(HasCallStack, Exception e) =>
GhcT m a -> (e -> GhcT m a) -> GhcT m a
MonadCatch, MonadCatch (GhcT m)
MonadCatch (GhcT m) =>
(forall b.
 HasCallStack =>
 ((forall a. GhcT m a -> GhcT m a) -> GhcT m b) -> GhcT m b)
-> (forall b.
    HasCallStack =>
    ((forall a. GhcT m a -> GhcT m a) -> GhcT m b) -> GhcT m b)
-> (forall a b c.
    HasCallStack =>
    GhcT m a
    -> (a -> ExitCase b -> GhcT m c)
    -> (a -> GhcT m b)
    -> GhcT m (b, c))
-> MonadMask (GhcT m)
forall b.
HasCallStack =>
((forall a. GhcT m a -> GhcT m a) -> GhcT m b) -> GhcT m b
forall a b c.
HasCallStack =>
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, HasCallStack) =>
((forall a. GhcT m a -> GhcT m a) -> GhcT m b) -> GhcT m b
forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
GhcT m a
-> (a -> ExitCase b -> GhcT m c)
-> (a -> GhcT m b)
-> GhcT m (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. GhcT m a -> GhcT m a) -> GhcT m b) -> GhcT m b
mask :: forall b.
HasCallStack =>
((forall a. GhcT m a -> GhcT m a) -> GhcT m b) -> GhcT m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. GhcT m a -> GhcT m a) -> GhcT m b) -> GhcT m b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. GhcT m a -> GhcT m a) -> GhcT m b) -> GhcT m b
$cgeneralBracket :: forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
GhcT m a
-> (a -> ExitCase b -> GhcT m c)
-> (a -> GhcT m b)
-> GhcT m (b, c)
generalBracket :: forall a b c.
HasCallStack =>
GhcT m a
-> (a -> ExitCase b -> GhcT m c)
-> (a -> GhcT m b)
-> GhcT m (b, c)
MonadMask, Monad (GhcT m)
Monad (GhcT m) => (forall a. IO a -> GhcT m a) -> MonadIO (GhcT m)
forall a. IO a -> GhcT m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (GhcT m)
forall (m :: * -> *) a. MonadIO m => IO a -> GhcT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> GhcT m a
liftIO :: forall a. IO a -> GhcT m a
MonadIO) 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 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'


-- | Print the all diagnostics in a 'SourceError'.  Useful inside exception
--   handlers.
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
      !print_config :: DiagnosticOpts GhcMessage
print_config = DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig 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
-> DiagnosticOpts GhcMessage
-> DiagOpts
-> Messages GhcMessage
-> IO ()
forall a.
Diagnostic a =>
Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
printMessages Logger
logger DiagnosticOpts GhcMessage
print_config DiagOpts
diag_opts (SourceError -> Messages GhcMessage
srcErrorMessages SourceError
err)

-- | A function called to log warnings and errors.
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