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