X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcDeriv.lhs;h=d9f0b626be99690de83ceeec81236391c3728493;hb=1fb1ab5d53a09607e7f6d2450806760688396387;hp=fee38f4a5b5cd2e9e726003f6153c21d6d09107e;hpb=7a3bd641457666e10d0a47be9f22762e03defbf0;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index fee38f4..d9f0b62 100644
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -15,7 +15,8 @@ IMP_Ubiq()
 import HsSyn		( HsDecl, FixityDecl, Fixity, InstDecl, 
 			  Sig, HsBinds(..), Bind(..), MonoBinds(..),
 			  GRHSsAndBinds, Match, HsExpr, HsLit, InPat,
-			  ArithSeqInfo, Fake, HsType
+			  ArithSeqInfo, Fake, HsType,
+			  collectMonoBinders
 			)
 import HsPragmas	( InstancePragmas(..) )
 import RdrHsSyn		( RdrName, SYN_IE(RdrNameMonoBinds) )
@@ -32,7 +33,7 @@ import TcInstUtil	( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
 import TcSimplify	( tcSimplifyThetas )
 
 import RnBinds		( rnMethodBinds, rnTopMonoBinds )
-import RnEnv		( newDfunName )
+import RnEnv		( newDfunName, bindLocatedLocalsRn )
 import RnMonad		( SYN_IE(RnM), RnDown, GDown, SDown, RnNameSupply(..), 
 			  setNameSupplyRn, renameSourceCode, thenRn, mapRn, returnRn )
 
@@ -48,7 +49,8 @@ import Name		( isLocallyDefined, getSrcLoc, ExportFlag(..), Provenance,
 import Outputable	( Outputable(..){-instances e.g., (,)-} )
 import PprType		( GenType, GenTyVar, GenClass, TyCon )
 import PprStyle		( PprStyle(..) )
-import Pretty		( ppAbove, ppAboves, ppCat, ppBesides, ppStr, ppHang, SYN_IE(Pretty) )
+import Pretty		( ppAbove, ppAboves, ppCat, ppBesides, 
+		          ppPStr, ppStr, ppChar, ppHang, SYN_IE(Pretty) )
 --import Pretty--ToDo:rm
 --import FiniteMap--ToDo:rm
 import SrcLoc		( mkGeneratedSrcLoc, SrcLoc )
@@ -64,6 +66,7 @@ import TysPrim		( voidTy )
 import TyVar		( GenTyVar )
 import UniqFM		( emptyUFM )
 import Unique		-- Keys stuff
+import Bag		( bagToList )
 import Util		( zipWithEqual, zipEqual, sortLt, removeDups,  assoc,
 			  thenCmp, cmpList, panic, panic#, pprPanic, pprPanic#,
 			  assertPanic-- , pprTrace{-ToDo:rm-}
@@ -228,18 +231,20 @@ tcDeriving modname rn_name_supply inst_decl_infos_in
 	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
+	mbinders	 = bagToList (collectMonoBinders extra_mbinds)
 	
 	-- Rename to get RenamedBinds.
 	-- The only tricky bit is that the extra_binds must scope over the
 	-- method bindings for the instances.
 	(dfun_names_w_method_binds, rn_extra_binds)
 		= renameSourceCode modname rn_name_supply (
+			bindLocatedLocalsRn "deriving" mbinders	$ \ _ ->
 			rnTopMonoBinds extra_mbinds []		`thenRn` \ rn_extra_binds ->
 			mapRn rn_one method_binds_s		`thenRn` \ dfun_names_w_method_binds ->
 			returnRn (dfun_names_w_method_binds, rn_extra_binds)
 		  )
-	rn_one meth_binds = newDfunName mkGeneratedSrcLoc	`thenRn` \ dfun_name ->
-			    rnMethodBinds meth_binds		`thenRn` \ rn_meth_binds ->
+	rn_one meth_binds = newDfunName Nothing mkGeneratedSrcLoc	`thenRn` \ dfun_name ->
+			    rnMethodBinds meth_binds			`thenRn` \ rn_meth_binds ->
 			    returnRn (dfun_name, rn_meth_binds)
     in
 
@@ -712,6 +717,6 @@ gen_taggery_Names inst_infos
 derivingThingErr :: String -> TyCon -> Error
 
 derivingThingErr thing tycon sty
-  = ppHang (ppCat [ppStr "Can't make a derived instance of", ppStr thing])
-	 4 (ppBesides [ppStr "for the type `", ppr sty tycon, ppStr "'"])
+  = ppHang (ppCat [ppPStr SLIT("Can't make a derived instance of"), ppStr thing])
+	 4 (ppBesides [ppPStr SLIT("for the type `"), ppr sty tycon, ppChar '\''])
 \end{code}