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