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