From: simonpj@microsoft.com Date: Fri, 18 Aug 2006 11:07:02 +0000 (+0000) Subject: Fall over more gracefully when there's a Template Haskell error X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=7a59afcebe45ea87c42006873f77eb4600d7316f Fall over more gracefully when there's a Template Haskell error For a long time, Template Haskell has fallen over in a very un-graceful way (i.e. panic) even when it encounters a programmer error. In particular, when DsMeta converts HsSyn to TH syntax, it may find Haskell code that TH does not understand. This should be reported as a normal programmer error, not with a compiler panic! Originally the desugarer was supposed to never generate error messages, but this TH desugaring thing does make it do so. And in fact, for other reasons, the desugarer now uses the TcRnIf monad, the common monad used by the renamer, typechecker, interface checker, and desugarer. This patch completes the job, by - allowing the desugarer to generate errors - re-plumbing the error handling to take account of this - making DsMeta use the new facilities to report error gracefully Quite a few lines of code are touched, but nothing deep is going on. Fixes Trac# 760. --- diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 56741a2..dc0e124 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -32,15 +32,12 @@ import PackageConfig ( thPackageId ) import RdrName ( GlobalRdrEnv ) import NameSet import VarSet -import Bag ( Bag, isEmptyBag, emptyBag ) import Rules ( roughTopNames ) import CoreLint ( showPass, endPass ) import CoreFVs ( ruleRhsFreeVars, exprsFreeNames ) -import ErrUtils ( doIfSet, dumpIfSet_dyn, printBagOfWarnings, - errorsFound, WarnMsg ) +import ErrUtils ( doIfSet, dumpIfSet_dyn ) import ListSetOps ( insertList ) import Outputable -import UniqSupply ( mkSplitUniqSupply ) import SrcLoc ( Located(..) ) import DATA_IOREF ( readIORef ) import Maybes ( catMaybes ) @@ -55,7 +52,7 @@ import Util ( sortLe ) %************************************************************************ \begin{code} -deSugar :: HscEnv -> TcGblEnv -> IO (Bag WarnMsg, Maybe ModGuts) +deSugar :: HscEnv -> TcGblEnv -> IO (Maybe ModGuts) -- Can modify PCS by faulting in more declarations deSugar hsc_env @@ -78,9 +75,8 @@ deSugar hsc_env = do { showPass dflags "Desugar" -- Desugar the program - ; ((all_prs, ds_rules, ds_fords), warns) - <- case ghcMode (hsc_dflags hsc_env) of - JustTypecheck -> return (([], [], NoStubs), emptyBag) + ; mb_res <- case ghcMode dflags of + JustTypecheck -> return (Just ([], [], NoStubs)) _ -> initDs hsc_env mod rdr_env type_env $ do { core_prs <- dsTopLHsBinds auto_scc binds ; (ds_fords, foreign_prs) <- dsForeigns fords @@ -89,11 +85,9 @@ deSugar hsc_env ; ds_rules <- mappM (dsRule mod local_bndrs) rules ; return (all_prs, catMaybes ds_rules, ds_fords) } - - -- If warnings are considered errors, leave. - ; if errorsFound dflags (warns, emptyBag) - then return (warns, Nothing) - else do + ; case mb_res of { + Nothing -> return Nothing ; + Just (all_prs, ds_rules, ds_fords) -> do { -- Add export flags to bindings keep_alive <- readIORef keep_var @@ -161,40 +155,37 @@ deSugar hsc_env mg_binds = ds_binds, mg_foreign = ds_fords } - ; return (warns, Just mod_guts) - }} + ; return (Just mod_guts) + }}} where - dflags = hsc_dflags hsc_env - ghci_mode = ghcMode (hsc_dflags hsc_env) + dflags = hsc_dflags hsc_env + ghci_mode = ghcMode (hsc_dflags hsc_env) auto_scc | opt_SccProfilingOn = TopLevel | otherwise = NoSccs deSugarExpr :: HscEnv -> Module -> GlobalRdrEnv -> TypeEnv -> LHsExpr Id - -> IO CoreExpr + -> IO (Maybe CoreExpr) +-- Prints its own errors; returns Nothing if error occurred + deSugarExpr hsc_env this_mod rdr_env type_env tc_expr - = do { showPass dflags "Desugar" - ; us <- mkSplitUniqSupply 'd' + = do { let dflags = hsc_dflags hsc_env + ; showPass dflags "Desugar" -- Do desugaring - ; (core_expr, ds_warns) <- initDs hsc_env this_mod rdr_env type_env $ - dsLExpr tc_expr + ; mb_core_expr <- initDs hsc_env this_mod rdr_env type_env $ + dsLExpr tc_expr - -- Display any warnings - -- Note: if -Werror is used, we don't signal an error here. - ; doIfSet (not (isEmptyBag ds_warns)) - (printBagOfWarnings dflags ds_warns) + ; case mb_core_expr of { + Nothing -> return Nothing ; + Just expr -> do { - -- Dump output - ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr core_expr) - - ; return core_expr - } - where - dflags = hsc_dflags hsc_env + -- Dump output + dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr) + ; return (Just expr) } } } -- addExportFlags -- Set the no-discard flag if either @@ -267,7 +258,7 @@ dsRule mod in_scope (L loc (HsRule name act vars lhs tv_lhs rhs fv_rhs)) ; rhs' <- dsLExpr rhs ; case decomposeRuleLhs bndrs lhs' of { - Nothing -> do { dsWarn msg; return Nothing } ; + Nothing -> do { warnDs msg; return Nothing } ; Just (bndrs', fn_id, args) -> do -- Substitute the dict bindings eagerly, diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 64306af..e22cb00 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -236,7 +236,7 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind mb_lhs = decomposeRuleLhs (bndrs ++ const_dicts) body ; case mb_lhs of - Nothing -> do { dsWarn msg; return Nothing } + Nothing -> do { warnDs msg; return Nothing } Just (bndrs', var, args) -> return (Just (addInlineInfo inl spec_id spec_rhs, rule)) where diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 5fb0ec8..4c2bd3e 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -220,7 +220,7 @@ dsExpr (HsApp (L _ (HsApp realFun@(L _ (HsCoerce _ fun)) (L loc arg))) _) | HsVar funId <- fun , idName funId `elem` [breakpointJumpName, breakpointCondJumpName] , ids <- filter (isValidType . idType) (extractIds arg) - = do dsWarn (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids)) + = do warnDs (text "Extracted ids:" <+> ppr ids <+> ppr (map idType ids)) stablePtr <- ioToIOEnv $ newStablePtr ids -- Yes, I know... I'm gonna burn in hell. let Ptr addr# = castStablePtrToPtr stablePtr diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index ba13bf7..d85782b 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -214,7 +214,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, -- Un-handled cases repTyClD (L loc d) = putSrcSpanDs loc $ - do { dsWarn (hang ds_msg 4 (ppr d)) + do { warnDs (hang ds_msg 4 (ppr d)) ; return Nothing } -- represent fundeps @@ -256,20 +256,22 @@ repForD (L loc (ForeignImport name typ (CImport cc s ch cn cis))) MkC typ' <- repLTy typ MkC cc' <- repCCallConv cc MkC s' <- repSafety s + cis' <- conv_cimportspec cis MkC str <- coreStringLit $ static ++ unpackFS ch ++ " " ++ unpackFS cn ++ " " - ++ conv_cimportspec cis + ++ cis' dec <- rep2 forImpDName [cc', s', str, name', typ'] return (loc, dec) where - conv_cimportspec (CLabel cls) = panic "repForD': CLabel Not handled" - conv_cimportspec (CFunction DynamicTarget) = "dynamic" - conv_cimportspec (CFunction (StaticTarget fs)) = unpackFS fs - conv_cimportspec CWrapper = "wrapper" + conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls)) + conv_cimportspec (CFunction DynamicTarget) = return "dynamic" + conv_cimportspec (CFunction (StaticTarget fs)) = return (unpackFS fs) + conv_cimportspec CWrapper = return "wrapper" static = case cis of CFunction (StaticTarget _) -> "static " _ -> "" +repForD decl = notHandled "Foreign declaration" (ppr decl) repCCallConv :: CCallConv -> DsM (Core TH.Callconv) repCCallConv CCallConv = rep2 cCallName [] @@ -299,9 +301,8 @@ repC (L loc (ConDecl con expl tvs (L cloc ctxt) details ResTyH98)) } } repC (L loc con_decl) -- GADTs - = putSrcSpanDs loc $ - do { dsWarn (hang ds_msg 4 (ppr con_decl)) - ; return (panic "DsMeta:repC") } + = putSrcSpanDs loc $ + notHandled "GADT declaration" (ppr con_decl) repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ)) repBangTy ty= do @@ -326,7 +327,7 @@ repDerivs (Just ctxt) rep_deriv :: LHsType Name -> DsM (Core TH.Name) -- Deriving clauses must have the simple H98 form rep_deriv (L _ (HsPredTy (HsClassP cls []))) = lookupOcc cls - rep_deriv other = panic "rep_deriv" + rep_deriv other = notHandled "Non-H98 deriving clause" (ppr other) ------------------------------------------------------- @@ -396,8 +397,7 @@ repPred (HsClassP cls tys) = do tcon <- repTy (HsTyVar cls) tys1 <- repLTys tys repTapps tcon tys1 -repPred (HsIParam _ _) = - panic "DsMeta.repTy: Can't represent predicates with implicit parameters" +repPred p@(HsIParam _ _) = notHandled "Implicit parameter constraint" (ppr p) -- yield the representation of a list of types -- @@ -448,11 +448,9 @@ repTy (HsTupleTy tc tys) = do repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) `nlHsAppTy` ty2) repTy (HsParTy t) = repLTy t -repTy (HsNumTy i) = - panic "DsMeta.repTy: Can't represent number types (for generics)" repTy (HsPredTy pred) = repPred pred -repTy (HsKindSig ty kind) = - panic "DsMeta.repTy: Can't represent explicit kind signatures yet" +repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty) +repTy ty = notHandled "Exotic form of type" (ppr ty) ----------------------------------------------------------------------------- @@ -467,7 +465,7 @@ repLEs es = do { es' <- mapM repLE es ; -- unless we can make sure that constructs, which are plainly not -- supported in TH already lead to error messages at an earlier stage repLE :: LHsExpr Name -> DsM (Core TH.ExpQ) -repLE (L _ e) = repE e +repLE (L loc e) = putSrcSpanDs loc (repE e) repE :: HsExpr Name -> DsM (Core TH.ExpQ) repE (HsVar x) = @@ -478,7 +476,7 @@ repE (HsVar x) = Just (Bound y) -> repVarOrCon x (coreVar y) Just (Splice e) -> do { e' <- dsExpr e ; return (MkC e') } } -repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters" +repE e@(HsIPVar x) = notHandled "Implicit parameters" (ppr e) -- Remember, we're desugaring renamer output here, so -- HsOverlit can definitely occur @@ -524,13 +522,12 @@ repE (HsDo ListComp sts body ty) ret <- repNoBindSt body'; e <- repComp (nonEmptyCoreList (zs ++ [ret])); wrapGenSyns ss e } -repE (HsDo _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet" +repE e@(HsDo _ _ _ _) = notHandled "mdo and [: :]" (ppr e) repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs } -repE (ExplicitPArr ty es) = - panic "DsMeta.repE: No explicit parallel arrays yet" -repE (ExplicitTuple es boxed) +repE e@(ExplicitPArr ty es) = notHandled "Parallel arrays" (ppr e) +repE e@(ExplicitTuple es boxed) | isBoxed boxed = do { xs <- repLEs es; repTup xs } - | otherwise = panic "DsMeta.repE: Can't represent unboxed tuples" + | otherwise = notHandled "Unboxed tuples" (ppr e) repE (RecordCon c _ flds) = do { x <- lookupLOcc c; fs <- repFields flds; @@ -557,18 +554,19 @@ repE (ArithSeq _ aseq) = ds2 <- repLE e2 ds3 <- repLE e3 repFromThenTo ds1 ds2 ds3 -repE (PArrSeq _ aseq) = panic "DsMeta.repE: parallel array seq.s missing" -repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations -repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC" -repE (HsBracketOut _ _) = panic "DsMeta.repE: Can't represent Oxford brackets" repE (HsSpliceE (HsSplice n _)) = do { mb_val <- dsLookupMetaEnv n ; case mb_val of Just (Splice e) -> do { e' <- dsExpr e ; return (MkC e') } - other -> pprPanic "HsSplice" (ppr n) } + other -> pprPanic "HsSplice" (ppr n) } + -- Should not happen; statically checked -repE e = pprPanic "DsMeta.repE: Illegal expression form" (ppr e) +repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e) +repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e) +repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e) +repE e@(HsBracketOut {}) = notHandled "TH brackets" (ppr e) +repE e = notHandled "Expression form" (ppr e) ----------------------------------------------------------------------------- -- Building representations of auxillary structures like Match, Clause, Stmt, @@ -583,6 +581,7 @@ repMatchTup (L _ (Match [p] ty (GRHSs guards wheres))) = ; gs <- repGuards guards ; match <- repMatch p1 gs ds ; wrapGenSyns (ss1++ss2) match }}} +repMatchTup other = panic "repMatchTup: case alt with more than one arg" repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ) repClauseTup (L _ (Match ps ty (GRHSs guards wheres))) = @@ -669,8 +668,8 @@ repSts (ExprStmt e _ _ : ss) = ; z <- repNoBindSt e2 ; (ss2,zs) <- repSts ss ; return (ss2, z : zs) } -repSts [] = return ([],[]) -repSts other = panic "Exotic Stmt in meta brackets" +repSts [] = return ([],[]) +repSts other = notHandled "Exotic statement" (ppr other) ----------------------------------------------------------- @@ -682,8 +681,7 @@ repBinds EmptyLocalBinds = do { core_list <- coreList decQTyConName [] ; return ([], core_list) } -repBinds (HsIPBinds _) - = panic "DsMeta:repBinds: can't do implicit parameters" +repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b) repBinds (HsValBinds decs) = do { let { bndrs = map unLoc (collectHsValBinders decs) } @@ -703,6 +701,8 @@ rep_val_binds (ValBindsOut binds sigs) = do { core1 <- rep_binds' (unionManyBags (map snd binds)) ; core2 <- rep_sigs' sigs ; return (core1 ++ core2) } +rep_val_binds (ValBindsOut binds sigs) + = panic "rep_val_binds: ValBindsOut" rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ] rep_binds binds = do { binds_w_locs <- rep_binds' binds @@ -750,6 +750,8 @@ rep_bind (L loc (VarBind { var_id = v, var_rhs = e})) ; ans <- repVal patcore x empty_decls ; return (srcLocSpan (getSrcLoc v), ans) } +rep_bind other = panic "rep_bind: AbsBinds" + ----------------------------------------------------------------------------- -- Since everything in a Bind is mutually recursive we need rename all -- all the variables simultaneously. For example: @@ -782,7 +784,7 @@ repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds))) do { xs <- repLPs ps; body <- repLE e; repLam xs body }) ; wrapGenSyns ss lam } -repLambda z = panic "Can't represent a guarded lambda in Template Haskell" +repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch LambdaExpr m) ----------------------------------------------------------------------------- @@ -822,10 +824,17 @@ repP (ConPatIn dc details) p2' <- repLP p2; repPinfix p1' con_str p2' } } -repP (NPat l (Just _) _ _) = panic "Can't cope with negative overloaded patterns yet (repP (NPat _ (Just _)))" repP (NPat l Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a } -repP (SigPatIn p t) = do { p' <- repLP p; t' <- repLTy t; repPsig p' t' } -repP other = panic "Exotic pattern inside meta brackets" +repP p@(NPat l (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p) +repP p@(SigPatIn {}) = notHandled "Type signatures in patterns" (ppr p) + -- The problem is to do with scoped type variables. + -- To implement them, we have to implement the scoping rules + -- here in DsMeta, and I don't want to do that today! + -- do { p' <- repLP p; t' <- repLTy t; repPsig p' t' } + -- repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ) + -- repPsig (MkC p) (MkC t) = rep2 sigPName [p, t] + +repP other = notHandled "Exotic pattern" (ppr other) ---------------------------------------------------------- -- Declaration ordering helpers @@ -878,7 +887,9 @@ lookupBinder n = do { mb_val <- dsLookupMetaEnv n; case mb_val of Just (Bound x) -> return (coreVar x) - other -> pprPanic "DsMeta: failed binder lookup when desugaring a TH bracket:" (ppr n) } + other -> failWithDs msg } + where + msg = ptext SLIT("DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n -- Look up a name that is either locally bound or a global name -- @@ -1030,9 +1041,6 @@ repPwild = rep2 wildPName [] repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ) repPlist (MkC ps) = rep2 listPName [ps] -repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ) -repPsig (MkC p) (MkC t) = rep2 sigPName [p, t] - --------------- Expressions ----------------- repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ) repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str @@ -1239,20 +1247,20 @@ repLiteral lit HsDoublePrim r -> mk_rational r _ -> return lit lit_expr <- dsLit lit' - rep2 lit_name [lit_expr] + case mb_lit_name of + Just lit_name -> rep2 lit_name [lit_expr] + Nothing -> notHandled "Exotic literal" (ppr lit) where - lit_name = case lit of - HsInteger _ _ -> integerLName - HsInt _ -> integerLName - HsIntPrim _ -> intPrimLName - HsFloatPrim _ -> floatPrimLName - HsDoublePrim _ -> doublePrimLName - HsChar _ -> charLName - HsString _ -> stringLName - HsRat _ _ -> rationalLName - other -> uh_oh - uh_oh = pprPanic "DsMeta.repLiteral: trying to represent exotic literal" - (ppr lit) + mb_lit_name = case lit of + HsInteger _ _ -> Just integerLName + HsInt _ -> Just integerLName + HsIntPrim _ -> Just intPrimLName + HsFloatPrim _ -> Just floatPrimLName + HsDoublePrim _ -> Just doublePrimLName + HsChar _ -> Just charLName + HsString _ -> Just stringLName + HsRat _ _ -> Just rationalLName + other -> Nothing mk_integer i = do integer_ty <- lookupType integerTyConName return $ HsInteger i integer_ty @@ -1307,6 +1315,12 @@ coreIntLit i = return (MkC (mkIntExpr (fromIntegral i))) coreVar :: Id -> Core TH.Name -- The Id has type Name coreVar id = MkC (Var id) +----------------- Failure ----------------------- +notHandled :: String -> SDoc -> DsM a +notHandled what doc = failWithDs msg + where + msg = hang (text what <+> ptext SLIT("not (yet) handled by Template Haskell")) + 2 doc -- %************************************************************************ diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index ae76bfd..acdecfe 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -6,7 +6,7 @@ \begin{code} module DsMonad ( DsM, mappM, mapAndUnzipM, - initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, + initDs, initDsTc, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, foldlDs, foldrDs, newTyVarsDs, newLocalName, @@ -22,7 +22,7 @@ module DsMonad ( DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, -- Warnings - DsWarning, dsWarn, + DsWarning, warnDs, failWithDs, -- Data types DsMatchContext(..), @@ -37,9 +37,9 @@ import CoreSyn ( CoreExpr ) import HsSyn ( HsExpr, HsMatchContext, Pat ) import TcIface ( tcIfaceGlobal ) import RdrName ( GlobalRdrEnv ) -import HscTypes ( TyThing(..), TypeEnv, HscEnv, +import HscTypes ( TyThing(..), TypeEnv, HscEnv(..), tyThingId, tyThingTyCon, tyThingDataCon, mkPrintUnqualified ) -import Bag ( emptyBag, snocBag, Bag ) +import Bag ( emptyBag, snocBag ) import DataCon ( DataCon ) import TyCon ( TyCon ) import Id ( mkSysLocal, setIdUnique, Id ) @@ -53,9 +53,8 @@ import Name ( Name, nameOccName ) import NameEnv import OccName ( occNameFS ) import DynFlags ( DynFlags ) -import ErrUtils ( WarnMsg, mkWarnMsg ) -import Bag ( mapBag ) - +import ErrUtils ( Messages, mkWarnMsg, mkErrMsg, + printErrorsAndWarnings, errorsFound ) import DATA_IOREF ( newIORef, readIORef ) infixr 9 `thenDs` @@ -131,7 +130,8 @@ type DsWarning = (SrcSpan, SDoc) data DsGblEnv = DsGblEnv { ds_mod :: Module, -- For SCC profiling - ds_warns :: IORef (Bag DsWarning), -- Warning messages + ds_unqual :: PrintUnqualified, + ds_msgs :: IORef Messages, -- Warning messages ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, -- possibly-imported things } @@ -153,33 +153,57 @@ data DsMetaVal | Splice (HsExpr Id) -- These bindings are introduced by -- the PendingSplices on a HsBracketOut --- initDs returns the UniqSupply out the end (not just the result) - initDs :: HscEnv -> Module -> GlobalRdrEnv -> TypeEnv -> DsM a - -> IO (a, Bag WarnMsg) + -> IO (Maybe a) +-- Print errors and warnings, if any arise initDs hsc_env mod rdr_env type_env thing_inside - = do { warn_var <- newIORef emptyBag - ; let { if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) } - ; if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod) - ; gbl_env = DsGblEnv { ds_mod = mod, - ds_if_env = (if_genv, if_lenv), - ds_warns = warn_var } - ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv, - ds_loc = noSrcSpan } } - - ; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside - - ; warns <- readIORef warn_var - ; return (res, mapBag mk_warn warns) - } - where - print_unqual = mkPrintUnqualified rdr_env - - mk_warn :: (SrcSpan,SDoc) -> WarnMsg - mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc + = do { msg_var <- newIORef (emptyBag, emptyBag) + ; let (ds_gbl_env, ds_lcl_env) = mkDsEnvs mod rdr_env type_env msg_var + + ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $ + tryM thing_inside -- Catch exceptions (= errors during desugaring) + + -- Display any errors and warnings + -- Note: if -Werror is used, we don't signal an error here. + ; let dflags = hsc_dflags hsc_env + ; msgs <- readIORef msg_var + ; printErrorsAndWarnings dflags msgs + + ; let final_res | errorsFound dflags msgs = Nothing + | otherwise = case either_res of + Right res -> Just res + Left exn -> pprPanic "initDs" (text (show exn)) + -- The (Left exn) case happens when the thing_inside throws + -- a UserError exception. Then it should have put an error + -- message in msg_var, so we just discard the exception + + ; return final_res } + +initDsTc :: DsM a -> TcM a +initDsTc thing_inside + = do { this_mod <- getModule + ; tcg_env <- getGblEnv + ; msg_var <- getErrsVar + ; let type_env = tcg_type_env tcg_env + rdr_env = tcg_rdr_env tcg_env + ; setEnvs (mkDsEnvs this_mod rdr_env type_env msg_var) thing_inside } + +mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv + -> IORef Messages -> (DsGblEnv, DsLclEnv) +mkDsEnvs mod rdr_env type_env msg_var + = (gbl_env, lcl_env) + where + if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) } + if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod) + gbl_env = DsGblEnv { ds_mod = mod, + ds_if_env = (if_genv, if_lenv), + ds_unqual = mkPrintUnqualified rdr_env, + ds_msgs = msg_var } + lcl_env = DsLclEnv { ds_meta = emptyNameEnv, + ds_loc = noSrcSpan } \end{code} %************************************************************************ @@ -241,12 +265,22 @@ getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) } putSrcSpanDs :: SrcSpan -> DsM a -> DsM a putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside -dsWarn :: SDoc -> DsM () -dsWarn warn = do { env <- getGblEnv +warnDs :: SDoc -> DsM () +warnDs warn = do { env <- getGblEnv ; loc <- getSrcSpanDs - ; updMutVar (ds_warns env) (`snocBag` (loc,msg)) } + ; let msg = mkWarnMsg loc (ds_unqual env) + (ptext SLIT("Warning:") <+> warn) + ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) } where - msg = ptext SLIT("Warning:") <+> warn + +failWithDs :: SDoc -> DsM a +failWithDs err + = do { env <- getGblEnv + ; loc <- getSrcSpanDs + ; let msg = mkErrMsg loc (ds_unqual env) err + ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) + ; failM } + where \end{code} \begin{code} diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index d72d6ad..b428658 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -91,7 +91,7 @@ The next two functions create the warning message. \begin{code} dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM () dsShadowWarn ctx@(DsMatchContext kind loc) qs - = putSrcSpanDs loc (dsWarn warn) + = putSrcSpanDs loc (warnDs warn) where warn | qs `lengthExceeds` maximum_output = pp_context ctx (ptext SLIT("are overlapped")) @@ -104,7 +104,7 @@ dsShadowWarn ctx@(DsMatchContext kind loc) qs dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM () dsIncompleteWarn ctx@(DsMatchContext kind loc) pats - = putSrcSpanDs loc (dsWarn warn) + = putSrcSpanDs loc (warnDs warn) where warn = pp_context ctx (ptext SLIT("are non-exhaustive")) (\f -> hang (ptext SLIT("Patterns not matched:")) diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 6536068..422c270 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -25,11 +25,11 @@ module HscMain #include "HsVersions.h" #ifdef GHCI -import HsSyn ( Stmt(..), LHsExpr, LStmt, LHsType ) -import Module ( Module ) +import HsSyn ( Stmt(..), LStmt, LHsType ) import CodeOutput ( outputForeignStubs ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker ( HValue, linkExpr ) +import CoreSyn ( CoreExpr ) import CoreTidy ( tidyExpr ) import CorePrep ( corePrepExpr ) import Flattening ( flattenExpr ) @@ -41,7 +41,7 @@ import PrelNames ( iNTERACTIVE ) import Kind ( Kind ) import CoreLint ( lintUnfolding ) import DsMeta ( templateHaskellNames ) -import SrcLoc ( noSrcLoc, getLoc ) +import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan ) import VarEnv ( emptyTidyEnv ) #endif @@ -462,10 +462,7 @@ hscFileFrontEnd = ------------------- -- DESUGAR ------------------- - -> do (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-} - deSugar hsc_env tc_result - printBagOfWarnings dflags warns - return maybe_ds_result + -> {-# SCC "DeSugar" #-} deSugar hsc_env tc_result -------------------------------------------------------------- -- Simplifiers @@ -805,14 +802,22 @@ hscStmt hsc_env stmt Nothing -> return Nothing ; Just (new_ic, bound_names, tc_expr) -> do { + + -- Desugar it + ; let rdr_env = ic_rn_gbl_env new_ic + type_env = ic_type_env new_ic + ; 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 - ; hval <- compileExpr hsc_env iNTERACTIVE - (ic_rn_gbl_env new_ic) - (ic_type_env new_ic) - tc_expr + ; let src_span = srcLocSpan interactiveSrcLoc + ; hval <- compileExpr hsc_env src_span ds_expr ; return (Just (hsc_env{ hsc_IC=new_ic }, bound_names, hval)) - }}}}} + }}}}}}} hscTcExpr -- Typecheck an expression (but don't run it) :: HscEnv @@ -892,19 +897,12 @@ hscParseThing parser dflags str \begin{code} #ifdef GHCI -compileExpr :: HscEnv - -> Module -> GlobalRdrEnv -> TypeEnv - -> LHsExpr Id - -> IO HValue +compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue -compileExpr hsc_env this_mod rdr_env type_env tc_expr +compileExpr hsc_env srcspan ds_expr = do { let { dflags = hsc_dflags hsc_env ; - lint_on = dopt Opt_DoCoreLinting dflags ; - !srcspan = getLoc tc_expr } + lint_on = dopt Opt_DoCoreLinting dflags } - -- Desugar it - ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr - -- Flatten it ; flat_expr <- flattenExpr hsc_env ds_expr diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 7bf2f87..e942eec 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -124,13 +124,14 @@ import HscTypes ( InteractiveContext(..), Dependencies(..) ) import BasicTypes ( Fixity, RecFlag(..) ) import SrcLoc ( unLoc ) +import Data.Maybe ( isNothing ) #endif import FastString ( mkFastString ) import Util ( sortLe ) import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags ) -import Data.Maybe ( isJust, isNothing ) +import Data.Maybe ( isJust ) \end{code} diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index f1e8c56..6ac66d6 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -55,6 +55,8 @@ import Id ( idName, globalIdDetails ) import IdInfo ( GlobalIdDetails(..) ) import TysWiredIn ( mkListTy ) import DsMeta ( expQTyConName, typeQTyConName, decTyConName, qTyConName, nameTyConName ) +import DsExpr ( dsLExpr ) +import DsMonad ( initDsTc ) import ErrUtils ( Message ) import SrcLoc ( SrcSpan, noLoc, unLoc, getLoc ) import Outputable @@ -368,17 +370,14 @@ runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn) -> LHsExpr Id -- Of type X -> TcM hs_syn -- Of type t runMeta convert expr - = do { hsc_env <- getTopEnv - ; tcg_env <- getGblEnv - ; this_mod <- getModule - ; let type_env = tcg_type_env tcg_env - rdr_env = tcg_rdr_env tcg_env + = do { -- Desugar + ds_expr <- initDsTc (dsLExpr expr) -- Compile and link it; might fail if linking fails + ; hsc_env <- getTopEnv + ; src_span <- getSrcSpanM ; either_hval <- tryM $ ioToTcRn $ - HscMain.compileExpr - hsc_env this_mod - rdr_env type_env expr + HscMain.compileExpr hsc_env src_span ds_expr ; case either_hval of { Left exn -> failWithTc (mk_msg "compile and link" exn) ; Right hval -> do