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 {})
; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
; dicts' <- addTickEvBinds (recS_dicts stmt)
; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
, recS_mfix_fn = mfix', recS_bind_fn = bind'
, recS_dicts = dicts' }) }
, recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
......@@ -539,9 +537,6 @@ addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
addTickLHsCmd :: LHsCmd Id -> TM (LHsCmd Id)
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 (HsRecFields fields dd)
= do { fields' <- mapM process fields
......
......@@ -779,8 +779,8 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do
dsCmdStmt ids local_vars env_ids out_ids
(RecStmt { recS_stmts = stmts, recS_later_ids = later_ids, recS_rec_ids = rec_ids
, recS_rec_rets = rhss, recS_dicts = _binds }) = do
let -- ToDo: ****** binds not desugared; ROSS PLEASE FIX ********
, recS_rec_rets = rhss }) = do
let
env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
env2_ids = varSetElems env2_id_set
env2_ty = mkBigCoreVarTupTy env2_ids
......
......@@ -34,7 +34,6 @@ import DsMeta
#endif
import HsSyn
import TcHsSyn
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types
......@@ -338,10 +337,8 @@ dsExpr (HsDo DoExpr stmts body result_ty)
dsExpr (HsDo GhciStmt stmts body result_ty)
= dsDo stmts body result_ty
dsExpr (HsDo ctxt@(MDoExpr tbl) stmts body result_ty)
= do { (meth_binds, tbl') <- dsSyntaxTable tbl
; core_expr <- dsMDo ctxt tbl' stmts body result_ty
; return (mkLets meth_binds core_expr) }
dsExpr (HsDo MDoExpr stmts body result_ty)
= dsDo stmts body result_ty
dsExpr (HsDo PArrComp stmts body result_ty)
= -- Special case for array comprehensions
......@@ -753,16 +750,15 @@ dsDo stmts body result_ty
go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_ret_fn = return_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( isEmptyTcEvBinds _ev_binds ) -- No method binds
goL (new_bind_stmt : stmts)
where
-- returnE <- dsExpr return_id
-- mfixE <- dsExpr mfix_id
new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app
bind_op
noSyntaxExpr -- Tuple cannot fail
noSyntaxExpr -- Tuple cannot fail
tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
rec_tup_pats = map nlVarPat tup_ids
......@@ -778,15 +774,16 @@ dsDo stmts body result_ty
body_ty = mkAppTy m_ty tup_ty
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
-- the monadic 'fail' rather than throwing an exception
handle_failure pat match fail_op
| matchCanFail match
= do { fail_op' <- dsExpr fail_op
; fail_msg <- mkStringExpr (mk_fail_msg pat)
; extractMatchResult match (App fail_op' fail_msg) }
| otherwise
= extractMatchResult match (error "It can't fail")
handle_failure pat match fail_op
| matchCanFail match
= do { fail_op' <- dsExpr fail_op
; fail_msg <- mkStringExpr (mk_fail_msg pat)
; extractMatchResult match (App fail_op' fail_msg) }
| otherwise
= extractMatchResult match (error "It can't fail")
mk_fail_msg :: Located e -> String
mk_fail_msg pat = "Pattern match failure in do expression at " ++
......@@ -801,7 +798,8 @@ We turn (RecStmt [v1,..vn] stmts) into:
return (v1,..vn))
\begin{code}
dsMDo :: HsStmtContext Name
{-
dsMDo :: HsStmtContext Name
-> [(Name,Id)]
-> [LStmt Id]
-> LHsExpr Id
......@@ -815,7 +813,6 @@ dsMDo ctxt tbl stmts body result_ty
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)
mfix_id = lookupEvidence tbl mfixName
return_id = lookupEvidence tbl returnMName
bind_id = lookupEvidence tbl bindMName
then_id = lookupEvidence tbl thenMName
......@@ -825,35 +822,34 @@ dsMDo ctxt tbl stmts body result_ty
= do { rest <- goL stmts
; dsLocalBinds binds rest }
go _ (ExprStmt rhs _ rhs_ty) stmts
go _ (ExprStmt rhs then_expr rhs_ty) stmts
= do { rhs2 <- dsLExpr rhs
; warnDiscardedDoBindings rhs m_ty rhs_ty
; then_expr2 <- dsExpr then_expr
; 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
= do { body <- goL stmts
; var <- selectSimpleMatchVarL pat
go _ (BindStmt pat rhs bind_op _) stmts
= do { body <- goL stmts
; rhs' <- dsLExpr rhs
; bind_op' <- dsExpr bind_op
; var <- selectSimpleMatchVarL pat
; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
result_ty (cantFailMatchResult body)
; fail_msg <- mkStringExpr (mk_fail_msg pat)
; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg]
; 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]) }
result_ty (cantFailMatchResult body)
; match_code <- handle_failure pat match fail_op
; return (mkApps bind_op [rhs', Lam var match_code]) }
go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
, recS_dicts = _ev_binds }) stmts
, recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
, recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) stmts
= ASSERT( length rec_ids > 0 )
ASSERT( length rec_ids == length rec_rets )
ASSERT( isEmptyTcEvBinds _ev_binds )
pprTrace "dsMDo" (ppr later_ids) $
goL (new_bind_stmt : stmts)
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)
-- in rec_rets, because there's no need to knot-tie them separately
......@@ -861,7 +857,7 @@ dsMDo ctxt tbl stmts body result_ty
later_ids' = filter (`notElem` mono_rec_ids) later_ids
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]
(mkFunTy tup_ty body_ty))
......@@ -877,8 +873,7 @@ dsMDo ctxt tbl stmts body result_ty
body_ty = mkAppTy m_ty tup_ty
tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case
return_app = nlHsApp (nlHsTyApp return_id [tup_ty])
(mkLHsTupleExpr rets)
return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
mk_wild_pat :: Id -> LPat Id
mk_wild_pat v = noLoc $ WildPat $ idType v
......@@ -890,6 +885,7 @@ dsMDo ctxt tbl stmts body result_ty
mk_tup_pat :: [LPat Id] -> LPat Id
mk_tup_pat [p] = p
mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed
-}
\end{code}
......
......@@ -905,9 +905,6 @@ data StmtLR idL idR
-- because the Id may be *polymorphic*, but
-- the returned thing has to be *monomorphic*,
-- so they may be type applications
, recS_dicts :: TcEvBinds -- Method bindings of Ids bound by the
-- RecStmt, and used afterwards
}
deriving (Data, Typeable)
\end{code}
......@@ -1043,7 +1040,7 @@ pprBy (Just e) = ptext (sLit "by") <+> ppr e
pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
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 (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 PArrComp stmts body = pa_brackets $ pprComp stmts body
pprDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt
......@@ -1176,9 +1173,7 @@ data HsStmtContext id
= ListComp
| DoExpr
| GhciStmt -- A command-line Stmt in GHCi pat <- rhs
| MDoExpr PostTcTable -- Recursive do-expression
-- (tiresomely, it needs table
-- of its return/bind ops)
| MDoExpr -- Recursive do-expression
| PArrComp -- Parallel array comprehension
| PatGuard (HsMatchContext id) -- Pattern guard for specified thing
| ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt
......@@ -1188,9 +1183,9 @@ data HsStmtContext id
\begin{code}
isDoExpr :: HsStmtContext id -> Bool
isDoExpr DoExpr = True
isDoExpr (MDoExpr _) = True
isDoExpr _ = False
isDoExpr DoExpr = True
isDoExpr MDoExpr = True
isDoExpr _ = False
isListCompExpr :: HsStmtContext id -> Bool
isListCompExpr ListComp = True
......@@ -1241,7 +1236,7 @@ pprStmtContext (PatGuard ctxt)
= ptext (sLit "a pattern guard for") $$ pprMatchContext ctxt
pprStmtContext GhciStmt = ptext (sLit "an interactive GHCi command")
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 PArrComp = ptext (sLit "an array comprehension")
......@@ -1274,7 +1269,7 @@ matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (
matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard")
matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command")
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 PArrComp) = ptext (sLit "array comprehension")
\end{code}
......
......@@ -228,7 +228,7 @@ mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
, recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
, recS_bind_fn = noSyntaxExpr
, recS_rec_rets = [], recS_dicts = emptyTcEvBinds }
, recS_rec_rets = [] }
mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
......
......@@ -1284,7 +1284,9 @@ exp10 :: { LHsExpr RdrName }
return (L loc (mkHsDo DoExpr stmts body)) }
| 'mdo' stmtlist {% let loc = comb2 $1 $2 in
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
then HsSCC (unLoc $1) $2
else HsPar $2 }
......
......@@ -773,7 +773,7 @@ rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt)
rnGRHS' :: HsMatchContext Name -> GRHS RdrName -> RnM (GRHS Name, FreeVars)
rnGRHS' ctxt (GRHS guards rhs)
= do { pattern_guards_allowed <- xoptM Opt_PatternGuards
; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $
; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $ \ _ ->
rnLExpr rhs
; unless (pattern_guards_allowed || is_standard_guard guards')
......
......@@ -221,7 +221,7 @@ rnExpr (HsLet binds expr)
return (HsLet binds' expr', fvExpr)
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
; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
......@@ -637,16 +637,7 @@ rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
%************************************************************************
\begin{code}
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]
rnStmts :: HsStmtContext Name -> [LStmt RdrName]
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt Name], thing), FreeVars)
-- Variables bound by the Stmts, and mentioned in thing_inside,
......@@ -654,15 +645,15 @@ rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
--
-- Renaming a single RecStmt can give a sequence of smaller Stmts
rnNormalStmts _ [] thing_inside
rnStmts _ [] thing_inside
= do { (res, fvs) <- thing_inside []
; return (([], res), fvs) }
rnNormalStmts ctxt (stmt@(L loc _) : stmts) thing_inside
rnStmts ctxt (stmt@(L loc _) : stmts) thing_inside
= do { ((stmts1, (stmts2, thing)), fvs)
<- setSrcSpan loc $
rnStmt ctxt stmt $ \ bndrs1 ->
rnNormalStmts ctxt stmts $ \ bndrs2 ->
rnStmts ctxt stmts $ \ bndrs2 ->
thing_inside (bndrs1 ++ bndrs2)
; return (((stmts1 ++ stmts2), thing), fvs) }
......@@ -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
-- (This set may not be empty, because we're in a recursive
-- context.)
; rn_rec_stmts_and_then rec_stmts $ \ segs -> do
; rnRecStmtsAndThen rec_stmts $ \ segs -> do
{ let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
emptyNameSet segs
......@@ -753,7 +744,7 @@ rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside
; (using', fvs1) <- rnLExpr using
; ((stmts', (by', used_bndrs, thing)), fvs2)
<- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
<- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
do { (by', fvs_by) <- case by of
Nothing -> return (Nothing, emptyFVs)
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
-- Rename the stmts and the 'by' expression
-- Keep track of the variables mentioned in the 'by' expression
; ((stmts', (by', used_bndrs, thing)), fvs2)
<- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
<- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by
; (thing, fvs_thing) <- thing_inside bndrs
; let fvs = fvs_by `plusFV` fvs_thing
......@@ -816,7 +807,7 @@ rnParallelStmts ctxt segs thing_inside
rn_segs env bndrs_so_far ((stmts,_) : segs)
= do { ((stmts', (used_bndrs, segs', thing)), fvs)
<- rnNormalStmts ctxt stmts $ \ bndrs ->
<- rnStmts ctxt stmts $ \ bndrs ->
setLocalRdrEnv env $ do
{ ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
; let used_bndrs = filter (`elemNameSet` fvs) bndrs
......@@ -864,28 +855,13 @@ type Segment stmts = (Defs,
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
rn_rec_stmts_and_then :: [LStmt RdrName]
rnRecStmtsAndThen :: [LStmt RdrName]
-- assumes that the FreeVars returned includes
-- the FreeVars of the Segments
-> ([Segment (LStmt Name)] -> 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
fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
......@@ -1000,7 +976,7 @@ rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
(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'
return [(duDefs du_binds, allUses du_binds,
emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
......@@ -1173,9 +1149,9 @@ checkLetStmt _ctxt _binds = return ()
---------
checkRecStmt :: HsStmtContext Name -> RnM ()
checkRecStmt (MDoExpr {}) = return () -- Recursive stmt ok in 'mdo'
checkRecStmt (DoExpr {}) = return () -- and in 'do'
checkRecStmt ctxt = addErr msg
checkRecStmt MDoExpr = return () -- Recursive stmt ok in 'mdo'
checkRecStmt DoExpr = return () -- and in 'do'
checkRecStmt ctxt = addErr msg
where
msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
......
......@@ -11,7 +11,7 @@ rnLExpr :: LHsExpr RdrName
rnStmts :: --forall thing.
HsStmtContext Name -> [LStmt RdrName]
-> RnM (thing, FreeVars)
-> ([Name] -> RnM (thing, FreeVars))
-> RnM (([LStmt Name], thing), FreeVars)
\end{code}
......@@ -580,8 +580,7 @@ zonkExpr env (HsDo do_or_lc stmts body ty)
= zonkStmts env stmts `thenM` \ (new_env, new_stmts) ->
zonkLExpr new_env body `thenM` \ new_body ->
zonkTcTypeToType env ty `thenM` \ new_ty ->
zonkDo env do_or_lc `thenM` \ new_do_or_lc ->
returnM (HsDo new_do_or_lc new_stmts new_body new_ty)
returnM (HsDo do_or_lc new_stmts new_body new_ty)
zonkExpr env (ExplicitList ty exprs)
= zonkTcTypeToType env ty `thenM` \ new_ty ->
......@@ -688,13 +687,6 @@ zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty
zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env 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 env lit@(OverLit { ol_witness = e, ol_type = ty })
......@@ -747,7 +739,7 @@ zonkStmt env (ParStmt stmts_w_bndrs)
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
, recS_rec_rets = rets, recS_dicts = binds })
, recS_rec_rets = rets })
= do { new_rvs <- zonkIdBndrs env rvs
; new_lvs <- zonkIdBndrs env lvs
; new_ret_id <- zonkExpr env ret_id
......@@ -758,13 +750,11 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id
-- Zonk the ret-expressions in an envt that
-- has the polymorphic bindings in the envt
; new_rets <- mapM (zonkExpr env2) rets
; let env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
; (env4, new_binds) <- zonkTcEvBinds env3 binds
; return (env4,
; return (extendZonkEnv env new_lvs, -- Only the lvs are needed
RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
, recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
, recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
, recS_rec_rets = new_rets, recS_dicts = new_binds }) }
, recS_rec_rets = new_rets }) }
zonkStmt env (ExprStmt expr then_op ty)
= zonkLExpr env expr `thenM` \ new_expr ->
......
......@@ -17,7 +17,6 @@ import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcCheckId,
import HsSyn
import TcRnMonad
import Inst
import TcEnv
import TcPat
import TcMType
......@@ -26,7 +25,6 @@ import TcBinds
import TcUnify
import Name
import TysWiredIn
import PrelNames
import Id
import TyCon
import TysPrim
......@@ -264,19 +262,10 @@ tcDoStmts DoExpr stmts body res_ty
tcBody body
; return (HsDo DoExpr stmts' body' res_ty) }
tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
= do { (coi, (m_ty, elt_ty)) <- matchExpectedAppTy res_ty
; let res_ty' = mkAppTy m_ty elt_ty -- The matchExpected consumes res_ty
tc_rhs rhs = tcInfer $ \ pat_ty ->
tcMonoExpr rhs (mkAppTy m_ty pat_ty)
; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty' $
tcDoStmts MDoExpr stmts body res_ty
= do { (stmts', body') <- tcStmts MDoExpr tcDoStmt stmts res_ty $
tcBody body
; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
; insts <- mapM (\name -> newMethodFromName DoOrigin name m_ty) names
; return $ mkHsWrapCoI coi $
HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty' }
; return (HsDo MDoExpr stmts' body' res_ty) }
tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
......@@ -571,7 +560,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
, recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
, recS_rec_rets = tup_rets, recS_dicts = emptyTcEvBinds }, thing)
, recS_rec_rets = tup_rets }, thing)
}}
tcDoStmt _ stmt _ _
......@@ -608,7 +597,8 @@ tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside
; thing <- thing_inside res_ty
; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _ _ _ _) res_ty thing_inside
tcMDoStmt tc_rhs ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames
, recS_rec_ids = recNames }) res_ty thing_inside
= do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
; let rec_ids = zipWith mkLocalId recNames rec_tys
; tcExtendIdEnv rec_ids $ do
......@@ -625,11 +615,7 @@ tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _ _ _ _) res_ty thing
-- some of them with polymorphic things with the same Name
-- (see note [RecStmt] in HsExpr)
-- Need the bindLocalMethods if we re-add Method constraints
-- ; lie_binds <- bindLocalMethods lie later_ids
; let lie_binds = emptyTcEvBinds
; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets lie_binds, thing)
; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets, thing)
}}
tcMDoStmt _ _ stmt _ _
......
......@@ -1082,7 +1082,8 @@ tcRnStmt hsc_env ictxt rdr_stmt
setInteractiveContext hsc_env ictxt $ do {
-- Rename; use CmdLineMode because tcRnStmt is only used interactively
(([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] (return ((), emptyFVs)) ;
(([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] $ \_ ->
return ((), emptyFVs) ;
traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
failIfErrsM ;
rnDump (ppr rn_stmt) ;
......
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