Commit 7a59afce authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

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.
parent d5c6d002
......@@ -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,
......
......@@ -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
......
......@@ -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
......
......@@ -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
-- %************************************************************************
......
......@@ -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}
......
......@@ -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:"))
......
......@@ -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 ;