X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcClassDcl.lhs;h=2d113b7bb57c030026948d6ba72c058b54347016;hb=77166b1729061531eeb77c33f4d3b2581f7d4c41;hp=23ee42366781005c6f5154ec039929149dff3432;hpb=0af418beb1aadcae1df036240151556895d00321;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index 23ee423..2d113b7 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -179,7 +179,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
 	; let
 	      (tyvars, _, _, op_items) = classBigSig clas
 	      rigid_info  = ClsSkol clas
-	      prag_fn	  = mkPragFun sigs
+	      prag_fn	  = mkPragFun sigs default_binds
 	      sig_fn	  = mkTcSigFun sigs
 	      clas_tyvars = tcSkolSigTyVars rigid_info tyvars
 	      pred  	  = mkClassPred clas (mkTyVarTys clas_tyvars)
@@ -234,16 +234,20 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn sel_id
         ; (dm_id_w_inline, spec_prags) 
                 <- tcPrags NonRecursive False True dm_id (prag_fn sel_name)
 
+        ; warnTc (not (null spec_prags))
+                 (ptext (sLit "Ignoring SPECIALISE pragmas on default method") 
+                  <+> quotes (ppr sel_name))
+
         ; tcInstanceMethodBody (instLoc this_dict) 
                                tyvars [this_dict]
                                ([], emptyBag)
                                dm_id_w_inline local_dm_id
-                               dm_sig_fn spec_prags meth_bind }
+                               dm_sig_fn IsDefaultMethod meth_bind }
 
 ---------------
 tcInstanceMethodBody :: InstLoc -> [TcTyVar] -> [Inst]
 		     -> ([Inst], LHsBinds Id) -> Id -> Id
-          	     -> TcSigFun -> [LSpecPrag] -> LHsBind Name 
+          	     -> TcSigFun -> TcSpecPrags -> LHsBind Name 
           	     -> TcM (Id, LHsBind Id)
 tcInstanceMethodBody inst_loc tyvars dfun_dicts
 		     (this_dict, this_bind) meth_id local_meth_id