X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;fp=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=ab788d7eedc8d976d37e764731ce04b1e6a5c7c8;hp=1979c8d96b61522f234726f7b27e6afc19ed3c30;hb=27310213397bb89555bb03585e057ba1b017e895;hpb=fd6de028d045654e42dc375e8c73b074c530f883

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 1979c8d..ab788d7 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -13,7 +13,6 @@ import TcBinds
 import TcTyClsDecls
 import TcClassDcl
 import TcPat( addInlinePrags )
-import TcSimplify( simplifyTop )
 import TcRnMonad
 import TcMType
 import TcType
@@ -621,7 +620,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
     setSrcSpan loc                              $
     addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ 
     do {  -- Instantiate the instance decl with skolem constants
-       ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolSigType skol_info (idType dfun_id)
+       ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
        ; let (clas, inst_tys) = tcSplitDFunHead inst_head
              (class_tyvars, sc_theta, _, op_items) = classBigSig clas
              sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
@@ -633,16 +632,15 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
        ; orig_ev_vars   <- newEvVars orig_theta
        ; let dfun_ev_vars = silent_ev_vars ++ orig_ev_vars
 
-       ; (sc_binds, sc_dicts, sc_args)
-             <- mapAndUnzip3M (tcSuperClass n_ty_args dfun_ev_vars) sc_theta'
+       ; (sc_dicts, sc_args)
+             <- mapAndUnzipM (tcSuperClass n_ty_args dfun_ev_vars) sc_theta'
 
        -- Check that any superclasses gotten from a silent arguemnt
        -- can be deduced from the originally-specified dfun arguments
        ; ct_loc <- getCtLoc ScOrigin
        ; _ <- checkConstraints skol_info inst_tyvars orig_ev_vars $
-              emitConstraints $ listToBag $
-              [ WcEvVar (WantedEvVar sc ct_loc)
-              | sc <- sc_dicts, isSilentEvVar sc ]
+              emitFlats $ listToBag $
+              [ mkEvVarX sc ct_loc | sc <- sc_dicts, isSilentEvVar sc ]
 
        -- Deal with 'SPECIALISE instance' pragmas
        -- See Note [SPECIALISE instance pragmas]
@@ -698,7 +696,6 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
                                   , abs_binds = unitBag dict_bind }
 
        ; return (unitBag (L loc main_bind) `unionBags`
-                 unionManyBags sc_binds    `unionBags`
                  listToBag meth_binds)
        }
  where
@@ -708,23 +705,17 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
    loc       = getSrcSpan dfun_id
 
 ------------------------------
-tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (LHsBinds Id, Id, DFunArg CoreExpr)
+tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (EvVar, DFunArg CoreExpr)
+-- All superclasses should be either
+--   (a) be one of the arguments to the dfun, of
+--   (b) be a constant, soluble at top level
 tcSuperClass n_ty_args ev_vars pred
   | Just (ev, i) <- find n_ty_args ev_vars
-  = return (emptyBag, ev, DFunLamArg i)
+  = return (ev, DFunLamArg i)
   | otherwise
-  = ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred)
-    do { sc_dict  <- newWantedEvVar pred
-       ; loc      <- getCtLoc ScOrigin
-       ; ev_binds <- simplifyTop (unitBag (WcEvVar (WantedEvVar sc_dict loc)))
-       ; let ev_wrap = WpLet (EvBinds ev_binds)
-             sc_bind = mkVarBind sc_dict (noLoc $ (wrapId ev_wrap sc_dict))
-       ; return (unitBag sc_bind, sc_dict, DFunConstArg (Var sc_dict)) }
-           -- It's very important to solve the superclass constraint *in isolation*
-       	   -- so that it isn't generated by superclass selection from something else
-           -- We then generate the (also rather degenerate) top-level binding:
-       	   --      sc_dict = let sc_dict = <blah> in sc_dict
-       	   -- where <blah> is generated by solving the implication constraint
+  = ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred)       -- Constant!
+    do { sc_dict  <- emitWanted ScOrigin pred
+       ; return (sc_dict, DFunConstArg (Var sc_dict)) }
   where
     find _ [] = Nothing
     find i (ev:evs) | pred `tcEqPred` evVarPred ev = Just (ev, i)
@@ -863,7 +854,7 @@ tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
         ; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty
         ; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys
 
-        ; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt)
+        ; co_fn <- tcSubType (SpecPragOrigin name) SpecInstCtxt
                              (idType dfun_id) spec_dfun_ty
         ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
   where