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