X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=601f0deb2c579d1be188871a78e8090a3f29afd0;hb=2ed6929441ca033f2c5e1cf1a836579fff30b073;hp=472ce6b94d3942ba706c186acbff3ea569ba2a05;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 472ce6b..601f0de 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,7 +31,7 @@ import RnEnv		( bindLocalNames )
 import HscTypes		( FixityEnv )
 
 import Class		( className, classArity, classKey, classTyVars, classSCTheta, Class )
-import Type		( zipOpenTvSubst, substTheta )
+import Type		( zipOpenTvSubst, substTheta, pprThetaArrow, pprClassPred )
 import ErrUtils		( dumpIfSet_dyn )
 import MkId		( mkDictFunId )
 import DataCon		( isNullarySrcDataCon, isVanillaDataCon, dataConOrigArgTys )
@@ -44,8 +45,8 @@ import TyCon		( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics,
 			  isEnumerationTyCon, isRecursiveTyCon, TyCon
 			)
 import TcType		( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon,
-			  isUnLiftedType, mkClassPred, tyVarsOfTypes, isArgTypeKind,
-			  tcEqTypes, tcSplitAppTys, mkAppTys )
+			  isUnLiftedType, mkClassPred, tyVarsOfType,
+			  isArgTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys )
 import Var		( TyVar, tyVarKind, varName )
 import VarSet		( mkVarSet, subVarSet )
 import PrelNames
@@ -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) ->
@@ -419,7 +420,8 @@ makeDerivEqns overlap_flag tycl_decls
 	args_to_drop   = drop n_args_to_keep rep_ty_args
  	args_to_keep   = take n_args_to_keep rep_ty_args
 
-	rep_tys  = tys ++ [mkAppTys rep_fn args_to_keep]
+	rep_fn'  = mkAppTys rep_fn args_to_keep
+	rep_tys  = tys ++ [rep_fn']
 	rep_pred = mkClassPred clas rep_tys
 		-- rep_pred is the representation dictionary, from where
 		-- we are gong to get all the methods for the newtype dictionary
@@ -494,7 +496,7 @@ makeDerivEqns overlap_flag tycl_decls
 	--	(b) the remaining type args mention 
 	--	    only the remaining type variables
 	eta_ok = (args_to_drop `tcEqTypes` mkTyVarTys tyvars_to_drop)
-	      && (tyVarsOfTypes args_to_keep `subVarSet` mkVarSet tyvars_to_keep) 
+	      && (tyVarsOfType rep_fn' `subVarSet` mkVarSet tyvars_to_keep) 
 
 	cant_derive_err = derivingThingErr clas tys tycon tyvars_to_keep
 				(vcat [ptext SLIT("even with cunning newtype deriving:"),
@@ -725,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
@@ -827,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, 
@@ -945,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}