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