[commit: ghc] wip/T12382: tidyType: Rename variables of nested forall at once (1162fc4)

[git at git.haskell.org]

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

On branch  : wip/T12382
Link       : http://ghc.haskell.org/trac/ghc/changeset/1162fc4dd3e8f1845cf2beb1bcf2e01c6e5ebfdc/ghc

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

commit 1162fc4dd3e8f1845cf2beb1bcf2e01c6e5ebfdc
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Jul 12 16:52:42 2016 +0200

    tidyType: Rename variables of nested forall at once
    
    this refactoring commit prepares for fixing #12382, which can now be
    implemented soley in `tidyOccNames`.


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

1162fc4dd3e8f1845cf2beb1bcf2e01c6e5ebfdc
 compiler/basicTypes/OccName.hs |  6 +++++-
 compiler/types/TyCoRep.hs      | 46 +++++++++++++++++++++++++++++++++---------
 2 files changed, 42 insertions(+), 10 deletions(-)

diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs
index 65195ab..c17bd06 100644
--- a/compiler/basicTypes/OccName.hs
+++ b/compiler/basicTypes/OccName.hs
@@ -98,7 +98,7 @@ module OccName (
         filterOccSet,
 
         -- * Tidying up
-        TidyOccEnv, emptyTidyOccEnv, tidyOccName, initTidyOccEnv,
+        TidyOccEnv, emptyTidyOccEnv, tidyOccNames, tidyOccName, initTidyOccEnv,
 
         -- FsEnv
         FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv
@@ -114,6 +114,7 @@ import FastStringEnv
 import Outputable
 import Lexeme
 import Binary
+import Data.List (mapAccumL)
 import Data.Char
 import Data.Data
 
@@ -822,6 +823,9 @@ initTidyOccEnv = foldl add emptyUFM
   where
     add env (OccName _ fs) = addToUFM env fs 1
 
+tidyOccNames :: TidyOccEnv -> [OccName] -> (TidyOccEnv, [OccName])
+tidyOccNames env occs = mapAccumL tidyOccName env occs
+
 tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
 tidyOccName env occ@(OccName occ_sp fs)
   = case lookupUFM env fs of
diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs
index 08ac9c9..08d1744 100644
--- a/compiler/types/TyCoRep.hs
+++ b/compiler/types/TyCoRep.hs
@@ -3104,17 +3104,31 @@ ppSuggestExplicitKinds
 --
 -- It doesn't change the uniques at all, just the print names.
 tidyTyCoVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])
-tidyTyCoVarBndrs env tvs = mapAccumL tidyTyCoVarBndr env tvs
+tidyTyCoVarBndrs tidy_env@(occ_env, subst) tvs
+  = case tidyOccNames occ_env (map getHelpfulOccName tvs) of
+      (occ_env', occs') -> ((occ_env', subst'), tvs')
+        where
+          subst' = extendVarEnvList subst (zip tvs tvs')
+          tvs'   = zipWith (updateOccName tidy_env) occs' tvs
 
 tidyTyCoVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)
 tidyTyCoVarBndr tidy_env@(occ_env, subst) tyvar
-  = case tidyOccName occ_env occ1 of
-      (tidy', occ') -> ((tidy', subst'), tyvar')
+  = case tidyOccName occ_env (getHelpfulOccName tyvar) of
+      (occ_env', occ') -> ((occ_env', subst'), tyvar')
         where
           subst' = extendVarEnv subst tyvar tyvar'
-          tyvar' = setTyVarKind (setTyVarName tyvar name') kind'
-          name'  = tidyNameOcc name occ'
-          kind'  = tidyKind tidy_env (tyVarKind tyvar)
+          tyvar' = updateOccName tidy_env occ' tyvar
+
+updateOccName :: TidyEnv -> OccName -> TyCoVar -> TyCoVar
+updateOccName tidy_env occ tyvar = tyvar'
+  where
+    name = tyVarName tyvar
+    tyvar' = setTyVarKind (setTyVarName tyvar name') kind'
+    name'  = tidyNameOcc name occ
+    kind'  = tidyKind tidy_env (tyVarKind tyvar)
+
+getHelpfulOccName :: TyCoVar -> OccName
+getHelpfulOccName tyvar = occ1
   where
     name = tyVarName tyvar
     occ  = getOccName name
@@ -3182,13 +3196,27 @@ tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys
                                     in args `seqList` TyConApp tycon args
 tidyType env (AppTy fun arg)      = (AppTy $! (tidyType env fun)) $! (tidyType env arg)
 tidyType env (FunTy fun arg)      = (FunTy $! (tidyType env fun)) $! (tidyType env arg)
-tidyType env (ForAllTy (TvBndr tv vis) ty)
-  = (ForAllTy $! ((TvBndr $! tvp) $! vis)) $! (tidyType envp ty)
+tidyType env (ty@(ForAllTy{}))    = mkForAllTys' (zip tvs' vis) $! tidyType env' body_ty
   where
-    (envp, tvp) = tidyTyCoVarBndr env tv
+    (tvs, vis, body_ty) = splitForAllTys' ty
+    (env', tvs') = tidyTyCoVarBndrs env tvs
 tidyType env (CastTy ty co)       = (CastTy $! tidyType env ty) $! (tidyCo env co)
 tidyType env (CoercionTy co)      = CoercionTy $! (tidyCo env co)
 
+
+-- The following two functions differ from mkForAllTys and splitForAllTys in that
+-- they expect/preserve the ArgFlag argument. Thes belong to types/Type.hs, but
+-- how should they be named?
+mkForAllTys' :: [(TyVar, ArgFlag)] -> Type -> Type
+mkForAllTys' tvvs ty = foldr (\(tv, vis) -> ForAllTy (TvBndr tv vis)) ty tvvs
+
+splitForAllTys' :: Type -> ([TyVar], [ArgFlag], Type)
+splitForAllTys' ty = go ty [] []
+  where
+    go (ForAllTy (TvBndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss)
+    go ty                            tvs viss = (reverse tvs, reverse viss, ty)
+
+
 ---------------
 -- | Grabs the free type variables, tidies them
 -- and then uses 'tidyType' to work over the type itself