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