X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=1bb1bb76710641a8b2d05ae7c0fbcf233b460a83;hb=5d541fe7c43a1dc4c1b2dd9ee49e64238b0754ca;hp=a1ea0dd3514798d33652bc171e2ba4fe6a6d6db7;hpb=8697e394c38c50e20178fcafbe4f569b8e61b90f;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index a1ea0dd..1bb1bb7 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -15,7 +15,7 @@ import TcClassDcl	( tcMethodBind, mkMethodBind, badMethodErr,
 import TcRnMonad       
 import TcMType		( tcSkolSigType, checkValidInstance, checkValidInstHead )
 import TcType		( mkClassPred, tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys,
-                          SkolemInfo(InstSkol), tcSplitDFunTy )
+                          SkolemInfo(InstSkol), tcSplitDFunTy, mkFunTy )
 import Inst		( tcInstClassOp, newDicts, instToId, showLIE, 
 			  getOverlapFlag, tcExtendLocalInstEnv )
 import InstEnv		( mkLocalInstance, instanceDFunId )
@@ -29,11 +29,11 @@ import TcSimplify	( tcSimplifyCheck, tcSimplifySuperClasses )
 import Type		( zipOpenTvSubst, substTheta, substTys, mkTyConApp, mkTyVarTy )
 import Coercion         ( mkAppCoercion, mkAppsCoercion )
 import TyCon            ( TyCon, newTyConCo )
-import DataCon		( classDataCon, dataConTyCon )
-import Class		( classBigSig )
+import DataCon		( classDataCon, dataConTyCon, dataConInstArgTys )
+import Class		( classBigSig, classMethods )
 import Var		( TyVar, Id, idName, idType )
 import Id               ( mkSysLocal )
-import UniqSupply       ( uniqsFromSupply )
+import UniqSupply       ( uniqsFromSupply, splitUniqSupply )
 import MkId		( mkDictFunId )
 import Name		( Name, getSrcLoc )
 import Maybe		( catMaybes )
@@ -337,37 +337,60 @@ tcInstDecl2 (InstInfo { iSpec = ispec,
               maybe_co_con = newTyConCo tycon
 	; (tvs, theta, inst_head) <- tcSkolSigType rigid_info inst_ty
 	; dicts <- newDicts origin theta
-	; uniqs <- newUniqueSupply
-	; let (rep_dict_id:sc_dict_ids) = map instToId dicts
+        ; uniqs <- newUniqueSupply
+        ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head
+        ; [this_dict] <- newDicts origin [mkClassPred cls rep_tys]
+        ; let (rep_dict_id:sc_dict_ids) =
+                 if null dicts then
+                     [instToId this_dict]
+                 else
+                     map instToId dicts
+
 		-- (Here, we are relying on the order of dictionary 
 		-- arguments built by NewTypeDerived in TcDeriv.)
 
-              wrap_fn = CoTyLams tvs <.> CoLams sc_dict_ids
+              wrap_fn = CoTyLams tvs <.> CoLams (rep_dict_id:sc_dict_ids)
 	 
-	      coerced_rep_dict = mkHsCoerce (co_fn tvs cls_tycon) (HsVar rep_dict_id)
-              mk_located a = L noSrcSpan a
+              coerced_rep_dict = mkHsCoerce (co_fn tvs cls_tycon) (HsVar rep_dict_id)
+
 	      body | null sc_dict_ids = coerced_rep_dict
-		   | otherwise = HsCase (mk_located coerced_rep_dict) $
-				 MatchGroup [the_match] inst_head
-	      the_match = mkSimpleMatch [the_pat] the_rhs
+		   | otherwise = HsCase (noLoc coerced_rep_dict) $
+				 MatchGroup [the_match] (mkFunTy in_dict_ty inst_head)
+	      in_dict_ty = mkTyConApp cls_tycon cls_inst_tys
+
+              the_match = mkSimpleMatch [the_pat] the_rhs
+
+	      (uniqs1, uniqs2) = splitUniqSupply uniqs
+
 	      op_ids = zipWith (mkSysLocal FSLIT("op"))
-                        	      (uniqsFromSupply uniqs) op_tys
-	      the_pat = mk_located $ ConPatOut { pat_con = mk_located cls_data_con, pat_tvs = [],
-				    pat_dicts = sc_dict_ids,
+                        	      (uniqsFromSupply uniqs1) op_tys
+
+              dict_ids = zipWith (mkSysLocal FSLIT("dict"))
+                          (uniqsFromSupply uniqs2) (map idType sc_dict_ids)
+
+	      the_pat = noLoc $
+                        ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
+				    pat_dicts = dict_ids,
 				    pat_binds = emptyLHsBinds,
 				    pat_args = PrefixCon (map nlVarPat op_ids),
-				    pat_ty = inst_head }
-              (cls, op_tys) = tcSplitDFunHead inst_head
+				    pat_ty = in_dict_ty} 
+
               cls_data_con = classDataCon cls
               cls_tycon = dataConTyCon cls_data_con
+              cls_arg_tys = dataConInstArgTys cls_data_con cls_inst_tys 
               
-	      the_rhs = mkHsConApp (cls_data_con) (mkTyVarTys tvs) (map HsVar (sc_dict_ids ++ op_ids))
-
-        ; return (unitBag (mk_located $ VarBind (dfun_id) (mk_located (mkHsCoerce wrap_fn body)))) }
+              n_dict_args = if length dicts == 0 then 0 else length dicts - 1
+              op_tys = drop n_dict_args cls_arg_tys
+              
+	      the_rhs = mkHsConApp cls_data_con cls_inst_tys (map HsVar (sc_dict_ids ++ op_ids))
+              dict = (mkHsCoerce wrap_fn body)
+        ; return (unitBag (noLoc $ VarBind (dfun_id) (noLoc dict))) }
   where
     co_fn :: [TyVar] -> TyCon -> ExprCoFn
     co_fn tvs cls_tycon | Just co_con <- newTyConCo tycon
-	  = ExprCoFn (mkAppCoercion (mkAppsCoercion (mkTyConApp cls_tycon []) rep_tys) 
+	  = ExprCoFn (mkAppCoercion -- (mkAppsCoercion 
+                                     (mkTyConApp cls_tycon []) 
+                                     -- rep_tys)
                        		    (mkTyConApp co_con (map mkTyVarTy tvs)))
 	  | otherwise
 	  = idCoercion