X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=65c425d255d1c9522b34585dd3e0d658fdca6a31;hb=c76c69c5b62f1ca4fa52d75b0dfbd37b7eddbb09;hp=c31e6aaf0fba2e205d24fc8319814395a0d2fa74;hpb=aa2c486e51caa0386aaff0d1b866a60316500b41;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index c31e6aa..65c425d 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -15,6 +15,7 @@ import DynFlags	( DynFlag(..) )
 
 import Generics		( mkTyConGenericBinds )
 import TcRnMonad
+import TcMType		( checkValidInstance )
 import TcEnv		( newDFunName, pprInstInfoDetails, 
 			  InstInfo(..), InstBindings(..), simpleInstInfoClsTy,
 			  tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
@@ -30,10 +31,10 @@ import RnEnv		( bindLocalNames )
 import HscTypes		( FixityEnv )
 
 import Class		( className, classArity, classKey, classTyVars, classSCTheta, Class )
-import Type		( zipOpenTvSubst, substTheta )
+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 )
@@ -341,7 +342,7 @@ makeDerivEqns overlap_flag tycl_decls
     mk_eqn (new_or_data, tycon_name, hs_deriv_ty)
       = tcLookupTyCon tycon_name		`thenM` \ tycon ->
 	setSrcSpan (srcLocSpan (getSrcLoc tycon))		$
-        addErrCtxt (derivCtxt Nothing tycon)	$
+        addErrCtxt (derivCtxt tycon)		$
 	tcExtendTyVarEnv (tyConTyVars tycon)	$	-- Deriving preds may (now) mention
 							-- the type variables for the type constructor
 	tcHsDeriv hs_deriv_ty			`thenM` \ (deriv_tvs, clas, tys) ->
@@ -567,7 +568,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?
         ]
 
@@ -726,10 +727,15 @@ solveDerivEqns overlap_flag orig_eqns
 
     ------------------------------------------------------------------
     gen_soln (_, clas, tc,tyvars,deriv_rhs)
-      = setSrcSpan (srcLocSpan (getSrcLoc tc))		$
-	addErrCtxt (derivCtxt (Just clas) tc)	$
-	tcSimplifyDeriv tc tyvars deriv_rhs	`thenM` \ theta ->
-	returnM (sortLe (<=) theta)	-- Canonicalise before returning the soluction
+      = setSrcSpan (srcLocSpan (getSrcLoc tc))	$
+	do { let inst_tys = [mkTyConApp tc (mkTyVarTys tyvars)]
+	   ; theta <- addErrCtxt (derivInstCtxt1 clas inst_tys) $
+		      tcSimplifyDeriv tc tyvars deriv_rhs
+	   ; addErrCtxt (derivInstCtxt2 theta clas inst_tys) $
+	     checkValidInstance tyvars theta clas inst_tys
+	   ; return (sortLe (<=) theta) }	-- Canonicalise before returning the soluction
+      where
+	
 
     ------------------------------------------------------------------
     mk_inst_spec (dfun_name, clas, tycon, tyvars, _) theta
@@ -828,7 +834,7 @@ genInst spec
 	-- *non-renamed* auxiliary bindings
 	; (rn_meth_binds, _fvs) <- discardWarnings $ 
 				   bindLocalNames (map varName tyvars)	$
-			 	   rnMethodBinds clas_nm [] meth_binds
+			 	   rnMethodBinds clas_nm (\n -> []) [] meth_binds
 
 	-- Build the InstInfo
 	; return (InstInfo { iSpec = spec, 
@@ -946,16 +952,20 @@ 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)])
 
-derivCtxt :: Maybe Class -> TyCon -> SDoc
-derivCtxt maybe_cls tycon
-  = ptext SLIT("When deriving") <+> cls <+> ptext SLIT("for type") <+> quotes (ppr tycon)
-  where
-    cls = case maybe_cls of
-	    Nothing -> ptext SLIT("instances")
-	    Just c  -> ptext SLIT("the") <+> quotes (ppr c) <+> ptext SLIT("instance")
+derivCtxt :: TyCon -> SDoc
+derivCtxt tycon
+  = ptext SLIT("When deriving instances for") <+> quotes (ppr tycon)
+
+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}