\begin{code}
module RnExpr (
- rnMatch, rnGRHSs, rnLExpr, rnExpr, rnStmts,
+ rnMatchGroup, rnMatch, rnGRHSs, rnLExpr, rnExpr, rnStmts,
checkPrecMatch, checkTH
) where
************************************************************************
\begin{code}
+rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars)
+rnMatchGroup ctxt (MatchGroup ms _)
+ = mapFvRn (rnMatch ctxt) ms `thenM` \ (new_ms, ms_fvs) ->
+ returnM (MatchGroup new_ms placeHolderType, ms_fvs)
+
rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars)
rnMatch ctxt = wrapLocFstM (rnMatch' ctxt)
\begin{code}
rnGRHSs :: HsMatchContext Name -> GRHSs RdrName -> RnM (GRHSs Name, FreeVars)
-rnGRHSs ctxt (GRHSs grhss binds _)
+-- gaw 2004
+rnGRHSs ctxt (GRHSs grhss binds)
= rnBindGroupsAndThen binds $ \ binds' ->
mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) ->
- returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs)
+ returnM (GRHSs grhss' binds', fvGRHSs)
rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars)
rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt)
= rnOverLit lit `thenM` \ (lit', fvs) ->
returnM (HsOverLit lit', fvs)
-rnExpr (HsLam match)
- = rnMatch LambdaExpr match `thenM` \ (match', fvMatch) ->
- returnM (HsLam match', fvMatch)
-
rnExpr (HsApp fun arg)
= rnLExpr fun `thenM` \ (fun',fvFun) ->
rnLExpr arg `thenM` \ (arg',fvArg) ->
= rnLExpr expr `thenM` \ (expr', fvs_expr) ->
returnM (HsSCC lbl expr', fvs_expr)
-rnExpr (HsCase expr ms)
+rnExpr (HsLam matches)
+ = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
+ returnM (HsLam matches', fvMatch)
+
+rnExpr (HsCase expr matches)
= rnLExpr expr `thenM` \ (new_expr, e_fvs) ->
- mapFvRn (rnMatch CaseAlt) ms `thenM` \ (new_ms, ms_fvs) ->
- returnM (HsCase new_expr new_ms, e_fvs `plusFV` ms_fvs)
+ rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) ->
+ returnM (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
rnExpr (HsLet binds expr)
= rnBindGroupsAndThen binds $ \ binds' ->
returnM (RecordCon conname rbinds', fvRbinds `addOneFV` unLoc conname)
rnExpr (RecordUpd expr rbinds)
- = rnLExpr expr `thenM` \ (expr', fvExpr) ->
+ = rnLExpr expr `thenM` \ (expr', fvExpr) ->
rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) ->
returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
rnExpr (ExprWithTySig expr pty)
- = rnLExpr expr `thenM` \ (expr', fvExpr) ->
+ = rnLExpr expr `thenM` \ (expr', fvExpr) ->
rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) ->
returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
where
convertOpFormsCmd :: HsCmd id -> HsCmd id
convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
-
convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
-
convertOpFormsCmd (OpApp c1 op fixity c2)
= let
arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
+-- gaw 2004
convertOpFormsCmd (HsCase exp matches)
- = HsCase exp (map convertOpFormsMatch matches)
+ = HsCase exp (convertOpFormsMatch matches)
convertOpFormsCmd (HsIf exp c1 c2)
= HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
= RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es
convertOpFormsStmt stmt = stmt
-convertOpFormsMatch = fmap convert
+convertOpFormsMatch (MatchGroup ms ty)
+ = MatchGroup (map (fmap convert) ms) ty
where convert (Match pat mty grhss)
= Match pat mty (convertOpFormsGRHSs grhss)
-convertOpFormsGRHSs (GRHSs grhss binds ty)
- = GRHSs (map convertOpFormsGRHS grhss) binds ty
+convertOpFormsGRHSs (GRHSs grhss binds)
+ = GRHSs (map convertOpFormsGRHS grhss) binds
convertOpFormsGRHS = fmap convert
where convert (GRHS stmts)
methodNamesCmd (HsLam match) = methodNamesMatch match
methodNamesCmd (HsCase scrut matches)
- = plusFVs (map methodNamesMatch matches) `addOneFV` choiceAName
+ = methodNamesMatch matches `addOneFV` choiceAName
methodNamesCmd other = emptyFVs
-- Other forms can't occur in commands, but it's not convenient
-- The type checker will complain later
---------------------------------------------------
-methodNamesMatch (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss
+methodNamesMatch (MatchGroup ms ty)
+ = plusFVs (map do_one ms)
+ where
+ do_one (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss
-------------------------------------------------
-methodNamesGRHSs (GRHSs grhss binds ty) = plusFVs (map methodNamesGRHS grhss)
+-- gaw 2004
+methodNamesGRHSs (GRHSs grhss binds) = plusFVs (map methodNamesGRHS grhss)
-------------------------------------------------
methodNamesGRHS (L _ (GRHS stmts)) = methodNamesLStmt (last stmts)
in
returnM stmts_w_fvs
where
- doc = text "In a mdo-expression"
+
+ doc = text "In a recursive mdo-expression"
----------------------------------------------------
\end{code}
\begin{code}
-checkPrecMatch :: Bool -> Name -> LMatch Name -> RnM ()
+checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM ()
+ -- True indicates an infix lhs
+ -- See comments with rnExpr (OpApp ...) about "deriving"
-checkPrecMatch False fn match
+checkPrecMatch False fn match
= returnM ()
+checkPrecMatch True op (MatchGroup ms _)
+ = mapM_ check ms
+ where
+ check (L _ (Match (p1:p2:_) _ _))
+ = checkPrec op (unLoc p1) False `thenM_`
+ checkPrec op (unLoc p2) True
-checkPrecMatch True op (L _ (Match (p1:p2:_) _ _))
- -- True indicates an infix lhs
- = -- See comments with rnExpr (OpApp ...) about "deriving"
- checkPrec op (unLoc p1) False `thenM_`
- checkPrec op (unLoc p2) True
-
-checkPrecMatch True op _ = panic "checkPrecMatch"
+ check _ = panic "checkPrecMatch"
checkPrec op (ConPatIn op1 (InfixCon _ _)) right
= lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) ->