Fix recursive superclasses (again). Fixes Trac #4809.

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

diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 46b8c04..6b4449a 100644 (file)
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -82,7 +82,6 @@ hsPatType :: Pat Id -> Type
 hsPatType (ParPat pat)                = hsLPatType pat
 hsPatType (WildPat ty)                = ty
 hsPatType (VarPat var)                = idType var
-hsPatType (VarPatOut var _)           = idType var
 hsPatType (BangPat pat)               = hsLPatType pat
 hsPatType (LazyPat pat)               = hsLPatType pat
 hsPatType (LitPat lit)                = hsLitType lit
@@ -270,13 +269,14 @@ zonkTopLExpr e = zonkLExpr emptyZonkEnv e
 
 zonkTopDecls :: Bag EvBind 
              -> LHsBinds TcId -> NameSet
-             -> [LRuleDecl TcId] -> [LForeignDecl TcId]
+             -> [LRuleDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
             -> TcM ([Id], 
                     Bag EvBind,
                     Bag (LHsBind  Id),
                     [LForeignDecl Id],
+                    [LTcSpecPrag],
                     [LRuleDecl    Id])
-zonkTopDecls ev_binds binds sig_ns rules fords
+zonkTopDecls ev_binds binds sig_ns rules imp_specs fords
   = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
 
         -- Warn about missing signatures
@@ -288,8 +288,9 @@ zonkTopDecls ev_binds binds sig_ns rules fords
         ; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds
                        -- Top level is implicitly recursive
        ; rules' <- zonkRules env2 rules
+        ; specs' <- zonkLTcSpecPrags env2 imp_specs
        ; fords' <- zonkForeignExports env2 fords
-       ; return (zonkEnvIds env2, ev_binds', binds', fords', rules') }
+       ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') }
 
 ---------------------------------------------
 zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
@@ -430,12 +431,16 @@ zonk_bind env sig_warn (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
 
 zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
 zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
-zonkSpecPrags env (SpecPrags ps)  = do { ps' <- mapM zonk_prag ps
+zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
                                        ; return (SpecPrags ps') }
+
+zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
+zonkLTcSpecPrags env ps
+  = mapM zonk_prag ps
   where
-    zonk_prag (L loc (SpecPrag co_fn inl))
+    zonk_prag (L loc (SpecPrag id co_fn inl))
        = do { (_, co_fn') <- zonkCoFn env co_fn
-            ; return (L loc (SpecPrag co_fn' inl)) }
+            ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
 \end{code}
 
 %************************************************************************
@@ -559,11 +564,12 @@ zonkExpr env (HsCase expr ms)
     zonkMatchGroup env ms      `thenM` \ new_ms ->
     returnM (HsCase new_expr new_ms)
 
-zonkExpr env (HsIf e1 e2 e3)
-  = zonkLExpr env e1   `thenM` \ new_e1 ->
-    zonkLExpr env e2   `thenM` \ new_e2 ->
-    zonkLExpr env e3   `thenM` \ new_e3 ->
-    returnM (HsIf new_e1 new_e2 new_e3)
+zonkExpr env (HsIf e0 e1 e2 e3)
+  = do { new_e0 <- fmapMaybeM (zonkExpr env) e0
+       ; new_e1 <- zonkLExpr env e1
+       ; new_e2 <- zonkLExpr env e2
+       ; new_e3 <- zonkLExpr env e3
+       ; returnM (HsIf new_e0 new_e1 new_e2 new_e3) }
 
 zonkExpr env (HsLet binds expr)
   = zonkLocalBinds env binds   `thenM` \ (new_env, new_binds) ->
@@ -845,11 +851,6 @@ zonk_pat env (VarPat v)
   = do { v' <- zonkIdBndr env v
        ; return (extendZonkEnv1 env v', VarPat v') }
 
-zonk_pat env (VarPatOut v binds)
-  = do { v' <- zonkIdBndr env v
-       ; (env', binds') <- zonkTcEvBinds (extendZonkEnv1 env v') binds
-       ; returnM (env', VarPatOut v' binds') }
-
 zonk_pat env (LazyPat pat)
   = do { (env', pat') <- zonkPat env pat
        ; return (env',  LazyPat pat') }
@@ -902,10 +903,7 @@ zonk_pat env (SigPatOut pat ty)
 
 zonk_pat env (NPat lit mb_neg eq_expr)
   = do { lit' <- zonkOverLit env lit
-       ; mb_neg' <- case mb_neg of
-                       Nothing  -> return Nothing
-                       Just neg -> do { neg' <- zonkExpr env neg
-                                      ; return (Just neg') }
+       ; mb_neg' <- fmapMaybeM (zonkExpr env) mb_neg
        ; eq_expr' <- zonkExpr env eq_expr
        ; return (env, NPat lit' mb_neg' eq_expr') }
 
@@ -1035,7 +1033,7 @@ zonkEvTerm env (EvCast v co)      = ASSERT( isId v)
                                     do { co' <- zonkTcTypeToType env co
                                        ; return (EvCast (zonkIdOcc env v) co') }
 zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n)
-zonkEvTerm env (EvDFunApp df tys tms) 
+zonkEvTerm env (EvDFunApp df tys tms)
   = do { tys' <- zonkTcTypeToTypes env tys
        ; let tms' = map (zonkEvVarOcc env) tms
        ; return (EvDFunApp (zonkIdOcc env df) tys' tms') }
@@ -1070,7 +1068,7 @@ zonkEvBind env (EvBind var term)
 
 %************************************************************************
 %*                                                                     *
-\subsection[BackSubst-Foreign]{Foreign exports}
+                         Zonking types
 %*                                                                     *
 %************************************************************************