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