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