From: simonpj <unknown>
Date: Fri, 21 Dec 2001 10:05:11 +0000 (+0000)
Subject: [project @ 2001-12-21 10:05:11 by simonpj]
X-Git-Tag: Approximately_9120_patches~355
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0a7b8d872ebf93a1bfc8f87a8a60cce0097ecfc2;p=ghc-hetmet.git

[project @ 2001-12-21 10:05:11 by simonpj]
More wibbles to newtype deriving
---

diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 348090e..5d77419 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -43,11 +43,11 @@ import RdrName		( RdrName )
 
 import TyCon		( tyConTyVars, tyConDataCons, tyConArity, newTyConRep,
 			  tyConTheta, maybeTyConSingleCon, isDataTyCon,
-			  isEnumerationTyCon, TyCon, isRecursiveTyCon
+			  isEnumerationTyCon, TyCon
 			)
 import TcType		( TcType, ThetaType, mkTyVarTys, mkTyConApp, getClassPredTys_maybe,
 			  isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys, 
-			  tcSplitTyConApp_maybe )
+			  tcSplitTyConApp_maybe, tcEqTypes )
 import Var		( TyVar, tyVarKind )
 import VarSet		( mkVarSet, subVarSet )
 import PrelNames
@@ -386,12 +386,12 @@ makeDerivEqns tycl_decls
 	Just (rep_tc, rep_ty_args) = maybe_rep_app
 
 	n_tyvars_to_keep = tyConArity tycon  - n_args_to_drop
-	tyvars_to_keep = ASSERT( n_tyvars_to_keep >= 0 && n_tyvars_to_keep <= length tyvars )
-			 take n_tyvars_to_keep tyvars	-- Kind checking should ensure this
+	tyvars_to_drop   = drop n_tyvars_to_keep tyvars
+	tyvars_to_keep   = take n_tyvars_to_keep tyvars
 
 	n_args_to_keep = tyConArity rep_tc - n_args_to_drop
- 	args_to_keep   = ASSERT( n_args_to_keep >= 0 && n_args_to_keep <= length rep_ty_args )
-			 take n_args_to_keep rep_ty_args
+	args_to_drop   = drop n_args_to_keep rep_ty_args
+ 	args_to_keep   = take n_args_to_keep rep_ty_args
 
 	ctxt_pred = mkClassPred clas (tys ++ [mkTyConApp rep_tc args_to_keep])
 
@@ -405,10 +405,19 @@ makeDerivEqns tycl_decls
 	can_derive_via_isomorphism
 	   =  not (clas `hasKey` readClassKey)	-- Never derive Read,Show this way
 	   && not (clas `hasKey` showClassKey)
-	   && not (isRecursiveTyCon tycon)	-- Newtype isn't recursive
+	   && n_tyvars_to_keep >= 0		-- Well kinded; 
+						-- eg not: newtype T = T Int deriving( Monad )
 	   && isJust maybe_rep_app	 	-- The rep type is a type constructor app
-	   && (tyVarsOfTypes args_to_keep `subVarSet` mkVarSet tyvars_to_keep) 
-						-- and the tyvars are all in scope
+	   && n_args_to_keep   >= 0		-- Well kinded: 
+						-- eg not: newtype T a = T Int deriving( Monad )
+	   && eta_ok				-- Eta reduction works
+
+	-- Check that eta reduction is OK
+	-- 	(a) the dropped-off args are identical
+	--	(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) 
 
 	cant_derive_err = derivingThingErr clas tys tycon tyvars_to_keep
 					   SLIT("too hard for cunning newtype deriving")
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 88973ba..b116104 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -41,7 +41,7 @@ module TcType (
   ---------------------------------
   -- Predicates. 
   -- Again, newtypes are opaque
-  tcEqType, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred,
+  tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred,
   isSigmaTy, isOverloadedTy, 
   isDoubleTy, isFloatTy, isIntTy,
   isIntegerTy, isAddrTy, isBoolTy, isUnitTy, isForeignPtrTy, 
@@ -575,6 +575,9 @@ But ignoring usage types
 tcEqType :: Type -> Type -> Bool
 tcEqType ty1 ty2 = case ty1 `tcCmpType` ty2 of { EQ -> True; other -> False }
 
+tcEqTypes :: [Type] -> [Type] -> Bool
+tcEqTypes ty1 ty2 = case ty1 `tcCmpTypes` ty2 of { EQ -> True; other -> False }
+
 tcEqPred :: PredType -> PredType -> Bool
 tcEqPred p1 p2 = case p1 `tcCmpPred` p2 of { EQ -> True; other -> False }