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