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