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