[project @ 1997-03-14 07:52:06 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcDeriv.lhs

diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index fee38f4..d9f0b62 100644 (file)
--- 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}