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