X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcDeriv.lhs;h=fd54e6ecdc02ae86c20e96c7d497c715016e32de;hb=be97d35b91db37fed3f5a4ea1f6efc538e3daaaa;hp=9bb8089f6aa990e7b63102fc0a32cd0800dc3ae5;hpb=a6eede3173cee960884e732f40b0998cf84ae015;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 9bb8089..fd54e6e 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -11,7 +11,7 @@ module TcDeriv ( tcDeriving ) where
 #include "HsVersions.h"
 
 import HsSyn		( HsBinds(..), MonoBinds(..), collectMonoBinders )
-import RdrHsSyn		( RdrName, RdrNameMonoBinds )
+import RdrHsSyn		( RdrNameMonoBinds )
 import RnHsSyn		( RenamedHsBinds, RenamedMonoBinds )
 import CmdLineOpts	( opt_D_dump_deriv )
 
@@ -35,10 +35,13 @@ import Id		( mkVanillaId )
 import DataCon		( dataConArgTys, isNullaryDataCon )
 import PrelInfo		( needsDataDeclCtxtClassKeys )
 import Maybes		( maybeToBool )
+import Module		( ModuleName )
 import Name		( isLocallyDefined, getSrcLoc,
-			  Name, Module, NamedThing(..),
+			  Name, NamedThing(..),
 			  OccName, nameOccName
 			)
+import RdrName		( RdrName )
+import RnMonad		( Fixities )
 import SrcLoc		( mkGeneratedSrcLoc, SrcLoc )
 import TyCon		( tyConTyVars, tyConDataCons, tyConDerivings,
 			  tyConTheta, maybeTyConSingleCon, isDataTyCon,
@@ -183,13 +186,14 @@ context to the instance decl.  The "offending classes" are
 %************************************************************************
 
 \begin{code}
-tcDeriving  :: Module			-- name of module under scrutiny
+tcDeriving  :: ModuleName		-- name of module under scrutiny
+	    -> Fixities			-- for the deriving code (Show/Read.)
 	    -> RnNameSupply		-- for "renaming" bits of generated code
 	    -> Bag InstInfo		-- What we already know about instances
 	    -> TcM s (Bag InstInfo,	-- The generated "instance decls".
 		      RenamedHsBinds)	-- Extra generated bindings
 
-tcDeriving modname rn_name_supply inst_decl_infos_in
+tcDeriving modname fixs rn_name_supply inst_decl_infos_in
   = recoverTc (returnTc (emptyBag, EmptyBinds)) $
 
   	-- Fish the "deriving"-related information out of the TcEnv
@@ -216,7 +220,7 @@ tcDeriving modname rn_name_supply inst_decl_infos_in
     let
 	extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
 	extra_mbinds     = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list
-	method_binds_s   = map gen_bind new_inst_infos
+	method_binds_s   = map (gen_bind fixs) new_inst_infos
 	mbinders	 = bagToList (collectMonoBinders extra_mbinds)
 	
 	-- Rename to get RenamedBinds.
@@ -230,13 +234,14 @@ tcDeriving modname rn_name_supply inst_decl_infos_in
 			returnRn (dfun_names_w_method_binds, rn_extra_binds)
 		  )
 	rn_one (cl_nm, tycon_nm, meth_binds) 
-	        = newDFunName cl_nm tycon_nm
-		              Nothing mkGeneratedSrcLoc	        `thenRn` \ dfun_name ->
-		  rnMethodBinds meth_binds			`thenRn` \ (rn_meth_binds, _) ->
+	        = newDFunName (cl_nm, tycon_nm)
+		              mkGeneratedSrcLoc	        `thenRn` \ dfun_name ->
+		  rnMethodBinds meth_binds		`thenRn` \ (rn_meth_binds, _) ->
 		  returnRn (dfun_name, rn_meth_binds)
 
-	really_new_inst_infos = map (gen_inst_info modname)
-			  	    (new_inst_infos `zip` dfun_names_w_method_binds)
+	really_new_inst_infos = zipWith gen_inst_info
+			  	        new_inst_infos
+					dfun_names_w_method_binds
 
 	ddump_deriv = ddump_deriving really_new_inst_infos rn_extra_binds
     in
@@ -552,10 +557,14 @@ the renamer.  What a great hack!
 -- Generate the method bindings for the required instance
 -- (paired with class name, as we need that when generating dict
 --  names.)
-gen_bind :: InstInfo -> ({-class-}OccName, {-tyCon-}OccName, RdrNameMonoBinds)
-gen_bind (InstInfo clas _ [ty] _ _ _ _ _)
+gen_bind :: Fixities -> InstInfo -> ({-class-}OccName, {-tyCon-}OccName, RdrNameMonoBinds)
+gen_bind fixities (InstInfo clas _ [ty] _ _ _ _ _)
   | not from_here 
   = (clas_nm, tycon_nm, EmptyMonoBinds)
+  |  ckey == showClassKey 
+  = (clas_nm, tycon_nm, gen_Show_binds fixities tycon)
+  |  ckey == readClassKey 
+  = (clas_nm, tycon_nm, gen_Read_binds fixities tycon)
   | otherwise
   = (clas_nm, tycon_nm,
      assoc "gen_bind:bad derived class"
@@ -563,25 +572,24 @@ gen_bind (InstInfo clas _ [ty] _ _ _ _ _)
 	   ,(ordClassKey,     gen_Ord_binds)
 	   ,(enumClassKey,    gen_Enum_binds)
 	   ,(boundedClassKey, gen_Bounded_binds)
-	   ,(showClassKey,    gen_Show_binds)
-	   ,(readClassKey,    gen_Read_binds)
 	   ,(ixClassKey,      gen_Ix_binds)
 	   ]
-	   (classKey clas) 
+	   ckey
 	   tycon)
   where
       clas_nm     = nameOccName (getName clas)
       tycon_nm    = nameOccName (getName tycon)
       from_here   = isLocallyDefined tycon
       (tycon,_,_) = splitAlgTyConApp ty	
+      ckey	  = classKey clas
 	    
 
-gen_inst_info :: Module					-- Module name
-	      -> (InstInfo, (Name, RenamedMonoBinds))		-- the main stuff to work on
+gen_inst_info :: InstInfo
+	      -> (Name, RenamedMonoBinds)
 	      -> InstInfo				-- the gen'd (filled-in) "instance decl"
 
-gen_inst_info modname
-    (InstInfo clas tyvars tys@(ty:_) inst_decl_theta _ _ locn _, (dfun_name, meth_binds))
+gen_inst_info (InstInfo clas tyvars tys@(ty:_) inst_decl_theta _ _ locn _) 
+	      (dfun_name, meth_binds)
   =
 	-- Generate the various instance-related Ids
     InstInfo clas tyvars tys inst_decl_theta
@@ -663,7 +671,8 @@ gen_taggery_Names inst_infos
     do_tag2con acc_Names tycon
       | isDataTyCon tycon &&
          (we_are_deriving enumClassKey tycon ||
-	  we_are_deriving ixClassKey   tycon)
+	  we_are_deriving ixClassKey   tycon
+	  && isEnumerationTyCon tycon)
       = returnTc ( (tag2con_RDR tycon, tycon, GenTag2Con)
 		 : (maxtag_RDR  tycon, tycon, GenMaxTag)
 		 : acc_Names)