+newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
+
+instance Monad Hsc where
+ return a = Hsc $ \_ w -> return (a, w)
+ Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w
+ case k a of
+ Hsc k' -> k' e w1
+
+instance MonadIO Hsc where
+ liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)
+
+runHsc :: HscEnv -> Hsc a -> IO a
+runHsc hsc_env (Hsc hsc) = do
+ (a, w) <- hsc hsc_env emptyBag
+ printOrThrowWarnings (hsc_dflags hsc_env) w
+ return a
+
+getWarnings :: Hsc WarningMessages
+getWarnings = Hsc $ \_ w -> return (w, w)
+
+clearWarnings :: Hsc ()
+clearWarnings = Hsc $ \_ _w -> return ((), emptyBag)
+
+logWarnings :: WarningMessages -> Hsc ()
+logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
+
+getHscEnv :: Hsc HscEnv
+getHscEnv = Hsc $ \e w -> return (e, w)
+
+getDynFlags :: Hsc DynFlags
+getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)
+
+handleWarnings :: Hsc ()
+handleWarnings = do
+ dflags <- getDynFlags
+ w <- getWarnings
+ liftIO $ printOrThrowWarnings dflags w
+ clearWarnings
+
+-- | log warning in the monad, and if there are errors then
+-- throw a SourceError exception.
+logWarningsReportErrors :: Messages -> Hsc ()
+logWarningsReportErrors (warns,errs) = do
+ logWarnings warns
+ when (not (isEmptyBag errs)) $ do
+ liftIO $ throwIO $ mkSrcErr errs
+
+-- | Deal with errors and warnings returned by a compilation step
+--
+-- 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 :: IO (Messages, Maybe a) -> Hsc 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
+
+-- | like ioMsgMaybe, except that we ignore error messages and return
+-- 'Nothing' instead.
+ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)
+ioMsgMaybe' ioA = do
+ ((warns,_errs), mb_r) <- liftIO $ ioA
+ logWarnings warns
+ return mb_r
+
+-- -----------------------------------------------------------------------------
+-- | Lookup things in the compiler's environment
+
+#ifdef GHCI
+hscTcRnLookupRdrName :: HscEnv -> RdrName -> IO [Name]
+hscTcRnLookupRdrName hsc_env rdr_name =
+ runHsc hsc_env $ ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name
+#endif
+
+hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
+hscTcRcLookupName hsc_env name =
+ runHsc hsc_env $ ioMsgMaybe' $ tcRnLookupName hsc_env name
+ -- ignore errors: the only error we're likely to get is
+ -- "name not found", and the Maybe in the return type
+ -- is used to indicate that.
+
+hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [Instance]))
+hscTcRnGetInfo hsc_env name =
+ runHsc hsc_env $ ioMsgMaybe' $ tcRnGetInfo hsc_env name
+
+#ifdef GHCI
+hscGetModuleExports :: HscEnv -> Module -> IO (Maybe [AvailInfo])
+hscGetModuleExports hsc_env mdl =
+ runHsc hsc_env $ ioMsgMaybe' $ getModuleExports hsc_env mdl
+
+-- -----------------------------------------------------------------------------
+-- | Rename some import declarations
+
+hscRnImportDecls
+ :: HscEnv
+ -> Module
+ -> [LImportDecl RdrName]
+ -> IO GlobalRdrEnv
+
+-- It is important that we use tcRnImports instead of calling rnImports directly
+-- because tcRnImports will force-load any orphan modules necessary, making extra
+-- instances/family instances visible (GHC #4832)
+hscRnImportDecls hsc_env this_mod import_decls
+ = runHsc hsc_env $ ioMsgMaybe $ initTc hsc_env HsSrcFile False this_mod $
+ fmap tcg_rdr_env $ tcRnImports hsc_env this_mod import_decls
+
+#endif
+
+-- -----------------------------------------------------------------------------