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

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 72c9e66..b0e92bb 100644 (file)
--- 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)
        ; 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'
        ; 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
 
 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
 
 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
 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 3360a95..58bf6b8 100644 (file)
--- 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
 
 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
         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 e79ce7f..4084310 100644 (file)
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -34,7 +34,6 @@ import DsMeta
 #endif
 
 import HsSyn
 #endif
 
 import HsSyn

-import TcHsSyn

 
 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
 --     needs to see source types
 
 -- 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 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
 
 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
     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( 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 
         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
 
         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
 
        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
     -- 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 " ++ 
 
 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}
                                      return (v1,..vn))
 
 \begin{code}

-dsMDo  :: HsStmtContext Name
+{-
+dsMDo   :: HsStmtContext Name

         -> [(Name,Id)]
        -> [LStmt Id]
        -> LHsExpr Id
         -> [(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)
     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
     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 }
 
       = 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
       = do { rhs2 <- dsLExpr rhs
           ; 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
-      = 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
           ; 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
     
     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
       = 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
        
                -- 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 ]
     
        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))
 
        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
 
        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
 
        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
        mk_tup_pat :: [LPat Id] -> LPat Id
        mk_tup_pat [p] = p
        mk_tup_pat ps  = noLoc $ mkVanillaTuplePat ps Boxed

+-}

 \end{code}
 
 
 \end{code}
 
 

diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 7857707..56fc9a7 100644 (file)
--- 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
                                      -- 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}
       }
   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 :: 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
 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
   = 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
   | 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
 
 \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
 
 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")
  = 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")
 
 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 (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}
 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 18f9abd..d17f850 100644 (file)
--- 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
 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 }
 
 
 mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
 

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 9859949..a0cc964 100644 (file)
--- 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 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 }
         | 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 4899adb..0b10764 100644 (file)
--- 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
 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')
                                    rnLExpr rhs
 
        ; unless (pattern_guards_allowed || is_standard_guard guards')

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 310d075..4b5071f 100644 (file)
--- 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 _)
     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) }
 
                                    rnLExpr body
        ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
 

@@ -637,16 +637,7 @@ rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \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,
              -> ([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
 
 --
 -- 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) }
 
   = 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 ->
   = 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) }
 
                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.)
        -- 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
 
        { 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)
        ; (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) }
                 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) 
          -- 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
                 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)
 
     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
                        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]
 
 
                      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
                          -- the FreeVars of the Segments
                       -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
                       -> RnM (a, FreeVars)
                          -- 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)
 
   = 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) <- 
 
 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')))]
       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 :: 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
 
   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 5fba8c3..8870017 100644 (file)
--- a/compiler/rename/RnExpr.lhs-boot
+++ b/compiler/rename/RnExpr.lhs-boot
@@ -11,7 +11,7 @@ rnLExpr :: LHsExpr RdrName
 \r
 rnStmts :: --forall thing.\r
           HsStmtContext Name -> [LStmt RdrName] \r
 \r
 rnStmts :: --forall thing.\r
           HsStmtContext Name -> [LStmt RdrName] \r

-       -> RnM (thing, FreeVars)\r
+        -> ([Name] -> RnM (thing, FreeVars))\r

        -> RnM (([LStmt Name], thing), FreeVars)\r
 \end{code}\r
 \r
        -> RnM (([LStmt Name], thing), FreeVars)\r
 \end{code}\r
 \r

diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 6b4449a..5bc7333 100644 (file)
--- 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   ->
   = 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 ->
 
 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') }
 
 -------------------------------------------------------------------------
                                 ; 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
 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
 
 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
   = 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
        -- 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
                  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 ->
 
 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 a73b1d3..46b67da 100644 (file)
--- 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 HsSyn
 import TcRnMonad

-import Inst

 import TcEnv
 import TcPat
 import TcMType
 import TcEnv
 import TcPat
 import TcMType

@@ -26,7 +25,6 @@ import TcBinds
 import TcUnify
 import Name
 import TysWiredIn
 import TcUnify
 import Name
 import TysWiredIn

-import PrelNames

 import Id
 import TyCon
 import TysPrim
 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) }
 
                             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
                             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)
 
 
 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'
         ; 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 _ _
         }}
 
 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) }
 
        ; 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
   = 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)
 
                --      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 _ _
        }}
 
 tcMDoStmt _ _ stmt _ _

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 60f0fe9..893365e 100644 (file)
--- 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
     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) ;
     traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
     failIfErrsM ;
     rnDump (ppr rn_stmt) ;