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

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

diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 7b7a9f4..1e99876 100644 (file)
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -181,8 +181,9 @@ data CanonicalCt
 compatKind :: Kind -> Kind -> Bool 
 compatKind k1 k2 = k1 `isSubKind` k2 || k2 `isSubKind` k1 
 
-makeGivens :: CanonicalCts -> CanonicalCts
-makeGivens = mapBag (\ct -> ct { cc_flavor = mkGivenFlavor (cc_flavor ct) UnkSkol })
+makeGivens :: Bag WantedEvVar -> Bag (CtFlavor,EvVar) 
+makeGivens = mapBag (\(WantedEvVar ev wloc) -> (mkGivenFlavor (Wanted wloc) UnkSkol, ev))
+-- ct { cc_flavor = mkGivenFlavor (cc_flavor ct) UnkSkol })
           -- The UnkSkol doesn't matter because these givens are
           -- not contradictory (else we'd have rejected them already)
 
@@ -459,6 +460,7 @@ data SimplContext
   | SimplRuleLhs       -- Inferring type of a RULE lhs
   | SimplInteractive   -- Inferring type at GHCi prompt
   | SimplCheck         -- Checking a type signature or RULE rhs
+  deriving Eq
 
 instance Outputable SimplContext where
   ppr SimplInfer       = ptext (sLit "SimplInfer")
@@ -899,10 +901,8 @@ isGoodRecEv ev_var wv
 
         chase_ev assocs trg curr_grav visited (EvCoercion co)
             = chase_co assocs trg curr_grav visited co
-        chase_ev assocs trg curr_grav visited (EvDFunApp _ _ _ev_vars ev_deps)
+        chase_ev assocs trg curr_grav visited (EvDFunApp _ _ ev_deps)
             = do { chase_results <- mapM (chase_ev_var assocs trg (curr_grav+1) visited) ev_deps
-                                    -- Notice that we chase the ev_deps and not the ev_vars
-                                    -- See Note [Dependencies in self dictionaries] in TcSimplify
                  ; return (comb_chase_res Nothing chase_results) }
 
         chase_co assocs trg curr_grav visited co 
@@ -935,7 +935,7 @@ matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Either TyVar TcT
 matchClass clas tys
   = do { let pred = mkClassPred clas tys 
         ; instEnvs <- getInstEnvs
-       ; case lookupInstEnv instEnvs clas tys of {
+        ; case lookupInstEnv instEnvs clas tys of {
             ([], unifs)               -- Nothing matches  
                 -> do { traceTcS "matchClass not matching"
                                  (vcat [ text "dict" <+> ppr pred, 
@@ -947,7 +947,7 @@ matchClass clas tys
                        ; traceTcS "matchClass success"
                                   (vcat [text "dict" <+> ppr pred, 
                                          text "witness" <+> ppr dfun_id
-                                          <+> ppr (idType dfun_id) ])
+                                           <+> ppr (idType dfun_id), ppr instEnvs ])
                                  -- Record that this dfun is needed
                         ; return $ MatchInstSingle (dfun_id, inst_tys)
                         } ;