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