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