never executed always true always false
1
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE TypeFamilies #-}
4
5 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
6
7 {-
8 (c) The University of Glasgow 2006
9 (c) The AQUA Project, Glasgow University, 1996-1998
10
11 -}
12
13 -- | Specialisations of the @HsSyn@ syntax for the typechecker
14 --
15 -- This module is an extension of @HsSyn@ syntax, for use in the type checker.
16 module GHC.Tc.Utils.Zonk (
17 -- * Other HsSyn functions
18 mkHsDictLet, mkHsApp,
19 mkHsAppTy, mkHsCaseAlt,
20 tcShortCutLit, shortCutLit, hsOverLitName,
21 conLikeResTy,
22
23 -- * re-exported from TcMonad
24 TcId, TcIdSet,
25
26 -- * Zonking
27 -- | For a description of "zonking", see Note [What is zonking?]
28 -- in "GHC.Tc.Utils.TcMType"
29 zonkTopDecls, zonkTopExpr, zonkTopLExpr,
30 zonkTopBndrs,
31 ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv,
32 zonkTyVarBindersX, zonkTyVarBinderX,
33 zonkTyBndrs, zonkTyBndrsX,
34 zonkTcTypeToType, zonkTcTypeToTypeX,
35 zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX,
36 zonkTyVarOcc,
37 zonkCoToCo,
38 zonkEvBinds, zonkTcEvBinds,
39 zonkTcMethInfoToMethInfoX,
40 lookupTyVarOcc
41 ) where
42
43 import GHC.Prelude
44
45 import GHC.Platform
46
47 import GHC.Builtin.Types
48 import GHC.Builtin.Names
49
50 import GHC.Hs
51
52 import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice)
53 import GHC.Tc.Utils.Monad
54 import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo )
55 import GHC.Tc.Utils.TcType
56 import GHC.Tc.Utils.TcMType
57 import GHC.Tc.Utils.Env ( tcLookupGlobalOnly )
58 import GHC.Tc.Types.Evidence
59
60 import GHC.Core.TyCo.Ppr ( pprTyVar )
61 import GHC.Core.TyCon
62 import GHC.Core.Type
63 import GHC.Core.Coercion
64 import GHC.Core.ConLike
65 import GHC.Core.DataCon
66
67 import GHC.Utils.Outputable
68 import GHC.Utils.Misc
69 import GHC.Utils.Panic
70 import GHC.Utils.Panic.Plain
71 import GHC.Utils.Constants (debugIsOn)
72
73 import GHC.Core.Multiplicity
74 import GHC.Core
75 import GHC.Core.Predicate
76
77 import GHC.Types.Name
78 import GHC.Types.Name.Env
79 import GHC.Types.Var
80 import GHC.Types.Var.Env
81 import GHC.Types.Id
82 import GHC.Types.Id.Info
83 import GHC.Types.TypeEnv
84 import GHC.Types.SourceText
85 import GHC.Types.Basic
86 import GHC.Types.SrcLoc
87 import GHC.Types.Unique.FM
88 import GHC.Types.TyThing
89 import GHC.Driver.Session( getDynFlags, targetPlatform )
90
91 import GHC.Data.Maybe
92 import GHC.Data.Bag
93
94 import Control.Monad
95 import Data.List ( partition )
96 import Control.Arrow ( second )
97
98 {- *********************************************************************
99 * *
100 Short-cuts for overloaded numeric literals
101 * *
102 ********************************************************************* -}
103
104 -- Overloaded literals. Here mainly because it uses isIntTy etc
105
106 {- Note [Short cut for overloaded literals]
107 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
108 A literal like "3" means (fromInteger @ty (dNum :: Num ty) (3::Integer)).
109 But if we have a list like
110 [4,2,3,2,4,4,2]::[Int]
111 we use a lot of compile time and space generating and solving all those Num
112 constraints, and generating calls to fromInteger etc. Better just to cut to
113 the chase, and cough up an Int literal. Large collections of literals like this
114 sometimes appear in source files, so it's quite a worthwhile fix.
115
116 So we try to take advantage of whatever nearby type information we have,
117 to short-cut the process for built-in types. We can do this in two places;
118
119 * In the typechecker, when we are about to typecheck the literal.
120 * If that fails, in the desugarer, once we know the final type.
121 -}
122
123 tcShortCutLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc))
124 tcShortCutLit lit@(OverLit { ol_val = val, ol_ext = OverLitRn rebindable _}) exp_res_ty
125 | not rebindable
126 , Just res_ty <- checkingExpType_maybe exp_res_ty
127 = do { dflags <- getDynFlags
128 ; let platform = targetPlatform dflags
129 ; case shortCutLit platform val res_ty of
130 Just expr -> return $ Just $
131 lit { ol_ext = OverLitTc False expr res_ty }
132 Nothing -> return Nothing }
133 | otherwise
134 = return Nothing
135
136 shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTc)
137 shortCutLit platform val res_ty
138 = case val of
139 HsIntegral int_lit -> go_integral int_lit
140 HsFractional frac_lit -> go_fractional frac_lit
141 HsIsString s src -> go_string s src
142 where
143 go_integral int@(IL src neg i)
144 | isIntTy res_ty && platformInIntRange platform i
145 = Just (HsLit noAnn (HsInt noExtField int))
146 | isWordTy res_ty && platformInWordRange platform i
147 = Just (mkLit wordDataCon (HsWordPrim src i))
148 | isIntegerTy res_ty
149 = Just (HsLit noAnn (HsInteger src i res_ty))
150 | otherwise
151 = go_fractional (integralFractionalLit neg i)
152 -- The 'otherwise' case is important
153 -- Consider (3 :: Float). Syntactically it looks like an IntLit,
154 -- so we'll call shortCutIntLit, but of course it's a float
155 -- This can make a big difference for programs with a lot of
156 -- literals, compiled without -O
157
158 go_fractional f
159 | isFloatTy res_ty && valueInRange = Just (mkLit floatDataCon (HsFloatPrim noExtField f))
160 | isDoubleTy res_ty && valueInRange = Just (mkLit doubleDataCon (HsDoublePrim noExtField f))
161 | otherwise = Nothing
162 where
163 valueInRange =
164 case f of
165 FL { fl_exp = e } -> (-100) <= e && e <= 100
166 -- We limit short-cutting Fractional Literals to when their power of 10
167 -- is less than 100, which ensures desugaring isn't slow.
168
169 go_string src s
170 | isStringTy res_ty = Just (HsLit noAnn (HsString src s))
171 | otherwise = Nothing
172
173 mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc
174 mkLit con lit = HsApp noComments (nlHsDataCon con) (nlHsLit lit)
175
176 ------------------------------
177 hsOverLitName :: OverLitVal -> Name
178 -- Get the canonical 'fromX' name for a particular OverLitVal
179 hsOverLitName (HsIntegral {}) = fromIntegerName
180 hsOverLitName (HsFractional {}) = fromRationalName
181 hsOverLitName (HsIsString {}) = fromStringName
182
183 {-
184 ************************************************************************
185 * *
186 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
187 * *
188 ************************************************************************
189
190 The rest of the zonking is done *after* typechecking.
191 The main zonking pass runs over the bindings
192
193 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
194 b) convert unbound TcTyVar to Void
195 c) convert each TcId to an Id by zonking its type
196
197 The type variables are converted by binding mutable tyvars to immutable ones
198 and then zonking as normal.
199
200 The Ids are converted by binding them in the normal Tc envt; that
201 way we maintain sharing; eg an Id is zonked at its binding site and they
202 all occurrences of that Id point to the common zonked copy
203
204 It's all pretty boring stuff, because HsSyn is such a large type, and
205 the environment manipulation is tiresome.
206 -}
207
208 -- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType.
209
210 -- | See Note [The ZonkEnv]
211 -- Confused by zonking? See Note [What is zonking?] in "GHC.Tc.Utils.TcMType".
212 data ZonkEnv -- See Note [The ZonkEnv]
213 = ZonkEnv { ze_flexi :: ZonkFlexi
214 , ze_tv_env :: TyCoVarEnv TyCoVar
215 , ze_id_env :: IdEnv Id
216 , ze_meta_tv_env :: TcRef (TyVarEnv Type) }
217
218 {- Note [The ZonkEnv]
219 ~~~~~~~~~~~~~~~~~~~~~
220 * ze_flexi :: ZonkFlexi says what to do with a
221 unification variable that is still un-unified.
222 See Note [Un-unified unification variables]
223
224 * ze_tv_env :: TyCoVarEnv TyCoVar promotes sharing. At a binding site
225 of a tyvar or covar, we zonk the kind right away and add a mapping
226 to the env. This prevents re-zonking the kind at every
227 occurrence. But this is *just* an optimisation.
228
229 * ze_id_env : IdEnv Id promotes sharing among Ids, by making all
230 occurrences of the Id point to a single zonked copy, built at the
231 binding site.
232
233 Unlike ze_tv_env, it is knot-tied: see extendIdZonkEnvRec.
234 In a mutually recursive group
235 rec { f = ...g...; g = ...f... }
236 we want the occurrence of g to point to the one zonked Id for g,
237 and the same for f.
238
239 Because it is knot-tied, we must be careful to consult it lazily.
240 Specifically, zonkIdOcc is not monadic.
241
242 * ze_meta_tv_env: see Note [Sharing when zonking to Type]
243
244
245 Notes:
246 * We must be careful never to put coercion variables (which are Ids,
247 after all) in the knot-tied ze_id_env, because coercions can
248 appear in types, and we sometimes inspect a zonked type in this
249 module. [Question: where, precisely?]
250
251 * In zonkTyVarOcc we consult ze_tv_env in a monadic context,
252 a second reason that ze_tv_env can't be monadic.
253
254 * An obvious suggestion would be to have one VarEnv Var to
255 replace both ze_id_env and ze_tv_env, but that doesn't work
256 because of the knot-tying stuff mentioned above.
257
258 Note [Un-unified unification variables]
259 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
260 What should we do if we find a Flexi unification variable?
261 There are three possibilities:
262
263 * DefaultFlexi: this is the common case, in situations like
264 length @alpha ([] @alpha)
265 It really doesn't matter what type we choose for alpha. But
266 we must choose a type! We can't leave mutable unification
267 variables floating around: after typecheck is complete, every
268 type variable occurrence must have a binding site.
269
270 So we default it to 'Any' of the right kind.
271
272 All this works for both type and kind variables (indeed
273 the two are the same thing).
274
275 * SkolemiseFlexi: is a special case for the LHS of RULES.
276 See Note [Zonking the LHS of a RULE]
277
278 * RuntimeUnkFlexi: is a special case for the GHCi debugger.
279 It's a way to have a variable that is not a mutable
280 unification variable, but doesn't have a binding site
281 either.
282
283 * NoFlexi: See Note [Error on unconstrained meta-variables]
284 in GHC.Tc.Utils.TcMType. This mode will panic on unfilled
285 meta-variables.
286 -}
287
288 data ZonkFlexi -- See Note [Un-unified unification variables]
289 = DefaultFlexi -- Default unbound unification variables to Any
290 | SkolemiseFlexi -- Skolemise unbound unification variables
291 -- See Note [Zonking the LHS of a RULE]
292 | RuntimeUnkFlexi -- Used in the GHCi debugger
293 | NoFlexi -- Panic on unfilled meta-variables
294 -- See Note [Error on unconstrained meta-variables]
295 -- in GHC.Tc.Utils.TcMType
296
297 instance Outputable ZonkEnv where
298 ppr (ZonkEnv { ze_tv_env = tv_env
299 , ze_id_env = id_env })
300 = text "ZE" <+> braces (vcat
301 [ text "ze_tv_env =" <+> ppr tv_env
302 , text "ze_id_env =" <+> ppr id_env ])
303
304 -- The EvBinds have to already be zonked, but that's usually the case.
305 emptyZonkEnv :: TcM ZonkEnv
306 emptyZonkEnv = mkEmptyZonkEnv DefaultFlexi
307
308 mkEmptyZonkEnv :: ZonkFlexi -> TcM ZonkEnv
309 mkEmptyZonkEnv flexi
310 = do { mtv_env_ref <- newTcRef emptyVarEnv
311 ; return (ZonkEnv { ze_flexi = flexi
312 , ze_tv_env = emptyVarEnv
313 , ze_id_env = emptyVarEnv
314 , ze_meta_tv_env = mtv_env_ref }) }
315
316 initZonkEnv :: (ZonkEnv -> TcM b) -> TcM b
317 initZonkEnv thing_inside = do { ze <- mkEmptyZonkEnv DefaultFlexi
318 ; thing_inside ze }
319
320 -- | Extend the knot-tied environment.
321 extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv
322 extendIdZonkEnvRec ze@(ZonkEnv { ze_id_env = id_env }) ids
323 -- NB: Don't look at the var to decide which env't to put it in. That
324 -- would end up knot-tying all the env'ts.
325 = ze { ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] }
326 -- Given coercion variables will actually end up here. That's OK though:
327 -- coercion variables are never looked up in the knot-tied env't, so zonking
328 -- them simply doesn't get optimised. No one gets hurt. An improvement (?)
329 -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the
330 -- recursive groups. But perhaps the time it takes to do the analysis is
331 -- more than the savings.
332
333 extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
334 extendZonkEnv ze@(ZonkEnv { ze_tv_env = tyco_env, ze_id_env = id_env }) vars
335 = ze { ze_tv_env = extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars]
336 , ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] }
337 where
338 (tycovars, ids) = partition isTyCoVar vars
339
340 extendIdZonkEnv :: ZonkEnv -> Var -> ZonkEnv
341 extendIdZonkEnv ze@(ZonkEnv { ze_id_env = id_env }) id
342 = ze { ze_id_env = extendVarEnv id_env id id }
343
344 extendTyZonkEnv :: ZonkEnv -> TyVar -> ZonkEnv
345 extendTyZonkEnv ze@(ZonkEnv { ze_tv_env = ty_env }) tv
346 = ze { ze_tv_env = extendVarEnv ty_env tv tv }
347
348 setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv
349 setZonkType ze flexi = ze { ze_flexi = flexi }
350
351 zonkEnvIds :: ZonkEnv -> TypeEnv
352 zonkEnvIds (ZonkEnv { ze_id_env = id_env})
353 = mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env]
354 -- It's OK to use nonDetEltsUFM here because we forget the ordering
355 -- immediately by creating a TypeEnv
356
357 zonkLIdOcc :: ZonkEnv -> LocatedN TcId -> LocatedN Id
358 zonkLIdOcc env = mapLoc (zonkIdOcc env)
359
360 zonkIdOcc :: ZonkEnv -> TcId -> Id
361 -- Ids defined in this module should be in the envt;
362 -- ignore others. (Actually, data constructors are also
363 -- not LocalVars, even when locally defined, but that is fine.)
364 -- (Also foreign-imported things aren't currently in the ZonkEnv;
365 -- that's ok because they don't need zonking.)
366 --
367 -- Actually, Template Haskell works in 'chunks' of declarations, and
368 -- an earlier chunk won't be in the 'env' that the zonking phase
369 -- carries around. Instead it'll be in the tcg_gbl_env, already fully
370 -- zonked. There's no point in looking it up there (except for error
371 -- checking), and it's not conveniently to hand; hence the simple
372 -- 'orElse' case in the LocalVar branch.
373 --
374 -- Even without template splices, in module Main, the checking of
375 -- 'main' is done as a separate chunk.
376 zonkIdOcc (ZonkEnv { ze_id_env = id_env}) id
377 | isLocalVar id = lookupVarEnv id_env id `orElse`
378 id
379 | otherwise = id
380
381 zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
382 zonkIdOccs env ids = map (zonkIdOcc env) ids
383
384 -- zonkIdBndr is used *after* typechecking to get the Id's type
385 -- to its final form. The TyVarEnv give
386 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
387 zonkIdBndr env v
388 = do Scaled w' ty' <- zonkScaledTcTypeToTypeX env (idScaledType v)
389 return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdMult (setIdType v ty') w'))
390
391 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
392 zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
393
394 zonkTopBndrs :: [TcId] -> TcM [Id]
395 zonkTopBndrs ids = initZonkEnv $ \ ze -> zonkIdBndrs ze ids
396
397 zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTc -> TcM (FieldOcc GhcTc)
398 zonkFieldOcc env (FieldOcc sel lbl)
399 = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel
400
401 zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
402 zonkEvBndrsX = mapAccumLM zonkEvBndrX
403
404 zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
405 -- Works for dictionaries and coercions
406 zonkEvBndrX env var
407 = do { var' <- zonkEvBndr env var
408 ; return (extendZonkEnv env [var'], var') }
409
410 zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
411 -- Works for dictionaries and coercions
412 -- Does not extend the ZonkEnv
413 zonkEvBndr env var
414 = updateIdTypeAndMultM ({-# SCC "zonkEvBndr_zonkTcTypeToType" #-} zonkTcTypeToTypeX env) var
415
416 {-
417 zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm
418 zonkEvVarOcc env v
419 | isCoVar v
420 = EvCoercion <$> zonkCoVarOcc env v
421 | otherwise
422 = return (EvId $ zonkIdOcc env v)
423 -}
424
425 zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var)
426 zonkCoreBndrX env v
427 | isId v = do { v' <- zonkIdBndr env v
428 ; return (extendIdZonkEnv env v', v') }
429 | otherwise = zonkTyBndrX env v
430
431 zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var])
432 zonkCoreBndrsX = mapAccumLM zonkCoreBndrX
433
434 zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TyVar])
435 zonkTyBndrs tvs = initZonkEnv $ \ze -> zonkTyBndrsX ze tvs
436
437 zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])
438 zonkTyBndrsX = mapAccumLM zonkTyBndrX
439
440 zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)
441 -- This guarantees to return a TyVar (not a TcTyVar)
442 -- then we add it to the envt, so all occurrences are replaced
443 --
444 -- It does not clone: the new TyVar has the sane Name
445 -- as the old one. This important when zonking the
446 -- TyVarBndrs of a TyCon, whose Names may scope.
447 zonkTyBndrX env tv
448 = assertPpr (isImmutableTyVar tv) (ppr tv <+> dcolon <+> ppr (tyVarKind tv)) $
449 do { ki <- zonkTcTypeToTypeX env (tyVarKind tv)
450 -- Internal names tidy up better, for iface files.
451 ; let tv' = mkTyVar (tyVarName tv) ki
452 ; return (extendTyZonkEnv env tv', tv') }
453
454 zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis]
455 -> TcM (ZonkEnv, [VarBndr TyVar vis])
456 zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX
457
458 zonkTyVarBinderX :: ZonkEnv -> VarBndr TcTyVar vis
459 -> TcM (ZonkEnv, VarBndr TyVar vis)
460 -- Takes a TcTyVar and guarantees to return a TyVar
461 zonkTyVarBinderX env (Bndr tv vis)
462 = do { (env', tv') <- zonkTyBndrX env tv
463 ; return (env', Bndr tv' vis) }
464
465 zonkTopExpr :: HsExpr GhcTc -> TcM (HsExpr GhcTc)
466 zonkTopExpr e = initZonkEnv $ \ ze -> zonkExpr ze e
467
468 zonkTopLExpr :: LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
469 zonkTopLExpr e = initZonkEnv $ \ ze -> zonkLExpr ze e
470
471 zonkTopDecls :: Bag EvBind
472 -> LHsBinds GhcTc
473 -> [LRuleDecl GhcTc] -> [LTcSpecPrag]
474 -> [LForeignDecl GhcTc]
475 -> TcM (TypeEnv,
476 Bag EvBind,
477 LHsBinds GhcTc,
478 [LForeignDecl GhcTc],
479 [LTcSpecPrag],
480 [LRuleDecl GhcTc])
481 zonkTopDecls ev_binds binds rules imp_specs fords
482 = do { (env1, ev_binds') <- initZonkEnv $ \ ze -> zonkEvBinds ze ev_binds
483 ; (env2, binds') <- zonkRecMonoBinds env1 binds
484 -- Top level is implicitly recursive
485 ; rules' <- zonkRules env2 rules
486 ; specs' <- zonkLTcSpecPrags env2 imp_specs
487 ; fords' <- zonkForeignExports env2 fords
488 ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') }
489
490 ---------------------------------------------
491 zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTc
492 -> TcM (ZonkEnv, HsLocalBinds GhcTc)
493 zonkLocalBinds env (EmptyLocalBinds x)
494 = return (env, (EmptyLocalBinds x))
495
496 zonkLocalBinds _ (HsValBinds _ (ValBinds {}))
497 = panic "zonkLocalBinds" -- Not in typechecker output
498
499 zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs)))
500 = do { (env1, new_binds) <- go env binds
501 ; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) }
502 where
503 go env []
504 = return (env, [])
505 go env ((r,b):bs)
506 = do { (env1, b') <- zonkRecMonoBinds env b
507 ; (env2, bs') <- go env1 bs
508 ; return (env2, (r,b'):bs') }
509
510 zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do
511 new_binds <- mapM (wrapLocMA zonk_ip_bind) binds
512 let
513 env1 = extendIdZonkEnvRec env
514 [ n | (L _ (IPBind _ (Right n) _)) <- new_binds]
515 (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
516 return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds))
517 where
518 zonk_ip_bind (IPBind x n e)
519 = do n' <- mapIPNameTc (zonkIdBndr env) n
520 e' <- zonkLExpr env e
521 return (IPBind x n' e')
522
523 ---------------------------------------------
524 zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (ZonkEnv, LHsBinds GhcTc)
525 zonkRecMonoBinds env binds
526 = fixM (\ ~(_, new_binds) -> do
527 { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders CollNoDictBinders new_binds)
528 ; binds' <- zonkMonoBinds env1 binds
529 ; return (env1, binds') })
530
531 ---------------------------------------------
532 zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (LHsBinds GhcTc)
533 zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
534
535 zonk_lbind :: ZonkEnv -> LHsBind GhcTc -> TcM (LHsBind GhcTc)
536 zonk_lbind env = wrapLocMA (zonk_bind env)
537
538 zonk_bind :: ZonkEnv -> HsBind GhcTc -> TcM (HsBind GhcTc)
539 zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss
540 , pat_ext = ty})
541 = do { (_env, new_pat) <- zonkPat env pat -- Env already extended
542 ; new_grhss <- zonkGRHSs env zonkLExpr grhss
543 ; new_ty <- zonkTcTypeToTypeX env ty
544 ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss
545 , pat_ext = new_ty }) }
546
547 zonk_bind env (VarBind { var_ext = x
548 , var_id = var, var_rhs = expr })
549 = do { new_var <- zonkIdBndr env var
550 ; new_expr <- zonkLExpr env expr
551 ; return (VarBind { var_ext = x
552 , var_id = new_var
553 , var_rhs = new_expr }) }
554
555 zonk_bind env bind@(FunBind { fun_id = L loc var
556 , fun_matches = ms
557 , fun_ext = co_fn })
558 = do { new_var <- zonkIdBndr env var
559 ; (env1, new_co_fn) <- zonkCoFn env co_fn
560 ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
561 ; return (bind { fun_id = L loc new_var
562 , fun_matches = new_ms
563 , fun_ext = new_co_fn }) }
564
565 zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
566 , abs_ev_binds = ev_binds
567 , abs_exports = exports
568 , abs_binds = val_binds
569 , abs_sig = has_sig })
570 = assert (all isImmutableTyVar tyvars) $
571 do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
572 ; (env1, new_evs) <- zonkEvBndrsX env0 evs
573 ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
574 ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
575 do { let env3 = extendIdZonkEnvRec env2 $
576 collectHsBindsBinders CollNoDictBinders new_val_binds
577 ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds
578 ; new_exports <- mapM (zonk_export env3) exports
579 ; return (new_val_binds, new_exports) }
580 ; return (AbsBinds { abs_ext = noExtField
581 , abs_tvs = new_tyvars, abs_ev_vars = new_evs
582 , abs_ev_binds = new_ev_binds
583 , abs_exports = new_exports, abs_binds = new_val_bind
584 , abs_sig = has_sig }) }
585 where
586 zonk_val_bind env lbind
587 | has_sig
588 , (L loc bind@(FunBind { fun_id = (L mloc mono_id)
589 , fun_matches = ms
590 , fun_ext = co_fn })) <- lbind
591 = do { new_mono_id <- updateIdTypeAndMultM (zonkTcTypeToTypeX env) mono_id
592 -- Specifically /not/ zonkIdBndr; we do not want to
593 -- complain about a representation-polymorphic binder
594 ; (env', new_co_fn) <- zonkCoFn env co_fn
595 ; new_ms <- zonkMatchGroup env' zonkLExpr ms
596 ; return $ L loc $
597 bind { fun_id = L mloc new_mono_id
598 , fun_matches = new_ms
599 , fun_ext = new_co_fn } }
600 | otherwise
601 = zonk_lbind env lbind -- The normal case
602
603 zonk_export :: ZonkEnv -> ABExport GhcTc -> TcM (ABExport GhcTc)
604 zonk_export env (ABE{ abe_ext = x
605 , abe_wrap = wrap
606 , abe_poly = poly_id
607 , abe_mono = mono_id
608 , abe_prags = prags })
609 = do new_poly_id <- zonkIdBndr env poly_id
610 (_, new_wrap) <- zonkCoFn env wrap
611 new_prags <- zonkSpecPrags env prags
612 return (ABE{ abe_ext = x
613 , abe_wrap = new_wrap
614 , abe_poly = new_poly_id
615 , abe_mono = zonkIdOcc env mono_id
616 , abe_prags = new_prags })
617
618 zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id
619 , psb_args = details
620 , psb_def = lpat
621 , psb_dir = dir }))
622 = do { id' <- zonkIdBndr env id
623 ; (env1, lpat') <- zonkPat env lpat
624 ; details' <- zonkPatSynDetails env1 details
625 ; (_env2, dir') <- zonkPatSynDir env1 dir
626 ; return $ PatSynBind x $
627 bind { psb_id = L loc id'
628 , psb_args = details'
629 , psb_def = lpat'
630 , psb_dir = dir' } }
631
632 zonkPatSynDetails :: ZonkEnv
633 -> HsPatSynDetails GhcTc
634 -> TcM (HsPatSynDetails GhcTc)
635 zonkPatSynDetails env (PrefixCon _ as)
636 = pure $ PrefixCon noTypeArgs (map (zonkLIdOcc env) as)
637 zonkPatSynDetails env (InfixCon a1 a2)
638 = pure $ InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2)
639 zonkPatSynDetails env (RecCon flds)
640 = RecCon <$> mapM (zonkPatSynField env) flds
641
642 zonkPatSynField :: ZonkEnv -> RecordPatSynField GhcTc -> TcM (RecordPatSynField GhcTc)
643 zonkPatSynField env (RecordPatSynField x y) =
644 RecordPatSynField <$> zonkFieldOcc env x <*> pure (zonkLIdOcc env y)
645
646 zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTc
647 -> TcM (ZonkEnv, HsPatSynDir GhcTc)
648 zonkPatSynDir env Unidirectional = return (env, Unidirectional)
649 zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)
650 zonkPatSynDir env (ExplicitBidirectional mg) = do
651 mg' <- zonkMatchGroup env zonkLExpr mg
652 return (env, ExplicitBidirectional mg')
653
654 zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
655 zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod
656 zonkSpecPrags env (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags env ps
657 ; return (SpecPrags ps') }
658
659 zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
660 zonkLTcSpecPrags env ps
661 = mapM zonk_prag ps
662 where
663 zonk_prag (L loc (SpecPrag id co_fn inl))
664 = do { (_, co_fn') <- zonkCoFn env co_fn
665 ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
666
667 {-
668 ************************************************************************
669 * *
670 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
671 * *
672 ************************************************************************
673 -}
674
675 zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
676 => ZonkEnv
677 -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
678 -> MatchGroup GhcTc (LocatedA (body GhcTc))
679 -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
680 zonkMatchGroup env zBody (MG { mg_alts = L l ms
681 , mg_ext = MatchGroupTc arg_tys res_ty
682 , mg_origin = origin })
683 = do { ms' <- mapM (zonkMatch env zBody) ms
684 ; arg_tys' <- zonkScaledTcTypesToTypesX env arg_tys
685 ; res_ty' <- zonkTcTypeToTypeX env res_ty
686 ; return (MG { mg_alts = L l ms'
687 , mg_ext = MatchGroupTc arg_tys' res_ty'
688 , mg_origin = origin }) }
689
690 zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
691 => ZonkEnv
692 -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
693 -> LMatch GhcTc (LocatedA (body GhcTc))
694 -> TcM (LMatch GhcTc (LocatedA (body GhcTc)))
695 zonkMatch env zBody (L loc match@(Match { m_pats = pats
696 , m_grhss = grhss }))
697 = do { (env1, new_pats) <- zonkPats env pats
698 ; new_grhss <- zonkGRHSs env1 zBody grhss
699 ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
700
701 -------------------------------------------------------------------------
702 zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
703 => ZonkEnv
704 -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
705 -> GRHSs GhcTc (LocatedA (body GhcTc))
706 -> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
707
708 zonkGRHSs env zBody (GRHSs x grhss binds) = do
709 (new_env, new_binds) <- zonkLocalBinds env binds
710 let
711 zonk_grhs (GRHS xx guarded rhs)
712 = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
713 new_rhs <- zBody env2 rhs
714 return (GRHS xx new_guarded new_rhs)
715 new_grhss <- mapM (wrapLocMA zonk_grhs) grhss
716 return (GRHSs x new_grhss new_binds)
717
718 {-
719 ************************************************************************
720 * *
721 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
722 * *
723 ************************************************************************
724 -}
725
726 zonkLExprs :: ZonkEnv -> [LHsExpr GhcTc] -> TcM [LHsExpr GhcTc]
727 zonkLExpr :: ZonkEnv -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
728 zonkExpr :: ZonkEnv -> HsExpr GhcTc -> TcM (HsExpr GhcTc)
729
730 zonkLExprs env exprs = mapM (zonkLExpr env) exprs
731 zonkLExpr env expr = wrapLocMA (zonkExpr env) expr
732
733 zonkExpr env (HsVar x (L l id))
734 = assertPpr (isNothing (isDataConId_maybe id)) (ppr id) $
735 return (HsVar x (L l (zonkIdOcc env id)))
736
737 zonkExpr env (HsUnboundVar her occ)
738 = do her' <- zonk_her her
739 return (HsUnboundVar her' occ)
740 where
741 zonk_her :: HoleExprRef -> TcM HoleExprRef
742 zonk_her (HER ref ty u)
743 = do updMutVarM ref (zonkEvTerm env)
744 ty' <- zonkTcTypeToTypeX env ty
745 return (HER ref ty' u)
746
747 zonkExpr env (HsRecSel _ (FieldOcc v occ))
748 = return (HsRecSel noExtField (FieldOcc (zonkIdOcc env v) occ))
749
750 zonkExpr _ (HsIPVar x _) = dataConCantHappen x
751
752 zonkExpr _ (HsOverLabel x _) = dataConCantHappen x
753
754 zonkExpr env (HsLit x (HsRat e f ty))
755 = do new_ty <- zonkTcTypeToTypeX env ty
756 return (HsLit x (HsRat e f new_ty))
757
758 zonkExpr _ (HsLit x lit)
759 = return (HsLit x lit)
760
761 zonkExpr env (HsOverLit x lit)
762 = do { lit' <- zonkOverLit env lit
763 ; return (HsOverLit x lit') }
764
765 zonkExpr env (HsLam x matches)
766 = do new_matches <- zonkMatchGroup env zonkLExpr matches
767 return (HsLam x new_matches)
768
769 zonkExpr env (HsLamCase x matches)
770 = do new_matches <- zonkMatchGroup env zonkLExpr matches
771 return (HsLamCase x new_matches)
772
773 zonkExpr env (HsApp x e1 e2)
774 = do new_e1 <- zonkLExpr env e1
775 new_e2 <- zonkLExpr env e2
776 return (HsApp x new_e1 new_e2)
777
778 zonkExpr env (HsAppType ty e t)
779 = do new_e <- zonkLExpr env e
780 new_ty <- zonkTcTypeToTypeX env ty
781 return (HsAppType new_ty new_e t)
782 -- NB: the type is an HsType; can't zonk that!
783
784 zonkExpr _ (HsRnBracketOut x _ _) = dataConCantHappen x
785
786 zonkExpr env (HsTcBracketOut ty wrap body bs)
787 = do wrap' <- traverse zonkQuoteWrap wrap
788 bs' <- mapM (zonk_b env) bs
789 new_ty <- zonkTcTypeToTypeX env ty
790 return (HsTcBracketOut new_ty wrap' body bs')
791 where
792 zonkQuoteWrap (QuoteWrapper ev ty) = do
793 let ev' = zonkIdOcc env ev
794 ty' <- zonkTcTypeToTypeX env ty
795 return (QuoteWrapper ev' ty')
796
797 zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e
798 return (PendingTcSplice n e')
799
800 zonkExpr env (HsSpliceE _ (XSplice (HsSplicedT s))) =
801 runTopSplice s >>= zonkExpr env
802
803 zonkExpr _ e@(HsSpliceE _ _) = pprPanic "zonkExpr: HsSpliceE" (ppr e)
804
805 zonkExpr _ (OpApp x _ _ _) = dataConCantHappen x
806
807 zonkExpr env (NegApp x expr op)
808 = do (env', new_op) <- zonkSyntaxExpr env op
809 new_expr <- zonkLExpr env' expr
810 return (NegApp x new_expr new_op)
811
812 zonkExpr env (HsPar x lpar e rpar)
813 = do new_e <- zonkLExpr env e
814 return (HsPar x lpar new_e rpar)
815
816 zonkExpr _ (SectionL x _ _) = dataConCantHappen x
817 zonkExpr _ (SectionR x _ _) = dataConCantHappen x
818 zonkExpr env (ExplicitTuple x tup_args boxed)
819 = do { new_tup_args <- mapM zonk_tup_arg tup_args
820 ; return (ExplicitTuple x new_tup_args boxed) }
821 where
822 zonk_tup_arg (Present x e) = do { e' <- zonkLExpr env e
823 ; return (Present x e') }
824 zonk_tup_arg (Missing t) = do { t' <- zonkScaledTcTypeToTypeX env t
825 ; return (Missing t') }
826
827
828 zonkExpr env (ExplicitSum args alt arity expr)
829 = do new_args <- mapM (zonkTcTypeToTypeX env) args
830 new_expr <- zonkLExpr env expr
831 return (ExplicitSum new_args alt arity new_expr)
832
833 zonkExpr env (HsCase x expr ms)
834 = do new_expr <- zonkLExpr env expr
835 new_ms <- zonkMatchGroup env zonkLExpr ms
836 return (HsCase x new_expr new_ms)
837
838 zonkExpr env (HsIf x e1 e2 e3)
839 = do new_e1 <- zonkLExpr env e1
840 new_e2 <- zonkLExpr env e2
841 new_e3 <- zonkLExpr env e3
842 return (HsIf x new_e1 new_e2 new_e3)
843
844 zonkExpr env (HsMultiIf ty alts)
845 = do { alts' <- mapM (wrapLocMA zonk_alt) alts
846 ; ty' <- zonkTcTypeToTypeX env ty
847 ; return $ HsMultiIf ty' alts' }
848 where zonk_alt (GRHS x guard expr)
849 = do { (env', guard') <- zonkStmts env zonkLExpr guard
850 ; expr' <- zonkLExpr env' expr
851 ; return $ GRHS x guard' expr' }
852
853 zonkExpr env (HsLet x tkLet binds tkIn expr)
854 = do (new_env, new_binds) <- zonkLocalBinds env binds
855 new_expr <- zonkLExpr new_env expr
856 return (HsLet x tkLet new_binds tkIn new_expr)
857
858 zonkExpr env (HsDo ty do_or_lc (L l stmts))
859 = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
860 new_ty <- zonkTcTypeToTypeX env ty
861 return (HsDo new_ty do_or_lc (L l new_stmts))
862
863 zonkExpr env (ExplicitList ty exprs)
864 = do new_ty <- zonkTcTypeToTypeX env ty
865 new_exprs <- zonkLExprs env exprs
866 return (ExplicitList new_ty new_exprs)
867
868 zonkExpr env expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds })
869 = do { new_con_expr <- zonkExpr env con_expr
870 ; new_rbinds <- zonkRecFields env rbinds
871 ; return (expr { rcon_ext = new_con_expr
872 , rcon_flds = new_rbinds }) }
873
874 -- Record updates via dot syntax are replaced by desugared expressions
875 -- in the renamer. See Note [Rebindable Syntax and HsExpansion]. This
876 -- is why we match on 'rupd_flds = Left rbinds' here and panic otherwise.
877 zonkExpr env (RecordUpd { rupd_flds = Left rbinds
878 , rupd_expr = expr
879 , rupd_ext = RecordUpdTc {
880 rupd_cons = cons
881 , rupd_in_tys = in_tys
882 , rupd_out_tys = out_tys
883 , rupd_wrap = req_wrap }})
884 = do { new_expr <- zonkLExpr env expr
885 ; new_in_tys <- mapM (zonkTcTypeToTypeX env) in_tys
886 ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys
887 ; new_rbinds <- zonkRecUpdFields env rbinds
888 ; (_, new_recwrap) <- zonkCoFn env req_wrap
889 ; return (
890 RecordUpd {
891 rupd_expr = new_expr
892 , rupd_flds = Left new_rbinds
893 , rupd_ext = RecordUpdTc {
894 rupd_cons = cons
895 , rupd_in_tys = new_in_tys
896 , rupd_out_tys = new_out_tys
897 , rupd_wrap = new_recwrap }}) }
898 zonkExpr _ (RecordUpd {}) = panic "GHC.Tc.Utils.Zonk: zonkExpr: The impossible happened!"
899
900 zonkExpr env (ExprWithTySig _ e ty)
901 = do { e' <- zonkLExpr env e
902 ; return (ExprWithTySig noExtField e' ty) }
903
904 zonkExpr env (ArithSeq expr wit info)
905 = do (env1, new_wit) <- zonkWit env wit
906 new_expr <- zonkExpr env expr
907 new_info <- zonkArithSeq env1 info
908 return (ArithSeq new_expr new_wit new_info)
909 where zonkWit env Nothing = return (env, Nothing)
910 zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
911
912 zonkExpr env (HsPragE x prag expr)
913 = do new_expr <- zonkLExpr env expr
914 return (HsPragE x prag new_expr)
915
916 -- arrow notation extensions
917 zonkExpr env (HsProc x pat body)
918 = do { (env1, new_pat) <- zonkPat env pat
919 ; new_body <- zonkCmdTop env1 body
920 ; return (HsProc x new_pat new_body) }
921
922 -- StaticPointers extension
923 zonkExpr env (HsStatic fvs expr)
924 = HsStatic fvs <$> zonkLExpr env expr
925
926 zonkExpr env (XExpr (WrapExpr (HsWrap co_fn expr)))
927 = do (env1, new_co_fn) <- zonkCoFn env co_fn
928 new_expr <- zonkExpr env1 expr
929 return (XExpr (WrapExpr (HsWrap new_co_fn new_expr)))
930
931 zonkExpr env (XExpr (ExpansionExpr (HsExpanded a b)))
932 = XExpr . ExpansionExpr . HsExpanded a <$> zonkExpr env b
933
934 zonkExpr env (XExpr (ConLikeTc con tvs tys))
935 = XExpr . ConLikeTc con tvs <$> mapM zonk_scale tys
936 where
937 zonk_scale (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX env m <*> pure ty
938 -- Only the multiplicity can contain unification variables
939 -- The tvs come straight from the data-con, and so are strictly redundant
940 -- See Wrinkles of Note [Typechecking data constructors] in GHC.Tc.Gen.Head
941
942 zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
943
944 -------------------------------------------------------------------------
945 {-
946 Note [Skolems in zonkSyntaxExpr]
947 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
948 Consider rebindable syntax with something like
949
950 (>>=) :: (forall x. blah) -> (forall y. blah') -> blah''
951
952 The x and y become skolems that are in scope when type-checking the
953 arguments to the bind. This means that we must extend the ZonkEnv with
954 these skolems when zonking the arguments to the bind. But the skolems
955 are different between the two arguments, and so we should theoretically
956 carry around different environments to use for the different arguments.
957
958 However, this becomes a logistical nightmare, especially in dealing with
959 the more exotic Stmt forms. So, we simplify by making the critical
960 assumption that the uniques of the skolems are different. (This assumption
961 is justified by the use of newUnique in GHC.Tc.Utils.TcMType.instSkolTyCoVarX.)
962 Now, we can safely just extend one environment.
963 -}
964
965 -- See Note [Skolems in zonkSyntaxExpr]
966 zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTc
967 -> TcM (ZonkEnv, SyntaxExpr GhcTc)
968 zonkSyntaxExpr env (SyntaxExprTc { syn_expr = expr
969 , syn_arg_wraps = arg_wraps
970 , syn_res_wrap = res_wrap })
971 = do { (env0, res_wrap') <- zonkCoFn env res_wrap
972 ; expr' <- zonkExpr env0 expr
973 ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps
974 ; return (env1, SyntaxExprTc { syn_expr = expr'
975 , syn_arg_wraps = arg_wraps'
976 , syn_res_wrap = res_wrap' }) }
977 zonkSyntaxExpr env NoSyntaxExprTc = return (env, NoSyntaxExprTc)
978
979 -------------------------------------------------------------------------
980
981 zonkLCmd :: ZonkEnv -> LHsCmd GhcTc -> TcM (LHsCmd GhcTc)
982 zonkCmd :: ZonkEnv -> HsCmd GhcTc -> TcM (HsCmd GhcTc)
983
984 zonkLCmd env cmd = wrapLocMA (zonkCmd env) cmd
985
986 zonkCmd env (XCmd (HsWrap w cmd))
987 = do { (env1, w') <- zonkCoFn env w
988 ; cmd' <- zonkCmd env1 cmd
989 ; return (XCmd (HsWrap w' cmd')) }
990 zonkCmd env (HsCmdArrApp ty e1 e2 ho rl)
991 = do new_e1 <- zonkLExpr env e1
992 new_e2 <- zonkLExpr env e2
993 new_ty <- zonkTcTypeToTypeX env ty
994 return (HsCmdArrApp new_ty new_e1 new_e2 ho rl)
995
996 zonkCmd env (HsCmdArrForm x op f fixity args)
997 = do new_op <- zonkLExpr env op
998 new_args <- mapM (zonkCmdTop env) args
999 return (HsCmdArrForm x new_op f fixity new_args)
1000
1001 zonkCmd env (HsCmdApp x c e)
1002 = do new_c <- zonkLCmd env c
1003 new_e <- zonkLExpr env e
1004 return (HsCmdApp x new_c new_e)
1005
1006 zonkCmd env (HsCmdLam x matches)
1007 = do new_matches <- zonkMatchGroup env zonkLCmd matches
1008 return (HsCmdLam x new_matches)
1009
1010 zonkCmd env (HsCmdPar x lpar c rpar)
1011 = do new_c <- zonkLCmd env c
1012 return (HsCmdPar x lpar new_c rpar)
1013
1014 zonkCmd env (HsCmdCase x expr ms)
1015 = do new_expr <- zonkLExpr env expr
1016 new_ms <- zonkMatchGroup env zonkLCmd ms
1017 return (HsCmdCase x new_expr new_ms)
1018
1019 zonkCmd env (HsCmdLamCase x ms)
1020 = do new_ms <- zonkMatchGroup env zonkLCmd ms
1021 return (HsCmdLamCase x new_ms)
1022
1023 zonkCmd env (HsCmdIf x eCond ePred cThen cElse)
1024 = do { (env1, new_eCond) <- zonkSyntaxExpr env eCond
1025 ; new_ePred <- zonkLExpr env1 ePred
1026 ; new_cThen <- zonkLCmd env1 cThen
1027 ; new_cElse <- zonkLCmd env1 cElse
1028 ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) }
1029
1030 zonkCmd env (HsCmdLet x tkLet binds tkIn cmd)
1031 = do (new_env, new_binds) <- zonkLocalBinds env binds
1032 new_cmd <- zonkLCmd new_env cmd
1033 return (HsCmdLet x tkLet new_binds tkIn new_cmd)
1034
1035 zonkCmd env (HsCmdDo ty (L l stmts))
1036 = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
1037 new_ty <- zonkTcTypeToTypeX env ty
1038 return (HsCmdDo new_ty (L l new_stmts))
1039
1040
1041
1042 zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTc -> TcM (LHsCmdTop GhcTc)
1043 zonkCmdTop env cmd = wrapLocMA (zonk_cmd_top env) cmd
1044
1045 zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTc -> TcM (HsCmdTop GhcTc)
1046 zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)
1047 = do new_cmd <- zonkLCmd env cmd
1048 new_stack_tys <- zonkTcTypeToTypeX env stack_tys
1049 new_ty <- zonkTcTypeToTypeX env ty
1050 new_ids <- mapSndM (zonkExpr env) ids
1051
1052 massert (isLiftedTypeKind (tcTypeKind new_stack_tys))
1053 -- desugarer assumes that this is not representation-polymorphic...
1054 -- but indeed it should always be lifted due to the typing
1055 -- rules for arrows
1056
1057 return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd)
1058
1059 -------------------------------------------------------------------------
1060 zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
1061 zonkCoFn env WpHole = return (env, WpHole)
1062 zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
1063 ; (env2, c2') <- zonkCoFn env1 c2
1064 ; return (env2, WpCompose c1' c2') }
1065 zonkCoFn env (WpFun c1 c2 t1) = do { (env1, c1') <- zonkCoFn env c1
1066 ; (env2, c2') <- zonkCoFn env1 c2
1067 ; t1' <- zonkScaledTcTypeToTypeX env2 t1
1068 ; return (env2, WpFun c1' c2' t1') }
1069 zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co
1070 ; return (env, WpCast co') }
1071 zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev
1072 ; return (env', WpEvLam ev') }
1073 zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg
1074 ; return (env, WpEvApp arg') }
1075 zonkCoFn env (WpTyLam tv) = assert (isImmutableTyVar tv) $
1076 do { (env', tv') <- zonkTyBndrX env tv
1077 ; return (env', WpTyLam tv') }
1078 zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToTypeX env ty
1079 ; return (env, WpTyApp ty') }
1080 zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs
1081 ; return (env1, WpLet bs') }
1082 zonkCoFn env (WpMultCoercion co) = do { co' <- zonkCoToCo env co
1083 ; return (env, WpMultCoercion co') }
1084
1085 -------------------------------------------------------------------------
1086 zonkOverLit :: ZonkEnv -> HsOverLit GhcTc -> TcM (HsOverLit GhcTc)
1087 zonkOverLit env lit@(OverLit {ol_ext = x@OverLitTc { ol_witness = e, ol_type = ty } })
1088 = do { ty' <- zonkTcTypeToTypeX env ty
1089 ; e' <- zonkExpr env e
1090 ; return (lit { ol_ext = x { ol_witness = e'
1091 , ol_type = ty' } }) }
1092
1093 -------------------------------------------------------------------------
1094 zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTc -> TcM (ArithSeqInfo GhcTc)
1095
1096 zonkArithSeq env (From e)
1097 = do new_e <- zonkLExpr env e
1098 return (From new_e)
1099
1100 zonkArithSeq env (FromThen e1 e2)
1101 = do new_e1 <- zonkLExpr env e1
1102 new_e2 <- zonkLExpr env e2
1103 return (FromThen new_e1 new_e2)
1104
1105 zonkArithSeq env (FromTo e1 e2)
1106 = do new_e1 <- zonkLExpr env e1
1107 new_e2 <- zonkLExpr env e2
1108 return (FromTo new_e1 new_e2)
1109
1110 zonkArithSeq env (FromThenTo e1 e2 e3)
1111 = do new_e1 <- zonkLExpr env e1
1112 new_e2 <- zonkLExpr env e2
1113 new_e3 <- zonkLExpr env e3
1114 return (FromThenTo new_e1 new_e2 new_e3)
1115
1116
1117 -------------------------------------------------------------------------
1118 zonkStmts :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
1119 => ZonkEnv
1120 -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
1121 -> [LStmt GhcTc (LocatedA (body GhcTc))]
1122 -> TcM (ZonkEnv, [LStmt GhcTc (LocatedA (body GhcTc))])
1123 zonkStmts env _ [] = return (env, [])
1124 zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndMA (zonkStmt env zBody) s
1125 ; (env2, ss') <- zonkStmts env1 zBody ss
1126 ; return (env2, s' : ss') }
1127
1128 zonkStmt :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
1129 => ZonkEnv
1130 -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
1131 -> Stmt GhcTc (LocatedA (body GhcTc))
1132 -> TcM (ZonkEnv, Stmt GhcTc (LocatedA (body GhcTc)))
1133 zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op)
1134 = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op
1135 ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty
1136 ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs
1137 ; let new_binders = [b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs
1138 , b <- bs]
1139 env2 = extendIdZonkEnvRec env1 new_binders
1140 ; new_mzip <- zonkExpr env2 mzip_op
1141 ; return (env2
1142 , ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)}
1143 where
1144 zonk_branch :: ZonkEnv -> ParStmtBlock GhcTc GhcTc
1145 -> TcM (ParStmtBlock GhcTc GhcTc)
1146 zonk_branch env1 (ParStmtBlock x stmts bndrs return_op)
1147 = do { (env2, new_stmts) <- zonkStmts env1 zonkLExpr stmts
1148 ; (env3, new_return) <- zonkSyntaxExpr env2 return_op
1149 ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs)
1150 new_return) }
1151
1152 zonkStmt env zBody (RecStmt { recS_stmts = L _ segStmts, recS_later_ids = lvs
1153 , recS_rec_ids = rvs
1154 , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id
1155 , recS_bind_fn = bind_id
1156 , recS_ext =
1157 RecStmtTc { recS_bind_ty = bind_ty
1158 , recS_later_rets = later_rets
1159 , recS_rec_rets = rec_rets
1160 , recS_ret_ty = ret_ty} })
1161 = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id
1162 ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id
1163 ; (env3, new_ret_id) <- zonkSyntaxExpr env2 ret_id
1164 ; new_bind_ty <- zonkTcTypeToTypeX env3 bind_ty
1165 ; new_rvs <- zonkIdBndrs env3 rvs
1166 ; new_lvs <- zonkIdBndrs env3 lvs
1167 ; new_ret_ty <- zonkTcTypeToTypeX env3 ret_ty
1168 ; let env4 = extendIdZonkEnvRec env3 new_rvs
1169 ; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts
1170 -- Zonk the ret-expressions in an envt that
1171 -- has the polymorphic bindings in the envt
1172 ; new_later_rets <- mapM (zonkExpr env5) later_rets
1173 ; new_rec_rets <- mapM (zonkExpr env5) rec_rets
1174 ; return (extendIdZonkEnvRec env3 new_lvs, -- Only the lvs are needed
1175 RecStmt { recS_stmts = noLocA new_segStmts
1176 , recS_later_ids = new_lvs
1177 , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
1178 , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
1179 , recS_ext = RecStmtTc
1180 { recS_bind_ty = new_bind_ty
1181 , recS_later_rets = new_later_rets
1182 , recS_rec_rets = new_rec_rets
1183 , recS_ret_ty = new_ret_ty } }) }
1184
1185 zonkStmt env zBody (BodyStmt ty body then_op guard_op)
1186 = do (env1, new_then_op) <- zonkSyntaxExpr env then_op
1187 (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op
1188 new_body <- zBody env2 body
1189 new_ty <- zonkTcTypeToTypeX env2 ty
1190 return (env2, BodyStmt new_ty new_body new_then_op new_guard_op)
1191
1192 zonkStmt env zBody (LastStmt x body noret ret_op)
1193 = do (env1, new_ret) <- zonkSyntaxExpr env ret_op
1194 new_body <- zBody env1 body
1195 return (env, LastStmt x new_body noret new_ret)
1196
1197 zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
1198 , trS_by = by, trS_form = form, trS_using = using
1199 , trS_ret = return_op, trS_bind = bind_op
1200 , trS_ext = bind_arg_ty
1201 , trS_fmap = liftM_op })
1202 = do {
1203 ; (env1, bind_op') <- zonkSyntaxExpr env bind_op
1204 ; bind_arg_ty' <- zonkTcTypeToTypeX env1 bind_arg_ty
1205 ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts
1206 ; by' <- fmapMaybeM (zonkLExpr env2) by
1207 ; using' <- zonkLExpr env2 using
1208
1209 ; (env3, return_op') <- zonkSyntaxExpr env2 return_op
1210 ; binderMap' <- mapM (zonkBinderMapEntry env3) binderMap
1211 ; liftM_op' <- zonkExpr env3 liftM_op
1212 ; let env3' = extendIdZonkEnvRec env3 (map snd binderMap')
1213 ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
1214 , trS_by = by', trS_form = form, trS_using = using'
1215 , trS_ret = return_op', trS_bind = bind_op'
1216 , trS_ext = bind_arg_ty'
1217 , trS_fmap = liftM_op' }) }
1218 where
1219 zonkBinderMapEntry env (oldBinder, newBinder) = do
1220 let oldBinder' = zonkIdOcc env oldBinder
1221 newBinder' <- zonkIdBndr env newBinder
1222 return (oldBinder', newBinder')
1223
1224 zonkStmt env _ (LetStmt x binds)
1225 = do (env1, new_binds) <- zonkLocalBinds env binds
1226 return (env1, LetStmt x new_binds)
1227
1228 zonkStmt env zBody (BindStmt xbs pat body)
1229 = do { (env1, new_bind) <- zonkSyntaxExpr env (xbstc_bindOp xbs)
1230 ; new_w <- zonkTcTypeToTypeX env1 (xbstc_boundResultMult xbs)
1231 ; new_bind_ty <- zonkTcTypeToTypeX env1 (xbstc_boundResultType xbs)
1232 ; new_body <- zBody env1 body
1233 ; (env2, new_pat) <- zonkPat env1 pat
1234 ; new_fail <- case xbstc_failOp xbs of
1235 Nothing -> return Nothing
1236 Just f -> fmap (Just . snd) (zonkSyntaxExpr env1 f)
1237 ; return ( env2
1238 , BindStmt (XBindStmtTc
1239 { xbstc_bindOp = new_bind
1240 , xbstc_boundResultType = new_bind_ty
1241 , xbstc_boundResultMult = new_w
1242 , xbstc_failOp = new_fail
1243 })
1244 new_pat new_body) }
1245
1246 -- Scopes: join > ops (in reverse order) > pats (in forward order)
1247 -- > rest of stmts
1248 zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
1249 = do { (env1, new_mb_join) <- zonk_join env mb_join
1250 ; (env2, new_args) <- zonk_args env1 args
1251 ; new_body_ty <- zonkTcTypeToTypeX env2 body_ty
1252 ; return ( env2
1253 , ApplicativeStmt new_body_ty new_args new_mb_join) }
1254 where
1255 zonk_join env Nothing = return (env, Nothing)
1256 zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j
1257
1258 get_pat :: (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> LPat GhcTc
1259 get_pat (_, ApplicativeArgOne _ pat _ _) = pat
1260 get_pat (_, ApplicativeArgMany _ _ _ pat _) = pat
1261
1262 replace_pat :: LPat GhcTc
1263 -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
1264 -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
1265 replace_pat pat (op, ApplicativeArgOne fail_op _ a isBody)
1266 = (op, ApplicativeArgOne fail_op pat a isBody)
1267 replace_pat pat (op, ApplicativeArgMany x a b _ c)
1268 = (op, ApplicativeArgMany x a b pat c)
1269
1270 zonk_args env args
1271 = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args)
1272 ; (env2, new_pats) <- zonkPats env1 (map get_pat args)
1273 ; return (env2, zipWithEqual "zonkStmt" replace_pat
1274 new_pats (reverse new_args_rev)) }
1275
1276 -- these need to go backward, because if any operators are higher-rank,
1277 -- later operators may introduce skolems that are in scope for earlier
1278 -- arguments
1279 zonk_args_rev env ((op, arg) : args)
1280 = do { (env1, new_op) <- zonkSyntaxExpr env op
1281 ; new_arg <- zonk_arg env1 arg
1282 ; (env2, new_args) <- zonk_args_rev env1 args
1283 ; return (env2, (new_op, new_arg) : new_args) }
1284 zonk_args_rev env [] = return (env, [])
1285
1286 zonk_arg env (ApplicativeArgOne fail_op pat expr isBody)
1287 = do { new_expr <- zonkLExpr env expr
1288 ; new_fail <- forM fail_op $ \old_fail ->
1289 do { (_, fail') <- zonkSyntaxExpr env old_fail
1290 ; return fail'
1291 }
1292 ; return (ApplicativeArgOne new_fail pat new_expr isBody) }
1293 zonk_arg env (ApplicativeArgMany x stmts ret pat ctxt)
1294 = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
1295 ; new_ret <- zonkExpr env1 ret
1296 ; return (ApplicativeArgMany x new_stmts new_ret pat ctxt) }
1297
1298 -------------------------------------------------------------------------
1299 zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTc -> TcM (HsRecordBinds GhcTc)
1300 zonkRecFields env (HsRecFields flds dd)
1301 = do { flds' <- mapM zonk_rbind flds
1302 ; return (HsRecFields flds' dd) }
1303 where
1304 zonk_rbind (L l fld)
1305 = do { new_id <- wrapLocMA (zonkFieldOcc env) (hfbLHS fld)
1306 ; new_expr <- zonkLExpr env (hfbRHS fld)
1307 ; return (L l (fld { hfbLHS = new_id
1308 , hfbRHS = new_expr })) }
1309
1310 zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTc]
1311 -> TcM [LHsRecUpdField GhcTc]
1312 zonkRecUpdFields env = mapM zonk_rbind
1313 where
1314 zonk_rbind (L l fld)
1315 = do { new_id <- wrapLocMA (zonkFieldOcc env) (hsRecUpdFieldOcc fld)
1316 ; new_expr <- zonkLExpr env (hfbRHS fld)
1317 ; return (L l (fld { hfbLHS = fmap ambiguousFieldOcc new_id
1318 , hfbRHS = new_expr })) }
1319
1320 -------------------------------------------------------------------------
1321 mapIPNameTc :: (a -> TcM b) -> Either (LocatedAn NoEpAnns HsIPName) a
1322 -> TcM (Either (LocatedAn NoEpAnns HsIPName) b)
1323 mapIPNameTc _ (Left x) = return (Left x)
1324 mapIPNameTc f (Right x) = do r <- f x
1325 return (Right r)
1326
1327 {-
1328 ************************************************************************
1329 * *
1330 \subsection[BackSubst-Pats]{Patterns}
1331 * *
1332 ************************************************************************
1333 -}
1334
1335 zonkPat :: ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
1336 -- Extend the environment as we go, because it's possible for one
1337 -- pattern to bind something that is used in another (inside or
1338 -- to the right)
1339 zonkPat env pat = wrapLocSndMA (zonk_pat env) pat
1340
1341 zonk_pat :: ZonkEnv -> Pat GhcTc -> TcM (ZonkEnv, Pat GhcTc)
1342 zonk_pat env (ParPat x lpar p rpar)
1343 = do { (env', p') <- zonkPat env p
1344 ; return (env', ParPat x lpar p' rpar) }
1345
1346 zonk_pat env (WildPat ty)
1347 = do { ty' <- zonkTcTypeToTypeX env ty
1348 ; return (env, WildPat ty') }
1349
1350 zonk_pat env (VarPat x (L l v))
1351 = do { v' <- zonkIdBndr env v
1352 ; return (extendIdZonkEnv env v', VarPat x (L l v')) }
1353
1354 zonk_pat env (LazyPat x pat)
1355 = do { (env', pat') <- zonkPat env pat
1356 ; return (env', LazyPat x pat') }
1357
1358 zonk_pat env (BangPat x pat)
1359 = do { (env', pat') <- zonkPat env pat
1360 ; return (env', BangPat x pat') }
1361
1362 zonk_pat env (AsPat x (L loc v) pat)
1363 = do { v' <- zonkIdBndr env v
1364 ; (env', pat') <- zonkPat (extendIdZonkEnv env v') pat
1365 ; return (env', AsPat x (L loc v') pat') }
1366
1367 zonk_pat env (ViewPat ty expr pat)
1368 = do { expr' <- zonkLExpr env expr
1369 ; (env', pat') <- zonkPat env pat
1370 ; ty' <- zonkTcTypeToTypeX env ty
1371 ; return (env', ViewPat ty' expr' pat') }
1372
1373 zonk_pat env (ListPat ty pats)
1374 = do { ty' <- zonkTcTypeToTypeX env ty
1375 ; (env', pats') <- zonkPats env pats
1376 ; return (env', ListPat ty' pats') }
1377
1378 zonk_pat env (TuplePat tys pats boxed)
1379 = do { tys' <- mapM (zonkTcTypeToTypeX env) tys
1380 ; (env', pats') <- zonkPats env pats
1381 ; return (env', TuplePat tys' pats' boxed) }
1382
1383 zonk_pat env (SumPat tys pat alt arity )
1384 = do { tys' <- mapM (zonkTcTypeToTypeX env) tys
1385 ; (env', pat') <- zonkPat env pat
1386 ; return (env', SumPat tys' pat' alt arity) }
1387
1388 zonk_pat env p@(ConPat { pat_args = args
1389 , pat_con_ext = p'@(ConPatTc
1390 { cpt_tvs = tyvars
1391 , cpt_dicts = evs
1392 , cpt_binds = binds
1393 , cpt_wrap = wrapper
1394 , cpt_arg_tys = tys
1395 })
1396 })
1397 = assert (all isImmutableTyVar tyvars) $
1398 do { new_tys <- mapM (zonkTcTypeToTypeX env) tys
1399 ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars
1400 -- Must zonk the existential variables, because their
1401 -- /kind/ need potential zonking.
1402 -- cf typecheck/should_compile/tc221.hs
1403 ; (env1, new_evs) <- zonkEvBndrsX env0 evs
1404 ; (env2, new_binds) <- zonkTcEvBinds env1 binds
1405 ; (env3, new_wrapper) <- zonkCoFn env2 wrapper
1406 ; (env', new_args) <- zonkConStuff env3 args
1407 ; pure ( env'
1408 , p
1409 { pat_args = new_args
1410 , pat_con_ext = p'
1411 { cpt_arg_tys = new_tys
1412 , cpt_tvs = new_tyvars
1413 , cpt_dicts = new_evs
1414 , cpt_binds = new_binds
1415 , cpt_wrap = new_wrapper
1416 }
1417 }
1418 )
1419 }
1420
1421 zonk_pat env (LitPat x lit) = return (env, LitPat x lit)
1422
1423 zonk_pat env (SigPat ty pat hs_ty)
1424 = do { ty' <- zonkTcTypeToTypeX env ty
1425 ; (env', pat') <- zonkPat env pat
1426 ; return (env', SigPat ty' pat' hs_ty) }
1427
1428 zonk_pat env (NPat ty (L l lit) mb_neg eq_expr)
1429 = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr
1430 ; (env2, mb_neg') <- case mb_neg of
1431 Nothing -> return (env1, Nothing)
1432 Just n -> second Just <$> zonkSyntaxExpr env1 n
1433
1434 ; lit' <- zonkOverLit env2 lit
1435 ; ty' <- zonkTcTypeToTypeX env2 ty
1436 ; return (env2, NPat ty' (L l lit') mb_neg' eq_expr') }
1437
1438 zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2)
1439 = do { (env1, e1') <- zonkSyntaxExpr env e1
1440 ; (env2, e2') <- zonkSyntaxExpr env1 e2
1441 ; n' <- zonkIdBndr env2 n
1442 ; lit1' <- zonkOverLit env2 lit1
1443 ; lit2' <- zonkOverLit env2 lit2
1444 ; ty' <- zonkTcTypeToTypeX env2 ty
1445 ; return (extendIdZonkEnv env2 n',
1446 NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') }
1447 zonk_pat env (XPat ext) = case ext of
1448 { ExpansionPat orig pat->
1449 do { (env, pat') <- zonk_pat env pat
1450 ; return $ (env, XPat $ ExpansionPat orig pat') }
1451 ; CoPat co_fn pat ty ->
1452 do { (env', co_fn') <- zonkCoFn env co_fn
1453 ; (env'', pat') <- zonkPat env' (noLocA pat)
1454 ; ty' <- zonkTcTypeToTypeX env'' ty
1455 ; return (env'', XPat $ CoPat co_fn' (unLoc pat') ty')
1456 }}
1457
1458 zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
1459
1460 ---------------------------
1461 zonkConStuff :: ZonkEnv -> HsConPatDetails GhcTc
1462 -> TcM (ZonkEnv, HsConPatDetails GhcTc)
1463 zonkConStuff env (PrefixCon tyargs pats)
1464 = do { (env', pats') <- zonkPats env pats
1465 ; return (env', PrefixCon tyargs pats') }
1466
1467 zonkConStuff env (InfixCon p1 p2)
1468 = do { (env1, p1') <- zonkPat env p1
1469 ; (env', p2') <- zonkPat env1 p2
1470 ; return (env', InfixCon p1' p2') }
1471
1472 zonkConStuff env (RecCon (HsRecFields rpats dd))
1473 = do { (env', pats') <- zonkPats env (map (hfbRHS . unLoc) rpats)
1474 ; let rpats' = zipWith (\(L l rp) p' ->
1475 L l (rp { hfbRHS = p' }))
1476 rpats pats'
1477 ; return (env', RecCon (HsRecFields rpats' dd)) }
1478 -- Field selectors have declared types; hence no zonking
1479
1480 ---------------------------
1481 zonkPats :: ZonkEnv -> [LPat GhcTc] -> TcM (ZonkEnv, [LPat GhcTc])
1482 zonkPats env [] = return (env, [])
1483 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
1484 ; (env', pats') <- zonkPats env1 pats
1485 ; return (env', pat':pats') }
1486
1487 {-
1488 ************************************************************************
1489 * *
1490 \subsection[BackSubst-Foreign]{Foreign exports}
1491 * *
1492 ************************************************************************
1493 -}
1494
1495 zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTc]
1496 -> TcM [LForeignDecl GhcTc]
1497 zonkForeignExports env ls = mapM (wrapLocMA (zonkForeignExport env)) ls
1498
1499 zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTc -> TcM (ForeignDecl GhcTc)
1500 zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co
1501 , fd_fe = spec })
1502 = return (ForeignExport { fd_name = zonkLIdOcc env i
1503 , fd_sig_ty = undefined, fd_e_ext = co
1504 , fd_fe = spec })
1505 zonkForeignExport _ for_imp
1506 = return for_imp -- Foreign imports don't need zonking
1507
1508 zonkRules :: ZonkEnv -> [LRuleDecl GhcTc] -> TcM [LRuleDecl GhcTc]
1509 zonkRules env rs = mapM (wrapLocMA (zonkRule env)) rs
1510
1511 zonkRule :: ZonkEnv -> RuleDecl GhcTc -> TcM (RuleDecl GhcTc)
1512 zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-}
1513 , rd_lhs = lhs
1514 , rd_rhs = rhs })
1515 = do { (env_inside, new_tm_bndrs) <- mapAccumLM zonk_tm_bndr env tm_bndrs
1516
1517 ; let env_lhs = setZonkType env_inside SkolemiseFlexi
1518 -- See Note [Zonking the LHS of a RULE]
1519
1520 ; new_lhs <- zonkLExpr env_lhs lhs
1521 ; new_rhs <- zonkLExpr env_inside rhs
1522
1523 ; return $ rule { rd_tmvs = new_tm_bndrs
1524 , rd_lhs = new_lhs
1525 , rd_rhs = new_rhs } }
1526 where
1527 zonk_tm_bndr :: ZonkEnv -> LRuleBndr GhcTc -> TcM (ZonkEnv, LRuleBndr GhcTc)
1528 zonk_tm_bndr env (L l (RuleBndr x (L loc v)))
1529 = do { (env', v') <- zonk_it env v
1530 ; return (env', L l (RuleBndr x (L loc v'))) }
1531 zonk_tm_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig"
1532
1533 zonk_it env v
1534 | isId v = do { v' <- zonkIdBndr env v
1535 ; return (extendIdZonkEnvRec env [v'], v') }
1536 | otherwise = assert (isImmutableTyVar v)
1537 zonkTyBndrX env v
1538 -- DV: used to be return (env,v) but that is plain
1539 -- wrong because we may need to go inside the kind
1540 -- of v and zonk there!
1541
1542 {-
1543 ************************************************************************
1544 * *
1545 Constraints and evidence
1546 * *
1547 ************************************************************************
1548 -}
1549
1550 zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
1551 zonkEvTerm env (EvExpr e)
1552 = EvExpr <$> zonkCoreExpr env e
1553 zonkEvTerm env (EvTypeable ty ev)
1554 = EvTypeable <$> zonkTcTypeToTypeX env ty <*> zonkEvTypeable env ev
1555 zonkEvTerm env (EvFun { et_tvs = tvs, et_given = evs
1556 , et_binds = ev_binds, et_body = body_id })
1557 = do { (env0, new_tvs) <- zonkTyBndrsX env tvs
1558 ; (env1, new_evs) <- zonkEvBndrsX env0 evs
1559 ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
1560 ; let new_body_id = zonkIdOcc env2 body_id
1561 ; return (EvFun { et_tvs = new_tvs, et_given = new_evs
1562 , et_binds = new_ev_binds, et_body = new_body_id }) }
1563
1564 zonkCoreExpr :: ZonkEnv -> CoreExpr -> TcM CoreExpr
1565 zonkCoreExpr env (Var v)
1566 | isCoVar v
1567 = Coercion <$> zonkCoVarOcc env v
1568 | otherwise
1569 = return (Var $ zonkIdOcc env v)
1570 zonkCoreExpr _ (Lit l)
1571 = return $ Lit l
1572 zonkCoreExpr env (Coercion co)
1573 = Coercion <$> zonkCoToCo env co
1574 zonkCoreExpr env (Type ty)
1575 = Type <$> zonkTcTypeToTypeX env ty
1576
1577 zonkCoreExpr env (Cast e co)
1578 = Cast <$> zonkCoreExpr env e <*> zonkCoToCo env co
1579 zonkCoreExpr env (Tick t e)
1580 = Tick t <$> zonkCoreExpr env e -- Do we need to zonk in ticks?
1581
1582 zonkCoreExpr env (App e1 e2)
1583 = App <$> zonkCoreExpr env e1 <*> zonkCoreExpr env e2
1584 zonkCoreExpr env (Lam v e)
1585 = do { (env1, v') <- zonkCoreBndrX env v
1586 ; Lam v' <$> zonkCoreExpr env1 e }
1587 zonkCoreExpr env (Let bind e)
1588 = do (env1, bind') <- zonkCoreBind env bind
1589 Let bind'<$> zonkCoreExpr env1 e
1590 zonkCoreExpr env (Case scrut b ty alts)
1591 = do scrut' <- zonkCoreExpr env scrut
1592 ty' <- zonkTcTypeToTypeX env ty
1593 b' <- zonkIdBndr env b
1594 let env1 = extendIdZonkEnv env b'
1595 alts' <- mapM (zonkCoreAlt env1) alts
1596 return $ Case scrut' b' ty' alts'
1597
1598 zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt
1599 zonkCoreAlt env (Alt dc bndrs rhs)
1600 = do (env1, bndrs') <- zonkCoreBndrsX env bndrs
1601 rhs' <- zonkCoreExpr env1 rhs
1602 return $ Alt dc bndrs' rhs'
1603
1604 zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind)
1605 zonkCoreBind env (NonRec v e)
1606 = do v' <- zonkIdBndr env v
1607 e' <- zonkCoreExpr env e
1608 let env1 = extendIdZonkEnv env v'
1609 return (env1, NonRec v' e')
1610 zonkCoreBind env (Rec pairs)
1611 = do (env1, pairs') <- fixM go
1612 return (env1, Rec pairs')
1613 where
1614 go ~(_, new_pairs) = do
1615 let env1 = extendIdZonkEnvRec env (map fst new_pairs)
1616 pairs' <- mapM (zonkCorePair env1) pairs
1617 return (env1, pairs')
1618
1619 zonkCorePair :: ZonkEnv -> (CoreBndr, CoreExpr) -> TcM (CoreBndr, CoreExpr)
1620 zonkCorePair env (v,e) = (,) <$> zonkIdBndr env v <*> zonkCoreExpr env e
1621
1622 zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
1623 zonkEvTypeable env (EvTypeableTyCon tycon e)
1624 = do { e' <- mapM (zonkEvTerm env) e
1625 ; return $ EvTypeableTyCon tycon e' }
1626 zonkEvTypeable env (EvTypeableTyApp t1 t2)
1627 = do { t1' <- zonkEvTerm env t1
1628 ; t2' <- zonkEvTerm env t2
1629 ; return (EvTypeableTyApp t1' t2') }
1630 zonkEvTypeable env (EvTypeableTrFun tm t1 t2)
1631 = do { tm' <- zonkEvTerm env tm
1632 ; t1' <- zonkEvTerm env t1
1633 ; t2' <- zonkEvTerm env t2
1634 ; return (EvTypeableTrFun tm' t1' t2') }
1635 zonkEvTypeable env (EvTypeableTyLit t1)
1636 = do { t1' <- zonkEvTerm env t1
1637 ; return (EvTypeableTyLit t1') }
1638
1639 zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])
1640 zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs
1641 ; return (env, [EvBinds (unionManyBags bs')]) }
1642
1643 zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
1644 zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs
1645 ; return (env', EvBinds bs') }
1646
1647 zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind)
1648 zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var
1649 zonk_tc_ev_binds env (EvBinds bs) = zonkEvBinds env bs
1650
1651 zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
1652 zonkEvBindsVar env (EvBindsVar { ebv_binds = ref })
1653 = do { bs <- readMutVar ref
1654 ; zonkEvBinds env (evBindMapBinds bs) }
1655 zonkEvBindsVar env (CoEvBindsVar {}) = return (env, emptyBag)
1656
1657 zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
1658 zonkEvBinds env binds
1659 = {-# SCC "zonkEvBinds" #-}
1660 fixM (\ ~( _, new_binds) -> do
1661 { let env1 = extendIdZonkEnvRec env (collect_ev_bndrs new_binds)
1662 ; binds' <- mapBagM (zonkEvBind env1) binds
1663 ; return (env1, binds') })
1664 where
1665 collect_ev_bndrs :: Bag EvBind -> [EvVar]
1666 collect_ev_bndrs = foldr add []
1667 add (EvBind { eb_lhs = var }) vars = var : vars
1668
1669 zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
1670 zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term })
1671 = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var
1672
1673 -- Optimise the common case of Refl coercions
1674 -- See Note [Optimise coercion zonking]
1675 -- This has a very big effect on some programs (eg #5030)
1676
1677 ; term' <- case getEqPredTys_maybe (idType var') of
1678 Just (r, ty1, ty2) | ty1 `eqType` ty2
1679 -> return (evCoercion (mkTcReflCo r ty1))
1680 _other -> zonkEvTerm env term
1681
1682 ; return (bind { eb_lhs = var', eb_rhs = term' }) }
1683
1684 {- Note [Optimise coercion zonking]
1685 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1686 When optimising evidence binds we may come across situations where
1687 a coercion looks like
1688 cv = ReflCo ty
1689 or cv1 = cv2
1690 where the type 'ty' is big. In such cases it is a waste of time to zonk both
1691 * The variable on the LHS
1692 * The coercion on the RHS
1693 Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just
1694 use Refl on the right, ignoring the actual coercion on the RHS.
1695
1696 This can have a very big effect, because the constraint solver sometimes does go
1697 to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf #5030)
1698
1699
1700 ************************************************************************
1701 * *
1702 Zonking types
1703 * *
1704 ************************************************************************
1705 -}
1706
1707 {- Note [Sharing when zonking to Type]
1708 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1709 Problem:
1710
1711 In GHC.Tc.Utils.TcMType.zonkTcTyVar, we short-circuit (Indirect ty) to
1712 (Indirect zty), see Note [Sharing in zonking] in GHC.Tc.Utils.TcMType. But we
1713 /can't/ do this when zonking a TcType to a Type (#15552, esp
1714 comment:3). Suppose we have
1715
1716 alpha -> alpha
1717 where
1718 alpha is already unified:
1719 alpha := T{tc-tycon} Int -> Int
1720 and T is knot-tied
1721
1722 By "knot-tied" I mean that the occurrence of T is currently a TcTyCon,
1723 but the global env contains a mapping "T" :-> T{knot-tied-tc}. See
1724 Note [Type checking recursive type and class declarations] in
1725 GHC.Tc.TyCl.
1726
1727 Now we call zonkTcTypeToType on that (alpha -> alpha). If we follow
1728 the same path as Note [Sharing in zonking] in GHC.Tc.Utils.TcMType, we'll
1729 update alpha to
1730 alpha := T{knot-tied-tc} Int -> Int
1731
1732 But alas, if we encounter alpha for a /second/ time, we end up
1733 looking at T{knot-tied-tc} and fall into a black hole. The whole
1734 point of zonkTcTypeToType is that it produces a type full of
1735 knot-tied tycons, and you must not look at the result!!
1736
1737 To put it another way (zonkTcTypeToType . zonkTcTypeToType) is not
1738 the same as zonkTcTypeToType. (If we distinguished TcType from
1739 Type, this issue would have been a type error!)
1740
1741 Solutions: (see #15552 for other variants)
1742
1743 One possible solution is simply not to do the short-circuiting.
1744 That has less sharing, but maybe sharing is rare. And indeed,
1745 that usually turns out to be viable from a perf point of view
1746
1747 But zonkTyVarOcc implements something a bit better
1748
1749 * ZonkEnv contains ze_meta_tv_env, which maps
1750 from a MetaTyVar (unification variable)
1751 to a Type (not a TcType)
1752
1753 * In zonkTyVarOcc, we check this map to see if we have zonked
1754 this variable before. If so, use the previous answer; if not
1755 zonk it, and extend the map.
1756
1757 * The map is of course stateful, held in a TcRef. (That is unlike
1758 the treatment of lexically-scoped variables in ze_tv_env and
1759 ze_id_env.)
1760
1761 * In zonkTyVarOcc we read the TcRef to look up the unification
1762 variable:
1763 - if we get a hit we use the zonked result;
1764 - if not, in zonk_meta we see if the variable is `Indirect ty`,
1765 zonk that, and update the map (in finish_meta)
1766 But Nota Bene that the "update map" step must re-read the TcRef
1767 (or, more precisely, use updTcRef) because the zonking of the
1768 `Indirect ty` may have added lots of stuff to the map. See
1769 #19668 for an example where this made an asymptotic difference!
1770
1771 Is it worth the extra work of carrying ze_meta_tv_env? Some
1772 non-systematic perf measurements suggest that compiler allocation is
1773 reduced overall (by 0.5% or so) but compile time really doesn't
1774 change. But in some cases it makes a HUGE difference: see test
1775 T9198 and #19668. So yes, it seems worth it.
1776 -}
1777
1778 zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType
1779 zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi
1780 , ze_tv_env = tv_env
1781 , ze_meta_tv_env = mtv_env_ref }) tv
1782 | isTcTyVar tv
1783 = case tcTyVarDetails tv of
1784 SkolemTv {} -> lookup_in_tv_env
1785 RuntimeUnk {} -> lookup_in_tv_env
1786 MetaTv { mtv_ref = ref }
1787 -> do { mtv_env <- readTcRef mtv_env_ref
1788 -- See Note [Sharing when zonking to Type]
1789 ; case lookupVarEnv mtv_env tv of
1790 Just ty -> return ty
1791 Nothing -> do { mtv_details <- readTcRef ref
1792 ; zonk_meta ref mtv_details } }
1793 | otherwise
1794 = lookup_in_tv_env
1795
1796 where
1797 lookup_in_tv_env -- Look up in the env just as we do for Ids
1798 = case lookupVarEnv tv_env tv of
1799 Nothing -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv
1800 Just tv' -> return (mkTyVarTy tv')
1801
1802 zonk_meta ref Flexi
1803 = do { kind <- zonkTcTypeToTypeX env (tyVarKind tv)
1804 ; ty <- commitFlexi flexi tv kind
1805 ; writeMetaTyVarRef tv ref ty -- Belt and braces
1806 ; finish_meta ty }
1807
1808 zonk_meta _ (Indirect ty)
1809 = do { zty <- zonkTcTypeToTypeX env ty
1810 ; finish_meta zty }
1811
1812 finish_meta ty
1813 = do { updTcRef mtv_env_ref (\env -> extendVarEnv env tv ty)
1814 ; return ty }
1815
1816 lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar
1817 lookupTyVarOcc (ZonkEnv { ze_tv_env = tv_env }) tv
1818 = lookupVarEnv tv_env tv
1819
1820 commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type
1821 -- Only monadic so we can do tc-tracing
1822 commitFlexi flexi tv zonked_kind
1823 = case flexi of
1824 SkolemiseFlexi -> return (mkTyVarTy (mkTyVar name zonked_kind))
1825
1826 DefaultFlexi
1827 | isRuntimeRepTy zonked_kind
1828 -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv)
1829 ; return liftedRepTy }
1830 | isMultiplicityTy zonked_kind
1831 -> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv)
1832 ; return manyDataConTy }
1833 | otherwise
1834 -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv)
1835 ; return (anyTypeOfKind zonked_kind) }
1836
1837 RuntimeUnkFlexi
1838 -> do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv)
1839 ; return (mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk)) }
1840 -- This is where RuntimeUnks are born:
1841 -- otherwise-unconstrained unification variables are
1842 -- turned into RuntimeUnks as they leave the
1843 -- typechecker's monad
1844
1845 NoFlexi -> pprPanic "NoFlexi" (ppr tv <+> dcolon <+> ppr zonked_kind)
1846
1847 where
1848 name = tyVarName tv
1849
1850 zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion
1851 zonkCoVarOcc (ZonkEnv { ze_tv_env = tyco_env }) cv
1852 | Just cv' <- lookupVarEnv tyco_env cv -- don't look in the knot-tied env
1853 = return $ mkCoVarCo cv'
1854 | otherwise
1855 = do { cv' <- zonkCoVar cv; return (mkCoVarCo cv') }
1856
1857 zonkCoHole :: ZonkEnv -> CoercionHole -> TcM Coercion
1858 zonkCoHole env hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })
1859 = do { contents <- readTcRef ref
1860 ; case contents of
1861 Just co -> do { co' <- zonkCoToCo env co
1862 ; checkCoercionHole cv co' }
1863
1864 -- This next case should happen only in the presence of
1865 -- (undeferred) type errors. Originally, I put in a panic
1866 -- here, but that caused too many uses of `failIfErrsM`.
1867 Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole)
1868 ; when debugIsOn $
1869 whenNoErrs $
1870 massertPpr False
1871 (text "Type-correct unfilled coercion hole"
1872 <+> ppr hole)
1873 ; cv' <- zonkCoVar cv
1874 ; return $ mkCoVarCo cv' } }
1875 -- This will be an out-of-scope variable, but keeping
1876 -- this as a coercion hole led to #15787
1877
1878 zonk_tycomapper :: TyCoMapper ZonkEnv TcM
1879 zonk_tycomapper = TyCoMapper
1880 { tcm_tyvar = zonkTyVarOcc
1881 , tcm_covar = zonkCoVarOcc
1882 , tcm_hole = zonkCoHole
1883 , tcm_tycobinder = \env tv _vis -> zonkTyBndrX env tv
1884 , tcm_tycon = zonkTcTyConToTyCon }
1885
1886 -- Zonk a TyCon by changing a TcTyCon to a regular TyCon
1887 zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon
1888 zonkTcTyConToTyCon tc
1889 | isTcTyCon tc = do { thing <- tcLookupGlobalOnly (getName tc)
1890 ; case thing of
1891 ATyCon real_tc -> return real_tc
1892 _ -> pprPanic "zonkTcTyCon" (ppr tc $$ ppr thing) }
1893 | otherwise = return tc -- it's already zonked
1894
1895 -- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType.
1896 zonkTcTypeToType :: TcType -> TcM Type
1897 zonkTcTypeToType ty = initZonkEnv $ \ ze -> zonkTcTypeToTypeX ze ty
1898
1899 zonkScaledTcTypeToTypeX :: ZonkEnv -> Scaled TcType -> TcM (Scaled TcType)
1900 zonkScaledTcTypeToTypeX env (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX env m
1901 <*> zonkTcTypeToTypeX env ty
1902
1903 zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type
1904 zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type]
1905 zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion
1906 (zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkCoToCo, _)
1907 = mapTyCoX zonk_tycomapper
1908
1909 zonkScaledTcTypesToTypesX :: ZonkEnv -> [Scaled TcType] -> TcM [Scaled Type]
1910 zonkScaledTcTypesToTypesX env scaled_tys =
1911 mapM (zonkScaledTcTypeToTypeX env) scaled_tys
1912
1913 zonkTcMethInfoToMethInfoX :: ZonkEnv -> TcMethInfo -> TcM MethInfo
1914 zonkTcMethInfoToMethInfoX ze (name, ty, gdm_spec)
1915 = do { ty' <- zonkTcTypeToTypeX ze ty
1916 ; gdm_spec' <- zonk_gdm gdm_spec
1917 ; return (name, ty', gdm_spec') }
1918 where
1919 zonk_gdm :: Maybe (DefMethSpec (SrcSpan, TcType))
1920 -> TcM (Maybe (DefMethSpec (SrcSpan, Type)))
1921 zonk_gdm Nothing = return Nothing
1922 zonk_gdm (Just VanillaDM) = return (Just VanillaDM)
1923 zonk_gdm (Just (GenericDM (loc, ty)))
1924 = do { ty' <- zonkTcTypeToTypeX ze ty
1925 ; return (Just (GenericDM (loc, ty'))) }
1926
1927 ---------------------------------------
1928 {- Note [Zonking the LHS of a RULE]
1929 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1930 See also GHC.HsToCore.Binds Note [Free tyvars on rule LHS]
1931
1932 We need to gather the type variables mentioned on the LHS so we can
1933 quantify over them. Example:
1934 data T a = C
1935
1936 foo :: T a -> Int
1937 foo C = 1
1938
1939 {-# RULES "myrule" foo C = 1 #-}
1940
1941 After type checking the LHS becomes (foo alpha (C alpha)) and we do
1942 not want to zap the unbound meta-tyvar 'alpha' to Any, because that
1943 limits the applicability of the rule. Instead, we want to quantify
1944 over it!
1945
1946 We do this in two stages.
1947
1948 * During zonking, we skolemise the TcTyVar 'alpha' to TyVar 'a'. We
1949 do this by using zonkTvSkolemising as the UnboundTyVarZonker in the
1950 ZonkEnv. (This is in fact the whole reason that the ZonkEnv has a
1951 UnboundTyVarZonker.)
1952
1953 * In GHC.HsToCore.Binds, we quantify over it. See GHC.HsToCore.Binds
1954 Note [Free tyvars on rule LHS]
1955
1956 Quantifying here is awkward because (a) the data type is big and (b)
1957 finding the free type vars of an expression is necessarily monadic
1958 operation. (consider /\a -> f @ b, where b is side-effected to a)
1959 -}