X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=086f6e895aac86c21c2520332ca060b393d1a6bf;hb=1246293616fc45787ecaed13aa31a2555510f7e3;hp=f686f34931f2712feecd23e1709a5329930c1e0c;hpb=8407d75daa79566600c8c3f329792ae3a3810f84;p=ghc-hetmet.git diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index f686f34..086f6e8 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -25,7 +25,7 @@ module HscMain -- The new interface , parseFile - , typecheckModule + , typecheckModule' , typecheckRenameModule , deSugarModule , makeSimpleIface @@ -46,12 +46,12 @@ import PrelNames ( iNTERACTIVE ) import {- Kind parts of -} Type ( Kind ) import CoreLint ( lintUnfolding ) import DsMeta ( templateHaskellNames ) -import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan ) +import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan, noSrcSpan ) import VarSet import VarEnv ( emptyTidyEnv ) #endif -import Var ( Id ) +import Id ( Id ) import Module ( emptyModuleEnv, ModLocation(..), Module ) import RdrName import HsSyn @@ -84,6 +84,7 @@ import CmmParse ( parseCmmFile ) import CmmCPS import CmmCPSZ import CmmInfo +import OptimizationFuel ( initOptFuelState ) import CmmCvt import CmmTx import CmmContFlowOpt @@ -101,13 +102,16 @@ import MkExternalCore ( emitExternalCore ) import FastString import LazyUniqFM ( emptyUFM ) import UniqSupply ( initUs_ ) -import Bag ( unitBag ) +import Bag ( unitBag, emptyBag, unionBags ) +import Exception +import MonadUtils import Control.Monad import System.Exit import System.IO import Data.IORef \end{code} +#include "HsVersions.h" %************************************************************************ @@ -123,16 +127,19 @@ newHscEnv dflags ; us <- mkSplitUniqSupply 'r' ; nc_var <- newIORef (initNameCache us knownKeyNames) ; fc_var <- newIORef emptyUFM - ; mlc_var <- newIORef emptyModuleEnv + ; mlc_var <- newIORef emptyModuleEnv + ; optFuel <- initOptFuelState ; return (HscEnv { hsc_dflags = dflags, hsc_targets = [], hsc_mod_graph = [], - hsc_IC = emptyInteractiveContext, - hsc_HPT = emptyHomePackageTable, - hsc_EPS = eps_var, - hsc_NC = nc_var, - hsc_FC = fc_var, - hsc_MLC = mlc_var, + hsc_IC = emptyInteractiveContext, + hsc_HPT = emptyHomePackageTable, + hsc_EPS = eps_var, + hsc_NC = nc_var, + hsc_FC = fc_var, + hsc_MLC = mlc_var, + hsc_OptFuel = optFuel, + hsc_type_env_var = Nothing, hsc_global_rdr_env = emptyGlobalRdrEnv, hsc_global_type_env = emptyNameEnv } ) } @@ -149,64 +156,57 @@ knownKeyNames = map getName wiredInThings \begin{code} -- | parse a file, returning the abstract syntax -parseFile :: HscEnv -> ModSummary -> IO (Maybe (Located (HsModule RdrName))) -parseFile hsc_env mod_summary - = do - maybe_parsed <- myParseModule dflags hspp_file hspp_buf - case maybe_parsed of - Left err - -> do printBagOfErrors dflags (unitBag err) - return Nothing - Right rdr_module - -> return (Just rdr_module) +parseFile :: GhcMonad m => HscEnv -> ModSummary -> m (Located (HsModule RdrName)) +parseFile hsc_env mod_summary = do + maybe_parsed <- liftIO $ myParseModule dflags hspp_file hspp_buf + case maybe_parsed of + Left err -> do throw (mkSrcErr (unitBag err)) + Right rdr_module + -> return rdr_module where dflags = hsc_dflags hsc_env hspp_file = ms_hspp_file mod_summary hspp_buf = ms_hspp_buf mod_summary -- | Rename and typecheck a module -typecheckModule :: HscEnv -> ModSummary -> Located (HsModule RdrName) - -> IO (Maybe TcGblEnv) -typecheckModule hsc_env mod_summary rdr_module - = do - (tc_msgs, maybe_tc_result) - <- {-# SCC "Typecheck-Rename" #-} - tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module - printErrorsAndWarnings dflags tc_msgs - return maybe_tc_result - where - dflags = hsc_dflags hsc_env - +typecheckModule' :: GhcMonad m => + HscEnv -> ModSummary -> Located (HsModule RdrName) + -> m TcGblEnv +typecheckModule' hsc_env mod_summary rdr_module = do + r <- {-# SCC "Typecheck-Rename" #-} + ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module + return r + +-- 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 (HsDoc Name), HaddockModInfo Name)) --- | Rename and typecheck a module, additinoally returning the renamed syntax -typecheckRenameModule :: HscEnv -> ModSummary -> Located (HsModule RdrName) - -> IO (Maybe (TcGblEnv, RenamedStuff)) -typecheckRenameModule hsc_env mod_summary rdr_module - = do - (tc_msgs, maybe_tc_result) - <- {-# SCC "Typecheck-Rename" #-} - tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module - printErrorsAndWarnings dflags tc_msgs - case maybe_tc_result of - Nothing -> return Nothing - Just tc_result -> do - let rn_info = do decl <- tcg_rn_decls tc_result - imports <- tcg_rn_imports tc_result - let exports = tcg_rn_exports tc_result - let doc = tcg_doc tc_result - let hmi = tcg_hmi tc_result - return (decl,imports,exports,doc,hmi) - return (Just (tc_result, rn_info)) - where - dflags = hsc_dflags hsc_env +-- | Rename and typecheck a module, additionally returning the renamed syntax +typecheckRenameModule + :: GhcMonad m => + HscEnv -> ModSummary -> Located (HsModule RdrName) + -> m (TcGblEnv, RenamedStuff) +typecheckRenameModule hsc_env mod_summary rdr_module = do + tc_result + <- {-# SCC "Typecheck-Rename" #-} + ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module + + let rn_info = do decl <- tcg_rn_decls tc_result + imports <- tcg_rn_imports tc_result + let exports = tcg_rn_exports tc_result + let doc = tcg_doc tc_result + let hmi = tcg_hmi tc_result + return (decl,imports,exports,doc,hmi) + + return (tc_result, rn_info) -- | Convert a typechecked module to Core -deSugarModule :: HscEnv -> ModSummary -> TcGblEnv -> IO (Maybe ModGuts) -deSugarModule hsc_env mod_summary tc_result - = deSugar hsc_env (ms_location mod_summary) tc_result +deSugarModule :: GhcMonad m => HscEnv -> ModSummary -> TcGblEnv -> m ModGuts +deSugarModule hsc_env mod_summary tc_result = do + ioMsgMaybe $ deSugar hsc_env (ms_location mod_summary) tc_result -- | Make a 'ModIface' from the results of typechecking. Used when -- not optimising, and the interface doesn't need to contain any @@ -216,7 +216,7 @@ deSugarModule hsc_env mod_summary tc_result makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails -> IO (ModIface,Bool) makeSimpleIface hsc_env maybe_old_iface tc_result details = do - mkIfaceTc hsc_env maybe_old_iface details tc_result + 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. @@ -283,16 +283,25 @@ data InteractiveStatus -- I want Control.Monad.State! --Lemmih 03/07/2006 -newtype Comp a = Comp {runComp :: CompState -> IO (a, CompState)} +newtype Comp a = Comp {runComp :: CompState -> IORef Messages -> IO (a, CompState)} instance Monad Comp where - g >>= fn = Comp $ \s -> runComp g s >>= \(a,s') -> runComp (fn a) s' - return a = Comp $ \s -> return (a,s) + g >>= fn = Comp $ \s r -> runComp g s r >>= \(a,s') -> runComp (fn a) s' r + return a = Comp $ \s _ -> return (a,s) fail = error -evalComp :: Comp a -> CompState -> IO a -evalComp comp st = do (val,_st') <- runComp comp st - return val +evalComp :: Comp a -> CompState -> IO (Messages, a) +evalComp comp st = do r <- newIORef emptyMessages + (val,_st') <- runComp comp st r + msgs <- readIORef r + return (msgs, val) + +logMsgs :: Messages -> Comp () +logMsgs (warns', errs') = Comp $ \s r -> do + (warns, errs) <- readIORef r + writeIORef r $! ( warns' `unionBags` warns + , errs' `unionBags` errs ) + return ((), s) data CompState = CompState @@ -302,29 +311,29 @@ data CompState } get :: Comp CompState -get = Comp $ \s -> return (s,s) +get = Comp $ \s _ -> return (s,s) modify :: (CompState -> CompState) -> Comp () -modify f = Comp $ \s -> return ((), f s) +modify f = Comp $ \s _ -> return ((), f s) gets :: (CompState -> a) -> Comp a gets getter = do st <- get return (getter st) -liftIO :: IO a -> Comp a -liftIO ioA = Comp $ \s -> do a <- ioA - return (a,s) +instance MonadIO Comp where + liftIO ioA = Comp $ \s _ -> do a <- ioA; return (a,s) type NoRecomp result = ModIface -> Comp result -- FIXME: The old interface and module index are only using in 'batch' and -- 'interactive' mode. They should be removed from 'oneshot' mode. -type Compiler result = HscEnv +type Compiler result = GhcMonad m => + HscEnv -> ModSummary -> Bool -- True <=> source unchanged -> Maybe ModIface -- Old interface, if available -> Maybe (Int,Int) -- Just (i,n) <=> module i of n (for msgs) - -> IO (Maybe result) + -> m result -------------------------------------------------------------- -- Compilers @@ -332,7 +341,19 @@ type Compiler result = HscEnv -- Compile Haskell, boot and extCore in OneShot mode. hscCompileOneShot :: Compiler HscStatus -hscCompileOneShot +hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n + = do + -- One-shot mode needs a knot-tying mutable variable for interface files. + -- See TcRnTypes.TcGblEnv.tcg_type_env_var. + type_env_var <- liftIO $ newIORef emptyNameEnv + let + mod = ms_mod mod_summary + hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) } + --- + hscCompilerOneShot' hsc_env' mod_summary src_changed mb_old_iface mb_i_of_n + +hscCompilerOneShot' :: Compiler HscStatus +hscCompilerOneShot' = hscCompiler norecompOneShot oneShotMsg (genComp backend boot_backend) where backend inp = hscSimplify inp >>= hscNormalIface >>= hscWriteIface >>= hscOneShot @@ -379,7 +400,8 @@ hscCompiler -> Compiler result hscCompiler norecomp messenger recomp hsc_env mod_summary source_unchanged mbOldIface mbModIndex - = flip evalComp (CompState hsc_env mod_summary mbOldIface) $ + = ioMsgMaybe $ + flip evalComp (CompState hsc_env mod_summary mbOldIface) $ do (recomp_reqd, mbCheckedIface) <- {-# SCC "checkOldIface" #-} liftIO $ checkOldIface hsc_env mod_summary @@ -480,17 +502,17 @@ hscFileFrontEnd :: Comp (Maybe TcGblEnv) hscFileFrontEnd = do hsc_env <- gets compHscEnv mod_summary <- gets compModSummary - liftIO $ do + ------------------- -- PARSE ------------------- let dflags = hsc_dflags hsc_env hspp_file = ms_hspp_file mod_summary hspp_buf = ms_hspp_buf mod_summary - maybe_parsed <- myParseModule dflags hspp_file hspp_buf + maybe_parsed <- liftIO $ myParseModule dflags hspp_file hspp_buf case maybe_parsed of Left err - -> do printBagOfErrors dflags (unitBag err) + -> do logMsgs (emptyBag, unitBag err) return Nothing Right rdr_module ------------------- @@ -498,8 +520,9 @@ hscFileFrontEnd = ------------------- -> do (tc_msgs, maybe_tc_result) <- {-# SCC "Typecheck-Rename" #-} - tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module - printErrorsAndWarnings dflags tc_msgs + liftIO $ tcRnModule hsc_env (ms_hsc_src mod_summary) + False rdr_module + logMsgs tc_msgs return maybe_tc_result -------------------------------------------------------------- @@ -510,12 +533,14 @@ hscDesugar :: TcGblEnv -> Comp (Maybe ModGuts) hscDesugar tc_result = do mod_summary <- gets compModSummary hsc_env <- gets compHscEnv - liftIO $ do + ------------------- -- DESUGAR ------------------- - ds_result <- {-# SCC "DeSugar" #-} - deSugar hsc_env (ms_location mod_summary) tc_result + (msgs, ds_result) + <- {-# SCC "DeSugar" #-} + liftIO $ deSugar hsc_env (ms_location mod_summary) tc_result + logMsgs msgs return ds_result -------------------------------------------------------------- @@ -546,9 +571,9 @@ hscSimpleIface tc_result maybe_old_iface <- gets compOldIface liftIO $ do details <- mkBootModDetailsTc hsc_env tc_result - (new_iface, no_change) + (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} - mkIfaceTc hsc_env maybe_old_iface details tc_result + mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result -- And the answer is ... dumpIfaceStats hsc_env return (new_iface, no_change, details, tc_result) @@ -573,7 +598,8 @@ hscNormalIface simpl_result -- until after code output (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} - mkIface hsc_env maybe_old_iface details simpl_result + mkIface hsc_env (fmap mi_iface_hash maybe_old_iface) + details simpl_result -- Emit external core -- This should definitely be here and not after CorePrep, -- because CorePrep produces unqualified constructor wrapper declarations, @@ -656,8 +682,8 @@ hscCompile cgguts dir_imps cost_centre_info stg_binds hpc_info --- Optionally run experimental Cmm transformations --- - cmms <- optionallyConvertAndOrCPS dflags cmms - -- ^ unless certain dflags are on, the identity function + cmms <- optionallyConvertAndOrCPS hsc_env cmms + -- unless certain dflags are on, the identity function ------------------ Code output ----------------------- rawcmms <- cmmToRawCmm cmms (_stub_h_exists, stub_c_exists) @@ -702,27 +728,27 @@ hscInteractive _ = panic "GHC not compiled with interpreter" ------------------------------ -hscCmmFile :: DynFlags -> FilePath -> IO Bool -hscCmmFile dflags filename = do - maybe_cmm <- parseCmmFile dflags filename - case maybe_cmm of - Nothing -> return False - Just cmm -> do - cmms <- optionallyConvertAndOrCPS dflags [cmm] - rawCmms <- cmmToRawCmm cmms - codeOutput dflags no_mod no_loc NoStubs [] rawCmms - return True +hscCmmFile :: GhcMonad m => HscEnv -> FilePath -> m () +hscCmmFile hsc_env filename = do + dflags <- return $ hsc_dflags hsc_env + cmm <- ioMsgMaybe $ + parseCmmFile dflags filename + cmms <- liftIO $ optionallyConvertAndOrCPS hsc_env [cmm] + rawCmms <- liftIO $ cmmToRawCmm cmms + liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms + return () where no_mod = panic "hscCmmFile: no_mod" no_loc = ModLocation{ ml_hs_file = Just filename, ml_hi_file = panic "hscCmmFile: no hi file", ml_obj_file = panic "hscCmmFile: no obj file" } -optionallyConvertAndOrCPS :: DynFlags -> [Cmm] -> IO [Cmm] -optionallyConvertAndOrCPS dflags cmms = - do -------- Optionally convert to and from zipper ------ +optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm] +optionallyConvertAndOrCPS hsc_env cmms = + do let dflags = hsc_dflags hsc_env + -------- Optionally convert to and from zipper ------ cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags - then mapM (testCmmConversion dflags) cmms + then mapM (testCmmConversion hsc_env) cmms else return cmms --------- Optionally convert to CPS (MDA) ----------- cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) && @@ -732,9 +758,10 @@ optionallyConvertAndOrCPS dflags cmms = return cmms -testCmmConversion :: DynFlags -> Cmm -> IO Cmm -testCmmConversion dflags cmm = - do showPass dflags "CmmToCmm" +testCmmConversion :: HscEnv -> Cmm -> IO Cmm +testCmmConversion hsc_env cmm = + do let dflags = hsc_dflags hsc_env + showPass dflags "CmmToCmm" dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm) --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm us <- mkSplitUniqSupply 'C' @@ -742,7 +769,7 @@ testCmmConversion dflags cmm = let cvtm = do g <- cmmToZgraph cmm return $ cfopts g let zgraph = initUs_ us cvtm - cps_zgraph <- protoCmmCPSZ dflags zgraph + cps_zgraph <- protoCmmCPSZ hsc_env zgraph let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph) showPass dflags "Convert from Z back to Cmm" @@ -774,7 +801,7 @@ myParseModule dflags src_filename maybe_src_buf POk pst rdr_module -> do { let {ms = getMessages pst}; - printErrorsAndWarnings dflags ms; + printErrorsAndWarnings dflags ms; -- XXX when (errorsFound dflags ms) $ exitWith (ExitFailure 1); dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; @@ -838,113 +865,108 @@ A naked expression returns a singleton Name [it]. \begin{code} #ifdef GHCI hscStmt -- Compile a stmt all the way to an HValue, but don't run it - :: HscEnv + :: GhcMonad m => + HscEnv -> String -- The statement - -> IO (Maybe ([Id], HValue)) - -hscStmt hsc_env stmt - = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt - ; case maybe_stmt of { - Nothing -> return Nothing ; -- Parse error - Just Nothing -> return Nothing ; -- Empty line - Just (Just parsed_stmt) -> do { -- The real stuff - - -- Rename and typecheck it - let icontext = hsc_IC hsc_env - ; maybe_tc_result <- tcRnStmt hsc_env icontext parsed_stmt - - ; case maybe_tc_result of { - Nothing -> return Nothing ; - Just (ids, tc_expr) -> do { - - -- Desugar it - ; let rdr_env = ic_rn_gbl_env icontext - type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext)) - ; mb_ds_expr <- deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr - - ; case mb_ds_expr of { - Nothing -> return Nothing ; - Just ds_expr -> do { - - -- Then desugar, code gen, and link it - ; let src_span = srcLocSpan interactiveSrcLoc - ; hval <- compileExpr hsc_env src_span ds_expr - - ; return (Just (ids, hval)) - }}}}}}} + -> m (Maybe ([Id], HValue)) + -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error +hscStmt hsc_env stmt = do + maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt + case maybe_stmt of + Nothing -> return Nothing + Just parsed_stmt -> do -- The real stuff + + -- Rename and typecheck it + let icontext = hsc_IC hsc_env + (ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icontext parsed_stmt + -- Desugar it + let rdr_env = ic_rn_gbl_env icontext + type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext)) + ds_expr <- ioMsgMaybe $ + deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr + + -- Then desugar, code gen, and link it + let src_span = srcLocSpan interactiveSrcLoc + hval <- liftIO $ compileExpr hsc_env src_span ds_expr + + return $ Just (ids, hval) + hscTcExpr -- Typecheck an expression (but don't run it) - :: HscEnv + :: GhcMonad m => + HscEnv -> String -- The expression - -> IO (Maybe Type) - -hscTcExpr hsc_env expr - = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr - ; let icontext = hsc_IC hsc_env - ; case maybe_stmt of { - Nothing -> return Nothing ; -- Parse error - Just (Just (L _ (ExprStmt expr _ _))) - -> tcRnExpr hsc_env icontext expr ; - Just _ -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ; - return Nothing } ; - } } - -hscKcType -- Find the kind of a type - :: HscEnv - -> String -- The type - -> IO (Maybe Kind) - -hscKcType hsc_env str - = do { maybe_type <- hscParseType (hsc_dflags hsc_env) str - ; let icontext = hsc_IC hsc_env - ; case maybe_type of { - Just ty -> tcRnType hsc_env icontext ty ; - Nothing -> return Nothing } } + -> m Type + +hscTcExpr hsc_env expr = do + maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr + let icontext = hsc_IC hsc_env + case maybe_stmt of + Just (L _ (ExprStmt expr _ _)) -> do + ty <- ioMsgMaybe $ tcRnExpr hsc_env icontext expr + return ty + _ -> do throw $ mkSrcErr $ unitBag $ mkPlainErrMsg + noSrcSpan + (text "not an expression:" <+> quotes (text expr)) + +-- | Find the kind of a type +hscKcType + :: GhcMonad m => + HscEnv + -> String -- ^ The type + -> m Kind + +hscKcType hsc_env str = do + ty <- hscParseType (hsc_dflags hsc_env) str + let icontext = hsc_IC hsc_env + ioMsgMaybe $ tcRnType hsc_env icontext ty + #endif \end{code} \begin{code} #ifdef GHCI -hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName))) +hscParseStmt :: GhcMonad m => DynFlags -> String -> m (Maybe (LStmt RdrName)) hscParseStmt = hscParseThing parseStmt -hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName)) +hscParseType :: GhcMonad m => DynFlags -> String -> m (LHsType RdrName) hscParseType = hscParseThing parseType #endif -hscParseIdentifier :: DynFlags -> String -> IO (Maybe (Located RdrName)) +hscParseIdentifier :: GhcMonad m => DynFlags -> String -> m (Located RdrName) hscParseIdentifier = hscParseThing parseIdentifier -hscParseThing :: Outputable thing +hscParseThing :: (Outputable thing, GhcMonad m) => Lexer.P thing -> DynFlags -> String - -> IO (Maybe thing) + -> m thing -- Nothing => Parse error (message already printed) -- Just x => success hscParseThing parser dflags str - = showPass dflags "Parser" >> + = (liftIO $ showPass dflags "Parser") >> {-# SCC "Parser" #-} do - buf <- stringToStringBuffer str + buf <- liftIO $ stringToStringBuffer str let loc = mkSrcLoc (fsLit "") 1 0 - case unP parser (mkPState buf loc dflags) of { + case unP parser (mkPState buf loc dflags) of - PFailed span err -> do { printError span err; - return Nothing }; + PFailed span err -> do + let msg = mkPlainErrMsg span err + throw (mkSrcErr (unitBag msg)) - POk pst thing -> do { + POk pst thing -> do - let {ms = getMessages pst}; - printErrorsAndWarnings dflags ms; - when (errorsFound dflags ms) $ exitWith (ExitFailure 1); + let ms@(warns, errs) = getMessages pst + logWarnings warns + when (errorsFound dflags ms) $ -- handle -Werror + throw (mkSrcErr errs) - --ToDo: can't free the string buffer until we've finished this - -- compilation sweep and all the identifiers have gone away. - dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing); - return (Just thing) - }} + --ToDo: can't free the string buffer until we've finished this + -- compilation sweep and all the identifiers have gone away. + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing) + return thing \end{code} %************************************************************************ @@ -1028,4 +1050,3 @@ showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] " i_str = show i padded = replicate (length n_str - length i_str) ' ' ++ i_str \end{code} -