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