[commit: ghc] master: Unique-ify the names of top-level auxiliary bindings in derived instances (Trac #7947) (c41d214)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/c41d214a8dd8e2fe7ae9a3446aeda1a07328b831/ghc

>---------------------------------------------------------------

commit c41d214a8dd8e2fe7ae9a3446aeda1a07328b831
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Dec 2 15:13:32 2014 +0000

    Unique-ify the names of top-level auxiliary bindings in derived instances (Trac #7947)
    
    The problem and its solution are explained in
       Note [Auxiliary binders]
    in TcGenDeriv


>---------------------------------------------------------------

c41d214a8dd8e2fe7ae9a3446aeda1a07328b831
 compiler/typecheck/TcGenDeriv.lhs                 | 49 +++++++++++++++++++----
 testsuite/tests/deriving/should_compile/T7947.hs  | 16 ++++++++
 testsuite/tests/deriving/should_compile/T7947a.hs |  3 ++
 testsuite/tests/deriving/should_compile/T7947b.hs |  3 ++
 testsuite/tests/deriving/should_compile/all.T     |  1 +
 5 files changed, 64 insertions(+), 8 deletions(-)

diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 0d4374b..13d8e83 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -65,6 +65,7 @@ import Pair
 import Bag
 import Fingerprint
 import TcEnv (InstInfo)
+import StaticFlags( opt_PprStyle_Debug )
 
 import ListSetOps ( assocMaybe )
 import Data.List  ( partition, intersperse )
@@ -2294,6 +2295,11 @@ f_Pat           = nlVarPat f_RDR
 k_Pat           = nlVarPat k_RDR
 z_Pat           = nlVarPat z_RDR
 
+minusInt_RDR, tagToEnum_RDR, error_RDR :: RdrName
+minusInt_RDR  = getRdrName (primOpId IntSubOp   )
+tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
+error_RDR     = getRdrName eRROR_ID
+
 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
 -- Generates Orig s RdrName, for the binding positions
 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
@@ -2304,13 +2310,40 @@ mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
 
 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
-mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
--- Was: mkDerivedRdrName name occ_fun, which made an original name
--- But:  (a) that does not work well for standalone-deriving
---       (b) an unqualified name is just fine, provided it can't clash with user code
+-- ^ Make a top-level binder name for an auxiliary binding for a parent name
+-- See Note [Auxiliary binders]
+mkAuxBinderName parent occ_fun
+  = mkRdrUnqual (occ_fun uniq_parent_occ)
+  where
+    uniq_parent_occ = mkOccName (occNameSpace parent_occ) uniq_string
 
-minusInt_RDR, tagToEnum_RDR, error_RDR :: RdrName
-minusInt_RDR  = getRdrName (primOpId IntSubOp   )
-tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
-error_RDR     = getRdrName eRROR_ID
+    uniq_string
+      | opt_PprStyle_Debug = showSDocSimple (ppr parent_occ <> underscore <> ppr parent_uniq)
+      | otherwise          = show parent_uniq
+      -- The debug thing is just to generate longer, but perhaps more perspicuous, names
+
+    parent_uniq = nameUnique parent
+    parent_occ  = nameOccName parent
 \end{code}
+
+Note [Auxiliary binders]
+~~~~~~~~~~~~~~~~~~~~~~~~
+We often want to make a top-level auxiliary binding.  E.g. for comparison we haev
+
+  instance Ord T where
+    compare a b = $con2tag a `compare` $con2tag b
+
+  $con2tag :: T -> Int
+  $con2tag = ...code....
+
+Of course these top-level bindings should all have distinct name, and we are
+generating RdrNames here.  We can't just use the TyCon or DataCon to distinguish
+becuase with standalone deriving two imported TyCons might both be called T!
+(See Trac #7947.)
+
+So we use the *unique* from the parent name (T in this example) as part of the
+OccName we generate for the new binding.
+
+In the past we used mkDerivedRdrName name occ_fun, which made an original name
+But:  (a) that does not work well for standalone-deriving either
+      (b) an unqualified name is just fine, provided it can't clash with user code
diff --git a/testsuite/tests/deriving/should_compile/T7947.hs b/testsuite/tests/deriving/should_compile/T7947.hs
new file mode 100644
index 0000000..d4df435
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T7947.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module T7947 where
+
+import Data.Data
+import Data.Typeable
+
+import T7947a
+import qualified T7947b as B
+
+deriving instance Typeable A
+deriving instance Typeable B.B
+
+deriving instance Data A
+deriving instance Data B.B
diff --git a/testsuite/tests/deriving/should_compile/T7947a.hs b/testsuite/tests/deriving/should_compile/T7947a.hs
new file mode 100644
index 0000000..eb5c747
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T7947a.hs
@@ -0,0 +1,3 @@
+module T7947a where
+
+data A = C1 | C2 | C
diff --git a/testsuite/tests/deriving/should_compile/T7947b.hs b/testsuite/tests/deriving/should_compile/T7947b.hs
new file mode 100644
index 0000000..f17f1cd
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T7947b.hs
@@ -0,0 +1,3 @@
+module T7947b where
+
+data B = D1 | D2 | C
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index 2234dd5..8d90236 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -52,4 +52,5 @@ test('T7269', normal, compile, [''])
 test('T9069', normal, compile, [''])
 test('T9359', normal, compile, [''])
 test('T4896', normal, compile, [''])
+test('T7947', extra_clean(['T7947a.o', 'T7947a.hi', 'T7947b.o', 'T7947b.hi']), multimod_compile, ['T7947', '-v0'])