X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=550b274ec501ab8ca3b7d29dc06e5a44ddbf6673;hb=67ee8a93fc96a38c3f73468cb86d8421a11d2911;hp=65c425d255d1c9522b34585dd3e0d658fdca6a31;hpb=45b391025ccd6f91d6c280c7d0e5e755b67e760c;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 65c425d..550b274 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -39,14 +39,15 @@ import Maybes		( catMaybes )
 import RdrName		( RdrName )
 import Name		( Name, getSrcLoc )
 import NameSet		( duDefs )
-import Kind		( splitKindFunTys )
+import Type		( splitKindFunTys )
 import TyCon		( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics,
 			  tyConStupidTheta, isProductTyCon, isDataTyCon, newTyConRhs,
-			  isEnumerationTyCon, isRecursiveTyCon, TyCon
+			  isEnumerationTyCon, isRecursiveTyCon, TyCon, isNewTyCon,
+                          newTyConCo
 			)
 import TcType		( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon,
 			  isUnLiftedType, mkClassPred, tyVarsOfType,
-			  isArgTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys )
+			  isSubArgTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys )
 import Var		( TyVar, tyVarKind, varName )
 import VarSet		( mkVarSet, subVarSet )
 import PrelNames
@@ -313,6 +314,29 @@ or} has just one data constructor (e.g., tuples).
 [See Appendix~E in the Haskell~1.2 report.] This code here deals w/
 all those.
 
+Note [Newtype deriving superclasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The 'tys' here come from the partial application
+in the deriving clause. The last arg is the new
+instance type.
+
+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 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
+gotten from the Num dictionary. So we must build a whole new dictionary
+not just use the Num one.  The instance we want is something like:
+     instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
+     	(+) = ((+)@a)
+     	...etc...
+There may be a coercion needed which we get from the tycon for the newtype
+when the dict is constructed in TcInstDcls.tcInstDecl2
+
+
 \begin{code}
 makeDerivEqns :: OverlapFlag
 	      -> [LTyClDecl Name] 
@@ -350,6 +374,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)
@@ -363,7 +391,7 @@ makeDerivEqns overlap_flag tycl_decls
 	   traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)	`thenM_`
        	   new_dfun_name clas tycon  		`thenM` \ dfun_name ->
 	   returnM (Nothing, Just (InstInfo { iSpec  = mk_inst_spec dfun_name,
-					      iBinds = NewTypeDerived rep_tys }))
+					      iBinds = NewTypeDerived tycon rep_tys }))
       | std_class gla_exts clas
       = mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys	-- Go via bale-out route
 
@@ -425,26 +453,11 @@ makeDerivEqns overlap_flag tycl_decls
 	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
+        -- here we are figuring out what superclass dictionaries to use
+        -- see Note [Newtype deriving superclasses] above
 
 	inst_tys = (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars_to_keep)])
-		-- The 'tys' here come from the partial application
-		-- in the deriving clause. The last arg is the new
-		-- instance type.
-
-		-- 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
-		-- 	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
-		-- gotten from the Num dictionary. So we must build a whole new dictionary
-		-- not just use the Num one.  The instance we want is something like:
-		--	instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
-		--		(+) = ((+)@a)
-		--		...etc...
-		-- There's no 'corece' needed because after the type checker newtypes
-		-- are transparent.
+
 
 	sc_theta = substTheta (zipOpenTvSubst clas_tyvars inst_tys)
 			      (classSCTheta clas)
@@ -452,7 +465,7 @@ makeDerivEqns overlap_flag tycl_decls
 		-- If there are no tyvars, there's no need
 		-- to abstract over the dictionaries we need
 	dict_tvs = deriv_tvs ++ tc_tvs
-	dict_args | null dict_tvs = []
+	dict_args -- | null dict_tvs = []
 		  | otherwise     = rep_pred : sc_theta
 
 		-- Finally! Here's where we build the dictionary Id
@@ -649,7 +662,7 @@ cond_typeableOK :: Condition
 --	      (b) 7 or fewer args
 cond_typeableOK (gla_exts, tycon)
   | tyConArity tycon > 7				      = Just too_many
-  | not (all (isArgTypeKind . tyVarKind) (tyConTyVars tycon)) = Just bad_kind
+  | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars tycon)) = Just bad_kind
   | otherwise	  				              = Nothing
   where
     too_many = quotes (ppr tycon) <+> ptext SLIT("has too many arguments")