never executed always true always false
1 {-# LANGUAGE BangPatterns #-}
2 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
3 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
4
5 -- | Tidying types and coercions for printing in error messages.
6 module GHC.Core.TyCo.Tidy
7 (
8 -- * Tidying type related things up for printing
9 tidyType, tidyTypes,
10 tidyOpenType, tidyOpenTypes,
11 tidyOpenKind,
12 tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, avoidNameClashes,
13 tidyOpenTyCoVar, tidyOpenTyCoVars,
14 tidyTyCoVarOcc,
15 tidyTopType,
16 tidyKind,
17 tidyCo, tidyCos,
18 tidyTyCoVarBinder, tidyTyCoVarBinders
19 ) where
20
21 import GHC.Prelude
22
23 import GHC.Core.TyCo.Rep
24 import GHC.Core.TyCo.FVs (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList)
25
26 import GHC.Types.Name hiding (varName)
27 import GHC.Types.Var
28 import GHC.Types.Var.Env
29 import GHC.Utils.Misc (strictMap)
30
31 import Data.List (mapAccumL)
32
33 {-
34 %************************************************************************
35 %* *
36 \subsection{TidyType}
37 %* *
38 %************************************************************************
39 -}
40
41 -- | This tidies up a type for printing in an error message, or in
42 -- an interface file.
43 --
44 -- It doesn't change the uniques at all, just the print names.
45 tidyVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])
46 tidyVarBndrs tidy_env tvs
47 = mapAccumL tidyVarBndr (avoidNameClashes tvs tidy_env) tvs
48
49 tidyVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)
50 tidyVarBndr tidy_env@(occ_env, subst) var
51 = case tidyOccName occ_env (getHelpfulOccName var) of
52 (occ_env', occ') -> ((occ_env', subst'), var')
53 where
54 subst' = extendVarEnv subst var var'
55 var' = updateVarType (tidyType tidy_env) (setVarName var name')
56 name' = tidyNameOcc name occ'
57 name = varName var
58
59 avoidNameClashes :: [TyCoVar] -> TidyEnv -> TidyEnv
60 -- Seed the occ_env with clashes among the names, see
61 -- Note [Tidying multiple names at once] in GHC.Types.Names.OccName
62 avoidNameClashes tvs (occ_env, subst)
63 = (avoidClashesOccEnv occ_env occs, subst)
64 where
65 occs = map getHelpfulOccName tvs
66
67 getHelpfulOccName :: TyCoVar -> OccName
68 -- A TcTyVar with a System Name is probably a
69 -- unification variable; when we tidy them we give them a trailing
70 -- "0" (or 1 etc) so that they don't take precedence for the
71 -- un-modified name. Plus, indicating a unification variable in
72 -- this way is a helpful clue for users
73 getHelpfulOccName tv
74 | isSystemName name, isTcTyVar tv
75 = mkTyVarOcc (occNameString occ ++ "0")
76 | otherwise
77 = occ
78 where
79 name = varName tv
80 occ = getOccName name
81
82 tidyTyCoVarBinder :: TidyEnv -> VarBndr TyCoVar vis
83 -> (TidyEnv, VarBndr TyCoVar vis)
84 tidyTyCoVarBinder tidy_env (Bndr tv vis)
85 = (tidy_env', Bndr tv' vis)
86 where
87 (tidy_env', tv') = tidyVarBndr tidy_env tv
88
89 tidyTyCoVarBinders :: TidyEnv -> [VarBndr TyCoVar vis]
90 -> (TidyEnv, [VarBndr TyCoVar vis])
91 tidyTyCoVarBinders tidy_env tvbs
92 = mapAccumL tidyTyCoVarBinder
93 (avoidNameClashes (binderVars tvbs) tidy_env) tvbs
94
95 ---------------
96 tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv
97 -- ^ Add the free 'TyVar's to the env in tidy form,
98 -- so that we can tidy the type they are free in
99 tidyFreeTyCoVars tidy_env tyvars
100 = fst (tidyOpenTyCoVars tidy_env tyvars)
101
102 ---------------
103 tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])
104 tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars
105
106 ---------------
107 tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)
108 -- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name
109 -- using the environment if one has not already been allocated. See
110 -- also 'tidyVarBndr'
111 tidyOpenTyCoVar env@(_, subst) tyvar
112 = case lookupVarEnv subst tyvar of
113 Just tyvar' -> (env, tyvar') -- Already substituted
114 Nothing ->
115 let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar))
116 in tidyVarBndr env' tyvar -- Treat it as a binder
117
118 ---------------
119 tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar
120 tidyTyCoVarOcc env@(_, subst) tv
121 = case lookupVarEnv subst tv of
122 Nothing -> updateVarType (tidyType env) tv
123 Just tv' -> tv'
124
125 ---------------
126
127 {-
128 Note [Strictness in tidyType and friends]
129 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
130
131 Since the result of tidying will be inserted into the HPT, a potentially
132 long-lived structure, we generally want to avoid pieces of the old AST
133 being retained by the thunks produced by tidying.
134
135 For this reason we take great care to ensure that all pieces of the tidied AST
136 are evaluated strictly. So you will see lots of strict applications ($!) and
137 uses of `strictMap` in `tidyType`, `tidyTypes` and `tidyCo`.
138
139 In the case of tidying of lists (e.g. lists of arguments) we prefer to use
140 `strictMap f xs` rather than `seqList (map f xs)` as the latter will
141 unnecessarily allocate a thunk, which will then be almost-immediately
142 evaluated, for each list element.
143
144 Making `tidyType` strict has a rather large effect on performance: see #14738.
145 Sometimes as much as a 5% reduction in allocation.
146 -}
147
148 -- | Tidy a list of Types
149 --
150 -- See Note [Strictness in tidyType and friends]
151 tidyTypes :: TidyEnv -> [Type] -> [Type]
152 tidyTypes env tys = strictMap (tidyType env) tys
153
154 ---------------
155
156
157 -- | Tidy a Type
158 --
159 -- See Note [Strictness in tidyType and friends]
160 tidyType :: TidyEnv -> Type -> Type
161 tidyType _ t@(LitTy {}) = t -- Preserve sharing
162 tidyType env (TyVarTy tv) = TyVarTy $! tidyTyCoVarOcc env tv
163 tidyType _ t@(TyConApp _ []) = t -- Preserve sharing if possible
164 tidyType env (TyConApp tycon tys) = TyConApp tycon $! tidyTypes env tys
165 tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg)
166 tidyType env ty@(FunTy _ w arg res) = let { !w' = tidyType env w
167 ; !arg' = tidyType env arg
168 ; !res' = tidyType env res }
169 in ty { ft_mult = w', ft_arg = arg', ft_res = res' }
170 tidyType env (ty@(ForAllTy{})) = (mkForAllTys' $! (zip tvs' vis)) $! tidyType env' body_ty
171 where
172 (tvs, vis, body_ty) = splitForAllTyCoVars' ty
173 (env', tvs') = tidyVarBndrs env tvs
174 tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCo env co)
175 tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co)
176
177
178 -- The following two functions differ from mkForAllTys and splitForAllTyCoVars in that
179 -- they expect/preserve the ArgFlag argument. These belong to "GHC.Core.Type", but
180 -- how should they be named?
181 mkForAllTys' :: [(TyCoVar, ArgFlag)] -> Type -> Type
182 mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs
183 where
184 strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty
185
186 splitForAllTyCoVars' :: Type -> ([TyCoVar], [ArgFlag], Type)
187 splitForAllTyCoVars' ty = go ty [] []
188 where
189 go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss)
190 go ty tvs viss = (reverse tvs, reverse viss, ty)
191
192
193 ---------------
194 -- | Grabs the free type variables, tidies them
195 -- and then uses 'tidyType' to work over the type itself
196 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
197 tidyOpenTypes env tys
198 = (env', tidyTypes (trimmed_occ_env, var_env) tys)
199 where
200 (env'@(_, var_env), tvs') = tidyOpenTyCoVars env $
201 tyCoVarsOfTypesWellScoped tys
202 trimmed_occ_env = initTidyOccEnv (map getOccName tvs')
203 -- The idea here was that we restrict the new TidyEnv to the
204 -- _free_ vars of the types, so that we don't gratuitously rename
205 -- the _bound_ variables of the types.
206
207 ---------------
208 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
209 tidyOpenType env ty = let (env', [ty']) = tidyOpenTypes env [ty] in
210 (env', ty')
211
212 ---------------
213 -- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment)
214 tidyTopType :: Type -> Type
215 tidyTopType ty = tidyType emptyTidyEnv ty
216
217 ---------------
218 tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind)
219 tidyOpenKind = tidyOpenType
220
221 tidyKind :: TidyEnv -> Kind -> Kind
222 tidyKind = tidyType
223
224 ----------------
225
226 -- | Tidy a Coercion
227 --
228 -- See Note [Strictness in tidyType and friends]
229 tidyCo :: TidyEnv -> Coercion -> Coercion
230 tidyCo env@(_, subst) co
231 = go co
232 where
233 go_mco MRefl = MRefl
234 go_mco (MCo co) = MCo $! go co
235
236 go (Refl ty) = Refl $! tidyType env ty
237 go (GRefl r ty mco) = (GRefl r $! tidyType env ty) $! go_mco mco
238 go (TyConAppCo r tc cos) = TyConAppCo r tc $! strictMap go cos
239 go (AppCo co1 co2) = (AppCo $! go co1) $! go co2
240 go (ForAllCo tv h co) = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co)
241 where (envp, tvp) = tidyVarBndr env tv
242 -- the case above duplicates a bit of work in tidying h and the kind
243 -- of tv. But the alternative is to use coercionKind, which seems worse.
244 go (FunCo r w co1 co2) = ((FunCo r $! go w) $! go co1) $! go co2
245 go (CoVarCo cv) = case lookupVarEnv subst cv of
246 Nothing -> CoVarCo cv
247 Just cv' -> CoVarCo cv'
248 go (HoleCo h) = HoleCo h
249 go (AxiomInstCo con ind cos) = AxiomInstCo con ind $! strictMap go cos
250 go (UnivCo p r t1 t2) = (((UnivCo $! (go_prov p)) $! r) $!
251 tidyType env t1) $! tidyType env t2
252 go (SymCo co) = SymCo $! go co
253 go (TransCo co1 co2) = (TransCo $! go co1) $! go co2
254 go (NthCo r d co) = NthCo r d $! go co
255 go (LRCo lr co) = LRCo lr $! go co
256 go (InstCo co ty) = (InstCo $! go co) $! go ty
257 go (KindCo co) = KindCo $! go co
258 go (SubCo co) = SubCo $! go co
259 go (AxiomRuleCo ax cos) = AxiomRuleCo ax $ strictMap go cos
260
261 go_prov (PhantomProv co) = PhantomProv $! go co
262 go_prov (ProofIrrelProv co) = ProofIrrelProv $! go co
263 go_prov p@(PluginProv _) = p
264 go_prov p@(CorePrepProv _) = p
265
266 tidyCos :: TidyEnv -> [Coercion] -> [Coercion]
267 tidyCos env = strictMap (tidyCo env)