[commit: ghc] master: Fix a long-standing bug in tidying (b597182)

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/b597182dc291935c26e5c34f1100ced344ca7fe1

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

commit b597182dc291935c26e5c34f1100ced344ca7fe1
Author: Simon Peyton Jones <[email protected]>
Date:   Fri Oct 19 01:04:47 2012 +0100

    Fix a long-standing bug in tidying
    
    This showed up when looking at some type error messages.
    We were tidying some open types in a way that mapped two
    distinct variables to the same thing.  Urk!

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

 compiler/basicTypes/OccName.lhs |   55 ++++++++++++++++++++++++++++----------
 compiler/typecheck/TcType.lhs   |   34 +++++------------------
 2 files changed, 48 insertions(+), 41 deletions(-)

diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index 74fbeb7..ae5ba96 100644
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -758,29 +758,54 @@ There's a wrinkle for operators.  Consider '>>='.  We can't use '>>=1'
 because that isn't a single lexeme.  So we encode it to 'lle' and *then*
 tack on the '1', if necessary.
 
+Note [TidyOccEnv]
+~~~~~~~~~~~~~~~~~
+type TidyOccEnv = UniqFM Int
+
+* Domain = The OccName's FastString. These FastStrings are "taken";
+           make sure that we don't re-use
+
+* Int, n = A plausible starting point for new guesses
+           There is no guarantee that "FSn" is available; 
+           you must look that up in the TidyOccEnv.  But
+           it's a good place to start looking.
+
+* When looking for a renaming for "foo2" we strip off the "2" and start
+  with "foo".  Otherwise if we tidy twice we get silly names like foo23.
+
 \begin{code}
-type TidyOccEnv = OccEnv Int	-- The in-scope OccNames
-	-- Range gives a plausible starting point for new guesses
+type TidyOccEnv = UniqFM Int	-- The in-scope OccNames
+  -- See Note [TidyOccEnv]
 
 emptyTidyOccEnv :: TidyOccEnv
-emptyTidyOccEnv = emptyOccEnv
+emptyTidyOccEnv = emptyUFM
 
 initTidyOccEnv :: [OccName] -> TidyOccEnv	-- Initialise with names to avoid!
-initTidyOccEnv = foldl (\env occ -> extendOccEnv env occ 1) emptyTidyOccEnv
+initTidyOccEnv = foldl add emptyUFM
+  where
+    add env (OccName _ fs) = addToUFM env fs 1
 
 tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
-
-tidyOccName in_scope occ@(OccName occ_sp fs)
-  = case lookupOccEnv in_scope occ of
-	Nothing -> 	-- Not already used: make it used
-		   (extendOccEnv in_scope occ 1, occ)
-
-	Just n  -> 	-- Already used: make a new guess, 
-			-- change the guess base, and try again
-		   tidyOccName  (extendOccEnv in_scope occ (n+1))
-                                (mkOccName occ_sp (base_occ ++ show n))
+tidyOccName env occ@(OccName occ_sp fs)
+  = case lookupUFM env fs of
+	Just n  -> find n
+	Nothing -> (addToUFM env fs 1, occ)
   where
-    base_occ = reverse (dropWhile isDigit (reverse (unpackFS fs)))
+    base :: String  -- Drop trailing digits (see Note [TidyOccEnv])
+    base = reverse (dropWhile isDigit (reverse (unpackFS fs)))
+ 
+    find n 
+      = case lookupUFM env new_fs of
+          Just n' -> find (n1 `max` n')
+                     -- The max ensures that n increases, avoiding loops
+          Nothing -> (addToUFM (addToUFM env fs n1) new_fs n1,
+                      OccName occ_sp new_fs)
+                     -- We update only the beginning and end of the
+                     -- chain that find explores; it's a little harder to
+                     -- update the middle and there's no real need.
+       where
+         n1 = n+1
+         new_fs = mkFastString (base ++ show n)
 \end{code}
 
 %************************************************************************
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index aedf11d..aa69d75 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -554,31 +554,9 @@ tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
 -- ^ Add the free 'TyVar's to the env in tidy form,
 -- so that we can tidy the type they are free in
 tidyFreeTyVars (full_occ_env, var_env) tyvars 
-  = fst (tidyOpenTyVars (full_occ_env, var_env) tv_list)
+  = fst (tidyOpenTyVars (full_occ_env, var_env) (varSetElems tyvars))
 
-  where
-    tv_list = varSetElems tyvars
-    
-{-
-      -- The idea here was that we restrict the new TidyEnv to the 
-      -- _free_ vars of the type, so that we don't gratuitously rename
-      -- the _bound_ variables of the type.
-      --
-      -- But the idea goes badly wrong if we tidy more than 
-      -- one open type, e.g.  a_99 and (a_77 -> a_99). Then
-      -- we tidy the former to a0, and the latter to a0 -> a0!
-    trimmed_occ_env = foldr mk_occ_env emptyOccEnv tv_list
-
-    mk_occ_env :: TyVar -> TidyOccEnv -> TidyOccEnv
-    mk_occ_env tv env 
-       = case lookupOccEnv full_occ_env occ of
-            Just n  -> extendOccEnv env occ n
-            Nothing -> env
-       where
-         occ = getOccName tv
--}
-
----------------
+        ---------------
 tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
 tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars
 
@@ -620,9 +598,13 @@ tidyType env (ForAllTy tv ty)	  = ForAllTy tvp $! (tidyType envp ty)
 -- and then uses 'tidyType' to work over the type itself
 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
 tidyOpenType env ty
-  = (env', tidyType env' ty)
+  = (env', tidyType (trimmed_occ_env, var_env) ty)
   where
-    env' = tidyFreeTyVars env (tyVarsOfType ty)
+    (env'@(_, var_env), tvs') = tidyOpenTyVars env (varSetElems (tyVarsOfType ty))
+    trimmed_occ_env = initTidyOccEnv (map getOccName tvs')
+      -- The idea here was that we restrict the new TidyEnv to the 
+      -- _free_ vars of the type, so that we don't gratuitously rename
+      -- the _bound_ variables of the type.
 
 ---------------
 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])