Commit 278092c8 authored by simonpj's avatar simonpj
Browse files

[project @ 2002-09-27 12:42:42 by simonpj]

Wibbles to improve error reporting
parent dbc254c3
......@@ -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)
......
......@@ -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)
......
......@@ -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
......
......@@ -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}
......@@ -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.
......
......@@ -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
......@@ -551,6 +556,40 @@ type Segment = (Defs,
-- (b) used here, and bound in subsequent segments
[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
......@@ -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 }
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......
......@@ -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' ->
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment