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