Commit 18ac80ff authored by Joachim Breitner's avatar Joachim Breitner
Browse files

tidyType: Rename variables of nested forall at once

this refactoring commit prepares for fixing #12382, which can now be
implemented soley in tidyTyCoVarBndrs.
parent 45d8f4eb
......@@ -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
......
......@@ -3104,17 +3104,21 @@ 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 tvs = mapAccumL tidyTyCoVarBndr tidy_env 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)
name' = tidyNameOcc name occ'
name = tyVarName tyvar
getHelpfulOccName :: TyCoVar -> OccName
getHelpfulOccName tyvar = occ1
where
name = tyVarName tyvar
occ = getOccName name
......@@ -3182,13 +3186,29 @@ 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 strictMkForAllTy ty tvvs
where
strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((TvBndr $! tv) $! vis)) $! ty
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
......
......@@ -60,11 +60,13 @@ test('T4029',
[(wordsize(64), 82, 10)]),
# 2016-02-26: 66 (amd64/Linux) INITIAL
# 2016-05-23: 82 (amd64/Linux) Use -G1
# 2016-07-13: 92 (amd64/Linux) Changes to tidyType
stats_num_field('max_bytes_used',
[(wordsize(64), 25247216, 5)]),
# 2016-02-26: 24071720 (amd64/Linux) INITIAL
# 2016-04-21: 25542832 (amd64/Linux)
# 2016-05-23: 25247216 (amd64/Linux) Use -G1
# 2016-07-13: 27575416 (amd64/Linux) Changes to tidyType
extra_hc_opts('+RTS -G1 -RTS' ),
],
ghci_script,
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment