X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSMonad.lhs;h=36c46b3eff1967150941b88897e5b3290a10b9ad;hb=e491aa14a33502ade10049611d9fb79bab8360fc;hp=7b7a9f483dd26b918f004be0940ad050ecdd9bba;hpb=61f93d4611724685c5808bcfd41e3d3e0f3aa94f;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 7b7a9f4..36c46b3 100644 --- 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) ]) -- Record that this dfun is needed ; return $ MatchInstSingle (dfun_id, inst_tys) } ;