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