From f3695b15d9849df7b808e17aa600511ad6002a31 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Thu, 20 Dec 2001 17:10:01 +0000
Subject: [PATCH] [project @ 2001-12-20 17:10:00 by simonpj] Wibbles

---
 ghc/compiler/typecheck/TcDeriv.lhs    |   46 +++++++++++++++++++--------------
 ghc/compiler/typecheck/TcInstDcls.lhs |    3 +++
 2 files changed, 29 insertions(+), 20 deletions(-)

diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 9bc4540..348090e 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -18,7 +18,7 @@ import CmdLineOpts	( DynFlag(..), DynFlags )
 
 import TcMonad
 import TcEnv		( tcSetInstEnv, newDFunName, InstInfo(..), pprInstInfo,
-			  tcLookupClass, tcLookupTyCon
+			  tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
 			)
 import TcGenDeriv	-- Deriv stuff
 import InstEnv		( InstEnv, simpleDFunClassTyCon, extendInstEnv )
@@ -43,7 +43,7 @@ import RdrName		( RdrName )
 
 import TyCon		( tyConTyVars, tyConDataCons, tyConArity, newTyConRep,
 			  tyConTheta, maybeTyConSingleCon, isDataTyCon,
-			  isEnumerationTyCon, TyCon
+			  isEnumerationTyCon, TyCon, isRecursiveTyCon
 			)
 import TcType		( TcType, ThetaType, mkTyVarTys, mkTyConApp, getClassPredTys_maybe,
 			  isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys, 
@@ -314,6 +314,8 @@ makeDerivEqns tycl_decls
       = tcLookupTyCon tycon_name		`thenNF_Tc` \ tycon ->
 	tcAddSrcLoc (getSrcLoc tycon)		$
         tcAddErrCtxt (derivCtxt tycon)		$
+	tcExtendTyVarEnv (tyConTyVars tycon)	$	-- Deriving preds may (now) mention
+							-- the type variables for the type constructor
         tcHsPred pred				`thenTc` \ pred' ->
 	case getClassPredTys_maybe pred' of
 	   Nothing 	    -> bale_out (malformedPredErr tycon pred)
@@ -347,19 +349,17 @@ makeDerivEqns tycl_decls
 	offensive_class = classKey clas `elem` needsDataDeclCtxtClassKeys
 
 
-    mk_eqn_help NewType tycon clas []
-      | clas `hasKey` readClassKey || clas `hasKey` showClassKey
-      = mk_eqn_help DataType tycon clas []	-- Use the generate-full-code mechanism for Read and Show
-
     mk_eqn_help NewType tycon clas tys
-      = doptsTc Opt_GlasgowExts			`thenTc` \ gla_exts ->
-	if not gla_exts then			-- Not glasgow-exts?
-	   mk_eqn_help DataType tycon clas tys	--   revert to ordinary mechanism
-        else if not can_derive then
-	   bale_out cant_derive_err
-	else
-	   new_dfun_name clas tycon  		`thenNF_Tc` \ dfun_name ->
+      =	doptsTc Opt_GlasgowExts			`thenTc` \ gla_exts ->
+        if can_derive_via_isomorphism && (gla_exts || standard_instance) then
+		-- Go ahead and use the isomorphism
+       	   new_dfun_name clas tycon  		`thenNF_Tc` \ dfun_name ->
 	   returnTc (Nothing, Just (NewTypeDerived (mk_dfun dfun_name)))
+	else
+	   if standard_instance then
+		mk_eqn_help DataType tycon clas []	-- Go via bale-out route
+	   else
+	   	bale_out cant_derive_err
       where
 	-- Here is the plan for newtype derivings.  We see
 	--	  newtype T a1...an = T (t ak...an) deriving (C1...Cm)
@@ -400,8 +400,14 @@ makeDerivEqns tycl_decls
 						  [ctxt_pred]
 
 	-- We can only do this newtype deriving thing if:
-	can_derive =  isJust maybe_rep_app 	-- The rep type is a type constructor app
-		   && (tyVarsOfTypes args_to_keep `subVarSet` mkVarSet tyvars_to_keep) 
+	standard_instance = null tys && classKey clas `elem` derivableClassKeys
+
+	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
+	   && 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
 
 	cant_derive_err = derivingThingErr clas tys tycon tyvars_to_keep
@@ -427,11 +433,11 @@ makeDerivEqns tycl_decls
 	    is_single_con  = maybeToBool (maybeTyConSingleCon tycon)
 	    is_enumeration_or_single = is_enumeration || is_single_con
 
-	    single_nullary_why = SLIT("one constructor data type or type with all nullary constructors expected")
-	    nullary_why        = SLIT("data type with all nullary constructors expected")
-	    no_cons_why	       = SLIT("type has no data constructors")
-	    non_std_why	       = SLIT("not a derivable class")
-	    existential_why    = SLIT("it has existentially-quantified constructor(s)")
+    single_nullary_why = SLIT("one constructor data type or type with all nullary constructors expected")
+    nullary_why        = SLIT("data type with all nullary constructors expected")
+    no_cons_why	       = SLIT("type has no data constructors")
+    non_std_why	       = SLIT("not a derivable class")
+    existential_why    = SLIT("it has existentially-quantified constructor(s)")
 
 new_dfun_name clas tycon 	-- Just a simple wrapper
   = newDFunName clas [mkTyConApp tycon []] (getSrcLoc tycon)
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 3b3237c..bf79e5c 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -519,6 +519,9 @@ tcInstDecl2 (NewTypeDerived { iDFunId = dfun_id })
 	        (HsVar unsafeCoerceId `TyApp` [idType rep_dict_id, inst_head'])
 			  `HsApp` 
 		(HsVar rep_dict_id)
+	-- You might wonder why we have the 'coerce'.  It's because the
+	-- type equality mechanism isn't clever enough; see comments with Type.eqType.
+	-- So Lint complains if we don't have this. 
     in
     returnTc (emptyLIE, VarMonoBind dfun_id body)
 
-- 
1.7.10.4