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