bugs

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

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index a1ea0dd..1bb1bb7 100644 (file)
--- 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