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