+data Session = Session !(IORef HscEnv) !(IORef WarningMessages)
+
+mkSrcErr :: ErrorMessages -> SourceError
+srcErrorMessages :: SourceError -> ErrorMessages
+mkApiErr :: SDoc -> GhcApiError
+
+throwOneError :: MonadIO m => ErrMsg -> m ab
+throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err
+
+-- | A source error is an error that is caused by one or more errors in the
+-- source code. A 'SourceError' is thrown by many functions in the
+-- compilation pipeline. Inside GHC these errors are merely printed via
+-- 'log_action', but API clients may treat them differently, for example,
+-- insert them into a list box. If you want the default behaviour, use the
+-- idiom:
+--
+-- > handleSourceError printExceptionAndWarnings $ do
+-- > ... api calls that may fail ...
+--
+-- The 'SourceError's error messages can be accessed via 'srcErrorMessages'.
+-- This list may be empty if the compiler failed due to @-Werror@
+-- ('Opt_WarnIsError').
+--
+-- See 'printExceptionAndWarnings' for more information on what to take care
+-- of when writing a custom error handler.
+data SourceError = SourceError ErrorMessages
+
+instance Show SourceError where
+ show (SourceError msgs) = unlines . map show . bagToList $ msgs
+ -- ToDo: is there some nicer way to print this?
+
+sourceErrorTc :: Dyn.TyCon
+sourceErrorTc = Dyn.mkTyCon "SourceError"
+{-# NOINLINE sourceErrorTc #-}
+instance Typeable SourceError where
+ typeOf _ = Dyn.mkTyConApp sourceErrorTc []
+
+instance Exception SourceError
+
+mkSrcErr = SourceError
+
+-- | Perform the given action and call the exception handler if the action
+-- throws a 'SourceError'. See 'SourceError' for more information.
+handleSourceError :: (ExceptionMonad m) =>
+ (SourceError -> m a) -- ^ exception handler
+ -> m a -- ^ action to perform
+ -> m a
+handleSourceError handler act =
+ gcatch act (\(e :: SourceError) -> handler e)
+
+srcErrorMessages (SourceError msgs) = msgs
+
+-- | XXX: what exactly is an API error?
+data GhcApiError = GhcApiError SDoc
+
+instance Show GhcApiError where
+ show (GhcApiError msg) = showSDoc msg
+
+ghcApiErrorTc :: Dyn.TyCon
+ghcApiErrorTc = Dyn.mkTyCon "GhcApiError"
+{-# NOINLINE ghcApiErrorTc #-}
+instance Typeable GhcApiError where
+ typeOf _ = Dyn.mkTyConApp ghcApiErrorTc []
+
+instance Exception GhcApiError
+
+mkApiErr = GhcApiError
+
+-- | A monad that allows logging of warnings.
+class Monad m => WarnLogMonad m where
+ setWarnings :: WarningMessages -> m ()
+ getWarnings :: m WarningMessages
+
+logWarnings :: WarnLogMonad m => WarningMessages -> m ()
+logWarnings warns = do
+ warns0 <- getWarnings
+ setWarnings (unionBags warns warns0)
+
+-- | Clear the log of 'Warnings'.
+clearWarnings :: WarnLogMonad m => m ()
+clearWarnings = setWarnings emptyBag
+
+-- | Returns true if there were any warnings.
+hasWarnings :: WarnLogMonad m => m Bool
+hasWarnings = getWarnings >>= return . not . isEmptyBag
+
+-- | 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, MonadIO m, WarnLogMonad m, ExceptionMonad 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 f = getSession >>= f
+
+-- | Set the current session to the result of applying the current session to
+-- the argument.
+modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m ()
+modifySession f = do h <- getSession
+ setSession $! f h
+
+withSavedSession :: GhcMonad m => m a -> m a
+withSavedSession m = do
+ saved_session <- getSession
+ m `gfinally` setSession saved_session
+
+-- | Call an action with a temporarily modified Session.
+withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a
+withTempSession f m =
+ withSavedSession $ modifySession f >> m
+
+-- | 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 { unGhc :: Session -> IO a }
+
+instance Functor Ghc where
+ fmap f m = Ghc $ \s -> f `fmap` unGhc m s
+
+instance Monad Ghc where
+ return a = Ghc $ \_ -> return a
+ m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s
+
+instance MonadIO Ghc where
+ liftIO ioA = Ghc $ \_ -> ioA
+
+instance ExceptionMonad Ghc where
+ gcatch act handle =
+ Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s
+ gblock (Ghc m) = Ghc $ \s -> gblock (m s)
+ gunblock (Ghc m) = Ghc $ \s -> gunblock (m s)
+ gmask f =
+ Ghc $ \s -> gmask $ \io_restore ->
+ let
+ g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)
+ in
+ unGhc (f g_restore) s
+
+instance WarnLogMonad Ghc where
+ setWarnings warns = Ghc $ \(Session _ wref) -> writeIORef wref warns
+ -- | Return 'Warnings' accumulated so far.
+ getWarnings = Ghc $ \(Session _ wref) -> readIORef wref
+
+instance GhcMonad Ghc where
+ getSession = Ghc $ \(Session r _) -> readIORef r
+ setSession s' = Ghc $ \(Session r _) -> writeIORef r s'
+
+-- | 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 { unGhcT :: Session -> m a }
+liftGhcT :: Monad m => m a -> GhcT m a
+liftGhcT m = GhcT $ \_ -> m
+
+instance Functor m => Functor (GhcT m) where
+ fmap f m = GhcT $ \s -> f `fmap` unGhcT m s
+
+instance Monad m => Monad (GhcT m) where
+ return x = GhcT $ \_ -> return x
+ m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s
+
+instance MonadIO m => MonadIO (GhcT m) where
+ liftIO ioA = GhcT $ \_ -> liftIO ioA
+
+instance ExceptionMonad m => ExceptionMonad (GhcT m) where
+ gcatch act handle =
+ GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s
+ gblock (GhcT m) = GhcT $ \s -> gblock (m s)
+ gunblock (GhcT m) = GhcT $ \s -> gunblock (m s)
+ gmask f =
+ GhcT $ \s -> gmask $ \io_restore ->
+ let
+ g_restore (GhcT m) = GhcT $ \s -> io_restore (m s)
+ in
+ unGhcT (f g_restore) s
+
+instance MonadIO m => WarnLogMonad (GhcT m) where
+ setWarnings warns = GhcT $ \(Session _ wref) -> liftIO $ writeIORef wref warns
+ -- | Return 'Warnings' accumulated so far.
+ getWarnings = GhcT $ \(Session _ wref) -> liftIO $ readIORef wref
+
+instance (Functor m, ExceptionMonad m, MonadIO m) => GhcMonad (GhcT m) where
+ getSession = GhcT $ \(Session r _) -> liftIO $ readIORef r
+ setSession s' = GhcT $ \(Session r _) -> liftIO $ writeIORef r s'
+
+-- | Lift an IO action returning errors messages into a 'GhcMonad'.
+--
+-- In order to reduce dependencies to other parts of the compiler, functions
+-- outside the "main" parts of GHC return warnings and errors as a parameter
+-- and signal success via by wrapping the result in a 'Maybe' type. This
+-- function logs the returned warnings and propagates errors as exceptions
+-- (of type 'SourceError').
+--
+-- This function assumes the following invariants:
+--
+-- 1. If the second result indicates success (is of the form 'Just x'),
+-- there must be no error messages in the first result.
+--
+-- 2. If there are no error messages, but the second result indicates failure
+-- there should be warnings in the first result. That is, if the action
+-- failed, it must have been due to the warnings (i.e., @-Werror@).
+ioMsgMaybe :: GhcMonad m =>
+ IO (Messages, Maybe a) -> m a
+ioMsgMaybe ioA = do
+ ((warns,errs), mb_r) <- liftIO ioA
+ logWarnings warns
+ case mb_r of
+ Nothing -> liftIO $ throwIO (mkSrcErr errs)
+ Just r -> ASSERT( isEmptyBag errs ) return r
+
+-- | Lift a non-failing IO action into a 'GhcMonad'.
+--
+-- Like 'ioMsgMaybe', but assumes that the action will never return any error
+-- messages.
+ioMsg :: GhcMonad m => IO (Messages, a) -> m a
+ioMsg ioA = do
+ ((warns,errs), r) <- liftIO ioA
+ logWarnings warns
+ ASSERT( isEmptyBag errs ) return r
+
+-- | 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 m = unGhc m
+
+-- > Dual to 'reflectGhc'. See its documentation.
+reifyGhc :: (Session -> IO a) -> Ghc a
+reifyGhc act = Ghc $ act
+
+handleFlagWarnings :: GhcMonad m => DynFlags -> [Located String] -> m ()
+handleFlagWarnings dflags warns
+ = when (dopt Opt_WarnDeprecatedFlags dflags)
+ (handleFlagWarnings' dflags warns)
+
+handleFlagWarnings' :: GhcMonad m => DynFlags -> [Located String] -> m ()
+handleFlagWarnings' _ [] = return ()
+handleFlagWarnings' dflags warns
+ = do -- It would be nicer if warns :: [Located Message], but that has circular
+ -- import problems.
+ logWarnings $ listToBag (map mkFlagWarning warns)
+ when (dopt Opt_WarnIsError dflags) $
+ liftIO $ throwIO $ mkSrcErr emptyBag
+
+mkFlagWarning :: Located String -> WarnMsg
+mkFlagWarning (L loc warn)
+ = mkPlainWarnMsg loc (text warn)
+\end{code}
+
+\begin{code}
+-- | These functions are called in various places of the GHC API.
+--
+-- API clients can override any of these callbacks to change GHC's default
+-- behaviour.
+data GhcApiCallbacks
+ = GhcApiCallbacks {
+
+ -- | Called by 'load' after the compilating of each module.
+ --
+ -- The default implementation simply prints all warnings and errors to
+ -- @stderr@. Don't forget to call 'clearWarnings' when implementing your
+ -- own call.
+ --
+ -- The first argument is the module that was compiled.
+ --
+ -- The second argument is @Nothing@ if no errors occured, but there may
+ -- have been warnings. If it is @Just err@ at least one error has
+ -- occured. If 'srcErrorMessages' is empty, compilation failed due to
+ -- @-Werror@.
+ reportModuleCompilationResult :: GhcMonad m =>
+ ModSummary -> Maybe SourceError
+ -> m ()
+ }