[commit: ghc] wip/T12382: tidyOccNames: Rename variables fairly (86ad1d6)

[git at git.haskell.org]

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

On branch  : wip/T12382
Link       : http://ghc.haskell.org/trac/ghc/changeset/86ad1d649e57da4aa2447164395de813ee39816c/ghc

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

commit 86ad1d649e57da4aa2447164395de813ee39816c
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Jul 12 17:21:07 2016 +0200

    tidyOccNames: Rename variables fairly
    
    So that
    > :t (id,id,id)
    produces
    (id,id,id) :: (a3 -> a3, a2 -> a2, a1 -> a1)
    instead of
    (id,id,id) :: (a2 -> a2, a1 -> a1, a -> a)


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

86ad1d649e57da4aa2447164395de813ee39816c
 compiler/basicTypes/OccName.hs | 46 ++++++++++++++++++++++++++++++++++++------
 1 file changed, 40 insertions(+), 6 deletions(-)

diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs
index c17bd06..f41355e 100644
--- a/compiler/basicTypes/OccName.hs
+++ b/compiler/basicTypes/OccName.hs
@@ -810,6 +810,29 @@ So we use the TidyOccEnv mapping for "a" (not "a7" or "a8") as our base for
 starting the search; and we make sure to update the starting point for "a"
 after we allocate a new one.
 
+
+Node [Tidying multiple names at once]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Consider
+
+    > :t (id,id,id)
+
+Every id contributes a type variable to the type signature, and all of them are
+"a". If we tidy them one by one, we get
+
+    (id,id,id) :: (a2 -> a2, a1 -> a1, a -> a)
+
+which is a bit unfortunate, as it unfairly renames only one of them. What we
+would like to see is
+
+    (id,id,id) :: (a3 -> a3, a2 -> a2, a1 -> a1)
+
+This is achieved in tidyOccNames. It still uses tidyOccName to rename each name
+on its own, but it prepares the TidyEnv (using addDups), by “blocking” every
+name that occurs twice in the map. This way, none of the "a"s will get the priviledge of keeping this name, and all of them will get a suitable numbery by tidyOccName.
+This is #12382.
+
 -}
 
 type TidyOccEnv = UniqFM Int    -- The in-scope OccNames
@@ -823,16 +846,27 @@ initTidyOccEnv = foldl add emptyUFM
   where
     add env (OccName _ fs) = addToUFM env fs 1
 
+-- see Note [Tidying multiple names at once]
 tidyOccNames :: TidyOccEnv -> [OccName] -> (TidyOccEnv, [OccName])
-tidyOccNames env occs = mapAccumL tidyOccName env occs
+tidyOccNames env occs = mapAccumL tidyOccName env' occs
+  where
+    env' = addDups env emptyUFM occs
+
+addDups :: TidyOccEnv -> UniqFM () -> [OccName] -> TidyOccEnv
+addDups env _        [] = env
+addDups env seenOnce ((OccName _ fs):occs)
+  | fs `elemUFM` env      = addDups env seenOnce                  occs
+  | fs `elemUFM` seenOnce = addDups (addToUFM env fs 1) seenOnce  occs
+  | otherwise             = addDups env (addToUFM seenOnce fs ()) occs
 
 tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
 tidyOccName env occ@(OccName occ_sp fs)
-  = case lookupUFM env fs of
-      Nothing -> (addToUFM env fs 1, occ)   -- Desired OccName is free
-      Just {} -> case lookupUFM env base1 of
-                   Nothing -> (addToUFM env base1 2, OccName occ_sp base1)
-                   Just n  -> find 1 n
+  | not (fs `elemUFM` env)
+  = (addToUFM env fs 1, occ)   -- Desired OccName is free
+  | otherwise
+  = case lookupUFM env base1 of
+       Nothing -> (addToUFM env base1 2, OccName occ_sp base1)
+       Just n  -> find 1 n
   where
     base :: String  -- Drop trailing digits (see Note [TidyOccEnv])
     base  = dropWhileEndLE isDigit (unpackFS fs)