Use TyVars in PatSyns
[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 (a) a MetaTv (b) Flexi and
191 -- (c) its kind is alrady zonked
192 -- Note [Zonking the LHS of a RULE]
193
194 -- | A ZonkEnv carries around several bits.
195 -- The UnboundTyVarZonker just zaps unbouned meta-tyvars to Any (as
196 -- defined in zonkTypeZapping), except on the LHS of rules. See
197 -- Note [Zonking the LHS of a RULE].
198 --
199 -- The (TyCoVarEnv TyVar) and is just an optimisation: when binding a
200 -- tyvar or covar, we zonk the kind right away and add a mapping to
201 -- the env. This prevents re-zonking the kind at every occurrence. But
202 -- this is *just* an optimisation.
203 --
204 -- The final (IdEnv Var) optimises zonking for Ids. It is
205 -- knot-tied. We must be careful never to put coercion variables
206 -- (which are Ids, after all) in the knot-tied env, because coercions
207 -- can appear in types, and we sometimes inspect a zonked type in this
208 -- module.
209 --
210 -- Confused by zonking? See Note [What is zonking?] in TcMType.
211 data ZonkEnv
212 = ZonkEnv
213 UnboundTyVarZonker
214 (TyCoVarEnv TyVar)
215 (IdEnv Var) -- What variables are in scope
216 -- Maps an Id or EvVar to its zonked version; both have the same Name
217 -- Note that all evidence (coercion variables as well as dictionaries)
218 -- are kept in the ZonkEnv
219 -- Only *type* abstraction is done by side effect
220 -- Is only consulted lazily; hence knot-tying
221
222 instance Outputable ZonkEnv where
223 ppr (ZonkEnv _ _ty_env var_env) = pprUFM var_env (vcat . map ppr)
224
225
226 -- The EvBinds have to already be zonked, but that's usually the case.
227 emptyZonkEnv :: ZonkEnv
228 emptyZonkEnv = mkEmptyZonkEnv zonkTypeZapping
229
230 mkEmptyZonkEnv :: UnboundTyVarZonker -> ZonkEnv
231 mkEmptyZonkEnv zonker = ZonkEnv zonker emptyVarEnv emptyVarEnv
232
233 -- | Extend the knot-tied environment.
234 extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv
235 extendIdZonkEnvRec (ZonkEnv zonk_ty ty_env id_env) ids
236 -- NB: Don't look at the var to decide which env't to put it in. That
237 -- would end up knot-tying all the env'ts.
238 = ZonkEnv zonk_ty ty_env (extendVarEnvList id_env [(id,id) | id <- ids])
239 -- Given coercion variables will actually end up here. That's OK though:
240 -- coercion variables are never looked up in the knot-tied env't, so zonking
241 -- them simply doesn't get optimised. No one gets hurt. An improvement (?)
242 -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the
243 -- recursive groups. But perhaps the time it takes to do the analysis is
244 -- more than the savings.
245
246 extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
247 extendZonkEnv (ZonkEnv zonk_ty tyco_env id_env) vars
248 = ZonkEnv zonk_ty (extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars])
249 (extendVarEnvList id_env [(id,id) | id <- ids])
250 where (tycovars, ids) = partition isTyCoVar vars
251
252 extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
253 extendIdZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) id
254 = ZonkEnv zonk_ty ty_env (extendVarEnv id_env id id)
255
256 extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
257 extendTyZonkEnv1 (ZonkEnv zonk_ty ty_env id_env) tv
258 = ZonkEnv zonk_ty (extendVarEnv ty_env tv tv) id_env
259
260 setZonkType :: ZonkEnv -> UnboundTyVarZonker -> ZonkEnv
261 setZonkType (ZonkEnv _ ty_env id_env) zonk_ty
262 = ZonkEnv zonk_ty ty_env id_env
263
264 zonkEnvIds :: ZonkEnv -> TypeEnv
265 zonkEnvIds (ZonkEnv _ _ id_env) =
266 mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env]
267 -- It's OK to use nonDetEltsUFM here because we forget the ordering
268 -- immediately by creating a TypeEnv
269
270 zonkIdOcc :: ZonkEnv -> TcId -> Id
271 -- Ids defined in this module should be in the envt;
272 -- ignore others. (Actually, data constructors are also
273 -- not LocalVars, even when locally defined, but that is fine.)
274 -- (Also foreign-imported things aren't currently in the ZonkEnv;
275 -- that's ok because they don't need zonking.)
276 --
277 -- Actually, Template Haskell works in 'chunks' of declarations, and
278 -- an earlier chunk won't be in the 'env' that the zonking phase
279 -- carries around. Instead it'll be in the tcg_gbl_env, already fully
280 -- zonked. There's no point in looking it up there (except for error
281 -- checking), and it's not conveniently to hand; hence the simple
282 -- 'orElse' case in the LocalVar branch.
283 --
284 -- Even without template splices, in module Main, the checking of
285 -- 'main' is done as a separate chunk.
286 zonkIdOcc (ZonkEnv _zonk_ty _ty_env id_env) id
287 | isLocalVar id = lookupVarEnv id_env id `orElse`
288 id
289 | otherwise = id
290
291 zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
292 zonkIdOccs env ids = map (zonkIdOcc env) ids
293
294 -- zonkIdBndr is used *after* typechecking to get the Id's type
295 -- to its final form. The TyVarEnv give
296 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
297 zonkIdBndr env id
298 = do ty' <- zonkTcTypeToType env (idType id)
299 ensureNotRepresentationPolymorphic ty'
300 (text "In the type of binder" <+> quotes (ppr id))
301 return (setIdType id ty')
302
303 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
304 zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
305
306 zonkTopBndrs :: [TcId] -> TcM [Id]
307 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
308
309 zonkFieldOcc :: ZonkEnv -> FieldOcc TcId -> TcM (FieldOcc Id)
310 zonkFieldOcc env (FieldOcc lbl sel) = fmap (FieldOcc lbl) $ zonkIdBndr env sel
311
312 zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
313 zonkEvBndrsX = mapAccumLM zonkEvBndrX
314
315 zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
316 -- Works for dictionaries and coercions
317 zonkEvBndrX env var
318 = do { var' <- zonkEvBndr env var
319 ; return (extendZonkEnv env [var'], var') }
320
321 zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
322 -- Works for dictionaries and coercions
323 -- Does not extend the ZonkEnv
324 zonkEvBndr env var
325 = do { let var_ty = varType var
326 ; ty <-
327 {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
328 zonkTcTypeToType env var_ty
329 ; return (setVarType var ty) }
330
331 zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm
332 zonkEvVarOcc env v
333 | isCoVar v
334 = EvCoercion <$> zonkCoVarOcc env v
335 | otherwise
336 = return (EvId $ zonkIdOcc env v)
337
338 zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])
339 zonkTyBndrsX = mapAccumLM zonkTyBndrX
340
341 zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)
342 -- This guarantees to return a TyVar (not a TcTyVar)
343 -- then we add it to the envt, so all occurrences are replaced
344 zonkTyBndrX env tv
345 = ASSERT( isImmutableTyVar tv )
346 do { ki <- zonkTcTypeToType env (tyVarKind tv)
347 -- Internal names tidy up better, for iface files.
348 ; let tv' = mkTyVar (tyVarName tv) ki
349 ; return (extendTyZonkEnv1 env tv', tv') }
350
351 zonkTyVarBindersX :: ZonkEnv -> [TyVarBndr TcTyVar vis]
352 -> TcM (ZonkEnv, [TyVarBndr TyVar vis])
353 zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX
354
355 zonkTyVarBinderX :: ZonkEnv -> TyVarBndr TcTyVar vis
356 -> TcM (ZonkEnv, TyVarBndr TyVar vis)
357 -- Takes a TcTyVar and guarantees to return a TyVar
358 zonkTyVarBinderX env (TvBndr tv vis)
359 = do { (env', tv') <- zonkTyBndrX env tv
360 ; return (env', TvBndr tv' vis) }
361
362 zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id)
363 zonkTopExpr e = zonkExpr emptyZonkEnv e
364
365 zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
366 zonkTopLExpr e = zonkLExpr emptyZonkEnv e
367
368 zonkTopDecls :: Bag EvBind
369 -> LHsBinds TcId
370 -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
371 -> TcM (TypeEnv,
372 Bag EvBind,
373 LHsBinds Id,
374 [LForeignDecl Id],
375 [LTcSpecPrag],
376 [LRuleDecl Id],
377 [LVectDecl Id])
378 zonkTopDecls ev_binds binds rules vects imp_specs fords
379 = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
380 ; (env2, binds') <- zonkRecMonoBinds env1 binds
381 -- Top level is implicitly recursive
382 ; rules' <- zonkRules env2 rules
383 ; vects' <- zonkVects env2 vects
384 ; specs' <- zonkLTcSpecPrags env2 imp_specs
385 ; fords' <- zonkForeignExports env2 fords
386 ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') }
387
388 ---------------------------------------------
389 zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
390 zonkLocalBinds env EmptyLocalBinds
391 = return (env, EmptyLocalBinds)
392
393 zonkLocalBinds _ (HsValBinds (ValBindsIn {}))
394 = panic "zonkLocalBinds" -- Not in typechecker output
395
396 zonkLocalBinds env (HsValBinds (ValBindsOut binds sigs))
397 = do { (env1, new_binds) <- go env binds
398 ; return (env1, HsValBinds (ValBindsOut new_binds sigs)) }
399 where
400 go env []
401 = return (env, [])
402 go env ((r,b):bs)
403 = do { (env1, b') <- zonkRecMonoBinds env b
404 ; (env2, bs') <- go env1 bs
405 ; return (env2, (r,b'):bs') }
406
407 zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds)) = do
408 new_binds <- mapM (wrapLocM zonk_ip_bind) binds
409 let
410 env1 = extendIdZonkEnvRec env [ n | L _ (IPBind (Right n) _) <- new_binds]
411 (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
412 return (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
413 where
414 zonk_ip_bind (IPBind n e)
415 = do n' <- mapIPNameTc (zonkIdBndr env) n
416 e' <- zonkLExpr env e
417 return (IPBind n' e')
418
419 ---------------------------------------------
420 zonkRecMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (ZonkEnv, LHsBinds Id)
421 zonkRecMonoBinds env binds
422 = fixM (\ ~(_, new_binds) -> do
423 { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)
424 ; binds' <- zonkMonoBinds env1 binds
425 ; return (env1, binds') })
426
427 ---------------------------------------------
428 zonkMonoBinds :: ZonkEnv -> LHsBinds TcId -> TcM (LHsBinds Id)
429 zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
430
431 zonk_lbind :: ZonkEnv -> LHsBind TcId -> TcM (LHsBind Id)
432 zonk_lbind env = wrapLocM (zonk_bind env)
433
434 zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id)
435 zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
436 = do { (_env, new_pat) <- zonkPat env pat -- Env already extended
437 ; new_grhss <- zonkGRHSs env zonkLExpr grhss
438 ; new_ty <- zonkTcTypeToType env ty
439 ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) }
440
441 zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
442 = do { new_var <- zonkIdBndr env var
443 ; new_expr <- zonkLExpr env expr
444 ; return (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) }
445
446 zonk_bind env bind@(FunBind { fun_id = L loc var, fun_matches = ms
447 , fun_co_fn = co_fn })
448 = do { new_var <- zonkIdBndr env var
449 ; (env1, new_co_fn) <- zonkCoFn env co_fn
450 ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
451 ; return (bind { fun_id = L loc new_var, fun_matches = new_ms
452 , fun_co_fn = new_co_fn }) }
453
454 zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
455 , abs_ev_binds = ev_binds
456 , abs_exports = exports
457 , abs_binds = val_binds })
458 = ASSERT( all isImmutableTyVar tyvars )
459 do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
460 ; (env1, new_evs) <- zonkEvBndrsX env0 evs
461 ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
462 ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
463 do { let env3 = extendIdZonkEnvRec env2
464 (collectHsBindsBinders new_val_binds)
465 ; new_val_binds <- zonkMonoBinds env3 val_binds
466 ; new_exports <- mapM (zonkExport env3) exports
467 ; return (new_val_binds, new_exports) }
468 ; return (AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
469 , abs_ev_binds = new_ev_binds
470 , abs_exports = new_exports, abs_binds = new_val_bind }) }
471 where
472 zonkExport env (ABE{ abe_wrap = wrap
473 , abe_poly = poly_id
474 , abe_mono = mono_id, abe_prags = prags })
475 = do new_poly_id <- zonkIdBndr env poly_id
476 (_, new_wrap) <- zonkCoFn env wrap
477 new_prags <- zonkSpecPrags env prags
478 return (ABE{ abe_wrap = new_wrap
479 , abe_poly = new_poly_id
480 , abe_mono = zonkIdOcc env mono_id
481 , abe_prags = new_prags })
482
483 zonk_bind env outer_bind@(AbsBindsSig { abs_tvs = tyvars
484 , abs_ev_vars = evs
485 , abs_sig_export = poly
486 , abs_sig_prags = prags
487 , abs_sig_ev_bind = ev_bind
488 , abs_sig_bind = lbind })
489 | L bind_loc bind@(FunBind { fun_id = L loc local
490 , fun_matches = ms
491 , fun_co_fn = co_fn }) <- lbind
492 = ASSERT( all isImmutableTyVar tyvars )
493 do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
494 ; (env1, new_evs) <- zonkEvBndrsX env0 evs
495 ; (env2, new_ev_bind) <- zonkTcEvBinds env1 ev_bind
496 -- Inline zonk_bind (FunBind ...) because we wish to skip
497 -- the check for representation-polymorphic binders. The
498 -- local binder in the FunBind in an AbsBindsSig is never actually
499 -- bound in Core -- indeed, that's the whole point of AbsBindsSig.
500 -- just calling zonk_bind causes #11405.
501 ; new_local <- updateVarTypeM (zonkTcTypeToType env2) local
502 ; (env3, new_co_fn) <- zonkCoFn env2 co_fn
503 ; new_ms <- zonkMatchGroup env3 zonkLExpr ms
504 -- If there is a representation polymorphism problem, it will
505 -- be caught here:
506 ; new_poly_id <- zonkIdBndr env2 poly
507 ; new_prags <- zonkSpecPrags env2 prags
508 ; let new_val_bind = L bind_loc (bind { fun_id = L loc new_local
509 , fun_matches = new_ms
510 , fun_co_fn = new_co_fn })
511 ; return (AbsBindsSig { abs_tvs = new_tyvars
512 , abs_ev_vars = new_evs
513 , abs_sig_export = new_poly_id
514 , abs_sig_prags = new_prags
515 , abs_sig_ev_bind = new_ev_bind
516 , abs_sig_bind = new_val_bind }) }
517
518 | otherwise
519 = pprPanic "zonk_bind" (ppr outer_bind)
520
521 zonk_bind env (PatSynBind bind@(PSB { psb_id = L loc id
522 , psb_args = details
523 , psb_def = lpat
524 , psb_dir = dir }))
525 = do { id' <- zonkIdBndr env id
526 ; details' <- zonkPatSynDetails env details
527 ; (env1, lpat') <- zonkPat env lpat
528 ; (_env2, dir') <- zonkPatSynDir env1 dir
529 ; return $ PatSynBind $
530 bind { psb_id = L loc id'
531 , psb_args = details'
532 , psb_def = lpat'
533 , psb_dir = dir' } }
534
535 zonkPatSynDetails :: ZonkEnv
536 -> HsPatSynDetails (Located TcId)
537 -> TcM (HsPatSynDetails (Located Id))
538 zonkPatSynDetails env = traverse (wrapLocM $ zonkIdBndr env)
539
540 zonkPatSynDir :: ZonkEnv -> HsPatSynDir TcId -> TcM (ZonkEnv, HsPatSynDir Id)
541 zonkPatSynDir env Unidirectional = return (env, Unidirectional)
542 zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)
543 zonkPatSynDir env (ExplicitBidirectional mg) = do
544 mg' <- zonkMatchGroup env zonkLExpr mg
545 return (env, ExplicitBidirectional mg')
546
547 zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
548 zonkSpecPrags _ IsDefaultMethod = return IsDefaultMethod
549 zonkSpecPrags env (SpecPrags ps) = do { ps' <- zonkLTcSpecPrags env ps
550 ; return (SpecPrags ps') }
551
552 zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
553 zonkLTcSpecPrags env ps
554 = mapM zonk_prag ps
555 where
556 zonk_prag (L loc (SpecPrag id co_fn inl))
557 = do { (_, co_fn') <- zonkCoFn env co_fn
558 ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
559
560 {-
561 ************************************************************************
562 * *
563 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
564 * *
565 ************************************************************************
566 -}
567
568 zonkMatchGroup :: ZonkEnv
569 -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
570 -> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id)))
571 zonkMatchGroup env zBody (MG { mg_alts = L l ms, mg_arg_tys = arg_tys
572 , mg_res_ty = res_ty, mg_origin = origin })
573 = do { ms' <- mapM (zonkMatch env zBody) ms
574 ; arg_tys' <- zonkTcTypeToTypes env arg_tys
575 ; res_ty' <- zonkTcTypeToType env res_ty
576 ; return (MG { mg_alts = L l ms', mg_arg_tys = arg_tys'
577 , mg_res_ty = res_ty', mg_origin = origin }) }
578
579 zonkMatch :: ZonkEnv
580 -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
581 -> LMatch TcId (Located (body TcId)) -> TcM (LMatch Id (Located (body Id)))
582 zonkMatch env zBody (L loc (Match mf pats _ grhss))
583 = do { (env1, new_pats) <- zonkPats env pats
584 ; new_grhss <- zonkGRHSs env1 zBody grhss
585 ; return (L loc (Match mf new_pats Nothing new_grhss)) }
586
587 -------------------------------------------------------------------------
588 zonkGRHSs :: ZonkEnv
589 -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
590 -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id)))
591
592 zonkGRHSs env zBody (GRHSs grhss (L l binds)) = do
593 (new_env, new_binds) <- zonkLocalBinds env binds
594 let
595 zonk_grhs (GRHS guarded rhs)
596 = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
597 new_rhs <- zBody env2 rhs
598 return (GRHS new_guarded new_rhs)
599 new_grhss <- mapM (wrapLocM zonk_grhs) grhss
600 return (GRHSs new_grhss (L l new_binds))
601
602 {-
603 ************************************************************************
604 * *
605 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
606 * *
607 ************************************************************************
608 -}
609
610 zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
611 zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id)
612 zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id)
613
614 zonkLExprs env exprs = mapM (zonkLExpr env) exprs
615 zonkLExpr env expr = wrapLocM (zonkExpr env) expr
616
617 zonkExpr env (HsVar (L l id))
618 = return (HsVar (L l (zonkIdOcc env id)))
619
620 zonkExpr _ (HsIPVar id)
621 = return (HsIPVar id)
622
623 zonkExpr _ (HsOverLabel l)
624 = return (HsOverLabel l)
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 fixity args)
876 = do new_op <- zonkLExpr env op
877 new_args <- mapM (zonkCmdTop env) args
878 return (HsCmdArrForm new_op 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 return (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
932
933 -------------------------------------------------------------------------
934 zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
935 zonkCoFn env WpHole = return (env, WpHole)
936 zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
937 ; (env2, c2') <- zonkCoFn env1 c2
938 ; return (env2, WpCompose c1' c2') }
939 zonkCoFn env (WpFun c1 c2 t1) = do { (env1, c1') <- zonkCoFn env c1
940 ; (env2, c2') <- zonkCoFn env1 c2
941 ; t1' <- zonkTcTypeToType env2 t1
942 ; return (env2, WpFun c1' c2' t1') }
943 zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co
944 ; return (env, WpCast co') }
945 zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev
946 ; return (env', WpEvLam ev') }
947 zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg
948 ; return (env, WpEvApp arg') }
949 zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv )
950 do { (env', tv') <- zonkTyBndrX env tv
951 ; return (env', WpTyLam tv') }
952 zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty
953 ; return (env, WpTyApp ty') }
954 zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs
955 ; return (env1, WpLet bs') }
956
957 -------------------------------------------------------------------------
958 zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
959 zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
960 = do { ty' <- zonkTcTypeToType env ty
961 ; e' <- zonkExpr env e
962 ; return (lit { ol_witness = e', ol_type = ty' }) }
963
964 -------------------------------------------------------------------------
965 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
966
967 zonkArithSeq env (From e)
968 = do new_e <- zonkLExpr env e
969 return (From new_e)
970
971 zonkArithSeq env (FromThen e1 e2)
972 = do new_e1 <- zonkLExpr env e1
973 new_e2 <- zonkLExpr env e2
974 return (FromThen new_e1 new_e2)
975
976 zonkArithSeq env (FromTo e1 e2)
977 = do new_e1 <- zonkLExpr env e1
978 new_e2 <- zonkLExpr env e2
979 return (FromTo new_e1 new_e2)
980
981 zonkArithSeq env (FromThenTo e1 e2 e3)
982 = do new_e1 <- zonkLExpr env e1
983 new_e2 <- zonkLExpr env e2
984 new_e3 <- zonkLExpr env e3
985 return (FromThenTo new_e1 new_e2 new_e3)
986
987
988 -------------------------------------------------------------------------
989 zonkStmts :: ZonkEnv
990 -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
991 -> [LStmt TcId (Located (body TcId))] -> TcM (ZonkEnv, [LStmt Id (Located (body Id))])
992 zonkStmts env _ [] = return (env, [])
993 zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s
994 ; (env2, ss') <- zonkStmts env1 zBody ss
995 ; return (env2, s' : ss') }
996
997 zonkStmt :: ZonkEnv
998 -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
999 -> Stmt TcId (Located (body TcId)) -> TcM (ZonkEnv, Stmt Id (Located (body Id)))
1000 zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op bind_ty)
1001 = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op
1002 ; new_bind_ty <- zonkTcTypeToType env1 bind_ty
1003 ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs
1004 ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs]
1005 env2 = extendIdZonkEnvRec env1 new_binders
1006 ; new_mzip <- zonkExpr env2 mzip_op
1007 ; return (env2, ParStmt new_stmts_w_bndrs new_mzip new_bind_op new_bind_ty) }
1008 where
1009 zonk_branch env1 (ParStmtBlock stmts bndrs return_op)
1010 = do { (env2, new_stmts) <- zonkStmts env1 zonkLExpr stmts
1011 ; (env3, new_return) <- zonkSyntaxExpr env2 return_op
1012 ; return (ParStmtBlock new_stmts (zonkIdOccs env3 bndrs) new_return) }
1013
1014 zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
1015 , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id
1016 , recS_bind_fn = bind_id, recS_bind_ty = bind_ty
1017 , recS_later_rets = later_rets, recS_rec_rets = rec_rets
1018 , recS_ret_ty = ret_ty })
1019 = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id
1020 ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id
1021 ; (env3, new_ret_id) <- zonkSyntaxExpr env2 ret_id
1022 ; new_bind_ty <- zonkTcTypeToType env3 bind_ty
1023 ; new_rvs <- zonkIdBndrs env3 rvs
1024 ; new_lvs <- zonkIdBndrs env3 lvs
1025 ; new_ret_ty <- zonkTcTypeToType env3 ret_ty
1026 ; let env4 = extendIdZonkEnvRec env3 new_rvs
1027 ; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts
1028 -- Zonk the ret-expressions in an envt that
1029 -- has the polymorphic bindings in the envt
1030 ; new_later_rets <- mapM (zonkExpr env5) later_rets
1031 ; new_rec_rets <- mapM (zonkExpr env5) rec_rets
1032 ; return (extendIdZonkEnvRec env3 new_lvs, -- Only the lvs are needed
1033 RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
1034 , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
1035 , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
1036 , recS_bind_ty = new_bind_ty
1037 , recS_later_rets = new_later_rets
1038 , recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) }
1039
1040 zonkStmt env zBody (BodyStmt body then_op guard_op ty)
1041 = do (env1, new_then_op) <- zonkSyntaxExpr env then_op
1042 (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op
1043 new_body <- zBody env2 body
1044 new_ty <- zonkTcTypeToType env2 ty
1045 return (env2, BodyStmt new_body new_then_op new_guard_op new_ty)
1046
1047 zonkStmt env zBody (LastStmt body noret ret_op)
1048 = do (env1, new_ret) <- zonkSyntaxExpr env ret_op
1049 new_body <- zBody env1 body
1050 return (env, LastStmt new_body noret new_ret)
1051
1052 zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
1053 , trS_by = by, trS_form = form, trS_using = using
1054 , trS_ret = return_op, trS_bind = bind_op
1055 , trS_bind_arg_ty = bind_arg_ty
1056 , trS_fmap = liftM_op })
1057 = do {
1058 ; (env1, bind_op') <- zonkSyntaxExpr env bind_op
1059 ; bind_arg_ty' <- zonkTcTypeToType env1 bind_arg_ty
1060 ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts
1061 ; by' <- fmapMaybeM (zonkLExpr env2) by
1062 ; using' <- zonkLExpr env2 using
1063
1064 ; (env3, return_op') <- zonkSyntaxExpr env2 return_op
1065 ; binderMap' <- mapM (zonkBinderMapEntry env3) binderMap
1066 ; liftM_op' <- zonkExpr env3 liftM_op
1067 ; let env3' = extendIdZonkEnvRec env3 (map snd binderMap')
1068 ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
1069 , trS_by = by', trS_form = form, trS_using = using'
1070 , trS_ret = return_op', trS_bind = bind_op'
1071 , trS_bind_arg_ty = bind_arg_ty'
1072 , trS_fmap = liftM_op' }) }
1073 where
1074 zonkBinderMapEntry env (oldBinder, newBinder) = do
1075 let oldBinder' = zonkIdOcc env oldBinder
1076 newBinder' <- zonkIdBndr env newBinder
1077 return (oldBinder', newBinder')
1078
1079 zonkStmt env _ (LetStmt (L l binds))
1080 = do (env1, new_binds) <- zonkLocalBinds env binds
1081 return (env1, LetStmt (L l new_binds))
1082
1083 zonkStmt env zBody (BindStmt pat body bind_op fail_op bind_ty)
1084 = do { (env1, new_bind) <- zonkSyntaxExpr env bind_op
1085 ; new_bind_ty <- zonkTcTypeToType env1 bind_ty
1086 ; new_body <- zBody env1 body
1087 ; (env2, new_pat) <- zonkPat env1 pat
1088 ; (_, new_fail) <- zonkSyntaxExpr env1 fail_op
1089 ; return (env2, BindStmt new_pat new_body new_bind new_fail new_bind_ty) }
1090
1091 -- Scopes: join > ops (in reverse order) > pats (in forward order)
1092 -- > rest of stmts
1093 zonkStmt env _zBody (ApplicativeStmt args mb_join body_ty)
1094 = do { (env1, new_mb_join) <- zonk_join env mb_join
1095 ; (env2, new_args) <- zonk_args env1 args
1096 ; new_body_ty <- zonkTcTypeToType env2 body_ty
1097 ; return (env2, ApplicativeStmt new_args new_mb_join new_body_ty) }
1098 where
1099 zonk_join env Nothing = return (env, Nothing)
1100 zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j
1101
1102 get_pat (_, ApplicativeArgOne pat _) = pat
1103 get_pat (_, ApplicativeArgMany _ _ pat) = pat
1104
1105 replace_pat pat (op, ApplicativeArgOne _ a)
1106 = (op, ApplicativeArgOne pat a)
1107 replace_pat pat (op, ApplicativeArgMany a b _)
1108 = (op, ApplicativeArgMany a b pat)
1109
1110 zonk_args env args
1111 = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args)
1112 ; (env2, new_pats) <- zonkPats env1 (map get_pat args)
1113 ; return (env2, zipWith replace_pat new_pats (reverse new_args_rev)) }
1114
1115 -- these need to go backward, because if any operators are higher-rank,
1116 -- later operators may introduce skolems that are in scope for earlier
1117 -- arguments
1118 zonk_args_rev env ((op, arg) : args)
1119 = do { (env1, new_op) <- zonkSyntaxExpr env op
1120 ; new_arg <- zonk_arg env1 arg
1121 ; (env2, new_args) <- zonk_args_rev env1 args
1122 ; return (env2, (new_op, new_arg) : new_args) }
1123 zonk_args_rev env [] = return (env, [])
1124
1125 zonk_arg env (ApplicativeArgOne pat expr)
1126 = do { new_expr <- zonkLExpr env expr
1127 ; return (ApplicativeArgOne pat new_expr) }
1128 zonk_arg env (ApplicativeArgMany stmts ret pat)
1129 = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
1130 ; new_ret <- zonkExpr env1 ret
1131 ; return (ApplicativeArgMany new_stmts new_ret pat) }
1132
1133 -------------------------------------------------------------------------
1134 zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
1135 zonkRecFields env (HsRecFields flds dd)
1136 = do { flds' <- mapM zonk_rbind flds
1137 ; return (HsRecFields flds' dd) }
1138 where
1139 zonk_rbind (L l fld)
1140 = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld)
1141 ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
1142 ; return (L l (fld { hsRecFieldLbl = new_id
1143 , hsRecFieldArg = new_expr })) }
1144
1145 zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField TcId] -> TcM [LHsRecUpdField TcId]
1146 zonkRecUpdFields env = mapM zonk_rbind
1147 where
1148 zonk_rbind (L l fld)
1149 = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld)
1150 ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
1151 ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id
1152 , hsRecFieldArg = new_expr })) }
1153
1154 -------------------------------------------------------------------------
1155 mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a
1156 -> TcM (Either (Located HsIPName) b)
1157 mapIPNameTc _ (Left x) = return (Left x)
1158 mapIPNameTc f (Right x) = do r <- f x
1159 return (Right r)
1160
1161 {-
1162 ************************************************************************
1163 * *
1164 \subsection[BackSubst-Pats]{Patterns}
1165 * *
1166 ************************************************************************
1167 -}
1168
1169 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
1170 -- Extend the environment as we go, because it's possible for one
1171 -- pattern to bind something that is used in another (inside or
1172 -- to the right)
1173 zonkPat env pat = wrapLocSndM (zonk_pat env) pat
1174
1175 zonk_pat :: ZonkEnv -> Pat TcId -> TcM (ZonkEnv, Pat Id)
1176 zonk_pat env (ParPat p)
1177 = do { (env', p') <- zonkPat env p
1178 ; return (env', ParPat p') }
1179
1180 zonk_pat env (WildPat ty)
1181 = do { ty' <- zonkTcTypeToType env ty
1182 ; ensureNotRepresentationPolymorphic ty'
1183 (text "In a wildcard pattern")
1184 ; return (env, WildPat ty') }
1185
1186 zonk_pat env (VarPat (L l v))
1187 = do { v' <- zonkIdBndr env v
1188 ; return (extendIdZonkEnv1 env v', VarPat (L l v')) }
1189
1190 zonk_pat env (LazyPat pat)
1191 = do { (env', pat') <- zonkPat env pat
1192 ; return (env', LazyPat pat') }
1193
1194 zonk_pat env (BangPat pat)
1195 = do { (env', pat') <- zonkPat env pat
1196 ; return (env', BangPat pat') }
1197
1198 zonk_pat env (AsPat (L loc v) pat)
1199 = do { v' <- zonkIdBndr env v
1200 ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat
1201 ; return (env', AsPat (L loc v') pat') }
1202
1203 zonk_pat env (ViewPat expr pat ty)
1204 = do { expr' <- zonkLExpr env expr
1205 ; (env', pat') <- zonkPat env pat
1206 ; ty' <- zonkTcTypeToType env ty
1207 ; return (env', ViewPat expr' pat' ty') }
1208
1209 zonk_pat env (ListPat pats ty Nothing)
1210 = do { ty' <- zonkTcTypeToType env ty
1211 ; (env', pats') <- zonkPats env pats
1212 ; return (env', ListPat pats' ty' Nothing) }
1213
1214 zonk_pat env (ListPat pats ty (Just (ty2,wit)))
1215 = do { (env', wit') <- zonkSyntaxExpr env wit
1216 ; ty2' <- zonkTcTypeToType env' ty2
1217 ; ty' <- zonkTcTypeToType env' ty
1218 ; (env'', pats') <- zonkPats env' pats
1219 ; return (env'', ListPat pats' ty' (Just (ty2',wit'))) }
1220
1221 zonk_pat env (PArrPat pats ty)
1222 = do { ty' <- zonkTcTypeToType env ty
1223 ; (env', pats') <- zonkPats env pats
1224 ; return (env', PArrPat pats' ty') }
1225
1226 zonk_pat env (TuplePat pats boxed tys)
1227 = do { tys' <- mapM (zonkTcTypeToType env) tys
1228 ; (env', pats') <- zonkPats env pats
1229 ; return (env', TuplePat pats' boxed tys') }
1230
1231 zonk_pat env (SumPat pat alt arity tys)
1232 = do { tys' <- mapM (zonkTcTypeToType env) tys
1233 ; (env', pat') <- zonkPat env pat
1234 ; return (env', SumPat pat' alt arity tys') }
1235
1236 zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars
1237 , pat_dicts = evs, pat_binds = binds
1238 , pat_args = args, pat_wrap = wrapper })
1239 = ASSERT( all isImmutableTyVar tyvars )
1240 do { new_tys <- mapM (zonkTcTypeToType env) tys
1241 ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars
1242 -- Must zonk the existential variables, because their
1243 -- /kind/ need potential zonking.
1244 -- cf typecheck/should_compile/tc221.hs
1245 ; (env1, new_evs) <- zonkEvBndrsX env0 evs
1246 ; (env2, new_binds) <- zonkTcEvBinds env1 binds
1247 ; (env3, new_wrapper) <- zonkCoFn env2 wrapper
1248 ; (env', new_args) <- zonkConStuff env3 args
1249 ; return (env', p { pat_arg_tys = new_tys,
1250 pat_tvs = new_tyvars,
1251 pat_dicts = new_evs,
1252 pat_binds = new_binds,
1253 pat_args = new_args,
1254 pat_wrap = new_wrapper}) }
1255
1256 zonk_pat env (LitPat lit) = return (env, LitPat lit)
1257
1258 zonk_pat env (SigPatOut pat ty)
1259 = do { ty' <- zonkTcTypeToType env ty
1260 ; (env', pat') <- zonkPat env pat
1261 ; return (env', SigPatOut pat' ty') }
1262
1263 zonk_pat env (NPat (L l lit) mb_neg eq_expr ty)
1264 = do { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr
1265 ; (env2, mb_neg') <- case mb_neg of
1266 Nothing -> return (env1, Nothing)
1267 Just n -> second Just <$> zonkSyntaxExpr env1 n
1268
1269 ; lit' <- zonkOverLit env2 lit
1270 ; ty' <- zonkTcTypeToType env2 ty
1271 ; return (env2, NPat (L l lit') mb_neg' eq_expr' ty') }
1272
1273 zonk_pat env (NPlusKPat (L loc n) (L l lit1) lit2 e1 e2 ty)
1274 = do { (env1, e1') <- zonkSyntaxExpr env e1
1275 ; (env2, e2') <- zonkSyntaxExpr env1 e2
1276 ; n' <- zonkIdBndr env2 n
1277 ; lit1' <- zonkOverLit env2 lit1
1278 ; lit2' <- zonkOverLit env2 lit2
1279 ; ty' <- zonkTcTypeToType env2 ty
1280 ; return (extendIdZonkEnv1 env2 n',
1281 NPlusKPat (L loc n') (L l lit1') lit2' e1' e2' ty') }
1282
1283 zonk_pat env (CoPat co_fn pat ty)
1284 = do { (env', co_fn') <- zonkCoFn env co_fn
1285 ; (env'', pat') <- zonkPat env' (noLoc pat)
1286 ; ty' <- zonkTcTypeToType env'' ty
1287 ; return (env'', CoPat co_fn' (unLoc pat') ty') }
1288
1289 zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
1290
1291 ---------------------------
1292 zonkConStuff :: ZonkEnv
1293 -> HsConDetails (OutPat TcId) (HsRecFields id (OutPat TcId))
1294 -> TcM (ZonkEnv,
1295 HsConDetails (OutPat Id) (HsRecFields id (OutPat Id)))
1296 zonkConStuff env (PrefixCon pats)
1297 = do { (env', pats') <- zonkPats env pats
1298 ; return (env', PrefixCon pats') }
1299
1300 zonkConStuff env (InfixCon p1 p2)
1301 = do { (env1, p1') <- zonkPat env p1
1302 ; (env', p2') <- zonkPat env1 p2
1303 ; return (env', InfixCon p1' p2') }
1304
1305 zonkConStuff env (RecCon (HsRecFields rpats dd))
1306 = do { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats)
1307 ; let rpats' = zipWith (\(L l rp) p' -> L l (rp { hsRecFieldArg = p' }))
1308 rpats pats'
1309 ; return (env', RecCon (HsRecFields rpats' dd)) }
1310 -- Field selectors have declared types; hence no zonking
1311
1312 ---------------------------
1313 zonkPats :: ZonkEnv -> [OutPat TcId] -> TcM (ZonkEnv, [OutPat Id])
1314 zonkPats env [] = return (env, [])
1315 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
1316 ; (env', pats') <- zonkPats env1 pats
1317 ; return (env', pat':pats') }
1318
1319 {-
1320 ************************************************************************
1321 * *
1322 \subsection[BackSubst-Foreign]{Foreign exports}
1323 * *
1324 ************************************************************************
1325 -}
1326
1327 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
1328 zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls
1329
1330 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
1331 zonkForeignExport env (ForeignExport { fd_name = i, fd_co = co, fd_fe = spec })
1332 = return (ForeignExport { fd_name = fmap (zonkIdOcc env) i
1333 , fd_sig_ty = undefined, fd_co = co
1334 , fd_fe = spec })
1335 zonkForeignExport _ for_imp
1336 = return for_imp -- Foreign imports don't need zonking
1337
1338 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
1339 zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs
1340
1341 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
1342 zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
1343 = do { (env_inside, new_bndrs) <- mapAccumLM zonk_bndr env vars
1344
1345 ; let env_lhs = setZonkType env_inside zonkTvSkolemising
1346 -- See Note [Zonking the LHS of a RULE]
1347
1348 ; new_lhs <- zonkLExpr env_lhs lhs
1349 ; new_rhs <- zonkLExpr env_inside rhs
1350
1351 ; return (HsRule name act new_bndrs new_lhs fv_lhs new_rhs fv_rhs) }
1352 where
1353 zonk_bndr env (L l (RuleBndr (L loc v)))
1354 = do { (env', v') <- zonk_it env v
1355 ; return (env', L l (RuleBndr (L loc v'))) }
1356 zonk_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_bndr RuleBndrSig"
1357
1358 zonk_it env v
1359 | isId v = do { v' <- zonkIdBndr env v
1360 ; return (extendIdZonkEnvRec env [v'], v') }
1361 | otherwise = ASSERT( isImmutableTyVar v)
1362 zonkTyBndrX env v
1363 -- DV: used to be return (env,v) but that is plain
1364 -- wrong because we may need to go inside the kind
1365 -- of v and zonk there!
1366
1367 zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id]
1368 zonkVects env = mapM (wrapLocM (zonkVect env))
1369
1370 zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id)
1371 zonkVect env (HsVect s v e)
1372 = do { v' <- wrapLocM (zonkIdBndr env) v
1373 ; e' <- zonkLExpr env e
1374 ; return $ HsVect s v' e'
1375 }
1376 zonkVect env (HsNoVect s v)
1377 = do { v' <- wrapLocM (zonkIdBndr env) v
1378 ; return $ HsNoVect s v'
1379 }
1380 zonkVect _env (HsVectTypeOut s t rt)
1381 = return $ HsVectTypeOut s t rt
1382 zonkVect _ (HsVectTypeIn _ _ _ _) = panic "TcHsSyn.zonkVect: HsVectTypeIn"
1383 zonkVect _env (HsVectClassOut c)
1384 = return $ HsVectClassOut c
1385 zonkVect _ (HsVectClassIn _ _) = panic "TcHsSyn.zonkVect: HsVectClassIn"
1386 zonkVect _env (HsVectInstOut i)
1387 = return $ HsVectInstOut i
1388 zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn"
1389
1390 {-
1391 ************************************************************************
1392 * *
1393 Constraints and evidence
1394 * *
1395 ************************************************************************
1396 -}
1397
1398 zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
1399 zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v )
1400 zonkEvVarOcc env v
1401 zonkEvTerm env (EvCoercion co) = do { co' <- zonkCoToCo env co
1402 ; return (EvCoercion co') }
1403 zonkEvTerm env (EvCast tm co) = do { tm' <- zonkEvTerm env tm
1404 ; co' <- zonkCoToCo env co
1405 ; return (mkEvCast tm' co') }
1406 zonkEvTerm _ (EvLit l) = return (EvLit l)
1407
1408 zonkEvTerm env (EvTypeable ty ev) =
1409 do { ev' <- zonkEvTypeable env ev
1410 ; ty' <- zonkTcTypeToType env ty
1411 ; return (EvTypeable ty' ev') }
1412 zonkEvTerm env (EvCallStack cs)
1413 = case cs of
1414 EvCsEmpty -> return (EvCallStack cs)
1415 EvCsPushCall n l tm -> do { tm' <- zonkEvTerm env tm
1416 ; return (EvCallStack (EvCsPushCall n l tm')) }
1417
1418 zonkEvTerm env (EvSuperClass d n) = do { d' <- zonkEvTerm env d
1419 ; return (EvSuperClass d' n) }
1420 zonkEvTerm env (EvDFunApp df tys tms)
1421 = do { tys' <- zonkTcTypeToTypes env tys
1422 ; tms' <- mapM (zonkEvTerm env) tms
1423 ; return (EvDFunApp (zonkIdOcc env df) tys' tms') }
1424 zonkEvTerm env (EvDelayedError ty msg)
1425 = do { ty' <- zonkTcTypeToType env ty
1426 ; return (EvDelayedError ty' msg) }
1427
1428 zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
1429 zonkEvTypeable env (EvTypeableTyCon ts)
1430 = do { ts' <- mapM (zonkEvTerm env) ts
1431 ; return $ EvTypeableTyCon ts' }
1432 zonkEvTypeable env (EvTypeableTyApp t1 t2)
1433 = do { t1' <- zonkEvTerm env t1
1434 ; t2' <- zonkEvTerm env t2
1435 ; return (EvTypeableTyApp t1' t2') }
1436 zonkEvTypeable env (EvTypeableTyLit t1)
1437 = do { t1' <- zonkEvTerm env t1
1438 ; return (EvTypeableTyLit t1') }
1439
1440 zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])
1441 zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs
1442 ; return (env, [EvBinds (unionManyBags bs')]) }
1443
1444 zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
1445 zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs
1446 ; return (env', EvBinds bs') }
1447
1448 zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind)
1449 zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var
1450 zonk_tc_ev_binds env (EvBinds bs) = zonkEvBinds env bs
1451
1452 zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
1453 zonkEvBindsVar env (EvBindsVar { ebv_binds = ref })
1454 = do { bs <- readMutVar ref
1455 ; zonkEvBinds env (evBindMapBinds bs) }
1456
1457 zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
1458 zonkEvBinds env binds
1459 = {-# SCC "zonkEvBinds" #-}
1460 fixM (\ ~( _, new_binds) -> do
1461 { let env1 = extendIdZonkEnvRec env (collect_ev_bndrs new_binds)
1462 ; binds' <- mapBagM (zonkEvBind env1) binds
1463 ; return (env1, binds') })
1464 where
1465 collect_ev_bndrs :: Bag EvBind -> [EvVar]
1466 collect_ev_bndrs = foldrBag add []
1467 add (EvBind { eb_lhs = var }) vars = var : vars
1468
1469 zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
1470 zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term })
1471 = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var
1472
1473 -- Optimise the common case of Refl coercions
1474 -- See Note [Optimise coercion zonking]
1475 -- This has a very big effect on some programs (eg Trac #5030)
1476
1477 ; term' <- case getEqPredTys_maybe (idType var') of
1478 Just (r, ty1, ty2) | ty1 `eqType` ty2
1479 -> return (EvCoercion (mkTcReflCo r ty1))
1480 _other -> zonkEvTerm env term
1481
1482 ; return (bind { eb_lhs = var', eb_rhs = term' }) }
1483
1484 {-
1485 ************************************************************************
1486 * *
1487 Zonking types
1488 * *
1489 ************************************************************************
1490
1491 Note [Zonking mutable unbound type or kind variables]
1492 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1493 In zonkTypeZapping, we zonk mutable but unbound type or kind variables to an
1494 arbitrary type. We know if they are unbound even though we don't carry an
1495 environment, because at the binding site for a variable we bind the mutable
1496 var to a fresh immutable one. So the mutable store plays the role of an
1497 environment. If we come across a mutable variable that isn't so bound, it
1498 must be completely free. We zonk the expected kind to make sure we don't get
1499 some unbound meta variable as the kind.
1500
1501 Note that since we have kind polymorphism, zonk_unbound_tyvar will handle both
1502 type and kind variables. Consider the following datatype:
1503
1504 data Phantom a = Phantom Int
1505
1506 The type of Phantom is (forall (k : *). forall (a : k). Int). Both `a` and
1507 `k` are unbound variables. We want to zonk this to
1508 (forall (k : Any *). forall (a : Any (Any *)). Int).
1509
1510 Note [Optimise coercion zonking]
1511 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1512 When optimising evidence binds we may come across situations where
1513 a coercion looks like
1514 cv = ReflCo ty
1515 or cv1 = cv2
1516 where the type 'ty' is big. In such cases it is a waste of time to zonk both
1517 * The variable on the LHS
1518 * The coercion on the RHS
1519 Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just
1520 use Refl on the right, ignoring the actual coercion on the RHS.
1521
1522 This can have a very big effect, because the constraint solver sometimes does go
1523 to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf Trac #5030)
1524
1525 -}
1526
1527 zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType
1528 zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv
1529 | isTcTyVar tv
1530 = case tcTyVarDetails tv of
1531 SkolemTv {} -> lookup_in_env
1532 RuntimeUnk {} -> lookup_in_env
1533 FlatSkol ty -> zonkTcTypeToType env ty
1534 MetaTv { mtv_ref = ref }
1535 -> do { cts <- readMutVar ref
1536 ; case cts of
1537 Flexi -> do { kind <- {-# SCC "zonkKind1" #-}
1538 zonkTcTypeToType env (tyVarKind tv)
1539 ; zonk_unbound_tyvar (setTyVarKind tv kind) }
1540 Indirect ty -> do { zty <- zonkTcTypeToType env ty
1541 -- Small optimisation: shortern-out indirect steps
1542 -- so that the old type may be more easily collected.
1543 ; writeMutVar ref (Indirect zty)
1544 ; return zty } }
1545 | otherwise
1546 = lookup_in_env
1547 where
1548 lookup_in_env -- Look up in the env just as we do for Ids
1549 = case lookupVarEnv tv_env tv of
1550 Nothing -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToType env) tv
1551 Just tv' -> return (mkTyVarTy tv')
1552
1553 zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion
1554 zonkCoVarOcc env@(ZonkEnv _ tyco_env _) cv
1555 | Just cv' <- lookupVarEnv tyco_env cv -- don't look in the knot-tied env
1556 = return $ mkCoVarCo cv'
1557 | otherwise
1558 = mkCoVarCo <$> updateVarTypeM (zonkTcTypeToType env) cv
1559
1560 zonkCoHole :: ZonkEnv -> CoercionHole
1561 -> Role -> Type -> Type -- these are all redundant with
1562 -- the details in the hole,
1563 -- unzonked
1564 -> TcM Coercion
1565 zonkCoHole env h r t1 t2
1566 = do { contents <- unpackCoercionHole_maybe h
1567 ; case contents of
1568 Just co -> do { co <- zonkCoToCo env co
1569 ; checkCoercionHole co h r t1 t2 }
1570
1571 -- This next case should happen only in the presence of
1572 -- (undeferred) type errors. Originally, I put in a panic
1573 -- here, but that caused too many uses of `failIfErrsM`.
1574 Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr h)
1575 ; when debugIsOn $
1576 whenNoErrs $
1577 MASSERT2( False
1578 , text "Type-correct unfilled coercion hole"
1579 <+> ppr h )
1580 ; t1 <- zonkTcTypeToType env t1
1581 ; t2 <- zonkTcTypeToType env t2
1582 ; return $ mkHoleCo h r t1 t2 } }
1583
1584 zonk_tycomapper :: TyCoMapper ZonkEnv TcM
1585 zonk_tycomapper = TyCoMapper
1586 { tcm_smart = True -- Establish type invariants
1587 -- See Note [Type-checking inside the knot] in TcHsType
1588 , tcm_tyvar = zonkTyVarOcc
1589 , tcm_covar = zonkCoVarOcc
1590 , tcm_hole = zonkCoHole
1591 , tcm_tybinder = \env tv _vis -> zonkTyBndrX env tv }
1592
1593 -- Confused by zonking? See Note [What is zonking?] in TcMType.
1594 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
1595 zonkTcTypeToType = mapType zonk_tycomapper
1596
1597 zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
1598 zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
1599
1600 zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion
1601 zonkCoToCo = mapCoercion zonk_tycomapper
1602
1603 zonkSigType :: TcType -> TcM Type
1604 -- Zonk the type obtained from a user type signature
1605 -- We want to turn any quantified (forall'd) variables into TyVars
1606 -- but we may find some free TcTyVars, and we want to leave them
1607 -- completely alone. They may even have unification variables inside
1608 -- e.g. f (x::a) = ...(e :: a -> a)....
1609 -- The type sig for 'e' mentions a free 'a' which will be a
1610 -- unification SigTv variable.
1611 zonkSigType = zonkTcTypeToType (mkEmptyZonkEnv zonk_unbound_tv)
1612 where
1613 zonk_unbound_tv :: UnboundTyVarZonker
1614 zonk_unbound_tv tv = return (mkTyVarTy tv)
1615
1616 zonkTvSkolemising :: UnboundTyVarZonker
1617 -- This variant is used for the LHS of rules
1618 -- See Note [Zonking the LHS of a RULE].
1619 zonkTvSkolemising tv
1620 = do { tv' <- skolemiseUnboundMetaTyVar tv
1621 ; return (mkTyVarTy tv') }
1622
1623 zonkTypeZapping :: UnboundTyVarZonker
1624 -- This variant is used for everything except the LHS of rules
1625 -- It zaps unbound type variables to Any, except for RuntimeRep
1626 -- vars which it zonks to PtrRepLIfted
1627 -- Works on both types and kinds
1628 zonkTypeZapping tv
1629 = do { let ty | isRuntimeRepVar tv = ptrRepLiftedTy
1630 | otherwise = anyTypeOfKind (tyVarKind tv)
1631 ; writeMetaTyVar tv ty
1632 ; return ty }
1633
1634 ---------------------------------------
1635 {- Note [Zonking the LHS of a RULE]
1636 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1637 See also DsBinds Note [Free tyvars on rule LHS]
1638
1639 We need to gather the type variables mentioned on the LHS so we can
1640 quantify over them. Example:
1641 data T a = C
1642
1643 foo :: T a -> Int
1644 foo C = 1
1645
1646 {-# RULES "myrule" foo C = 1 #-}
1647
1648 After type checking the LHS becomes (foo alpha (C alpha)) and we do
1649 not want to zap the unbound meta-tyvar 'alpha' to Any, because that
1650 limits the applicability of the rule. Instead, we want to quantify
1651 over it!
1652
1653 We do this in two stages.
1654
1655 * During zonking, we skolemise 'alpha' to 'a'. We do this by using
1656 zonkTvSkolemising as the UnboundTyVarZonker in the ZonkEnv.
1657 (This is the whole reason that the ZonkEnv has a UnboundTyVarZonker.)
1658
1659 * In DsBinds, we quantify over it. See DsBinds
1660 Note [Free tyvars on rule LHS]
1661
1662 Quantifying here is awkward because (a) the data type is big and (b)
1663 finding the free type vars of an expression is necessarily monadic
1664 operation. (consider /\a -> f @ b, where b is side-effected to a)
1665
1666 Note [Unboxed tuples in representation polymorphism check]
1667 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1668 Recall that all types that have values (that is, lifted and unlifted
1669 types) have kinds that look like (TYPE rep), where (rep :: RuntimeRep)
1670 tells how the values are represented at runtime. Lifted types have
1671 kind (TYPE PtrRepLifted) (for which * is just a synonym) and, say,
1672 Int# has kind (TYPE IntRep).
1673
1674 It would be terrible if the code generator came upon a binder of a type
1675 whose kind is something like TYPE r, where r is a skolem type variable.
1676 The code generator wouldn't know what to do. So we eliminate that case
1677 here.
1678
1679 Although representation polymorphism and the RuntimeRep type catch
1680 most ways of abusing unlifted types, it still isn't quite satisfactory
1681 around unboxed tuples. That's because all unboxed tuple types have kind
1682 TYPE UnboxedTupleRep, which is clearly a lie: it doesn't actually tell
1683 you what the representation is.
1684
1685 Naively, when checking for representation polymorphism, you might think we can
1686 just look for free variables in a type's RuntimeRep. But this misses the
1687 UnboxedTupleRep case.
1688
1689 So, instead, we handle unboxed tuples specially. Only after unboxed tuples
1690 are handled do we look for free tyvars in a RuntimeRep.
1691
1692 We must still be careful in the UnboxedTupleRep case. A binder whose type
1693 has kind UnboxedTupleRep is OK -- only as long as the type is really an
1694 unboxed tuple, which the code generator treats specially. So we do this:
1695 1. Check if the type is an unboxed tuple. If so, recur.
1696 2. Check if the kind is TYPE UnboxedTupleRep. If so, error.
1697 3. Check if the kind has any free variables. If so, error.
1698
1699 In case 1, we have a type that looks like
1700
1701 (# , #) PtrRepLifted IntRep Bool Int#
1702
1703 recalling that
1704
1705 (# , #) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep).
1706 TYPE r1 -> TYPE r2 -> TYPE UnboxedTupleRep
1707
1708 It's tempting just to look at the RuntimeRep arguments to make sure
1709 that they are devoid of free variables and not UnboxedTupleRep. This
1710 naive check, though, fails on nested unboxed tuples, like
1711 (# Int#, (# Bool, Void# #) #). Thus, instead of looking at the RuntimeRep
1712 args to the unboxed tuple constructor, we look at the types themselves.
1713
1714 Here are a few examples:
1715
1716 type family F r :: TYPE r
1717
1718 x :: (F r :: TYPE r) -- REJECTED: simple representation polymorphism
1719 where r is an in-scope type variable of kind RuntimeRep
1720
1721 x :: (F PtrRepLifted :: TYPE PtrRepLifted) -- OK
1722 x :: (F IntRep :: TYPE IntRep) -- OK
1723
1724 x :: (F UnboxedTupleRep :: TYPE UnboxedTupleRep) -- REJECTED
1725
1726 x :: ((# Int, Bool #) :: TYPE UnboxedTupleRep) -- OK
1727 -}
1728
1729 -- | According to the rules around representation polymorphism
1730 -- (see https://ghc.haskell.org/trac/ghc/wiki/NoSubKinds), no binder
1731 -- can have a representation-polymorphic type. This check ensures
1732 -- that we respect this rule. It is a bit regrettable that this error
1733 -- occurs in zonking, after which we should have reported all errors.
1734 -- But it's hard to see where else to do it, because this can be discovered
1735 -- only after all solving is done. And, perhaps most importantly, this
1736 -- isn't really a compositional property of a type system, so it's
1737 -- not a terrible surprise that the check has to go in an awkward spot.
1738 ensureNotRepresentationPolymorphic
1739 :: Type -- its zonked type
1740 -> SDoc -- where this happened
1741 -> TcM ()
1742 ensureNotRepresentationPolymorphic ty doc
1743 = whenNoErrs $ -- sometimes we end up zonking bogus definitions of type
1744 -- forall a. a. See, for example, test ghci/scripts/T9140
1745 checkForRepresentationPolymorphism doc ty
1746
1747 -- See Note [Unboxed tuples in representation polymorphism check]
1748 checkForRepresentationPolymorphism :: SDoc -> Type -> TcM ()
1749 checkForRepresentationPolymorphism extra ty
1750 | Just (tc, tys) <- splitTyConApp_maybe ty
1751 , isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc
1752 = mapM_ (checkForRepresentationPolymorphism extra) (dropRuntimeRepArgs tys)
1753
1754 | tuple_rep || sum_rep
1755 = addErr (vcat [ text "The type" <+> quotes (ppr tidy_ty) <+>
1756 (text "is not an unboxed" <+> tuple_or_sum <> comma)
1757 , text "and yet its kind suggests that it has the representation"
1758 , text "of an unboxed" <+> tuple_or_sum <> text ". This is not allowed." ] $$
1759 extra)
1760
1761 | not (isEmptyVarSet (tyCoVarsOfType runtime_rep))
1762 = addErr $
1763 hang (text "A representation-polymorphic type is not allowed here:")
1764 2 (vcat [ text "Type:" <+> ppr tidy_ty
1765 , text "Kind:" <+> ppr tidy_ki ]) $$
1766 extra
1767
1768 | otherwise
1769 = return ()
1770 where
1771 tuple_rep = runtime_rep `eqType` unboxedTupleRepDataConTy
1772 sum_rep = runtime_rep `eqType` unboxedSumRepDataConTy
1773 tuple_or_sum = text (if tuple_rep then "tuple" else "sum")
1774
1775 ki = typeKind ty
1776 runtime_rep = getRuntimeRepFromKind "check_type" ki
1777
1778 (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty
1779 tidy_ki = tidyType tidy_env (typeKind ty)