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

Tidy up rebindable syntax for MDo

For a long time an 'mdo' expression has had a SyntaxTable
attached to it.  However, we're busy deprecating SyntaxTables
in favour of rebindable syntax attached to individual Stmts,
and MDoExpr was totally inconsistent with DoExpr in this
regard.

This patch tidies it all up.  Now there's no SyntaxTable on
MDoExpr, and 'modo' is generally handled much more like 'do'.

There is resulting small change in behaviour: now MonadFix is
required only if you actually *use* recursion in mdo. This
seems consistent with the implicit dependency analysis that
is done for mdo.

Still to do:
  * Deal with #4148 (this patch is on the way)
  * Get rid of the last remaining SyntaxTable on HsCmdTop
parent 16dd51fb
...@@ -465,10 +465,8 @@ addTickStmt isGuard stmt@(RecStmt {}) ...@@ -465,10 +465,8 @@ addTickStmt isGuard stmt@(RecStmt {})
; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
; dicts' <- addTickEvBinds (recS_dicts stmt)
; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
, recS_mfix_fn = mfix', recS_bind_fn = bind' , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
, recS_dicts = dicts' }) }
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id) addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
...@@ -539,9 +537,6 @@ addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) = ...@@ -539,9 +537,6 @@ addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id) addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id)
addTickLHsCmd x = addTickLHsExpr x addTickLHsCmd x = addTickLHsExpr x
addTickEvBinds :: TcEvBinds -> TM TcEvBinds
addTickEvBinds x = return x -- No coverage testing for dictionary binding
addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id) addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
addTickHsRecordBinds (HsRecFields fields dd) addTickHsRecordBinds (HsRecFields fields dd)
= do { fields' <- mapM process fields = do { fields' <- mapM process fields
......
...@@ -779,8 +779,8 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do ...@@ -779,8 +779,8 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do
dsCmdStmt ids local_vars env_ids out_ids dsCmdStmt ids local_vars env_ids out_ids
(RecStmt { recS_stmts = stmts, recS_later_ids = later_ids, recS_rec_ids = rec_ids (RecStmt { recS_stmts = stmts, recS_later_ids = later_ids, recS_rec_ids = rec_ids
, recS_rec_rets = rhss, recS_dicts = _binds }) = do , recS_rec_rets = rhss }) = do
let -- ToDo: ****** binds not desugared; ROSS PLEASE FIX ******** let
env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
env2_ids = varSetElems env2_id_set env2_ids = varSetElems env2_id_set
env2_ty = mkBigCoreVarTupTy env2_ids env2_ty = mkBigCoreVarTupTy env2_ids
......
...@@ -34,7 +34,6 @@ import DsMeta ...@@ -34,7 +34,6 @@ import DsMeta
#endif #endif
import HsSyn import HsSyn
import TcHsSyn
-- NB: The desugarer, which straddles the source and Core worlds, sometimes -- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types -- needs to see source types
...@@ -338,10 +337,8 @@ dsExpr (HsDo DoExpr stmts body result_ty) ...@@ -338,10 +337,8 @@ dsExpr (HsDo DoExpr stmts body result_ty)
dsExpr (HsDo GhciStmt stmts body result_ty) dsExpr (HsDo GhciStmt stmts body result_ty)
= dsDo stmts body result_ty = dsDo stmts body result_ty
dsExpr (HsDo ctxt@(MDoExpr tbl) stmts body result_ty) dsExpr (HsDo MDoExpr stmts body result_ty)
= do { (meth_binds, tbl') <- dsSyntaxTable tbl = dsDo stmts body result_ty
; core_expr <- dsMDo ctxt tbl' stmts body result_ty
; return (mkLets meth_binds core_expr) }
dsExpr (HsDo PArrComp stmts body result_ty) dsExpr (HsDo PArrComp stmts body result_ty)
= -- Special case for array comprehensions = -- Special case for array comprehensions
...@@ -753,16 +750,15 @@ dsDo stmts body result_ty ...@@ -753,16 +750,15 @@ dsDo stmts body result_ty
go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_ret_fn = return_op , recS_rec_ids = rec_ids, recS_ret_fn = return_op
, recS_mfix_fn = mfix_op, recS_bind_fn = bind_op , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
, recS_rec_rets = rec_rets, recS_dicts = _ev_binds }) stmts , recS_rec_rets = rec_rets }) stmts
= ASSERT( length rec_ids > 0 ) = ASSERT( length rec_ids > 0 )
ASSERT( isEmptyTcEvBinds _ev_binds ) -- No method binds
goL (new_bind_stmt : stmts) goL (new_bind_stmt : stmts)
where where
-- returnE <- dsExpr return_id -- returnE <- dsExpr return_id
-- mfixE <- dsExpr mfix_id -- mfixE <- dsExpr mfix_id
new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app
bind_op bind_op
noSyntaxExpr -- Tuple cannot fail noSyntaxExpr -- Tuple cannot fail
tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
rec_tup_pats = map nlVarPat tup_ids rec_tup_pats = map nlVarPat tup_ids
...@@ -778,15 +774,16 @@ dsDo stmts body result_ty ...@@ -778,15 +774,16 @@ dsDo stmts body result_ty
body_ty = mkAppTy m_ty tup_ty body_ty = mkAppTy m_ty tup_ty
tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
-- In a do expression, pattern-match failure just calls -- In a do expression, pattern-match failure just calls
-- the monadic 'fail' rather than throwing an exception -- the monadic 'fail' rather than throwing an exception
handle_failure pat match fail_op handle_failure pat match fail_op
| matchCanFail match | matchCanFail match
= do { fail_op' <- dsExpr fail_op = do { fail_op' <- dsExpr fail_op
; fail_msg <- mkStringExpr (mk_fail_msg pat) ; fail_msg <- mkStringExpr (mk_fail_msg pat)
; extractMatchResult match (App fail_op' fail_msg) } ; extractMatchResult match (App fail_op' fail_msg) }
| otherwise | otherwise
= extractMatchResult match (error "It can't fail") = extractMatchResult match (error "It can't fail")
mk_fail_msg :: Located e -> String mk_fail_msg :: Located e -> String
mk_fail_msg pat = "Pattern match failure in do expression at " ++ mk_fail_msg pat = "Pattern match failure in do expression at " ++
...@@ -801,7 +798,8 @@ We turn (RecStmt [v1,..vn] stmts) into: ...@@ -801,7 +798,8 @@ We turn (RecStmt [v1,..vn] stmts) into:
return (v1,..vn)) return (v1,..vn))
\begin{code} \begin{code}
dsMDo :: HsStmtContext Name {-
dsMDo :: HsStmtContext Name
-> [(Name,Id)] -> [(Name,Id)]
-> [LStmt Id] -> [LStmt Id]
-> LHsExpr Id -> LHsExpr Id
...@@ -815,7 +813,6 @@ dsMDo ctxt tbl stmts body result_ty ...@@ -815,7 +813,6 @@ dsMDo ctxt tbl stmts body result_ty
goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
(m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b) (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b)
mfix_id = lookupEvidence tbl mfixName
return_id = lookupEvidence tbl returnMName return_id = lookupEvidence tbl returnMName
bind_id = lookupEvidence tbl bindMName bind_id = lookupEvidence tbl bindMName
then_id = lookupEvidence tbl thenMName then_id = lookupEvidence tbl thenMName
...@@ -825,35 +822,34 @@ dsMDo ctxt tbl stmts body result_ty ...@@ -825,35 +822,34 @@ dsMDo ctxt tbl stmts body result_ty
= do { rest <- goL stmts = do { rest <- goL stmts
; dsLocalBinds binds rest } ; dsLocalBinds binds rest }
go _ (ExprStmt rhs _ rhs_ty) stmts go _ (ExprStmt rhs then_expr rhs_ty) stmts
= do { rhs2 <- dsLExpr rhs = do { rhs2 <- dsLExpr rhs
; warnDiscardedDoBindings rhs m_ty rhs_ty ; warnDiscardedDoBindings rhs m_ty rhs_ty
; then_expr2 <- dsExpr then_expr
; rest <- goL stmts ; rest <- goL stmts
; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) } ; return (mkApps then_expr2 [rhs2, rest]) }
go _ (BindStmt pat rhs _ _) stmts go _ (BindStmt pat rhs bind_op _) stmts
= do { body <- goL stmts = do { body <- goL stmts
; var <- selectSimpleMatchVarL pat ; rhs' <- dsLExpr rhs
; bind_op' <- dsExpr bind_op
; var <- selectSimpleMatchVarL pat
; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
result_ty (cantFailMatchResult body) result_ty (cantFailMatchResult body)
; fail_msg <- mkStringExpr (mk_fail_msg pat) ; match_code <- handle_failure pat match fail_op
; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg] ; return (mkApps bind_op [rhs', Lam var match_code]) }
; match_code <- extractMatchResult match fail_expr
; rhs' <- dsLExpr rhs
; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
rhs', Lam var match_code]) }
go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_rec_rets = rec_rets , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
, recS_dicts = _ev_binds }) stmts , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) stmts
= ASSERT( length rec_ids > 0 ) = ASSERT( length rec_ids > 0 )
ASSERT( length rec_ids == length rec_rets ) ASSERT( length rec_ids == length rec_rets )
ASSERT( isEmptyTcEvBinds _ev_binds ) ASSERT( isEmptyTcEvBinds _ev_binds )
pprTrace "dsMDo" (ppr later_ids) $ pprTrace "dsMDo" (ppr later_ids) $
goL (new_bind_stmt : stmts) goL (new_bind_stmt : stmts)
where where
new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app new_bind_stmt = L loc $ BindStmt (mk_tup_pat later_pats) mfix_app
bind_op noSyntaxExpr
-- Remove the later_ids that appear (without fancy coercions) -- Remove the later_ids that appear (without fancy coercions)
-- in rec_rets, because there's no need to knot-tie them separately -- in rec_rets, because there's no need to knot-tie them separately
...@@ -861,7 +857,7 @@ dsMDo ctxt tbl stmts body result_ty ...@@ -861,7 +857,7 @@ dsMDo ctxt tbl stmts body result_ty
later_ids' = filter (`notElem` mono_rec_ids) later_ids later_ids' = filter (`notElem` mono_rec_ids) later_ids
mono_rec_ids = [ id | HsVar id <- rec_rets ] mono_rec_ids = [ id | HsVar id <- rec_rets ]
mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
(mkFunTy tup_ty body_ty)) (mkFunTy tup_ty body_ty))
...@@ -877,8 +873,7 @@ dsMDo ctxt tbl stmts body result_ty ...@@ -877,8 +873,7 @@ dsMDo ctxt tbl stmts body result_ty
body_ty = mkAppTy m_ty tup_ty body_ty = mkAppTy m_ty tup_ty
tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case
return_app = nlHsApp (nlHsTyApp return_id [tup_ty]) return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
(mkLHsTupleExpr rets)
mk_wild_pat :: Id -> LPat Id mk_wild_pat :: Id -> LPat Id
mk_wild_pat v = noLoc $ WildPat $ idType v mk_wild_pat v = noLoc $ WildPat $ idType v
...@@ -890,6 +885,7 @@ dsMDo ctxt tbl stmts body result_ty ...@@ -890,6 +885,7 @@ dsMDo ctxt tbl stmts body result_ty
mk_tup_pat :: [LPat Id] -> LPat Id mk_tup_pat :: [LPat Id] -> LPat Id
mk_tup_pat [p] = p mk_tup_pat [p] = p
mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
-}
\end{code} \end{code}
......
...@@ -905,9 +905,6 @@ data StmtLR idL idR ...@@ -905,9 +905,6 @@ data StmtLR idL idR
-- because the Id may be *polymorphic*, but -- because the Id may be *polymorphic*, but
-- the returned thing has to be *monomorphic*, -- the returned thing has to be *monomorphic*,
-- so they may be type applications -- so they may be type applications
, recS_dicts :: TcEvBinds -- Method bindings of Ids bound by the
-- RecStmt, and used afterwards
} }
deriving (Data, Typeable) deriving (Data, Typeable)
\end{code} \end{code}
...@@ -1043,7 +1040,7 @@ pprBy (Just e) = ptext (sLit "by") <+> ppr e ...@@ -1043,7 +1040,7 @@ pprBy (Just e) = ptext (sLit "by") <+> ppr e
pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
pprDo DoExpr stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body pprDo DoExpr stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body
pprDo GhciStmt stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body pprDo GhciStmt stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body
pprDo (MDoExpr _) stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body pprDo MDoExpr stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body
pprDo ListComp stmts body = brackets $ pprComp stmts body pprDo ListComp stmts body = brackets $ pprComp stmts body
pprDo PArrComp stmts body = pa_brackets $ pprComp stmts body pprDo PArrComp stmts body = pa_brackets $ pprComp stmts body
pprDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt pprDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt
...@@ -1176,9 +1173,7 @@ data HsStmtContext id ...@@ -1176,9 +1173,7 @@ data HsStmtContext id
= ListComp = ListComp
| DoExpr | DoExpr
| GhciStmt -- A command-line Stmt in GHCi pat <- rhs | GhciStmt -- A command-line Stmt in GHCi pat <- rhs
| MDoExpr PostTcTable -- Recursive do-expression | MDoExpr -- Recursive do-expression
-- (tiresomely, it needs table
-- of its return/bind ops)
| PArrComp -- Parallel array comprehension | PArrComp -- Parallel array comprehension
| PatGuard (HsMatchContext id) -- Pattern guard for specified thing | PatGuard (HsMatchContext id) -- Pattern guard for specified thing
| ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt | ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt
...@@ -1188,9 +1183,9 @@ data HsStmtContext id ...@@ -1188,9 +1183,9 @@ data HsStmtContext id
\begin{code} \begin{code}
isDoExpr :: HsStmtContext id -> Bool isDoExpr :: HsStmtContext id -> Bool
isDoExpr DoExpr = True isDoExpr DoExpr = True
isDoExpr (MDoExpr _) = True isDoExpr MDoExpr = True
isDoExpr _ = False isDoExpr _ = False
isListCompExpr :: HsStmtContext id -> Bool isListCompExpr :: HsStmtContext id -> Bool
isListCompExpr ListComp = True isListCompExpr ListComp = True
...@@ -1241,7 +1236,7 @@ pprStmtContext (PatGuard ctxt) ...@@ -1241,7 +1236,7 @@ pprStmtContext (PatGuard ctxt)
= ptext (sLit "a pattern guard for") $$ pprMatchContext ctxt = ptext (sLit "a pattern guard for") $$ pprMatchContext ctxt
pprStmtContext GhciStmt = ptext (sLit "an interactive GHCi command") pprStmtContext GhciStmt = ptext (sLit "an interactive GHCi command")
pprStmtContext DoExpr = ptext (sLit "a 'do' expression") pprStmtContext DoExpr = ptext (sLit "a 'do' expression")
pprStmtContext (MDoExpr _) = ptext (sLit "an 'mdo' expression") pprStmtContext MDoExpr = ptext (sLit "an 'mdo' expression")
pprStmtContext ListComp = ptext (sLit "a list comprehension") pprStmtContext ListComp = ptext (sLit "a list comprehension")
pprStmtContext PArrComp = ptext (sLit "an array comprehension") pprStmtContext PArrComp = ptext (sLit "an array comprehension")
...@@ -1274,7 +1269,7 @@ matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString ( ...@@ -1274,7 +1269,7 @@ matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (
matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard") matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard")
matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command") matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command")
matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' expression") matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' expression")
matchContextErrString (StmtCtxt (MDoExpr _)) = ptext (sLit "'mdo' expression") matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' expression")
matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension") matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension")
matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension") matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension")
\end{code} \end{code}
......
...@@ -228,7 +228,7 @@ mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr ...@@ -228,7 +228,7 @@ mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = [] emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
, recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
, recS_bind_fn = noSyntaxExpr , recS_bind_fn = noSyntaxExpr
, recS_rec_rets = [], recS_dicts = emptyTcEvBinds } , recS_rec_rets = [] }
mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
......
...@@ -1284,7 +1284,9 @@ exp10 :: { LHsExpr RdrName } ...@@ -1284,7 +1284,9 @@ exp10 :: { LHsExpr RdrName }
return (L loc (mkHsDo DoExpr stmts body)) } return (L loc (mkHsDo DoExpr stmts body)) }
| 'mdo' stmtlist {% let loc = comb2 $1 $2 in | 'mdo' stmtlist {% let loc = comb2 $1 $2 in
checkDo loc (unLoc $2) >>= \ (stmts,body) -> checkDo loc (unLoc $2) >>= \ (stmts,body) ->
return (L loc (mkHsDo (MDoExpr noPostTcTable) stmts body)) } return (L loc (mkHsDo MDoExpr
[L loc (mkRecStmt stmts)]
body)) }
| scc_annot exp { LL $ if opt_SccProfilingOn | scc_annot exp { LL $ if opt_SccProfilingOn
then HsSCC (unLoc $1) $2 then HsSCC (unLoc $1) $2
else HsPar $2 } else HsPar $2 }
......
...@@ -773,7 +773,7 @@ rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt) ...@@ -773,7 +773,7 @@ rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt)
rnGRHS' :: HsMatchContext Name -> GRHS RdrName -> RnM (GRHS Name, FreeVars) rnGRHS' :: HsMatchContext Name -> GRHS RdrName -> RnM (GRHS Name, FreeVars)
rnGRHS' ctxt (GRHS guards rhs) rnGRHS' ctxt (GRHS guards rhs)
= do { pattern_guards_allowed <- xoptM Opt_PatternGuards = do { pattern_guards_allowed <- xoptM Opt_PatternGuards
; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $ ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $ \ _ ->
rnLExpr rhs rnLExpr rhs
; unless (pattern_guards_allowed || is_standard_guard guards') ; unless (pattern_guards_allowed || is_standard_guard guards')
......
...@@ -221,7 +221,7 @@ rnExpr (HsLet binds expr) ...@@ -221,7 +221,7 @@ rnExpr (HsLet binds expr)
return (HsLet binds' expr', fvExpr) return (HsLet binds' expr', fvExpr)
rnExpr (HsDo do_or_lc stmts body _) rnExpr (HsDo do_or_lc stmts body _)
= do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $ = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $ \ _ ->
rnLExpr body rnLExpr body
; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) } ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
...@@ -637,16 +637,7 @@ rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG" ...@@ -637,16 +637,7 @@ rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
rnStmts :: HsStmtContext Name -> [LStmt RdrName] rnStmts :: HsStmtContext Name -> [LStmt RdrName]
-> RnM (thing, FreeVars)
-> RnM (([LStmt Name], thing), FreeVars)
-- Variables bound by the Stmts, and mentioned in thing_inside,
-- do not appear in the result FreeVars
rnStmts (MDoExpr _) stmts thing_inside = rnMDoStmts stmts thing_inside
rnStmts ctxt stmts thing_inside = rnNormalStmts ctxt stmts (\ _ -> thing_inside)
rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
-> ([Name] -> RnM (thing, FreeVars)) -> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt Name], thing), FreeVars) -> RnM (([LStmt Name], thing), FreeVars)
-- Variables bound by the Stmts, and mentioned in thing_inside, -- Variables bound by the Stmts, and mentioned in thing_inside,
...@@ -654,15 +645,15 @@ rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName] ...@@ -654,15 +645,15 @@ rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
-- --
-- Renaming a single RecStmt can give a sequence of smaller Stmts -- Renaming a single RecStmt can give a sequence of smaller Stmts
rnNormalStmts _ [] thing_inside rnStmts _ [] thing_inside
= do { (res, fvs) <- thing_inside [] = do { (res, fvs) <- thing_inside []
; return (([], res), fvs) } ; return (([], res), fvs) }
rnNormalStmts ctxt (stmt@(L loc _) : stmts) thing_inside rnStmts ctxt (stmt@(L loc _) : stmts) thing_inside
= do { ((stmts1, (stmts2, thing)), fvs) = do { ((stmts1, (stmts2, thing)), fvs)
<- setSrcSpan loc $ <- setSrcSpan loc $
rnStmt ctxt stmt $ \ bndrs1 -> rnStmt ctxt stmt $ \ bndrs1 ->
rnNormalStmts ctxt stmts $ \ bndrs2 -> rnStmts ctxt stmts $ \ bndrs2 ->
thing_inside (bndrs1 ++ bndrs2) thing_inside (bndrs1 ++ bndrs2)
; return (((stmts1 ++ stmts2), thing), fvs) } ; return (((stmts1 ++ stmts2), thing), fvs) }
...@@ -710,7 +701,7 @@ rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside ...@@ -710,7 +701,7 @@ rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
-- for which it's the fwd refs within the bind itself -- for which it's the fwd refs within the bind itself
-- (This set may not be empty, because we're in a recursive -- (This set may not be empty, because we're in a recursive
-- context.) -- context.)
; rn_rec_stmts_and_then rec_stmts $ \ segs -> do ; rnRecStmtsAndThen rec_stmts $ \ segs -> do
{ let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds)) { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
emptyNameSet segs emptyNameSet segs
...@@ -753,7 +744,7 @@ rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside ...@@ -753,7 +744,7 @@ rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside
; (using', fvs1) <- rnLExpr using ; (using', fvs1) <- rnLExpr using
; ((stmts', (by', used_bndrs, thing)), fvs2) ; ((stmts', (by', used_bndrs, thing)), fvs2)
<- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs -> <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
do { (by', fvs_by) <- case by of do { (by', fvs_by) <- case by of
Nothing -> return (Nothing, emptyFVs) Nothing -> return (Nothing, emptyFVs)
Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) } Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
...@@ -779,7 +770,7 @@ rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside ...@@ -779,7 +770,7 @@ rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside
-- Rename the stmts and the 'by' expression -- Rename the stmts and the 'by' expression
-- Keep track of the variables mentioned in the 'by' expression -- Keep track of the variables mentioned in the 'by' expression
; ((stmts', (by', used_bndrs, thing)), fvs2) ; ((stmts', (by', used_bndrs, thing)), fvs2)
<- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs -> <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
; (thing, fvs_thing) <- thing_inside bndrs ; (thing, fvs_thing) <- thing_inside bndrs
; let fvs = fvs_by `plusFV` fvs_thing ; let fvs = fvs_by `plusFV` fvs_thing
...@@ -816,7 +807,7 @@ rnParallelStmts ctxt segs thing_inside ...@@ -816,7 +807,7 @@ rnParallelStmts ctxt segs thing_inside
rn_segs env bndrs_so_far ((stmts,_) : segs) rn_segs env bndrs_so_far ((stmts,_) : segs)
= do { ((stmts', (used_bndrs, segs', thing)), fvs) = do { ((stmts', (used_bndrs, segs', thing)), fvs)
<- rnNormalStmts ctxt stmts $ \ bndrs -> <- rnStmts ctxt stmts $ \ bndrs ->
setLocalRdrEnv env $ do setLocalRdrEnv env $ do
{ ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
; let used_bndrs = filter (`elemNameSet` fvs) bndrs ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
...@@ -864,28 +855,13 @@ type Segment stmts = (Defs, ...@@ -864,28 +855,13 @@ type Segment stmts = (Defs,
stmts) -- Either Stmt or [Stmt] stmts) -- Either Stmt or [Stmt]
----------------------------------------------------
rnMDoStmts :: [LStmt RdrName]
-> RnM (thing, FreeVars)
-> RnM (([LStmt Name], thing), FreeVars)
rnMDoStmts stmts thing_inside
= rn_rec_stmts_and_then stmts $ \ segs -> do
{ (thing, fvs_later) <- thing_inside
; let segs_w_fwd_refs = addFwdRefs segs
grouped_segs = glomSegments segs_w_fwd_refs
(stmts', fvs) = segsToStmts emptyRecStmt grouped_segs fvs_later
; return ((stmts', thing), fvs) }
---------------------------------------------
-- wrapper that does both the left- and right-hand sides -- wrapper that does both the left- and right-hand sides
rn_rec_stmts_and_then :: [LStmt RdrName] rnRecStmtsAndThen :: [LStmt RdrName]
-- assumes that the FreeVars returned includes -- assumes that the FreeVars returned includes
-- the FreeVars of the Segments -- the FreeVars of the Segments
-> ([Segment (LStmt Name)] -> RnM (a, FreeVars)) -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
-> RnM (a, FreeVars) -> RnM (a, FreeVars)
rn_rec_stmts_and_then s cont rnRecStmtsAndThen s cont
= do { -- (A) Make the mini fixity env for all of the stmts = do { -- (A) Make the mini fixity env for all of the stmts
fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
...@@ -1000,7 +976,7 @@ rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _ ...@@ -1000,7 +976,7 @@ rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
(binds', du_binds) <- (binds', du_binds) <-
-- fixities and unused are handled above in rn_rec_stmts_and_then -- fixities and unused are handled above in rnRecStmtsAndThen
rnLocalValBindsRHS (mkNameSet all_bndrs) binds' rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
return [(duDefs du_binds, allUses du_binds, return [(duDefs du_binds, allUses du_binds,
emptyNameSet, L loc (LetStmt (HsValBinds binds')))] emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
...@@ -1173,9 +1149,9 @@ checkLetStmt _ctxt _binds = return () ...@@ -1173,9 +1149,9 @@ checkLetStmt _ctxt _binds = return ()
--------- ---------
checkRecStmt :: HsStmtContext Name -> RnM () checkRecStmt :: HsStmtContext Name -> RnM ()
checkRecStmt (MDoExpr {}) = return () -- Recursive stmt ok in 'mdo' checkRecStmt MDoExpr = return () -- Recursive stmt ok in 'mdo'
checkRecStmt (DoExpr {}) = return () -- and in 'do' checkRecStmt DoExpr = return () -- and in 'do'
checkRecStmt ctxt = addErr msg checkRecStmt ctxt = addErr msg
where where
msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
......
...@@ -11,7 +11,7 @@ rnLExpr :: LHsExpr RdrName ...@@ -11,7 +11,7 @@ rnLExpr :: LHsExpr RdrName
rnStmts :: --forall thing. rnStmts :: --forall thing.
HsStmtContext Name -> [LStmt RdrName] HsStmtContext Name -> [LStmt RdrName]
-> RnM (thing, FreeVars) -> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt Name], thing), FreeVars) -> RnM (([LStmt Name], thing), FreeVars)
\end{code} \end{code}
...@@ -580,8 +580,7 @@ zonkExpr env (HsDo do_or_lc stmts body ty) ...@@ -580,8 +580,7 @@ zonkExpr env (HsDo do_or_lc stmts body ty)
= zonkStmts env stmts `thenM` \ (new_env, new_stmts) -> = zonkStmts env stmts `thenM` \ (new_env, new_stmts) ->
zonkLExpr new_env body `thenM` \ new_body -> zonkLExpr new_env body `thenM` \ new_body ->
zonkTcTypeToType env ty `thenM` \ new_ty -> zonkTcTypeToType env ty `thenM` \ new_ty ->
zonkDo env do_or_lc `thenM` \ new_do_or_lc -> returnM (HsDo do_or_lc new_stmts new_body new_ty)
returnM (HsDo new_do_or_lc new_stmts new_body new_ty)
zonkExpr env (ExplicitList ty exprs) zonkExpr env (ExplicitList ty exprs)
= zonkTcTypeToType env ty `thenM` \ new_ty -> = zonkTcTypeToType env ty `thenM` \ new_ty ->
...@@ -688,13 +687,6 @@ zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty ...@@ -688,13 +687,6 @@ zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty
zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs
; return (env1, WpLet bs') } ; return (env1, WpLet bs') }
-------------------------------------------------------------------------
zonkDo :: ZonkEnv -> HsStmtContext Name -> TcM (HsStmtContext Name)
-- Only used for 'do', so the only Ids are in a MDoExpr table
zonkDo env (MDoExpr tbl) = do { tbl' <- mapSndM (zonkExpr env) tbl
; return (MDoExpr tbl') }
zonkDo _ do_or_lc = return do_or_lc
------------------------------------------------------------------------- -------------------------------------------------------------------------
zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id) zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty }) zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
...@@ -747,7 +739,7 @@ zonkStmt env (ParStmt stmts_w_bndrs) ...@@ -747,7 +739,7 @@ zonkStmt env (ParStmt stmts_w_bndrs)
zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
, recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id