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