X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=550b274ec501ab8ca3b7d29dc06e5a44ddbf6673;hb=4ea5fe11fbc339a7a1bce13cbb2a2301772b493a;hp=1f4c4768d85fdefda7e374c799e8ed6c27d37f84;hpb=1dfd77341ec56e9d61f2d78cb7ff2b9900385dac;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 1f4c476..550b274 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,22 +31,23 @@ 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 )
 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
@@ -312,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] 
@@ -341,7 +366,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) ->
@@ -349,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)
@@ -362,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
 
@@ -424,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)
@@ -451,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
@@ -567,7 +581,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?
         ]
 
@@ -648,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")
@@ -726,10 +740,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
@@ -946,16 +965,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}