Tidy up rebindable syntax for MDo

[ghc-hetmet.git] / compiler / typecheck / TcMatches.lhs

diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index 1442ac6..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 Inst
 import TcEnv
 import TcPat
 import TcMType
@@ -26,13 +25,11 @@ import TcBinds
 import TcUnify
 import Name
 import TysWiredIn
-import PrelNames
 import Id
 import TyCon
 import TysPrim
 import Coercion                ( mkSymCoI )
 import Outputable
-import VarSet
 import BasicTypes      ( Arity )
 import Util
 import SrcLoc
@@ -76,7 +73,7 @@ tcMatchesFun fun_name inf matches exp_ty
        ; checkArgs fun_name matches
 
        ; (wrap_gen, (wrap_fun, group)) 
-            <- tcGen (SigSkol (FunSigCtxt fun_name)) emptyVarSet exp_ty $ \ _ exp_rho ->
+            <- tcGen (SigSkol (FunSigCtxt fun_name)) exp_ty $ \ _ exp_rho ->
                  -- Note [Polymorphic expected type for tcMatchesFun]
                matchFunTys herald arity exp_rho $ \ pat_tys rhs_ty -> 
               tcMatches match_ctxt pat_tys rhs_ty matches 
@@ -186,7 +183,7 @@ tcMatch ctxt pat_tys rhs_ty match
   where
     tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
       = add_match_ctxt match $
-        do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys rhs_ty $
+        do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
                                tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
           ; return (Match pats' Nothing grhss') }
 
@@ -265,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)
 
@@ -345,7 +333,7 @@ tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
 
 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
   = do { (rhs', rhs_ty) <- tcInferRhoNC rhs    -- Stmt has a context already
-       ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat rhs_ty res_ty $
+       ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat rhs_ty $
                             thing_inside res_ty
        ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
@@ -363,7 +351,7 @@ tcLcStmt :: TyCon   -- The list/Parray type constructor ([] or PArray)
 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
  = do  { pat_ty <- newFlexiTyVarTy liftedTypeKind
         ; rhs'   <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty])
-       ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty $
+       ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty $
                             thing_inside res_ty
        ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
@@ -516,7 +504,7 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
                      else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
 
         ; rhs' <- tcMonoExprNC rhs rhs_ty
-       ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty new_res_ty $
+       ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
                            thing_inside new_res_ty
 
        ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
@@ -572,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 _ _
@@ -600,7 +588,7 @@ tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType))   -- RHS inference
          -> TcStmtChecker
 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
   = do { (rhs', pat_ty) <- tc_rhs rhs
-       ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty $
+       ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty $
                             thing_inside res_ty
        ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
@@ -609,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
@@ -626,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 _ _