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