X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcDeriv.lhs;h=2edd8361058480088578edd57eba6f22d0a69acf;hb=4c6a3f787abcaed009a574196d82237d9ae64fc8;hp=859b988157de503813b08690eaa64f643c4164bf;hpb=0a17d9c2a9c218841a67c258239fb7d2d4f2319d;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 859b988..2edd836 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -46,6 +46,7 @@ import SrcLoc
 import Util
 import ListSetOps
 import Outputable
+import FastString
 import Bag
 \end{code}
 
@@ -265,7 +266,7 @@ tcDeriving  :: [LTyClDecl Name]  -- All type constructors
 		    HsValBinds Name)	-- Extra generated top-level bindings
 
 tcDeriving tycl_decls inst_decls deriv_decls
-  = recoverM (returnM ([], emptyValBindsOut)) $
+  = recoverM (return ([], emptyValBindsOut)) $
     do	{   	-- Fish the "deriving"-related information out of the TcEnv
 		-- And make the necessary "equations".
 	; early_specs <- makeDerivSpecs tycl_decls inst_decls deriv_decls
@@ -286,8 +287,8 @@ tcDeriving tycl_decls inst_decls deriv_decls
 	; let inst_info = insts1 ++ insts2
 
 	; dflags <- getDOpts
-	; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" 
-	  	   (ddump_deriving inst_info rn_binds))
+	; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
+	         (ddump_deriving inst_info rn_binds))
 
 	; return (inst_info, rn_binds) }
   where
@@ -530,21 +531,24 @@ mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 				dataConInstOrigArgTys data_con rep_tc_args,
 	            not (isUnLiftedType arg_ty) ] -- No constraints for unlifted types?
 
+			-- See Note [Superclasses of derived instance]
+	      sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
+					  (classSCTheta cls)
+	      inst_tys =  [mkTyConApp tycon tc_args]
+
 	      stupid_subst = zipTopTvSubst (tyConTyVars rep_tc) rep_tc_args
 	      stupid_constraints = substTheta stupid_subst (tyConStupidTheta rep_tc)
-	      all_constraints = stupid_constraints ++ ordinary_constraints
-			 -- see Note [Data decl contexts] above
+	      all_constraints = stupid_constraints ++ sc_constraints ++ ordinary_constraints
 
 	      spec = DS { ds_loc = loc, ds_orig = orig
 			, ds_name = dfun_name, ds_tvs = tvs 
-			, ds_cls = cls, ds_tys = [mkTyConApp tycon tc_args]
+			, ds_cls = cls, ds_tys = inst_tys
 			, ds_theta =  mtheta `orElse` all_constraints
 			, ds_newtype = False }
 
   	; return (if isJust mtheta then Just (Right spec)	-- Specified context
 				   else Just (Left spec)) }	-- Infer context
 
-
 mk_typeable_eqn orig tvs cls tycon tc_args rep_tc _rep_tc_args mtheta
 	-- The Typeable class is special in several ways
 	-- 	  data T a b = ... deriving( Typeable )
@@ -695,6 +699,30 @@ new_dfun_name clas tycon 	-- Just a simple wrapper
 	-- a suitable string; hence the empty type arg list
 \end{code}
 
+Note [Superclasses of derived instance] 
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general, a derived instance decl needs the superclasses of the derived
+class too.  So if we have
+	data T a = ...deriving( Ord )
+then the initial context for Ord (T a) should include Eq (T a).  Often this is 
+redundant; we'll also generate an Ord constraint for each constructor argument,
+and that will probably generate enough constraints to make the Eq (T a) constraint 
+be satisfied too.  But not always; consider:
+
+ data S a = S
+ instance Eq (S a)
+ instance Ord (S a)
+
+ data T a = MkT (S a) deriving( Ord )
+ instance Num a => Eq (T a)
+
+The derived instance for (Ord (T a)) must have a (Num a) constraint!
+Similarly consider:
+	data T a = MkT deriving( Data, Typeable )
+Here there *is* no argument field, but we must nevertheless generate
+a context for the Data instances:
+	instance Typable a => Data (T a) where ...
+
 
 %************************************************************************
 %*									*
@@ -771,10 +799,10 @@ mkNewTypeEqn orig mayDeriveDataTypeable newtype_deriving tvs
 		-- Want to drop 1 arg from (T s a) and (ST s a)
 		-- to get 	instance Monad (ST s) => Monad (T s)
 
-	-- Note [newtype representation]
-	-- Need newTyConRhs *not* newTyConRep to get the representation 
-	-- type, because the latter looks through all intermediate newtypes
-	-- For example
+	-- Note [Newtype representation]
+	-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+	-- Need newTyConRhs (*not* a recursive representation finder) 
+	-- to get the representation type. For example
 	--	newtype B = MkB Int
 	--	newtype A = MkA B deriving( Num )
 	-- We want the Num instance of B, *not* the Num instance of Int,