X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=ab788d7eedc8d976d37e764731ce04b1e6a5c7c8;hb=78b556a7806d4ebc9d35c90f5d59b4032d717f86;hp=f4e338d096c2a19f18776fa63d42d6bd84719973;hpb=3d16d9d805e321c58459d0b62223591c19013060;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index f4e338d..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
@@ -371,7 +370,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
        ; let { (local_info,
                 at_tycons_s)   = unzip local_info_tycons
              ; at_idx_tycons   = concat at_tycons_s ++ idx_tycons
-             ; clas_decls      = filter (isClassDecl.unLoc) tycl_decls
+             ; clas_decls      = filter (isClassDecl . unLoc) tycl_decls
              ; implicit_things = concatMap implicitTyThings at_idx_tycons
 	     ; aux_binds       = mkRecSelBinds at_idx_tycons
              }
@@ -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
@@ -1249,7 +1240,7 @@ instDeclCtxt2 :: Type -> SDoc
 instDeclCtxt2 dfun_ty
   = inst_decl_ctxt (ppr (mkClassPred cls tys))
   where
-    (_,cls,tys) = tcSplitDFunTy dfun_ty
+    (_,_,cls,tys) = tcSplitDFunTy dfun_ty
 
 inst_decl_ctxt :: SDoc -> SDoc
 inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc