From 278092c8eeb3835ad850b595afab0423fa890026 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 27 Sep 2002 12:42:45 +0000 Subject: [PATCH] [project @ 2002-09-27 12:42:42 by simonpj] Wibbles to improve error reporting --- ghc/compiler/deSugar/DsBinds.lhs | 2 +- ghc/compiler/deSugar/DsExpr.lhs | 9 +-- ghc/compiler/deSugar/Match.lhs | 2 +- ghc/compiler/hsSyn/HsExpr.lhs | 100 ++++++++++++++++++++-------------- ghc/compiler/rename/RnBinds.lhs | 13 +++-- ghc/compiler/rename/RnExpr.lhs | 84 ++++++++++++++++++++++------ ghc/compiler/rename/RnTypes.lhs | 4 +- ghc/compiler/typecheck/TcExpr.lhs | 2 +- ghc/compiler/typecheck/TcHsSyn.lhs | 6 +- ghc/compiler/typecheck/TcMatches.lhs | 22 +++++--- 10 files changed, 159 insertions(+), 85 deletions(-) diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index a62b969..918f0e9 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -78,7 +78,7 @@ dsMonoBinds _ (VarMonoBind var expr) rest dsMonoBinds auto_scc (FunMonoBind fun _ matches locn) rest = putSrcLocDs locn $ - matchWrapper (FunRhs fun) matches `thenDs` \ (args, body) -> + matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, body) -> addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair -> returnDs (pair : rest) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 0cf2b97..8818229 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -45,10 +45,11 @@ import CoreUtils ( exprType, mkIfThenElse, bindNonRec ) import FieldLabel ( FieldLabel, fieldLabelTyCon ) import CostCentre ( mkUserCC ) -import Id ( Id, idType, recordSelectorFieldLabel ) +import Id ( Id, idType, idName, recordSelectorFieldLabel ) import PrelInfo ( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID ) import DataCon ( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys ) import DataCon ( isExistentialDataCon ) +import Name ( Name ) import TyCon ( tyConDataCons ) import TysWiredIn ( tupleCon, mkTupleTy ) import BasicTypes ( RecFlag(..), Boxity(..), ipNameName ) @@ -102,8 +103,8 @@ dsLet bind@(MonoBind (AbsBinds [] [] exports inlines binds) sigs is_rec) body -- below. Then pattern-match would fail. Urk.) case binds of FunMonoBind fun _ matches loc - -> putSrcLocDs loc $ - matchWrapper (FunRhs fun) matches `thenDs` \ (args, rhs) -> + -> putSrcLocDs loc $ + matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) -> ASSERT( null args ) -- Functions aren't lifted returnDs (bindNonRec fun rhs body_w_exports) @@ -571,7 +572,7 @@ dsExpr (PArrSeqIn _) = panic "dsExpr:PArrSeqIn" Basically does the translation given in the Haskell~1.3 report: \begin{code} -dsDo :: HsStmtContext +dsDo :: HsStmtContext Name -> [TypecheckedStmt] -> [Id] -- id for: [return,fail,>>=,>>] and possibly mfixName -> Type -- Element type; the whole expression has type (m t) diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 3982d4c..282ba80 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -114,7 +114,7 @@ pp_context NoMatchContext msg rest_of_msg_fun pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun = (loc, vcat [ptext SLIT("Pattern match(es)") <+> msg, - sep [ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]) + sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]) where (ppr_match, pref) = case kind of diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 874e4f1..59b5cd0 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -88,7 +88,9 @@ data HsExpr id Bool -- True <=> this was a 'with' binding -- (tmp, until 'with' is removed) - | HsDo HsStmtContext + | HsDo (HsStmtContext Name) -- The parameterisation is unimportant + -- because in this context we never use + -- the FunRhs variant [Stmt id] -- "do":one or more stmts [id] -- Ids for [return,fail,>>=,>>] -- Brutal but simple @@ -233,8 +235,7 @@ ppr_expr (HsIPVar v) = ppr v ppr_expr (HsLit lit) = ppr lit ppr_expr (HsOverLit lit) = ppr lit -ppr_expr (HsLam match) - = hsep [char '\\', nest 2 (pprMatch LambdaExpr match)] +ppr_expr (HsLam match) = pprMatch LambdaExpr match ppr_expr expr@(HsApp e1 e2) = let (fun, args) = collect_args expr [] in @@ -529,7 +530,9 @@ pprMatch ctxt (Match pats maybe_ty grhss) where pp_name (FunRhs fun) = ppr fun -- Not pprBndr; the AbsBinds will -- have printed the signature + pp_name LambdaExpr = char '\\' pp_name other = empty + ppr_maybe_ty = case maybe_ty of Just ty -> dcolon <+> ppr ty Nothing -> empty @@ -643,7 +646,7 @@ pprStmt (ParStmtOut stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss) pprStmt (RecStmt _ segment) = vcat (map ppr segment) -pprDo :: OutputableBndr id => HsStmtContext -> [Stmt id] -> SDoc +pprDo :: OutputableBndr id => HsStmtContext any -> [Stmt id] -> SDoc pprDo DoExpr stmts = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts)) pprDo MDoExpr stmts = hang (ptext SLIT("mdo")) 3 (vcat (map ppr stmts)) pprDo ListComp stmts = pprComp brackets stmts @@ -721,24 +724,26 @@ pp_dotdot = ptext SLIT(" .. ") %************************************************************************ \begin{code} -data HsMatchContext id -- Context of a Match or Stmt - = StmtCtxt HsStmtContext -- Do-stmt or list comprehension - | FunRhs id -- Function binding for f - | CaseAlt -- Guard on a case alternative - | LambdaExpr -- Lambda - | PatBindRhs -- Pattern binding - | RecUpd -- Record update +data HsMatchContext id -- Context of a Match + = FunRhs id -- Function binding for f + | CaseAlt -- Guard on a case alternative + | LambdaExpr -- Pattern of a lambda + | PatBindRhs -- Pattern binding + | RecUpd -- Record update [used only in DsExpr to tell matchWrapper + -- what sort of runtime error message to generate] + | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt or list comprehension deriving () -data HsStmtContext - = ListComp - | DoExpr - | MDoExpr -- recursive do-expression - | PArrComp -- parallel array comprehension - | PatGuard -- Never occurs in an HsDo expression, of course +data HsStmtContext id + = ListComp + | DoExpr + | MDoExpr -- Recursive do-expression + | PArrComp -- Parallel array comprehension + | PatGuard (HsMatchContext id) -- Pattern guard for specified thing \end{code} \begin{code} +isDoExpr :: HsStmtContext id -> Bool isDoExpr DoExpr = True isDoExpr MDoExpr = True isDoExpr other = False @@ -749,33 +754,46 @@ matchSeparator (FunRhs _) = ptext SLIT("=") matchSeparator CaseAlt = ptext SLIT("->") matchSeparator LambdaExpr = ptext SLIT("->") matchSeparator PatBindRhs = ptext SLIT("=") -matchSeparator (StmtCtxt _) = ptext SLIT("<-") -matchSeparator RecUpd = panic "When is this used?" +matchSeparator (StmtCtxt _) = ptext SLIT("<-") +matchSeparator RecUpd = panic "unused" \end{code} \begin{code} -pprMatchContext (FunRhs fun) = ptext SLIT("In the definition of") <+> quotes (ppr fun) -pprMatchContext CaseAlt = ptext SLIT("In a case alternative") -pprMatchContext RecUpd = ptext SLIT("In a record-update construct") -pprMatchContext PatBindRhs = ptext SLIT("In a pattern binding") -pprMatchContext LambdaExpr = ptext SLIT("In a lambda abstraction") -pprMatchContext (StmtCtxt ctxt) = pprStmtCtxt ctxt - -pprStmtCtxt PatGuard = ptext SLIT("In a pattern guard") -pprStmtCtxt DoExpr = ptext SLIT("In a 'do' expression pattern binding") -pprStmtCtxt MDoExpr = ptext SLIT("In an 'mdo' expression pattern binding") -pprStmtCtxt ListComp = ptext SLIT("In a 'list comprehension' pattern binding") -pprStmtCtxt PArrComp = ptext SLIT("In an 'array comprehension' pattern binding") +pprMatchContext (FunRhs fun) = ptext SLIT("the definition of") <+> quotes (ppr fun) +pprMatchContext CaseAlt = ptext SLIT("a case alternative") +pprMatchContext RecUpd = ptext SLIT("a record-update construct") +pprMatchContext PatBindRhs = ptext SLIT("a pattern binding") +pprMatchContext LambdaExpr = ptext SLIT("a lambda abstraction") +pprMatchContext (StmtCtxt ctxt) = ptext SLIT("a pattern binding in") $$ pprStmtContext ctxt + +pprMatchRhsContext (FunRhs fun) = ptext SLIT("a right-hand side of function") <+> quotes (ppr fun) +pprMatchRhsContext CaseAlt = ptext SLIT("the body of a case alternative") +pprMatchRhsContext PatBindRhs = ptext SLIT("the right-hand side of a pattern binding") +pprMatchRhsContext LambdaExpr = ptext SLIT("the body of a lambda") +pprMatchRhsContext RecUpd = panic "pprMatchRhsContext" + +pprStmtContext (PatGuard ctxt) = ptext SLIT("a pattern guard for") $$ pprMatchContext ctxt +pprStmtContext DoExpr = ptext SLIT("a 'do' expression") +pprStmtContext MDoExpr = ptext SLIT("an 'mdo' expression") +pprStmtContext ListComp = ptext SLIT("a list comprehension") +pprStmtContext PArrComp = ptext SLIT("an array comprehension") + +-- Used for the result statement of comprehension +-- e.g. the 'e' in [ e | ... ] +-- or the 'r' in f x = r +pprStmtResultContext (PatGuard ctxt) = pprMatchRhsContext ctxt +pprStmtResultContext other = ptext SLIT("the result of") <+> pprStmtContext other + -- Used to generate the string for a *runtime* error message -matchContextErrString (FunRhs fun) = "function " ++ showSDoc (ppr fun) -matchContextErrString CaseAlt = "case" -matchContextErrString PatBindRhs = "pattern binding" -matchContextErrString RecUpd = "record update" -matchContextErrString LambdaExpr = "lambda" -matchContextErrString (StmtCtxt PatGuard) = "pattern gaurd" -matchContextErrString (StmtCtxt DoExpr) = "'do' expression" -matchContextErrString (StmtCtxt MDoExpr) = "'mdo' expression" -matchContextErrString (StmtCtxt ListComp) = "list comprehension" -matchContextErrString (StmtCtxt PArrComp) = "array comprehension" +matchContextErrString (FunRhs fun) = "function " ++ showSDoc (ppr fun) +matchContextErrString CaseAlt = "case" +matchContextErrString PatBindRhs = "pattern binding" +matchContextErrString RecUpd = "record update" +matchContextErrString LambdaExpr = "lambda" +matchContextErrString (StmtCtxt (PatGuard _)) = "pattern gaurd" +matchContextErrString (StmtCtxt DoExpr) = "'do' expression" +matchContextErrString (StmtCtxt MDoExpr) = "'mdo' expression" +matchContextErrString (StmtCtxt ListComp) = "list comprehension" +matchContextErrString (StmtCtxt PArrComp) = "array comprehension" \end{code} diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index da97758..3205c22 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -303,7 +303,7 @@ flattenMonoBinds sigs (PatMonoBind pat grhss locn) names_bound_here = mkNameSet (collectPatBinders pat') in sigsForMe names_bound_here sigs `thenM` \ sigs_for_me -> - rnGRHSs grhss `thenM` \ (grhss', fvs) -> + rnGRHSs PatBindRhs grhss `thenM` \ (grhss', fvs) -> returnM [(names_bound_here, fvs `plusFV` pat_fvs, @@ -317,7 +317,7 @@ flattenMonoBinds sigs (FunMonoBind name inf matches locn) names_bound_here = unitNameSet new_name in sigsForMe names_bound_here sigs `thenM` \ sigs_for_me -> - mapFvRn (rnMatch (FunRhs name)) matches `thenM` \ (new_matches, fvs) -> + mapFvRn (rnMatch (FunRhs new_name)) matches `thenM` \ (new_matches, fvs) -> mappM_ (checkPrecMatch inf new_name) new_matches `thenM_` returnM [(unitNameSet new_name, @@ -370,19 +370,20 @@ rnMethodBinds cls gen_tyvars (FunMonoBind name inf matches locn) lookupInstDeclBndr cls name `thenM` \ sel_name -> -- We use the selector name as the binder - mapFvRn rn_match matches `thenM` \ (new_matches, fvs) -> + mapFvRn (rn_match sel_name) matches `thenM` \ (new_matches, fvs) -> mappM_ (checkPrecMatch inf sel_name) new_matches `thenM_` returnM (FunMonoBind sel_name inf new_matches locn, fvs `addOneFV` sel_name) where -- Gruesome; bring into scope the correct members of the generic type variables -- See comments in RnSource.rnSourceDecl(ClassDecl) - rn_match match@(Match (TypePat ty : _) _ _) - = extendTyVarEnvFVRn gen_tvs (rnMatch (FunRhs name) match) + rn_match sel_name match@(Match (TypePat ty : _) _ _) + = extendTyVarEnvFVRn gen_tvs $ + rnMatch (FunRhs sel_name) match where tvs = map rdrNameOcc (extractHsTyRdrNames ty) gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs] - rn_match match = rnMatch (FunRhs name) match + rn_match sel_name match = rnMatch (FunRhs sel_name) match -- Can't handle method pattern-bindings which bind multiple methods. diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 2ee2e8f..299bb31 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -63,7 +63,7 @@ import FastString ************************************************************************ \begin{code} -rnMatch :: HsMatchContext RdrName -> RdrNameMatch -> RnM (RenamedMatch, FreeVars) +rnMatch :: HsMatchContext Name -> RdrNameMatch -> RnM (RenamedMatch, FreeVars) rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) = addSrcLoc (getMatchLoc match) $ @@ -81,7 +81,7 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) -- Now the main event rnPatsAndThen ctxt pats $ \ pats' -> - rnGRHSs grhss `thenM` \ (grhss', grhss_fvs) -> + rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) -> returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs) -- The bindPatSigTyVars and rnPatsAndThen will remove the bound FVs @@ -100,20 +100,20 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) %************************************************************************ \begin{code} -rnGRHSs :: RdrNameGRHSs -> RnM (RenamedGRHSs, FreeVars) +rnGRHSs :: HsMatchContext Name -> RdrNameGRHSs -> RnM (RenamedGRHSs, FreeVars) -rnGRHSs (GRHSs grhss binds _) +rnGRHSs ctxt (GRHSs grhss binds _) = rnBindsAndThen binds $ \ binds' -> - mapFvRn rnGRHS grhss `thenM` \ (grhss', fvGRHSs) -> + mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) -> returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs) -rnGRHS (GRHS guarded locn) +rnGRHS ctxt (GRHS guarded locn) = addSrcLoc locn $ doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> checkM (opt_GlasgowExts || is_standard_guard guarded) (addWarn (nonStdGuardErr guarded)) `thenM_` - rnStmts PatGuard guarded `thenM` \ (guarded', fvs) -> + rnStmts (PatGuard ctxt) guarded `thenM` \ (guarded', fvs) -> returnM (GRHS guarded' locn, fvs) where -- Standard Haskell 1.4 guards are just a single boolean @@ -471,17 +471,18 @@ rnBracket (DecBr ds) = rnSrcDecls ds `thenM` \ (tcg_env, ds', fvs) -> %************************************************************************ \begin{code} -rnStmts :: HsStmtContext - -> [RdrNameStmt] - -> RnM ([RenamedStmt], FreeVars) +rnStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars) rnStmts MDoExpr stmts = rnMDoStmts stmts rnStmts ctxt stmts = rnNormalStmts ctxt stmts -rnNormalStmts :: HsStmtContext -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars) +rnNormalStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars) -- Used for cases *other* than recursive mdo -- Implements nested scopes +rnNormalStmts ctxt [] = returnM ([], emptyFVs) + -- Happens at the end of the sub-lists of a ParStmts + rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts) = addSrcLoc src_loc $ rnExpr expr `thenM` \ (expr', fv_expr) -> @@ -534,13 +535,17 @@ rnNormalStmts ctxt (ParStmt stmtss : stmts) err v = ptext SLIT("Duplicate binding in parallel list comprehension for:") <+> quotes (ppr v) -rnMDoStmts stmts - = bindLocalsRn doc (collectStmtsBinders stmts) $ \ _ -> - mappM rn_mdo_stmt stmts `thenM` \ segs -> - returnM (segsToStmts (glomSegments (addFwdRefs segs))) - where - doc = text "In a mdo-expression" +rnNormalStmts ctxt stmts = pprPanic "rnNormalStmts" (ppr stmts) +\end{code} + + +%************************************************************************ +%* * +\subsubsection{Precedence Parsing} +%* * +%************************************************************************ +\begin{code} type Defs = NameSet type Uses = NameSet -- Same as FreeVars really type FwdRefs = NameSet @@ -552,6 +557,40 @@ type Segment = (Defs, [RenamedStmt]) ---------------------------------------------------- +rnMDoStmts :: [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars) +rnMDoStmts stmts + = -- Step1: bring all the binders of the mdo into scope + bindLocalsRn doc (collectStmtsBinders stmts) $ \ _ -> + + -- Step 2: Rename each individual stmt, making a + -- singleton segment. At this stage the FwdRefs field + -- isn't finished: it's empty for all except a BindStmt + -- for which it's the fwd refs within the bind itself + mappM rn_mdo_stmt stmts `thenM` \ segs -> + let + -- Step 3: Fill in the fwd refs. + -- The segments are all singletons, but their fwd-ref + -- field mentions all the things used by the segment + -- that are bound after their use + segs_w_fwd_refs = addFwdRefs segs + + -- Step 4: Group together the segments to make bigger segments + -- Invariant: in the result, no segment uses a variable + -- bound in a later segment + grouped_segs = glomSegments segs_w_fwd_refs + + -- Step 5: Turn the segments into Stmts + -- Use RecStmt when and only when there are fwd refs + -- Also gather up the uses from the end towards the + -- start, so we can tell the RecStmt which things are + -- used 'after' the RecStmt + stmts_w_fvs = segsToStmts grouped_segs + in + returnM stmts_w_fvs + where + doc = text "In a mdo-expression" + +---------------------------------------------------- rn_mdo_stmt :: RdrNameStmt -> RnM Segment -- Assumes all binders are already in scope -- Turns each stmt into a singleton Stmt @@ -603,7 +642,11 @@ addFwdRefs pairs -- Add the downstream fwd refs here ---------------------------------------------------- --- Breaking a recursive 'do' into segments +-- Glomming the singleton segments of an mdo into +-- minimal recursive groups. +-- +-- At first I thought this was just strongly connected components, but +-- there's an important constraint: the order of the stmts must not change. -- -- Consider -- mdo { x <- ...y... @@ -613,6 +656,11 @@ addFwdRefs pairs -- z <- y -- r <- x } -- +-- Here, the first stmt mention 'y', which is bound in the third. +-- But that means that the innocent second stmt (p <- z) gets caught +-- up in the recursion. And that in turn means that the binding for +-- 'z' has to be included... and so on. +-- -- Start at the tail { r <- x } -- Now add the next one { z <- y ; r <- x } -- Now add one more { q <- x ; z <- y ; r <- x } diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index a2cb502..97a82d2 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -296,7 +296,7 @@ rnPred doc (HsIParam n ty) ********************************************************* \begin{code} -rnPatsAndThen :: HsMatchContext RdrName +rnPatsAndThen :: HsMatchContext Name -> [RdrNamePat] -> ([RenamedPat] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) @@ -323,7 +323,7 @@ rnPatsAndThen ctxt pats thing_inside where pat_sig_tys = collectSigTysFromPats pats bndrs = collectPatsBinders pats - doc_pat = pprMatchContext ctxt + doc_pat = ptext SLIT("In") <+> pprMatchContext ctxt rnPats :: [RdrNamePat] -> RnM ([RenamedPat], FreeVars) rnPats ps = mapFvRn rnPat ps diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 6bf8c32..c83b46e 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -1136,7 +1136,7 @@ missingStrictFields con fields | otherwise = colon <+> pprWithCommas ppr fields header = ptext SLIT("Constructor") <+> quotes (ppr con) <+> - ptext SLIT("does not have the required strict fields") + ptext SLIT("does not have the required strict field(s)") missingFields :: DataCon -> [FieldLabel] -> SDoc diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 3009de2..3e83ab8 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -59,7 +59,7 @@ import TysWiredIn ( charTy, stringTy, intTy, integerTy, import TyCon ( mkPrimTyCon, tyConKind ) import PrimRep ( PrimRep(VoidRep) ) import CoreSyn ( CoreExpr ) -import Name ( getOccName, mkInternalName, mkDerivedTyConOcc ) +import Name ( Name, getOccName, mkInternalName, mkDerivedTyConOcc ) import Var ( isId, isLocalVar, tyVarKind ) import VarSet import VarEnv @@ -106,7 +106,6 @@ type TypecheckedHsExpr = HsExpr Id type TypecheckedArithSeqInfo = ArithSeqInfo Id type TypecheckedStmt = Stmt Id type TypecheckedMatch = Match Id -type TypecheckedMatchContext = HsMatchContext Id type TypecheckedGRHSs = GRHSs Id type TypecheckedGRHS = GRHS Id type TypecheckedRecordBinds = HsRecordBinds Id @@ -114,6 +113,9 @@ type TypecheckedHsModule = HsModule Id type TypecheckedForeignDecl = ForeignDecl Id type TypecheckedRuleDecl = RuleDecl Id type TypecheckedCoreBind = (Id, CoreExpr) + +type TypecheckedMatchContext = HsMatchContext Name -- Keeps consistency with + -- HsDo arg StmtContext \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index f0d9c45..91d5aef 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -14,7 +14,8 @@ import {-# SOURCE #-} TcExpr( tcMonoExpr ) import HsSyn ( HsExpr(..), HsBinds(..), Match(..), GRHSs(..), GRHS(..), MonoBinds(..), Stmt(..), HsMatchContext(..), HsStmtContext(..), - pprMatch, getMatchLoc, pprMatchContext, pprStmtCtxt, isDoExpr, + pprMatch, getMatchLoc, isDoExpr, + pprMatchContext, pprStmtContext, pprStmtResultContext, mkMonoBind, nullMonoBinds, collectSigTysFromPats, andMonoBindList ) import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt, @@ -192,13 +193,15 @@ tcGRHSs :: RenamedMatchContext -> RenamedGRHSs tcGRHSs ctxt (GRHSs grhss binds _) expected_ty = tcBindsAndThen glue_on binds (tc_grhss grhss) where + m_ty = (\ty -> ty, expected_ty) + tc_grhss grhss = mappM tc_grhs grhss `thenM` \ grhss' -> returnM (GRHSs grhss' EmptyBinds expected_ty) tc_grhs (GRHS guarded locn) - = addSrcLoc locn $ - tcStmts PatGuard (\ty -> ty, expected_ty) guarded `thenM` \ guarded' -> + = addSrcLoc locn $ + tcStmts (PatGuard ctxt) m_ty guarded `thenM` \ guarded' -> returnM (GRHS guarded' locn) \end{code} @@ -317,7 +320,7 @@ tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req match_ty %************************************************************************ \begin{code} -tcDoStmts :: HsStmtContext -> [RenamedStmt] -> [Name] -> TcType +tcDoStmts :: HsStmtContext Name -> [RenamedStmt] -> [Name] -> TcType -> TcM (TcMonoBinds, [TcStmt], [Id]) tcDoStmts PArrComp stmts method_names res_ty = unifyPArrTy res_ty `thenM` \elt_ty -> @@ -399,7 +402,7 @@ tcStmts do_or_lc m_ty stmts tcStmtsAndThen :: (TcStmt -> thing -> thing) -- Combiner - -> HsStmtContext + -> HsStmtContext Name -> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs -- elt_ty, where type of the comprehension is (m elt_ty) -> [RenamedStmt] @@ -474,7 +477,7 @@ tcStmtAndThen combine do_or_lc m_ty (RecStmt recNames stmts) thing_inside -- ExprStmt tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside - = setErrCtxt (stmtCtxt do_or_lc stmt) ( + = addErrCtxt (stmtCtxt do_or_lc stmt) ( if isDoExpr do_or_lc then newTyVarTy openTypeKind `thenM` \ any_ty -> tcMonoExpr exp (m any_ty) `thenM` \ exp' -> @@ -490,7 +493,7 @@ tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) t -- Result statements tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside - = setErrCtxt (stmtCtxt do_or_lc stmt) ( + = addErrCtxt (resCtxt do_or_lc stmt) ( if isDoExpr do_or_lc then tcMonoExpr exp (m res_elt_ty) else @@ -530,8 +533,9 @@ sameNoOfArgs matches = isSingleton (nub (map args_in_match matches)) varyingArgsErr name matches = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)] -matchCtxt ctxt match = hang (pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match) -stmtCtxt do_or_lc stmt = hang (pprStmtCtxt do_or_lc <> colon) 4 (ppr stmt) +matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match) +stmtCtxt do_or_lc stmt = hang (ptext SLIT("In") <+> pprStmtContext do_or_lc <> colon) 4 (ppr stmt) +resCtxt do_or_lc stmt = hang (ptext SLIT("In") <+> pprStmtResultContext do_or_lc <> colon) 4 (ppr stmt) sigPatCtxt bound_tvs bound_ids match_ty tidy_env = zonkTcType match_ty `thenM` \ match_ty' -> -- 1.7.10.4