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