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