+-- -----------------------------------------------------------------------------
+-- The Hsc monad: collecting warnings
+
+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
+
+-- -----------------------------------------------------------------------------
+-- | parse a file, returning the abstract syntax
+
+hscParse :: HscEnv -> ModSummary -> IO (Located (HsModule RdrName))
+hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
+
+-- internal version, that doesn't fail due to -Werror
+hscParse' :: ModSummary -> Hsc (Located (HsModule RdrName))
+hscParse' mod_summary
+ = do
+ dflags <- getDynFlags
+ let
+ src_filename = ms_hspp_file mod_summary
+ maybe_src_buf = ms_hspp_buf mod_summary
+
+ -------------------------- Parser ----------------
+ liftIO $ showPass dflags "Parser"
+ {-# SCC "Parser" #-} do
+
+ -- sometimes we already have the buffer in memory, perhaps
+ -- because we needed to parse the imports out of it, or get the
+ -- module name.
+ buf <- case maybe_src_buf of
+ Just b -> return b
+ Nothing -> liftIO $ hGetStringBuffer src_filename
+
+ let loc = mkSrcLoc (mkFastString src_filename) 1 1
+
+ case unP parseModule (mkPState dflags buf loc) of
+ PFailed span err ->
+ liftIO $ throwOneError (mkPlainErrMsg span err)
+
+ POk pst rdr_module -> do
+ logWarningsReportErrors (getMessages pst)
+ liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
+ ppr rdr_module
+ liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
+ ppSourceStats False rdr_module
+ return rdr_module
+ -- ToDo: free the string buffer later.
+
+-- XXX: should this really be a Maybe X? Check under which circumstances this
+-- can become a Nothing and decide whether this should instead throw an
+-- exception/signal an error.
+type RenamedStuff =
+ (Maybe (HsGroup Name, [LImportDecl Name], Maybe [LIE Name],
+ Maybe LHsDocString))
+
+-- | Rename and typecheck a module, additionally returning the renamed syntax
+hscTypecheckRename :: HscEnv -> ModSummary -> Located (HsModule RdrName)
+ -> IO (TcGblEnv, RenamedStuff)
+hscTypecheckRename hsc_env mod_summary rdr_module
+ = runHsc hsc_env $ do
+ tc_result
+ <- {-# SCC "Typecheck-Rename" #-}
+ ioMsgMaybe $
+ tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module
+
+ let -- This 'do' is in the Maybe monad!
+ rn_info = do decl <- tcg_rn_decls tc_result
+ let imports = tcg_rn_imports tc_result
+ exports = tcg_rn_exports tc_result
+ doc_hdr = tcg_doc_hdr tc_result
+ return (decl,imports,exports,doc_hdr)
+
+ return (tc_result, rn_info)
+
+-- | Convert a typechecked module to Core
+hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
+hscDesugar hsc_env mod_summary tc_result
+ = runHsc hsc_env $ hscDesugar' mod_summary tc_result
+
+hscDesugar' :: ModSummary -> TcGblEnv -> Hsc ModGuts
+hscDesugar' mod_summary tc_result
+ = do
+ hsc_env <- getHscEnv
+ r <- ioMsgMaybe $
+ deSugar hsc_env (ms_location mod_summary) tc_result
+
+ handleWarnings
+ -- always check -Werror after desugaring, this is
+ -- the last opportunity for warnings to arise before
+ -- the backend.
+ return r
+
+-- | Make a 'ModIface' from the results of typechecking. Used when
+-- not optimising, and the interface doesn't need to contain any
+-- unfoldings or other cross-module optimisation info.
+-- ToDo: the old interface is only needed to get the version numbers,
+-- we should use fingerprint versions instead.
+makeSimpleIface :: HscEnv ->
+ Maybe ModIface -> TcGblEnv -> ModDetails
+ -> IO (ModIface,Bool)
+makeSimpleIface hsc_env maybe_old_iface tc_result details
+ = runHsc hsc_env $
+ ioMsgMaybe $
+ mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result
+
+-- | Make a 'ModDetails' from the results of typechecking. Used when
+-- typechecking only, as opposed to full compilation.
+makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
+makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
+\end{code}