diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/deSugar/Coverage.lhs | 7 | ||||
| -rw-r--r-- | compiler/deSugar/DsArrows.lhs | 4 | ||||
| -rw-r--r-- | compiler/deSugar/DsExpr.lhs | 68 | ||||
| -rw-r--r-- | compiler/hsSyn/HsExpr.lhs | 19 | ||||
| -rw-r--r-- | compiler/hsSyn/HsUtils.lhs | 2 | ||||
| -rw-r--r-- | compiler/parser/Parser.y.pp | 4 | ||||
| -rw-r--r-- | compiler/rename/RnBinds.lhs | 2 | ||||
| -rw-r--r-- | compiler/rename/RnExpr.lhs | 54 | ||||
| -rw-r--r-- | compiler/rename/RnExpr.lhs-boot | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcHsSyn.lhs | 18 | ||||
| -rw-r--r-- | compiler/typecheck/TcMatches.lhs | 28 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnDriver.lhs | 3 |
12 files changed, 76 insertions, 135 deletions
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 72c9e664f3..b0e92bb20e 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -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 diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs index 3360a95a97..58bf6b88e7 100644 --- a/compiler/deSugar/DsArrows.lhs +++ b/compiler/deSugar/DsArrows.lhs @@ -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 diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index e79ce7ff3c..4084310638 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -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} diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 78577072ef..56fc9a76b6 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -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} diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 18f9abddd6..d17f85099f 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -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 } diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 98599498ae..a0cc96417c 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -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 } diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 4899adb077..0b107645f3 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -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') diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 310d075d41..4b5071f8d1 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -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 diff --git a/compiler/rename/RnExpr.lhs-boot b/compiler/rename/RnExpr.lhs-boot index 5fba8c35fa..8870017a3a 100644 --- a/compiler/rename/RnExpr.lhs-boot +++ b/compiler/rename/RnExpr.lhs-boot @@ -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}
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 6b4449a107..5bc73338d2 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -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 -> @@ -689,13 +688,6 @@ 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 }) = do { ty' <- zonkTcTypeToType env 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 -> diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index a73b1d3a91..46b67da9be 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -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 _ _ diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 60f0fe93dd..893365e911 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -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) ; |