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