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