X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=0a8a4982326280d1a92550ff5b9b5b5e35c7cbca;hb=7121d8296720cf1a79259350f361f5771210b23d;hp=95d9697c0c67f716b970a85add2b890e733fd918;hpb=7f0ce617a0380339da927433dc816e45704db0be;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 95d9697..0a8a498 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -31,10 +31,10 @@ import RnEnv		( bindLocalNames )
 import HscTypes		( FixityEnv )
 
 import Class		( className, classArity, classKey, classTyVars, classSCTheta, Class )
-import Type		( zipOpenTvSubst, substTheta, pprThetaArrow, pprClassPred )
+import Type		( zipOpenTvSubst, substTheta, pprThetaArrow, pprClassPred, mkTyVarTy )
 import ErrUtils		( dumpIfSet_dyn )
 import MkId		( mkDictFunId )
-import DataCon		( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys )
+import DataCon		( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys, dataConInstOrigArgTys )
 import Maybes		( catMaybes )
 import RdrName		( RdrName )
 import Name		( Name, getSrcLoc )
@@ -350,6 +350,10 @@ makeDerivEqns overlap_flag tycl_decls
         mk_eqn_help gla_exts new_or_data tycon deriv_tvs clas tys
 
     ------------------------------------------------------------------
+    -- data/newtype T a = ... deriving( C t1 t2 )
+    --   leads to a call to mk_eqn_help with
+    --		tycon = T, deriv_tvs = ftv(t1,t2), clas = C, tys = [t1,t2]
+
     mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys
       | Just err <- checkSideConditions gla_exts tycon deriv_tvs clas tys
       = bale_out (derivingThingErr clas tys tycon (tyConTyVars tycon) err)
@@ -434,7 +438,7 @@ makeDerivEqns overlap_flag tycl_decls
 		-- We must pass the superclasses; the newtype might be an instance
 		-- of them in a different way than the representation type
 		-- E.g.		newtype Foo a = Foo a deriving( Show, Num, Eq )
-		-- Then the Show instance is not done via isomprphism; it shows
+		-- Then the Show instance is not done via isomorphism; it shows
 		-- 	Foo 3 as "Foo 3"
 		-- The Num instance is derived via isomorphism, but the Show superclass
 		-- dictionary must the Show instance for Foo, *not* the Show dictionary
@@ -568,7 +572,7 @@ mkDataTypeEqn tycon clas
     ordinary_constraints
       = [ mkClassPred clas [arg_ty] 
         | data_con <- tyConDataCons tycon,
-          arg_ty   <- dataConOrigArgTys data_con,
+          arg_ty <- dataConInstOrigArgTys data_con (map mkTyVarTy (tyConTyVars tycon)),
           not (isUnLiftedType arg_ty)	-- No constraints for unlifted types?
         ]
 
@@ -729,9 +733,9 @@ solveDerivEqns overlap_flag orig_eqns
     gen_soln (_, clas, tc,tyvars,deriv_rhs)
       = setSrcSpan (srcLocSpan (getSrcLoc tc))	$
 	do { let inst_tys = [mkTyConApp tc (mkTyVarTys tyvars)]
-	   ; theta <- addErrCtxt (derivInstCtxt [] clas inst_tys) $
+	   ; theta <- addErrCtxt (derivInstCtxt1 clas inst_tys) $
 		      tcSimplifyDeriv tc tyvars deriv_rhs
-	   ; addErrCtxt (derivInstCtxt theta clas inst_tys) $
+	   ; addErrCtxt (derivInstCtxt2 theta clas inst_tys) $
 	     checkValidInstance tyvars theta clas inst_tys
 	   ; return (sortLe (<=) theta) }	-- Canonicalise before returning the soluction
       where
@@ -952,7 +956,7 @@ genTaggeryBinds infos
 \begin{code}
 derivingThingErr clas tys tycon tyvars why
   = sep [hsep [ptext SLIT("Can't make a derived instance of"), quotes (ppr pred)],
-	 parens why]
+	 nest 2 (parens why)]
   where
     pred = mkClassPred clas (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars)])
 
@@ -960,8 +964,12 @@ derivCtxt :: TyCon -> SDoc
 derivCtxt tycon
   = ptext SLIT("When deriving instances for") <+> quotes (ppr tycon)
 
-derivInstCtxt theta clas inst_tys
-  = hang (ptext SLIT("In the derived instance"))
-       2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta, pprClassPred clas inst_tys])
+derivInstCtxt1 clas inst_tys
+  = ptext SLIT("When deriving the instance for") <+> quotes (pprClassPred clas inst_tys)
+
+derivInstCtxt2 theta clas inst_tys
+  = vcat [ptext SLIT("In the derived instance declaration"),
+          nest 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta, 
+						  pprClassPred clas inst_tys])]
 \end{code}