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)
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 )
-- 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)
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)
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
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
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
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
= 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
%************************************************************************
\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
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}
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,
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,
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.
************************************************************************
\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) $
-- 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
%************************************************************************
\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
%************************************************************************
\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) ->
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
[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
-- 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...
-- 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 }
*********************************************************
\begin{code}
-rnPatsAndThen :: HsMatchContext RdrName
+rnPatsAndThen :: HsMatchContext Name
-> [RdrNamePat]
-> ([RenamedPat] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
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
| 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
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
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
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}
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,
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}
%************************************************************************
\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 ->
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]
-- 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' ->
-- 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
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' ->
projects / ghc-hetmet.git / commitdiff