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