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