Refactor visible type application.
[ghc.git] / compiler / typecheck / TcHsSyn.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The AQUA Project, Glasgow University, 1996-1998
4
5
6 TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker
7
8 This module is an extension of @HsSyn@ syntax, for use in the type
9 checker.
10 -}
11
12 {-# LANGUAGE CPP, 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 env (HsAppTypeOut e t)
613 = do new_e <- zonkLExpr env e
614 return (HsAppTypeOut new_e t)
615 -- NB: the type is an HsType; can't zonk that!
616
617 zonkExpr _ e@(HsRnBracketOut _ _)
618 = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)
619
620 zonkExpr env (HsTcBracketOut body bs)
621 = do bs' <- mapM zonk_b bs
622 return (HsTcBracketOut body bs')
623 where
624 zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
625 return (PendingTcSplice n e')
626
627 zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
628 return (HsSpliceE s)
629
630 zonkExpr env (OpApp e1 op fixity e2)
631 = do new_e1 <- zonkLExpr env e1
632 new_op <- zonkLExpr env op
633 new_e2 <- zonkLExpr env e2
634 return (OpApp new_e1 new_op fixity new_e2)
635
636 zonkExpr env (NegApp expr op)
637 = do (env', new_op) <- zonkSyntaxExpr env op
638 new_expr <- zonkLExpr env' expr
639 return (NegApp new_expr new_op)
640
641 zonkExpr env (HsPar e)
642 = do new_e <- zonkLExpr env e
643 return (HsPar new_e)
644
645 zonkExpr env (SectionL expr op)
646 = do new_expr <- zonkLExpr env expr
647 new_op <- zonkLExpr env op
648 return (SectionL new_expr new_op)
649
650 zonkExpr env (SectionR op expr)
651 = do new_op <- zonkLExpr env op
652 new_expr <- zonkLExpr env expr
653 return (SectionR new_op new_expr)
654
655 zonkExpr env (ExplicitTuple tup_args boxed)
656 = do { new_tup_args <- mapM zonk_tup_arg tup_args
657 ; return (ExplicitTuple new_tup_args boxed) }
658 where
659 zonk_tup_arg (L l (Present e)) = do { e' <- zonkLExpr env e
660 ; return (L l (Present e')) }
661 zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t
662 ; return (L l (Missing t')) }
663
664 zonkExpr env (HsCase expr ms)
665 = do new_expr <- zonkLExpr env expr
666 new_ms <- zonkMatchGroup env zonkLExpr ms
667 return (HsCase new_expr new_ms)
668
669 zonkExpr env (HsIf Nothing e1 e2 e3)
670 = do new_e1 <- zonkLExpr env e1
671 new_e2 <- zonkLExpr env e2
672 new_e3 <- zonkLExpr env e3
673 return (HsIf Nothing new_e1 new_e2 new_e3)
674
675 zonkExpr env (HsIf (Just fun) e1 e2 e3)
676 = do (env1, new_fun) <- zonkSyntaxExpr env fun
677 new_e1 <- zonkLExpr env1 e1
678 new_e2 <- zonkLExpr env1 e2
679 new_e3 <- zonkLExpr env1 e3
680 return (HsIf (Just new_fun) new_e1 new_e2 new_e3)
681
682 zonkExpr env (HsMultiIf ty alts)
683 = do { alts' <- mapM (wrapLocM zonk_alt) alts
684 ; ty' <- zonkTcTypeToType env ty
685 ; return $ HsMultiIf ty' alts' }
686 where zonk_alt (GRHS guard expr)
687 = do { (env', guard') <- zonkStmts env zonkLExpr guard
688 ; expr' <- zonkLExpr env' expr
689 ; return $ GRHS guard' expr' }
690
691 zonkExpr env (HsLet (L l binds) expr)
692 = do (new_env, new_binds) <- zonkLocalBinds env binds
693 new_expr <- zonkLExpr new_env expr
694 return (HsLet (L l new_binds) new_expr)
695
696 zonkExpr env (HsDo do_or_lc (L l stmts) ty)
697 = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
698 new_ty <- zonkTcTypeToType env ty
699 return (HsDo do_or_lc (L l new_stmts) new_ty)
700
701 zonkExpr env (ExplicitList ty wit exprs)
702 = do (env1, new_wit) <- zonkWit env wit
703 new_ty <- zonkTcTypeToType env1 ty
704 new_exprs <- zonkLExprs env1 exprs
705 return (ExplicitList new_ty new_wit new_exprs)
706 where zonkWit env Nothing = return (env, Nothing)
707 zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
708
709 zonkExpr env (ExplicitPArr ty exprs)
710 = do new_ty <- zonkTcTypeToType env ty
711 new_exprs <- zonkLExprs env exprs
712 return (ExplicitPArr new_ty new_exprs)
713
714 zonkExpr env expr@(RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds })
715 = do { new_con_expr <- zonkExpr env con_expr
716 ; new_rbinds <- zonkRecFields env rbinds
717 ; return (expr { rcon_con_expr = new_con_expr
718 , rcon_flds = new_rbinds }) }
719
720 zonkExpr env (RecordUpd { rupd_expr = expr, rupd_flds = rbinds
721 , rupd_cons = cons, rupd_in_tys = in_tys
722 , rupd_out_tys = out_tys, rupd_wrap = req_wrap })
723 = do { new_expr <- zonkLExpr env expr
724 ; new_in_tys <- mapM (zonkTcTypeToType env) in_tys
725 ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
726 ; new_rbinds <- zonkRecUpdFields env rbinds
727 ; (_, new_recwrap) <- zonkCoFn env req_wrap
728 ; return (RecordUpd { rupd_expr = new_expr, rupd_flds = new_rbinds
729 , rupd_cons = cons, rupd_in_tys = new_in_tys
730 , rupd_out_tys = new_out_tys, rupd_wrap = new_recwrap }) }
731
732 zonkExpr env (ExprWithTySigOut e ty)
733 = do { e' <- zonkLExpr env e
734 ; return (ExprWithTySigOut e' ty) }
735
736 zonkExpr env (ArithSeq expr wit info)
737 = do (env1, new_wit) <- zonkWit env wit
738 new_expr <- zonkExpr env expr
739 new_info <- zonkArithSeq env1 info
740 return (ArithSeq new_expr new_wit new_info)
741 where zonkWit env Nothing = return (env, Nothing)
742 zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
743
744 zonkExpr env (PArrSeq expr info)
745 = do new_expr <- zonkExpr env expr
746 new_info <- zonkArithSeq env info
747 return (PArrSeq new_expr new_info)
748
749 zonkExpr env (HsSCC src lbl expr)
750 = do new_expr <- zonkLExpr env expr
751 return (HsSCC src lbl new_expr)
752
753 zonkExpr env (HsTickPragma src info srcInfo expr)
754 = do new_expr <- zonkLExpr env expr
755 return (HsTickPragma src info srcInfo new_expr)
756
757 -- hdaume: core annotations
758 zonkExpr env (HsCoreAnn src lbl expr)
759 = do new_expr <- zonkLExpr env expr
760 return (HsCoreAnn src lbl new_expr)
761
762 -- arrow notation extensions
763 zonkExpr env (HsProc pat body)
764 = do { (env1, new_pat) <- zonkPat env pat
765 ; new_body <- zonkCmdTop env1 body
766 ; return (HsProc new_pat new_body) }
767
768 -- StaticPointers extension
769 zonkExpr env (HsStatic expr)
770 = HsStatic <$> zonkLExpr env expr
771
772 zonkExpr env (HsWrap co_fn expr)
773 = do (env1, new_co_fn) <- zonkCoFn env co_fn
774 new_expr <- zonkExpr env1 expr
775 return (HsWrap new_co_fn new_expr)
776
777 zonkExpr _ (HsUnboundVar v)
778 = return (HsUnboundVar v)
779
780 zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
781
782 -------------------------------------------------------------------------
783 {-
784 Note [Skolems in zonkSyntaxExpr]
785 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
786 Consider rebindable syntax with something like
787
788 (>>=) :: (forall x. blah) -> (forall y. blah') -> blah''
789
790 The x and y become skolems that are in scope when type-checking the
791 arguments to the bind. This means that we must extend the ZonkEnv with
792 these skolems when zonking the arguments to the bind. But the skolems
793 are different between the two arguments, and so we should theoretically
794 carry around different environments to use for the different arguments.
795
796 However, this becomes a logistical nightmare, especially in dealing with
797 the more exotic Stmt forms. So, we simplify by making the critical
798 assumption that the uniques of the skolems are different. (This assumption
799 is justified by the use of newUnique in TcMType.instSkolTyCoVarX.)
800 Now, we can safely just extend one environment.
801 -}
802
803 -- See Note [Skolems in zonkSyntaxExpr]
804 zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr TcId
805 -> TcM (ZonkEnv, SyntaxExpr Id)
806 zonkSyntaxExpr env (SyntaxExpr { syn_expr = expr
807 , syn_arg_wraps = arg_wraps
808 , syn_res_wrap = res_wrap })
809 = do { (env0, res_wrap') <- zonkCoFn env res_wrap
810 ; expr' <- zonkExpr env0 expr
811 ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps
812 ; return (env1, SyntaxExpr { syn_expr = expr'
813 , syn_arg_wraps = arg_wraps'
814 , syn_res_wrap = res_wrap' }) }
815
816 -------------------------------------------------------------------------
817
818 zonkLCmd :: ZonkEnv -> LHsCmd TcId -> TcM (LHsCmd Id)
819 zonkCmd :: ZonkEnv -> HsCmd TcId -> TcM (HsCmd Id)
820
821 zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd
822
823 zonkCmd env (HsCmdWrap w cmd)
824 = do { (env1, w') <- zonkCoFn env w
825 ; cmd' <- zonkCmd env1 cmd
826 ; return (HsCmdWrap w' cmd') }
827 zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)
828 = do new_e1 <- zonkLExpr env e1
829 new_e2 <- zonkLExpr env e2
830 new_ty <- zonkTcTypeToType env ty
831 return (HsCmdArrApp new_e1 new_e2 new_ty ho rl)
832
833 zonkCmd env (HsCmdArrForm op fixity args)
834 = do new_op <- zonkLExpr env op
835 new_args <- mapM (zonkCmdTop env) args
836 return (HsCmdArrForm new_op fixity new_args)
837
838 zonkCmd env (HsCmdApp c e)
839 = do new_c <- zonkLCmd env c
840 new_e <- zonkLExpr env e
841 return (HsCmdApp new_c new_e)
842
843 zonkCmd env (HsCmdLam matches)
844 = do new_matches <- zonkMatchGroup env zonkLCmd matches
845 return (HsCmdLam new_matches)
846
847 zonkCmd env (HsCmdPar c)
848 = do new_c <- zonkLCmd env c
849 return (HsCmdPar new_c)
850
851 zonkCmd env (HsCmdCase expr ms)
852 = do new_expr <- zonkLExpr env expr
853 new_ms <- zonkMatchGroup env zonkLCmd ms
854 return (HsCmdCase new_expr new_ms)
855
856 zonkCmd env (HsCmdIf eCond ePred cThen cElse)
857 = do { (env1, new_eCond) <- zonkWit env eCond
858 ; new_ePred <- zonkLExpr env1 ePred
859 ; new_cThen <- zonkLCmd env1 cThen
860 ; new_cElse <- zonkLCmd env1 cElse
861 ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
862 where
863 zonkWit env Nothing = return (env, Nothing)
864 zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w
865
866 zonkCmd env (HsCmdLet (L l binds) cmd)
867 = do (new_env, new_binds) <- zonkLocalBinds env binds
868 new_cmd <- zonkLCmd new_env cmd
869 return (HsCmdLet (L l new_binds) new_cmd)
870
871 zonkCmd env (HsCmdDo (L l stmts) ty)
872 = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
873 new_ty <- zonkTcTypeToType env ty
874 return (HsCmdDo (L l new_stmts) new_ty)
875
876
877
878
879
880 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
881 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
882
883 zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
884 zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
885 = do new_cmd <- zonkLCmd env cmd
886 new_stack_tys <- zonkTcTypeToType env stack_tys
887 new_ty <- zonkTcTypeToType env ty
888 new_ids <- mapSndM (zonkExpr env) ids
889 return (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
890
891 -------------------------------------------------------------------------
892 zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
893 zonkCoFn env WpHole = return (env, WpHole)
894 zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
895 ; (env2, c2') <- zonkCoFn env1 c2
896 ; return (env2, WpCompose c1' c2') }
897 zonkCoFn env (WpFun c1 c2 t1) = do { (env1, c1') <- zonkCoFn env c1
898 ; (env2, c2') <- zonkCoFn env1 c2
899 ; t1' <- zonkTcTypeToType env2 t1
900 ; return (env2, WpFun c1' c2' t1') }
901 zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co
902 ; return (env, WpCast co') }
903 zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev
904 ; return (env', WpEvLam ev') }
905 zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg
906 ; return (env, WpEvApp arg') }
907 zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv )
908 do { (env', tv') <- zonkTyBndrX env tv
909 ; return (env', WpTyLam tv') }
910 zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty
911 ; return (env, WpTyApp ty') }
912 zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs
913 ; return (env1, WpLet bs') }
914
915 -------------------------------------------------------------------------
916 zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
917 zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
918 = do { ty' <- zonkTcTypeToType env ty
919 ; e' <- zonkExpr env e
920 ; return (lit { ol_witness = e', ol_type = ty' }) }
921
922 -------------------------------------------------------------------------
923 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
924
925 zonkArithSeq env (From e)
926 = do new_e <- zonkLExpr env e
927 return (From new_e)
928
929 zonkArithSeq env (FromThen e1 e2)
930 = do new_e1 <- zonkLExpr env e1
931 new_e2 <- zonkLExpr env e2
932 return (FromThen new_e1 new_e2)
933
934 zonkArithSeq env (FromTo e1 e2)
935 = do new_e1 <- zonkLExpr env e1
936 new_e2 <- zonkLExpr env e2
937 return (FromTo new_e1 new_e2)
938
939 zonkArithSeq env (FromThenTo e1 e2 e3)
940 = do new_e1 <- zonkLExpr env e1
941 new_e2 <- zonkLExpr env e2
942 new_e3 <- zonkLExpr env e3
943 return (FromThenTo new_e1 new_e2 new_e3)
944
945
946 -------------------------------------------------------------------------
947 zonkStmts :: ZonkEnv
948 -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
949 -> [LStmt TcId (Located (body TcId))] -> TcM (ZonkEnv, [LStmt Id (Located (body Id))])
950 zonkStmts env _ [] = return (env, [])
951 zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s
952 ; (env2, ss') <- zonkStmts env1 zBody ss
953 ; return (env2, s' : ss') }
954
955 zonkStmt :: ZonkEnv
956 -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
957 -> Stmt TcId (Located (body TcId)) -> TcM (ZonkEnv, Stmt Id (Located (body Id)))
958 zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op bind_ty)
959 = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op
960 ; new_bind_ty <- zonkTcTypeToType env1 bind_ty
961 ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs
962 ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs]
963 env2 = extendIdZonkEnvRec env1 new_binders
964 ; new_mzip <- zonkExpr env2 mzip_op
965 ; return (env2, ParStmt new_stmts_w_bndrs new_mzip new_bind_op new_bind_ty) }
966 where
967 zonk_branch env1 (ParStmtBlock stmts bndrs return_op)
968 = do { (env2, new_stmts) <- zonkStmts env1 zonkLExpr stmts
969 ; (env3, new_return) <- zonkSyntaxExpr env2 return_op
970 ; return (ParStmtBlock new_stmts (zonkIdOccs env3 bndrs) new_return) }
971
972 zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
973 , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id
974 , recS_bind_fn = bind_id, recS_bind_ty = bind_ty
975 , recS_later_rets = later_rets, recS_rec_rets = rec_rets
976 , recS_ret_ty = ret_ty })
977 = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id
978 ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id
979 ; (env3, new_ret_id) <- zonkSyntaxExpr env2 ret_id
980 ; new_bind_ty <- zonkTcTypeToType env3 bind_ty
981 ; new_rvs <- zonkIdBndrs env3 rvs
982 ; new_lvs <- zonkIdBndrs env3 lvs
983 ; new_ret_ty <- zonkTcTypeToType env3 ret_ty
984 ; let env4 = extendIdZonkEnvRec env3 new_rvs
985 ; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts
986 -- Zonk the ret-expressions in an envt that
987 -- has the polymorphic bindings in the envt
988 ; new_later_rets <- mapM (zonkExpr env5) later_rets
989 ; new_rec_rets <- mapM (zonkExpr env5) rec_rets
990 ; return (extendIdZonkEnvRec env3 new_lvs, -- Only the lvs are needed
991 RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
992 , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
993 , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
994 , recS_bind_ty = new_bind_ty
995 , recS_later_rets = new_later_rets
996 , recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) }
997
998 zonkStmt env zBody (BodyStmt body then_op guard_op ty)
999 = do (env1, new_then_op) <- zonkSyntaxExpr env then_op
1000 (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op
1001 new_body <- zBody env2 body
1002 new_ty <- zonkTcTypeToType env2 ty
1003 return (env2, BodyStmt new_body new_then_op new_guard_op new_ty)
1004
1005 zonkStmt env zBody (LastStmt body noret ret_op)
1006 = do (env1, new_ret) <- zonkSyntaxExpr env ret_op
1007 new_body <- zBody env1 body
1008 return (env, LastStmt new_body noret new_ret)
1009
1010 zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
1011 , trS_by = by, trS_form = form, trS_using = using
1012 , trS_ret = return_op, trS_bind = bind_op
1013 , trS_bind_arg_ty = bind_arg_ty
1014 , trS_fmap = liftM_op })
1015 = do {
1016 ; (env1, bind_op') <- zonkSyntaxExpr env bind_op
1017 ; bind_arg_ty' <- zonkTcTypeToType env1 bind_arg_ty
1018 ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts
1019 ; by' <- fmapMaybeM (zonkLExpr env2) by
1020 ; using' <- zonkLExpr env2 using
1021
1022 ; (env3, return_op') <- zonkSyntaxExpr env2 return_op
1023 ; binderMap' <- mapM (zonkBinderMapEntry env3) binderMap
1024 ; liftM_op' <- zonkExpr env3 liftM_op
1025 ; let env3' = extendIdZonkEnvRec env3 (map snd binderMap')
1026 ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
1027 , trS_by = by', trS_form = form, trS_using = using'
1028 , trS_ret = return_op', trS_bind = bind_op'
1029 , trS_bind_arg_ty = bind_arg_ty'
1030 , trS_fmap = liftM_op' }) }
1031 where
1032 zonkBinderMapEntry env (oldBinder, newBinder) = do
1033 let oldBinder' = zonkIdOcc env oldBinder
1034 newBinder' <- zonkIdBndr env newBinder
1035 return (oldBinder', newBinder')
1036
1037 zonkStmt env _ (LetStmt (L l binds))
1038 = do (env1, new_binds) <- zonkLocalBinds env binds
1039 return (env1, LetStmt (L l new_binds))
1040
1041 zonkStmt env zBody (BindStmt pat body bind_op fail_op bind_ty)
1042 = do { (env1, new_bind) <- zonkSyntaxExpr env bind_op
1043 ; new_bind_ty <- zonkTcTypeToType env1 bind_ty
1044 ; new_body <- zBody env1 body
1045 ; (env2, new_pat) <- zonkPat env1 pat
1046 ; (_, new_fail) <- zonkSyntaxExpr env1 fail_op
1047 ; return (env2, BindStmt new_pat new_body new_bind new_fail new_bind_ty) }
1048
1049 -- Scopes: join > ops (in reverse order) > pats (in forward order)
1050 -- > rest of stmts
1051 zonkStmt env _zBody (ApplicativeStmt args mb_join body_ty)
1052 = do { (env1, new_mb_join) <- zonk_join env mb_join
1053 ; (env2, new_args) <- zonk_args env1 args
1054 ; new_body_ty <- zonkTcTypeToType env2 body_ty
1055 ; return (env2, ApplicativeStmt new_args new_mb_join new_body_ty) }
1056 where
1057 zonk_join env Nothing = return (env, Nothing)
1058 zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j
1059
1060 get_pat (_, ApplicativeArgOne pat _) = pat
1061 get_pat (_, ApplicativeArgMany _ _ pat) = pat
1062
1063 replace_pat pat (op, ApplicativeArgOne _ a)
1064 = (op, ApplicativeArgOne pat a)
1065 replace_pat pat (op, ApplicativeArgMany a b _)
1066 = (op, ApplicativeArgMany a b pat)
1067
1068 zonk_args env args
1069 = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args)
1070 ; (env2, new_pats) <- zonkPats env1 (map get_pat args)
1071 ; return (env2, zipWith replace_pat new_pats (reverse new_args_rev)) }
1072
1073 -- these need to go backward, because if any operators are higher-rank,
1074 -- later operators may introduce skolems that are in scope for earlier
1075 -- arguments
1076 zonk_args_rev env ((op, arg) : args)
1077 = do { (env1, new_op) <- zonkSyntaxExpr env op
1078 ; new_arg <- zonk_arg env1 arg
1079 ; (env2, new_args) <- zonk_args_rev env1 args
1080 ; return (env2, (new_op, new_arg) : new_args) }
1081 zonk_args_rev env [] = return (env, [])
1082
1083 zonk_arg env (ApplicativeArgOne pat expr)
1084 = do { new_expr <- zonkLExpr env expr
1085 ; return (ApplicativeArgOne pat new_expr) }
1086 zonk_arg env (ApplicativeArgMany stmts ret pat)
1087 = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
1088 ; new_ret <- zonkExpr env1 ret
1089 ; return (ApplicativeArgMany new_stmts new_ret pat) }
1090
1091 -------------------------------------------------------------------------
1092 zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
1093 zonkRecFields env (HsRecFields flds dd)
1094 = do { flds' <- mapM zonk_rbind flds
1095 ; return (HsRecFields flds' dd) }
1096 where
1097 zonk_rbind (L l fld)
1098 = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld)
1099 ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
1100 ; return (L l (fld { hsRecFieldLbl = new_id
1101 , hsRecFieldArg = new_expr })) }
1102
1103 zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField TcId] -> TcM [LHsRecUpdField TcId]
1104 zonkRecUpdFields env = mapM zonk_rbind
1105 where
1106 zonk_rbind (L l fld)
1107 = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld)
1108 ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
1109 ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id
1110 , hsRecFieldArg = new_expr })) }
1111
1112 -------------------------------------------------------------------------
1113 mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a
1114 -> TcM (Either (Located HsIPName) b)
1115 mapIPNameTc _ (Left x) = return (Left x)
1116 mapIPNameTc f (Right x) = do r <- f x
1117 return (Right r)
1118
1119 {-
1120 ************************************************************************
1121 * *
1122 \subsection[BackSubst-Pats]{Patterns}
1123 * *
1124 ************************************************************************
1125 -}
1126
1127 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
1128 -- Extend the environment as we go, because it's possible for one
1129 -- pattern to bind something that is used in another (inside or
1130 -- to the right)
1131 zonkPat env pat = wrapLocSndM (zonk_pat env) pat
1132
1133 zonk_pat :: ZonkEnv -> Pat TcId -> TcM (ZonkEnv, Pat Id)
1134 zonk_pat env (ParPat p)
1135 = do { (env', p') <- zonkPat env p
1136 ; return (env', ParPat p') }
1137
1138 zonk_pat env (WildPat ty)
1139 = do { ty' <- zonkTcTypeToType env ty
1140 ; return (env, WildPat ty') }
1141
1142 zonk_pat env (VarPat (L l v))
1143 = do { v' <- zonkIdBndr env v
1144 ; return (extendIdZonkEnv1 env v', VarPat (L l v')) }
1145
1146 zonk_pat env (LazyPat pat)
1147 = do { (env', pat') <- zonkPat env pat
1148 ; return (env', LazyPat pat') }
1149
1150 zonk_pat env (BangPat pat)
1151 = do { (env', pat') <- zonkPat env pat
1152 ; return (env', BangPat pat') }
1153
1154 zonk_pat env (AsPat (L loc v) pat)
1155 = do { v' <- zonkIdBndr env v
1156 ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat
1157 ; return (env', AsPat (L loc v') pat') }
1158
1159 zonk_pat env (ViewPat expr pat ty)
1160 = do { expr' <- zonkLExpr env expr
1161 ; (env', pat') <- zonkPat env pat
1162 ; ty' <- zonkTcTypeToType env ty
1163 ; return (env', ViewPat expr' pat' ty') }
1164
1165 zonk_pat env (ListPat pats ty Nothing)
1166 = do { ty' <- zonkTcTypeToType env ty
1167 ; (env', pats') <- zonkPats env pats
1168 ; return (env', ListPat pats' ty' Nothing) }
1169
1170 zonk_pat env (ListPat pats ty (Just (ty2,wit)))
1171 = do { (env', wit') <- zonkSyntaxExpr env wit
1172 ; ty2' <- zonkTcTypeToType env' ty2
1173 ; ty' <- zonkTcTypeToType env' ty
1174 ; (env'', pats') <- zonkPats env' pats
1175 ; return (env'', ListPat pats' ty' (Just (ty2',wit'))) }
1176
1177 zonk_pat env (PArrPat pats ty)
1178 = do { ty' <- zonkTcTypeToType env ty
1179 ; (env', pats') <- zonkPats env pats
1180 ; return (env', PArrPat pats' ty') }
1181
1182 zonk_pat env (TuplePat pats boxed tys)
1183 = do { tys' <- mapM (zonkTcTypeToType env) tys
1184 ; (env', pats') <- zonkPats env pats
1185 ; return (env', TuplePat pats' boxed tys') }
1186
1187 zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars
1188 , pat_dicts = evs, pat_binds = binds
1189 , pat_args = args, pat_wrap = wrapper })
1190 = ASSERT( all isImmutableTyVar tyvars )
1191 do { new_tys <- mapM (zonkTcTypeToType env) tys
1192 ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars
1193 -- Must zonk the existential variables, because their
1194 -- /kind/ need potential zonking.
1195 -- cf typecheck/should_compile/tc221.hs
1196 ; (env1, new_evs) <- zonkEvBndrsX env0 evs
1197 ; (env2, new_binds) <- zonkTcEvBinds env1 binds
1198 ; (env3, new_wrapper) <- zonkCoFn env2 wrapper
1199 ; (env', new_args) <- zonkConStuff env3 args
1200 ; return (env', p { pat_arg_tys = new_tys,
1201 pat_tvs = new_tyvars,
1202 pat_dicts = new_evs,
1203 pat_binds = new_binds,
1204 pat_args = new_args,
1205 pat_wrap = new_wrapper}) }
1206
1207 zonk_pat env (LitPat lit) = return (env, LitPat lit)
1208
1209 zonk_pat env (SigPatOut pat ty)
1210 = do { ty' <- zonkTcTypeToType env ty
1211 ; (env', pat') <- zonkPat env pat
1212 ; return (env', SigPatOut pat' ty') }
1213
1214 zonk_pat env (NPat (L l lit) mb_neg eq_expr ty)
1215 = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr
1216 ; (env2, mb_neg') <- case mb_neg of
1217 Nothing -> return (env1, Nothing)
1218 Just n -> second Just <$> zonkSyntaxExpr env1 n
1219
1220 ; lit' <- zonkOverLit env2 lit
1221 ; ty' <- zonkTcTypeToType env2 ty
1222 ; return (env2, NPat (L l lit') mb_neg' eq_expr' ty') }
1223
1224 zonk_pat env (NPlusKPat (L loc n) (L l lit1) lit2 e1 e2 ty)
1225 = do { (env1, e1') <- zonkSyntaxExpr env e1
1226 ; (env2, e2') <- zonkSyntaxExpr env1 e2
1227 ; n' <- zonkIdBndr env2 n
1228 ; lit1' <- zonkOverLit env2 lit1
1229 ; lit2' <- zonkOverLit env2 lit2
1230 ; ty' <- zonkTcTypeToType env2 ty
1231 ; return (extendIdZonkEnv1 env2 n',
1232 NPlusKPat (L loc n') (L l lit1') lit2' e1' e2' ty') }
1233
1234 zonk_pat env (CoPat co_fn pat ty)
1235 = do { (env', co_fn') <- zonkCoFn env co_fn
1236 ; (env'', pat') <- zonkPat env' (noLoc pat)
1237 ; ty' <- zonkTcTypeToType env'' ty
1238 ; return (env'', CoPat co_fn' (unLoc pat') ty') }
1239
1240 zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
1241
1242 ---------------------------
1243 zonkConStuff :: ZonkEnv
1244 -> HsConDetails (OutPat TcId) (HsRecFields id (OutPat TcId))
1245 -> TcM (ZonkEnv,
1246 HsConDetails (OutPat Id) (HsRecFields id (OutPat Id)))
1247 zonkConStuff env (PrefixCon pats)
1248 = do { (env', pats') <- zonkPats env pats
1249 ; return (env', PrefixCon pats') }
1250
1251 zonkConStuff env (InfixCon p1 p2)
1252 = do { (env1, p1') <- zonkPat env p1
1253 ; (env', p2') <- zonkPat env1 p2
1254 ; return (env', InfixCon p1' p2') }
1255
1256 zonkConStuff env (RecCon (HsRecFields rpats dd))
1257 = do { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats)
1258 ; let rpats' = zipWith (\(L l rp) p' -> L l (rp { hsRecFieldArg = p' }))
1259 rpats pats'
1260 ; return (env', RecCon (HsRecFields rpats' dd)) }
1261 -- Field selectors have declared types; hence no zonking
1262
1263 ---------------------------
1264 zonkPats :: ZonkEnv -> [OutPat TcId] -> TcM (ZonkEnv, [OutPat Id])
1265 zonkPats env [] = return (env, [])
1266 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
1267 ; (env', pats') <- zonkPats env1 pats
1268 ; return (env', pat':pats') }
1269
1270 {-
1271 ************************************************************************
1272 * *
1273 \subsection[BackSubst-Foreign]{Foreign exports}
1274 * *
1275 ************************************************************************
1276 -}
1277
1278 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
1279 zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls
1280
1281 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
1282 zonkForeignExport env (ForeignExport { fd_name = i, fd_co = co, fd_fe = spec })
1283 = return (ForeignExport { fd_name = fmap (zonkIdOcc env) i
1284 , fd_sig_ty = undefined, fd_co = co
1285 , fd_fe = spec })
1286 zonkForeignExport _ for_imp
1287 = return for_imp -- Foreign imports don't need zonking
1288
1289 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
1290 zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs
1291
1292 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
1293 zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
1294 = do { unbound_tkv_set <- newMutVar emptyVarSet
1295 ; let kind_var_set = identify_kind_vars vars
1296 env_rule = setZonkType env (zonkTvCollecting kind_var_set unbound_tkv_set)
1297 -- See Note [Zonking the LHS of a RULE]
1298
1299 ; (env_inside, new_bndrs) <- mapAccumLM zonk_bndr env_rule vars
1300
1301 ; new_lhs <- zonkLExpr env_inside lhs
1302 ; new_rhs <- zonkLExpr env_inside rhs
1303
1304 ; unbound_tkvs <- readMutVar unbound_tkv_set
1305
1306 ; let final_bndrs :: [LRuleBndr Var]
1307 final_bndrs = map (noLoc . RuleBndr . noLoc)
1308 (varSetElemsWellScoped unbound_tkvs)
1309 ++ new_bndrs
1310
1311 ; return $
1312 HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs }
1313 where
1314 zonk_bndr env (L l (RuleBndr (L loc v)))
1315 = do { (env', v') <- zonk_it env v
1316 ; return (env', L l (RuleBndr (L loc v'))) }
1317 zonk_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_bndr RuleBndrSig"
1318
1319 zonk_it env v
1320 | isId v = do { v' <- zonkIdBndr env v
1321 ; return (extendIdZonkEnvRec env [v'], v') }
1322 | otherwise = ASSERT( isImmutableTyVar v)
1323 zonkTyBndrX env v
1324 -- DV: used to be return (env,v) but that is plain
1325 -- wrong because we may need to go inside the kind
1326 -- of v and zonk there!
1327
1328 -- returns the set of type variables mentioned in the kind of another
1329 -- type. This is used only when -XPolyKinds is not set.
1330 identify_kind_vars :: [LRuleBndr TcId] -> TyVarSet
1331 identify_kind_vars rule_bndrs
1332 = let vars = map strip_rulebndr rule_bndrs in
1333 unionVarSets (map (\v -> if isTyVar v
1334 then tyCoVarsOfType (tyVarKind v)
1335 else emptyVarSet) vars)
1336
1337 strip_rulebndr (L _ (RuleBndr (L _ v))) = v
1338 strip_rulebndr (L _ (RuleBndrSig {})) = panic "strip_rulebndr zonkRule"
1339
1340 zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id]
1341 zonkVects env = mapM (wrapLocM (zonkVect env))
1342
1343 zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id)
1344 zonkVect env (HsVect s v e)
1345 = do { v' <- wrapLocM (zonkIdBndr env) v
1346 ; e' <- zonkLExpr env e
1347 ; return $ HsVect s v' e'
1348 }
1349 zonkVect env (HsNoVect s v)
1350 = do { v' <- wrapLocM (zonkIdBndr env) v
1351 ; return $ HsNoVect s v'
1352 }
1353 zonkVect _env (HsVectTypeOut s t rt)
1354 = return $ HsVectTypeOut s t rt
1355 zonkVect _ (HsVectTypeIn _ _ _ _) = panic "TcHsSyn.zonkVect: HsVectTypeIn"
1356 zonkVect _env (HsVectClassOut c)
1357 = return $ HsVectClassOut c
1358 zonkVect _ (HsVectClassIn _ _) = panic "TcHsSyn.zonkVect: HsVectClassIn"
1359 zonkVect _env (HsVectInstOut i)
1360 = return $ HsVectInstOut i
1361 zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn"
1362
1363 {-
1364 ************************************************************************
1365 * *
1366 Constraints and evidence
1367 * *
1368 ************************************************************************
1369 -}
1370
1371 zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
1372 zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v )
1373 zonkEvVarOcc env v
1374 zonkEvTerm env (EvCoercion co) = do { co' <- zonkCoToCo env co
1375 ; return (EvCoercion co') }
1376 zonkEvTerm env (EvCast tm co) = do { tm' <- zonkEvTerm env tm
1377 ; co' <- zonkCoToCo env co
1378 ; return (mkEvCast tm' co') }
1379 zonkEvTerm _ (EvLit l) = return (EvLit l)
1380
1381 zonkEvTerm env (EvTypeable ty ev) =
1382 do { ev' <- zonkEvTypeable env ev
1383 ; ty' <- zonkTcTypeToType env ty
1384 ; return (EvTypeable ty' ev') }
1385 zonkEvTerm env (EvCallStack cs)
1386 = case cs of
1387 EvCsEmpty -> return (EvCallStack cs)
1388 EvCsPushCall n l tm -> do { tm' <- zonkEvTerm env tm
1389 ; return (EvCallStack (EvCsPushCall n l tm')) }
1390
1391 zonkEvTerm env (EvSuperClass d n) = do { d' <- zonkEvTerm env d
1392 ; return (EvSuperClass d' n) }
1393 zonkEvTerm env (EvDFunApp df tys tms)
1394 = do { tys' <- zonkTcTypeToTypes env tys
1395 ; tms' <- mapM (zonkEvTerm env) tms
1396 ; return (EvDFunApp (zonkIdOcc env df) tys' tms') }
1397 zonkEvTerm env (EvDelayedError ty msg)
1398 = do { ty' <- zonkTcTypeToType env ty
1399 ; return (EvDelayedError ty' msg) }
1400
1401 zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
1402 zonkEvTypeable env (EvTypeableTyCon ts)
1403 = do { ts' <- mapM (zonkEvTerm env) ts
1404 ; return $ EvTypeableTyCon ts' }
1405 zonkEvTypeable env (EvTypeableTyApp t1 t2)
1406 = do { t1' <- zonkEvTerm env t1
1407 ; t2' <- zonkEvTerm env t2
1408 ; return (EvTypeableTyApp t1' t2') }
1409 zonkEvTypeable env (EvTypeableTyLit t1)
1410 = do { t1' <- zonkEvTerm env t1
1411 ; return (EvTypeableTyLit t1') }
1412
1413 zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])
1414 zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs
1415 ; return (env, [EvBinds (unionManyBags bs')]) }
1416
1417 zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
1418 zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs
1419 ; return (env', EvBinds bs') }
1420
1421 zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind)
1422 zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var
1423 zonk_tc_ev_binds env (EvBinds bs) = zonkEvBinds env bs
1424
1425 zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
1426 zonkEvBindsVar env (EvBindsVar ref _) = do { bs <- readMutVar ref
1427 ; zonkEvBinds env (evBindMapBinds bs) }
1428
1429 zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
1430 zonkEvBinds env binds
1431 = {-# SCC "zonkEvBinds" #-}
1432 fixM (\ ~( _, new_binds) -> do
1433 { let env1 = extendIdZonkEnvRec env (collect_ev_bndrs new_binds)
1434 ; binds' <- mapBagM (zonkEvBind env1) binds
1435 ; return (env1, binds') })
1436 where
1437 collect_ev_bndrs :: Bag EvBind -> [EvVar]
1438 collect_ev_bndrs = foldrBag add []
1439 add (EvBind { eb_lhs = var }) vars = var : vars
1440
1441 zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
1442 zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term })
1443 = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var
1444
1445 -- Optimise the common case of Refl coercions
1446 -- See Note [Optimise coercion zonking]
1447 -- This has a very big effect on some programs (eg Trac #5030)
1448
1449 ; term' <- case getEqPredTys_maybe (idType var') of
1450 Just (r, ty1, ty2) | ty1 `eqType` ty2
1451 -> return (EvCoercion (mkTcReflCo r ty1))
1452 _other -> zonkEvTerm env term
1453
1454 ; return (bind { eb_lhs = var', eb_rhs = term' }) }
1455
1456 {-
1457 ************************************************************************
1458 * *
1459 Zonking types
1460 * *
1461 ************************************************************************
1462
1463 Note [Zonking the LHS of a RULE]
1464 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1465 We need to gather the type variables mentioned on the LHS so we can
1466 quantify over them. Example:
1467 data T a = C
1468
1469 foo :: T a -> Int
1470 foo C = 1
1471
1472 {-# RULES "myrule" foo C = 1 #-}
1473
1474 After type checking the LHS becomes (foo a (C a))
1475 and we do not want to zap the unbound tyvar 'a' to (), because
1476 that limits the applicability of the rule. Instead, we
1477 want to quantify over it!
1478
1479 It's easiest to get zonkTvCollecting to gather the free tyvars
1480 here. Attempts to do so earlier are tiresome, because (a) the data
1481 type is big and (b) finding the free type vars of an expression is
1482 necessarily monadic operation. (consider /\a -> f @ b, where b is
1483 side-effected to a)
1484
1485 And that in turn is why ZonkEnv carries the function to use for
1486 type variables!
1487
1488 Note [Zonking mutable unbound type or kind variables]
1489 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1490 In zonkTypeZapping, we zonk mutable but unbound type or kind variables to an
1491 arbitrary type. We know if they are unbound even though we don't carry an
1492 environment, because at the binding site for a variable we bind the mutable
1493 var to a fresh immutable one. So the mutable store plays the role of an
1494 environment. If we come across a mutable variable that isn't so bound, it
1495 must be completely free. We zonk the expected kind to make sure we don't get
1496 some unbound meta variable as the kind.
1497
1498 Note that since we have kind polymorphism, zonk_unbound_tyvar will handle both
1499 type and kind variables. Consider the following datatype:
1500
1501 data Phantom a = Phantom Int
1502
1503 The type of Phantom is (forall (k : *). forall (a : k). Int). Both `a` and
1504 `k` are unbound variables. We want to zonk this to
1505 (forall (k : Any *). forall (a : Any (Any *)). Int).
1506
1507 Note [Optimise coercion zonking]
1508 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1509 When optimising evidence binds we may come across situations where
1510 a coercion looks like
1511 cv = ReflCo ty
1512 or cv1 = cv2
1513 where the type 'ty' is big. In such cases it is a waste of time to zonk both
1514 * The variable on the LHS
1515 * The coercion on the RHS
1516 Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just
1517 use Refl on the right, ignoring the actual coercion on the RHS.
1518
1519 This can have a very big effect, because the constraint solver sometimes does go
1520 to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf Trac #5030)
1521
1522 -}
1523
1524 zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType
1525 zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv
1526 | isTcTyVar tv
1527 = case tcTyVarDetails tv of
1528 SkolemTv {} -> lookup_in_env
1529 RuntimeUnk {} -> lookup_in_env
1530 FlatSkol ty -> zonkTcTypeToType env ty
1531 MetaTv { mtv_ref = ref }
1532 -> do { cts <- readMutVar ref
1533 ; case cts of
1534 Flexi -> do { kind <- {-# SCC "zonkKind1" #-}
1535 zonkTcTypeToType env (tyVarKind tv)
1536 ; zonk_unbound_tyvar (setTyVarKind tv kind) }
1537 Indirect ty -> do { zty <- zonkTcTypeToType env ty
1538 -- Small optimisation: shortern-out indirect steps
1539 -- so that the old type may be more easily collected.
1540 ; writeMutVar ref (Indirect zty)
1541 ; return zty } }
1542 | otherwise
1543 = lookup_in_env
1544 where
1545 lookup_in_env -- Look up in the env just as we do for Ids
1546 = case lookupVarEnv tv_env tv of
1547 Nothing -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToType env) tv
1548 Just tv' -> return (mkTyVarTy tv')
1549
1550 zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion
1551 zonkCoVarOcc env@(ZonkEnv _ tyco_env _) cv
1552 | Just cv' <- lookupVarEnv tyco_env cv -- don't look in the knot-tied env
1553 = return $ mkCoVarCo cv'
1554 | otherwise
1555 = mkCoVarCo <$> updateVarTypeM (zonkTcTypeToType env) cv
1556
1557 zonkCoHole :: ZonkEnv -> CoercionHole
1558 -> Role -> Type -> Type -- these are all redundant with
1559 -- the details in the hole,
1560 -- unzonked
1561 -> TcM Coercion
1562 zonkCoHole env h r t1 t2
1563 = do { contents <- unpackCoercionHole_maybe h
1564 ; case contents of
1565 Just co -> do { co <- zonkCoToCo env co
1566 ; checkCoercionHole co h r t1 t2 }
1567
1568 -- This next case should happen only in the presence of
1569 -- (undeferred) type errors. Originally, I put in a panic
1570 -- here, but that caused too many uses of `failIfErrsM`.
1571 Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr h)
1572 ; when debugIsOn $
1573 whenNoErrs $
1574 MASSERT2( False
1575 , text "Type-correct unfilled coercion hole"
1576 <+> ppr h )
1577 ; t1 <- zonkTcTypeToType env t1
1578 ; t2 <- zonkTcTypeToType env t2
1579 ; return $ mkHoleCo h r t1 t2 } }
1580
1581 zonk_tycomapper :: TyCoMapper ZonkEnv TcM
1582 zonk_tycomapper = TyCoMapper
1583 { tcm_smart = True -- Establish type invariants
1584 -- See Note [Type-checking inside the knot] in TcHsType
1585 , tcm_tyvar = zonkTyVarOcc
1586 , tcm_covar = zonkCoVarOcc
1587 , tcm_hole = zonkCoHole
1588 , tcm_tybinder = \env tv _vis -> zonkTyBndrX env tv }
1589
1590 -- Confused by zonking? See Note [What is zonking?] in TcMType.
1591 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
1592 zonkTcTypeToType = mapType zonk_tycomapper
1593
1594 zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
1595 zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
1596
1597 -- | Used during kind-checking in TcTyClsDecls, where it's more convenient
1598 -- to keep the binders and result kind separate.
1599 zonkTcKindToKind :: [TcTyBinder] -> TcKind -> TcM ([TyBinder], Kind)
1600 zonkTcKindToKind binders res_kind
1601 = do { (env, binders') <- zonkTyBinders emptyZonkEnv binders
1602 ; res_kind' <- zonkTcTypeToType env res_kind
1603 ; return (binders', res_kind') }
1604
1605 zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion
1606 zonkCoToCo = mapCoercion zonk_tycomapper
1607
1608 zonkTvCollecting :: TyVarSet -> TcRef TyVarSet -> UnboundTyVarZonker
1609 -- This variant collects unbound type variables in a mutable variable
1610 -- Works on both types and kinds
1611 zonkTvCollecting kind_vars unbound_tv_set tv
1612 = do { poly_kinds <- xoptM LangExt.PolyKinds
1613 ; if tv `elemVarSet` kind_vars && not poly_kinds then defaultKindVar tv else do
1614 { ty_or_tv <- zonkQuantifiedTyVarOrType tv
1615 ; case ty_or_tv of
1616 Right ty -> return ty
1617 Left tv' -> do
1618 { tv_set <- readMutVar unbound_tv_set
1619 ; writeMutVar unbound_tv_set (extendVarSet tv_set tv')
1620 ; return (mkTyVarTy tv') } } }
1621
1622 zonkTypeZapping :: UnboundTyVarZonker
1623 -- This variant is used for everything except the LHS of rules
1624 -- It zaps unbound type variables to (), or some other arbitrary type
1625 -- Works on both types and kinds
1626 zonkTypeZapping tv
1627 = do { let ty | isRuntimeRepVar tv = ptrRepLiftedTy
1628 | otherwise = anyTypeOfKind (tyVarKind tv)
1629 ; writeMetaTyVar tv ty
1630 ; return ty }