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