Avoid panic due to partial ieName
[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 (L _ 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 . concatMap (map rdrNameOcc . ieNames . 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 = L l ms, mg_arg_tys = arg_tys
541 , mg_res_ty = res_ty, mg_origin = origin })
542 = do { ms' <- mapM (zonkMatch env zBody) ms
543 ; arg_tys' <- zonkTcTypeToTypes env arg_tys
544 ; res_ty' <- zonkTcTypeToType env res_ty
545 ; return (MG { mg_alts = L l ms', mg_arg_tys = arg_tys'
546 , mg_res_ty = res_ty', mg_origin = origin }) }
547
548 zonkMatch :: ZonkEnv
549 -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
550 -> LMatch TcId (Located (body TcId)) -> TcM (LMatch Id (Located (body Id)))
551 zonkMatch env zBody (L loc (Match mf pats _ grhss))
552 = do { (env1, new_pats) <- zonkPats env pats
553 ; new_grhss <- zonkGRHSs env1 zBody grhss
554 ; return (L loc (Match mf new_pats Nothing new_grhss)) }
555
556 -------------------------------------------------------------------------
557 zonkGRHSs :: ZonkEnv
558 -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
559 -> GRHSs TcId (Located (body TcId)) -> TcM (GRHSs Id (Located (body Id)))
560
561 zonkGRHSs env zBody (GRHSs grhss (L l binds)) = do
562 (new_env, new_binds) <- zonkLocalBinds env binds
563 let
564 zonk_grhs (GRHS guarded rhs)
565 = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
566 new_rhs <- zBody env2 rhs
567 return (GRHS new_guarded new_rhs)
568 new_grhss <- mapM (wrapLocM zonk_grhs) grhss
569 return (GRHSs new_grhss (L l new_binds))
570
571 {-
572 ************************************************************************
573 * *
574 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
575 * *
576 ************************************************************************
577 -}
578
579 zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id]
580 zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id)
581 zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id)
582
583 zonkLExprs env exprs = mapM (zonkLExpr env) exprs
584 zonkLExpr env expr = wrapLocM (zonkExpr env) expr
585
586 zonkExpr env (HsVar (L l id))
587 = return (HsVar (L l (zonkIdOcc env id)))
588
589 zonkExpr _ (HsIPVar id)
590 = return (HsIPVar id)
591
592 zonkExpr _ (HsOverLabel l)
593 = return (HsOverLabel l)
594
595 zonkExpr env (HsLit (HsRat f ty))
596 = do new_ty <- zonkTcTypeToType env ty
597 return (HsLit (HsRat f new_ty))
598
599 zonkExpr _ (HsLit lit)
600 = return (HsLit lit)
601
602 zonkExpr env (HsOverLit lit)
603 = do { lit' <- zonkOverLit env lit
604 ; return (HsOverLit lit') }
605
606 zonkExpr env (HsLam matches)
607 = do new_matches <- zonkMatchGroup env zonkLExpr matches
608 return (HsLam new_matches)
609
610 zonkExpr env (HsLamCase arg matches)
611 = do new_arg <- zonkTcTypeToType env arg
612 new_matches <- zonkMatchGroup env zonkLExpr matches
613 return (HsLamCase new_arg new_matches)
614
615 zonkExpr env (HsApp e1 e2)
616 = do new_e1 <- zonkLExpr env e1
617 new_e2 <- zonkLExpr env e2
618 return (HsApp new_e1 new_e2)
619
620 zonkExpr _ e@(HsRnBracketOut _ _)
621 = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)
622
623 zonkExpr env (HsTcBracketOut body bs)
624 = do bs' <- mapM zonk_b bs
625 return (HsTcBracketOut body bs')
626 where
627 zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
628 return (PendingTcSplice n e')
629
630 zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
631 return (HsSpliceE s)
632
633 zonkExpr env (OpApp e1 op fixity e2)
634 = do new_e1 <- zonkLExpr env e1
635 new_op <- zonkLExpr env op
636 new_e2 <- zonkLExpr env e2
637 return (OpApp new_e1 new_op fixity new_e2)
638
639 zonkExpr env (NegApp expr op)
640 = do new_expr <- zonkLExpr env expr
641 new_op <- zonkExpr env op
642 return (NegApp new_expr new_op)
643
644 zonkExpr env (HsPar e)
645 = do new_e <- zonkLExpr env e
646 return (HsPar new_e)
647
648 zonkExpr env (SectionL expr op)
649 = do new_expr <- zonkLExpr env expr
650 new_op <- zonkLExpr env op
651 return (SectionL new_expr new_op)
652
653 zonkExpr env (SectionR op expr)
654 = do new_op <- zonkLExpr env op
655 new_expr <- zonkLExpr env expr
656 return (SectionR new_op new_expr)
657
658 zonkExpr env (ExplicitTuple tup_args boxed)
659 = do { new_tup_args <- mapM zonk_tup_arg tup_args
660 ; return (ExplicitTuple new_tup_args boxed) }
661 where
662 zonk_tup_arg (L l (Present e)) = do { e' <- zonkLExpr env e
663 ; return (L l (Present e')) }
664 zonk_tup_arg (L l (Missing t)) = do { t' <- zonkTcTypeToType env t
665 ; return (L l (Missing t')) }
666
667 zonkExpr env (HsCase expr ms)
668 = do new_expr <- zonkLExpr env expr
669 new_ms <- zonkMatchGroup env zonkLExpr ms
670 return (HsCase new_expr new_ms)
671
672 zonkExpr env (HsIf e0 e1 e2 e3)
673 = do { new_e0 <- fmapMaybeM (zonkExpr env) e0
674 ; new_e1 <- zonkLExpr env e1
675 ; new_e2 <- zonkLExpr env e2
676 ; new_e3 <- zonkLExpr env e3
677 ; return (HsIf new_e0 new_e1 new_e2 new_e3) }
678
679 zonkExpr env (HsMultiIf ty alts)
680 = do { alts' <- mapM (wrapLocM zonk_alt) alts
681 ; ty' <- zonkTcTypeToType env ty
682 ; return $ HsMultiIf ty' alts' }
683 where zonk_alt (GRHS guard expr)
684 = do { (env', guard') <- zonkStmts env zonkLExpr guard
685 ; expr' <- zonkLExpr env' expr
686 ; return $ GRHS guard' expr' }
687
688 zonkExpr env (HsLet (L l binds) expr)
689 = do (new_env, new_binds) <- zonkLocalBinds env binds
690 new_expr <- zonkLExpr new_env expr
691 return (HsLet (L l new_binds) new_expr)
692
693 zonkExpr env (HsDo do_or_lc (L l stmts) ty)
694 = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
695 new_ty <- zonkTcTypeToType env ty
696 return (HsDo do_or_lc (L l new_stmts) new_ty)
697
698 zonkExpr env (ExplicitList ty wit exprs)
699 = do new_ty <- zonkTcTypeToType env ty
700 new_wit <- zonkWit env wit
701 new_exprs <- zonkLExprs env exprs
702 return (ExplicitList new_ty new_wit new_exprs)
703 where zonkWit _ Nothing = return Nothing
704 zonkWit env (Just fln) = do new_fln <- zonkExpr env fln
705 return (Just new_fln)
706
707 zonkExpr env (ExplicitPArr ty exprs)
708 = do new_ty <- zonkTcTypeToType env ty
709 new_exprs <- zonkLExprs env exprs
710 return (ExplicitPArr new_ty new_exprs)
711
712 zonkExpr env expr@(RecordCon { rcon_con_expr = con_expr, rcon_flds = rbinds })
713 = do { new_con_expr <- zonkExpr env con_expr
714 ; new_rbinds <- zonkRecFields env rbinds
715 ; return (expr { rcon_con_expr = new_con_expr
716 , rcon_flds = new_rbinds }) }
717
718 zonkExpr env (RecordUpd { rupd_expr = expr, rupd_flds = rbinds
719 , rupd_cons = cons, rupd_in_tys = in_tys
720 , rupd_out_tys = out_tys, rupd_wrap = req_wrap })
721 = do { new_expr <- zonkLExpr env expr
722 ; new_in_tys <- mapM (zonkTcTypeToType env) in_tys
723 ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys
724 ; new_rbinds <- zonkRecUpdFields env rbinds
725 ; (_, new_recwrap) <- zonkCoFn env req_wrap
726 ; return (RecordUpd { rupd_expr = new_expr, rupd_flds = new_rbinds
727 , rupd_cons = cons, rupd_in_tys = new_in_tys
728 , rupd_out_tys = new_out_tys, rupd_wrap = new_recwrap }) }
729
730 zonkExpr env (ExprWithTySigOut e ty)
731 = do { e' <- zonkLExpr env e
732 ; return (ExprWithTySigOut e' ty) }
733
734 zonkExpr env (ArithSeq expr wit info)
735 = do new_expr <- zonkExpr env expr
736 new_wit <- zonkWit env wit
737 new_info <- zonkArithSeq env info
738 return (ArithSeq new_expr new_wit new_info)
739 where zonkWit _ Nothing = return Nothing
740 zonkWit env (Just fln) = do new_fln <- zonkExpr env fln
741 return (Just new_fln)
742
743 zonkExpr env (PArrSeq expr info)
744 = do new_expr <- zonkExpr env expr
745 new_info <- zonkArithSeq env info
746 return (PArrSeq new_expr new_info)
747
748 zonkExpr env (HsSCC src lbl expr)
749 = do new_expr <- zonkLExpr env expr
750 return (HsSCC src lbl new_expr)
751
752 zonkExpr env (HsTickPragma src info expr)
753 = do new_expr <- zonkLExpr env expr
754 return (HsTickPragma src info new_expr)
755
756 -- hdaume: core annotations
757 zonkExpr env (HsCoreAnn src lbl expr)
758 = do new_expr <- zonkLExpr env expr
759 return (HsCoreAnn src lbl new_expr)
760
761 -- arrow notation extensions
762 zonkExpr env (HsProc pat body)
763 = do { (env1, new_pat) <- zonkPat env pat
764 ; new_body <- zonkCmdTop env1 body
765 ; return (HsProc new_pat new_body) }
766
767 -- StaticPointers extension
768 zonkExpr env (HsStatic expr)
769 = HsStatic <$> zonkLExpr env expr
770
771 zonkExpr env (HsWrap co_fn expr)
772 = do (env1, new_co_fn) <- zonkCoFn env co_fn
773 new_expr <- zonkExpr env1 expr
774 return (HsWrap new_co_fn new_expr)
775
776 zonkExpr _ (HsUnboundVar v)
777 = return (HsUnboundVar v)
778
779 zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
780
781 -------------------------------------------------------------------------
782
783 zonkLCmd :: ZonkEnv -> LHsCmd TcId -> TcM (LHsCmd Id)
784 zonkCmd :: ZonkEnv -> HsCmd TcId -> TcM (HsCmd Id)
785
786 zonkLCmd env cmd = wrapLocM (zonkCmd env) cmd
787
788 zonkCmd env (HsCmdCast co cmd)
789 = do { co' <- zonkTcCoToCo env co
790 ; cmd' <- zonkCmd env cmd
791 ; return (HsCmdCast co' cmd') }
792 zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)
793 = do new_e1 <- zonkLExpr env e1
794 new_e2 <- zonkLExpr env e2
795 new_ty <- zonkTcTypeToType env ty
796 return (HsCmdArrApp new_e1 new_e2 new_ty ho rl)
797
798 zonkCmd env (HsCmdArrForm op fixity args)
799 = do new_op <- zonkLExpr env op
800 new_args <- mapM (zonkCmdTop env) args
801 return (HsCmdArrForm new_op fixity new_args)
802
803 zonkCmd env (HsCmdApp c e)
804 = do new_c <- zonkLCmd env c
805 new_e <- zonkLExpr env e
806 return (HsCmdApp new_c new_e)
807
808 zonkCmd env (HsCmdLam matches)
809 = do new_matches <- zonkMatchGroup env zonkLCmd matches
810 return (HsCmdLam new_matches)
811
812 zonkCmd env (HsCmdPar c)
813 = do new_c <- zonkLCmd env c
814 return (HsCmdPar new_c)
815
816 zonkCmd env (HsCmdCase expr ms)
817 = do new_expr <- zonkLExpr env expr
818 new_ms <- zonkMatchGroup env zonkLCmd ms
819 return (HsCmdCase new_expr new_ms)
820
821 zonkCmd env (HsCmdIf eCond ePred cThen cElse)
822 = do { new_eCond <- fmapMaybeM (zonkExpr env) eCond
823 ; new_ePred <- zonkLExpr env ePred
824 ; new_cThen <- zonkLCmd env cThen
825 ; new_cElse <- zonkLCmd env cElse
826 ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
827
828 zonkCmd env (HsCmdLet (L l binds) cmd)
829 = do (new_env, new_binds) <- zonkLocalBinds env binds
830 new_cmd <- zonkLCmd new_env cmd
831 return (HsCmdLet (L l new_binds) new_cmd)
832
833 zonkCmd env (HsCmdDo (L l stmts) ty)
834 = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
835 new_ty <- zonkTcTypeToType env ty
836 return (HsCmdDo (L l new_stmts) new_ty)
837
838
839
840
841
842 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
843 zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
844
845 zonk_cmd_top :: ZonkEnv -> HsCmdTop TcId -> TcM (HsCmdTop Id)
846 zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids)
847 = do new_cmd <- zonkLCmd env cmd
848 new_stack_tys <- zonkTcTypeToType env stack_tys
849 new_ty <- zonkTcTypeToType env ty
850 new_ids <- mapSndM (zonkExpr env) ids
851 return (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
852
853 -------------------------------------------------------------------------
854 zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
855 zonkCoFn env WpHole = return (env, WpHole)
856 zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
857 ; (env2, c2') <- zonkCoFn env1 c2
858 ; return (env2, WpCompose c1' c2') }
859 zonkCoFn env (WpFun c1 c2 t1 t2) = do { (env1, c1') <- zonkCoFn env c1
860 ; (env2, c2') <- zonkCoFn env1 c2
861 ; t1' <- zonkTcTypeToType env2 t1
862 ; t2' <- zonkTcTypeToType env2 t2
863 ; return (env2, WpFun c1' c2' t1' t2') }
864 zonkCoFn env (WpCast co) = do { co' <- zonkTcCoToCo env co
865 ; return (env, WpCast co') }
866 zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev
867 ; return (env', WpEvLam ev') }
868 zonkCoFn env (WpEvApp arg) = do { arg' <- zonkEvTerm env arg
869 ; return (env, WpEvApp arg') }
870 zonkCoFn env (WpTyLam tv) = ASSERT( isImmutableTyVar tv )
871 do { (env', tv') <- zonkTyBndrX env tv
872 ; return (env', WpTyLam tv') }
873 zonkCoFn env (WpTyApp ty) = do { ty' <- zonkTcTypeToType env ty
874 ; return (env, WpTyApp ty') }
875 zonkCoFn env (WpLet bs) = do { (env1, bs') <- zonkTcEvBinds env bs
876 ; return (env1, WpLet bs') }
877
878 -------------------------------------------------------------------------
879 zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
880 zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty })
881 = do { ty' <- zonkTcTypeToType env ty
882 ; e' <- zonkExpr env e
883 ; return (lit { ol_witness = e', ol_type = ty' }) }
884
885 -------------------------------------------------------------------------
886 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)
887
888 zonkArithSeq env (From e)
889 = do new_e <- zonkLExpr env e
890 return (From new_e)
891
892 zonkArithSeq env (FromThen e1 e2)
893 = do new_e1 <- zonkLExpr env e1
894 new_e2 <- zonkLExpr env e2
895 return (FromThen new_e1 new_e2)
896
897 zonkArithSeq env (FromTo e1 e2)
898 = do new_e1 <- zonkLExpr env e1
899 new_e2 <- zonkLExpr env e2
900 return (FromTo new_e1 new_e2)
901
902 zonkArithSeq env (FromThenTo e1 e2 e3)
903 = do new_e1 <- zonkLExpr env e1
904 new_e2 <- zonkLExpr env e2
905 new_e3 <- zonkLExpr env e3
906 return (FromThenTo new_e1 new_e2 new_e3)
907
908
909 -------------------------------------------------------------------------
910 zonkStmts :: ZonkEnv
911 -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
912 -> [LStmt TcId (Located (body TcId))] -> TcM (ZonkEnv, [LStmt Id (Located (body Id))])
913 zonkStmts env _ [] = return (env, [])
914 zonkStmts env zBody (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env zBody) s
915 ; (env2, ss') <- zonkStmts env1 zBody ss
916 ; return (env2, s' : ss') }
917
918 zonkStmt :: ZonkEnv
919 -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
920 -> Stmt TcId (Located (body TcId)) -> TcM (ZonkEnv, Stmt Id (Located (body Id)))
921 zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op)
922 = do { new_stmts_w_bndrs <- mapM zonk_branch stmts_w_bndrs
923 ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs]
924 env1 = extendIdZonkEnv env new_binders
925 ; new_mzip <- zonkExpr env1 mzip_op
926 ; new_bind <- zonkExpr env1 bind_op
927 ; return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind) }
928 where
929 zonk_branch (ParStmtBlock stmts bndrs return_op)
930 = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
931 ; new_return <- zonkExpr env1 return_op
932 ; return (ParStmtBlock new_stmts (zonkIdOccs env1 bndrs) new_return) }
933
934 zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
935 , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id
936 , recS_later_rets = later_rets, recS_rec_rets = rec_rets
937 , recS_ret_ty = ret_ty })
938 = do { new_rvs <- zonkIdBndrs env rvs
939 ; new_lvs <- zonkIdBndrs env lvs
940 ; new_ret_ty <- zonkTcTypeToType env ret_ty
941 ; new_ret_id <- zonkExpr env ret_id
942 ; new_mfix_id <- zonkExpr env mfix_id
943 ; new_bind_id <- zonkExpr env bind_id
944 ; let env1 = extendIdZonkEnv env new_rvs
945 ; (env2, new_segStmts) <- zonkStmts env1 zBody segStmts
946 -- Zonk the ret-expressions in an envt that
947 -- has the polymorphic bindings in the envt
948 ; new_later_rets <- mapM (zonkExpr env2) later_rets
949 ; new_rec_rets <- mapM (zonkExpr env2) rec_rets
950 ; return (extendIdZonkEnv env new_lvs, -- Only the lvs are needed
951 RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
952 , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
953 , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
954 , recS_later_rets = new_later_rets
955 , recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) }
956
957 zonkStmt env zBody (BodyStmt body then_op guard_op ty)
958 = do new_body <- zBody env body
959 new_then <- zonkExpr env then_op
960 new_guard <- zonkExpr env guard_op
961 new_ty <- zonkTcTypeToType env ty
962 return (env, BodyStmt new_body new_then new_guard new_ty)
963
964 zonkStmt env zBody (LastStmt body noret ret_op)
965 = do new_body <- zBody env body
966 new_ret <- zonkExpr env ret_op
967 return (env, LastStmt new_body noret new_ret)
968
969 zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
970 , trS_by = by, trS_form = form, trS_using = using
971 , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op })
972 = do { (env', stmts') <- zonkStmts env zonkLExpr stmts
973 ; binderMap' <- mapM (zonkBinderMapEntry env') binderMap
974 ; by' <- fmapMaybeM (zonkLExpr env') by
975 ; using' <- zonkLExpr env using
976 ; return_op' <- zonkExpr env' return_op
977 ; bind_op' <- zonkExpr env' bind_op
978 ; liftM_op' <- zonkExpr env' liftM_op
979 ; let env'' = extendIdZonkEnv env' (map snd binderMap')
980 ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
981 , trS_by = by', trS_form = form, trS_using = using'
982 , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) }
983 where
984 zonkBinderMapEntry env (oldBinder, newBinder) = do
985 let oldBinder' = zonkIdOcc env oldBinder
986 newBinder' <- zonkIdBndr env newBinder
987 return (oldBinder', newBinder')
988
989 zonkStmt env _ (LetStmt (L l binds))
990 = do (env1, new_binds) <- zonkLocalBinds env binds
991 return (env1, LetStmt (L l new_binds))
992
993 zonkStmt env zBody (BindStmt pat body bind_op fail_op)
994 = do { new_body <- zBody env body
995 ; (env1, new_pat) <- zonkPat env pat
996 ; new_bind <- zonkExpr env bind_op
997 ; new_fail <- zonkExpr env fail_op
998 ; return (env1, BindStmt new_pat new_body new_bind new_fail) }
999
1000 zonkStmt env _zBody (ApplicativeStmt args mb_join body_ty)
1001 = do { (env', args') <- zonk_args env args
1002 ; new_mb_join <- traverse (zonkExpr env) mb_join
1003 ; new_body_ty <- zonkTcTypeToType env' body_ty
1004 ; return (env', ApplicativeStmt args' new_mb_join new_body_ty) }
1005 where
1006 zonk_args env [] = return (env, [])
1007 zonk_args env ((op, arg) : groups)
1008 = do { (env1, arg') <- zonk_arg env arg
1009 ; op' <- zonkExpr env1 op
1010 ; (env2, ss) <- zonk_args env1 groups
1011 ; return (env2, (op', arg') : ss) }
1012
1013 zonk_arg env (ApplicativeArgOne pat expr)
1014 = do { (env1, new_pat) <- zonkPat env pat
1015 ; new_expr <- zonkLExpr env expr
1016 ; return (env1, ApplicativeArgOne new_pat new_expr) }
1017 zonk_arg env (ApplicativeArgMany stmts ret pat)
1018 = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
1019 ; new_ret <- zonkExpr env1 ret
1020 ; (env2, new_pat) <- zonkPat env pat
1021 ; return (env2, ApplicativeArgMany new_stmts new_ret new_pat) }
1022
1023 -------------------------------------------------------------------------
1024 zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
1025 zonkRecFields env (HsRecFields flds dd)
1026 = do { flds' <- mapM zonk_rbind flds
1027 ; return (HsRecFields flds' dd) }
1028 where
1029 zonk_rbind (L l fld)
1030 = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld)
1031 ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
1032 ; return (L l (fld { hsRecFieldLbl = new_id
1033 , hsRecFieldArg = new_expr })) }
1034
1035 zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField TcId] -> TcM [LHsRecUpdField TcId]
1036 zonkRecUpdFields env = mapM zonk_rbind
1037 where
1038 zonk_rbind (L l fld)
1039 = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld)
1040 ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
1041 ; return (L l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id
1042 , hsRecFieldArg = new_expr })) }
1043
1044 -------------------------------------------------------------------------
1045 mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a
1046 -> TcM (Either (Located HsIPName) b)
1047 mapIPNameTc _ (Left x) = return (Left x)
1048 mapIPNameTc f (Right x) = do r <- f x
1049 return (Right r)
1050
1051 {-
1052 ************************************************************************
1053 * *
1054 \subsection[BackSubst-Pats]{Patterns}
1055 * *
1056 ************************************************************************
1057 -}
1058
1059 zonkPat :: ZonkEnv -> OutPat TcId -> TcM (ZonkEnv, OutPat Id)
1060 -- Extend the environment as we go, because it's possible for one
1061 -- pattern to bind something that is used in another (inside or
1062 -- to the right)
1063 zonkPat env pat = wrapLocSndM (zonk_pat env) pat
1064
1065 zonk_pat :: ZonkEnv -> Pat TcId -> TcM (ZonkEnv, Pat Id)
1066 zonk_pat env (ParPat p)
1067 = do { (env', p') <- zonkPat env p
1068 ; return (env', ParPat p') }
1069
1070 zonk_pat env (WildPat ty)
1071 = do { ty' <- zonkTcTypeToType env ty
1072 ; return (env, WildPat ty') }
1073
1074 zonk_pat env (VarPat (L l v))
1075 = do { v' <- zonkIdBndr env v
1076 ; return (extendIdZonkEnv1 env v', VarPat (L l v')) }
1077
1078 zonk_pat env (LazyPat pat)
1079 = do { (env', pat') <- zonkPat env pat
1080 ; return (env', LazyPat pat') }
1081
1082 zonk_pat env (BangPat pat)
1083 = do { (env', pat') <- zonkPat env pat
1084 ; return (env', BangPat pat') }
1085
1086 zonk_pat env (AsPat (L loc v) pat)
1087 = do { v' <- zonkIdBndr env v
1088 ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat
1089 ; return (env', AsPat (L loc v') pat') }
1090
1091 zonk_pat env (ViewPat expr pat ty)
1092 = do { expr' <- zonkLExpr env expr
1093 ; (env', pat') <- zonkPat env pat
1094 ; ty' <- zonkTcTypeToType env ty
1095 ; return (env', ViewPat expr' pat' ty') }
1096
1097 zonk_pat env (ListPat pats ty Nothing)
1098 = do { ty' <- zonkTcTypeToType env ty
1099 ; (env', pats') <- zonkPats env pats
1100 ; return (env', ListPat pats' ty' Nothing) }
1101
1102 zonk_pat env (ListPat pats ty (Just (ty2,wit)))
1103 = do { wit' <- zonkExpr env wit
1104 ; ty2' <- zonkTcTypeToType env ty2
1105 ; ty' <- zonkTcTypeToType env ty
1106 ; (env', pats') <- zonkPats env pats
1107 ; return (env', ListPat pats' ty' (Just (ty2',wit'))) }
1108
1109 zonk_pat env (PArrPat pats ty)
1110 = do { ty' <- zonkTcTypeToType env ty
1111 ; (env', pats') <- zonkPats env pats
1112 ; return (env', PArrPat pats' ty') }
1113
1114 zonk_pat env (TuplePat pats boxed tys)
1115 = do { tys' <- mapM (zonkTcTypeToType env) tys
1116 ; (env', pats') <- zonkPats env pats
1117 ; return (env', TuplePat pats' boxed tys') }
1118
1119 zonk_pat env p@(ConPatOut { pat_arg_tys = tys, pat_tvs = tyvars
1120 , pat_dicts = evs, pat_binds = binds
1121 , pat_args = args, pat_wrap = wrapper })
1122 = ASSERT( all isImmutableTyVar tyvars )
1123 do { new_tys <- mapM (zonkTcTypeToType env) tys
1124 ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars
1125 -- Must zonk the existential variables, because their
1126 -- /kind/ need potential zonking.
1127 -- cf typecheck/should_compile/tc221.hs
1128 ; (env1, new_evs) <- zonkEvBndrsX env0 evs
1129 ; (env2, new_binds) <- zonkTcEvBinds env1 binds
1130 ; (env3, new_wrapper) <- zonkCoFn env2 wrapper
1131 ; (env', new_args) <- zonkConStuff env3 args
1132 ; return (env', p { pat_arg_tys = new_tys,
1133 pat_tvs = new_tyvars,
1134 pat_dicts = new_evs,
1135 pat_binds = new_binds,
1136 pat_args = new_args,
1137 pat_wrap = new_wrapper}) }
1138
1139 zonk_pat env (LitPat lit) = return (env, LitPat lit)
1140
1141 zonk_pat env (SigPatOut pat ty)
1142 = do { ty' <- zonkTcTypeToType env ty
1143 ; (env', pat') <- zonkPat env pat
1144 ; return (env', SigPatOut pat' ty') }
1145
1146 zonk_pat env (NPat (L l lit) mb_neg eq_expr)
1147 = do { lit' <- zonkOverLit env lit
1148 ; mb_neg' <- fmapMaybeM (zonkExpr env) mb_neg
1149 ; eq_expr' <- zonkExpr env eq_expr
1150 ; return (env, NPat (L l lit') mb_neg' eq_expr') }
1151
1152 zonk_pat env (NPlusKPat (L loc n) (L l lit) e1 e2)
1153 = do { n' <- zonkIdBndr env n
1154 ; lit' <- zonkOverLit env lit
1155 ; e1' <- zonkExpr env e1
1156 ; e2' <- zonkExpr env e2
1157 ; return (extendIdZonkEnv1 env n',
1158 NPlusKPat (L loc n') (L l lit') e1' e2') }
1159
1160 zonk_pat env (CoPat co_fn pat ty)
1161 = do { (env', co_fn') <- zonkCoFn env co_fn
1162 ; (env'', pat') <- zonkPat env' (noLoc pat)
1163 ; ty' <- zonkTcTypeToType env'' ty
1164 ; return (env'', CoPat co_fn' (unLoc pat') ty') }
1165
1166 zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
1167
1168 ---------------------------
1169 zonkConStuff :: ZonkEnv
1170 -> HsConDetails (OutPat TcId) (HsRecFields id (OutPat TcId))
1171 -> TcM (ZonkEnv,
1172 HsConDetails (OutPat Id) (HsRecFields id (OutPat Id)))
1173 zonkConStuff env (PrefixCon pats)
1174 = do { (env', pats') <- zonkPats env pats
1175 ; return (env', PrefixCon pats') }
1176
1177 zonkConStuff env (InfixCon p1 p2)
1178 = do { (env1, p1') <- zonkPat env p1
1179 ; (env', p2') <- zonkPat env1 p2
1180 ; return (env', InfixCon p1' p2') }
1181
1182 zonkConStuff env (RecCon (HsRecFields rpats dd))
1183 = do { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats)
1184 ; let rpats' = zipWith (\(L l rp) p' -> L l (rp { hsRecFieldArg = p' }))
1185 rpats pats'
1186 ; return (env', RecCon (HsRecFields rpats' dd)) }
1187 -- Field selectors have declared types; hence no zonking
1188
1189 ---------------------------
1190 zonkPats :: ZonkEnv -> [OutPat TcId] -> TcM (ZonkEnv, [OutPat Id])
1191 zonkPats env [] = return (env, [])
1192 zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
1193 ; (env', pats') <- zonkPats env1 pats
1194 ; return (env', pat':pats') }
1195
1196 {-
1197 ************************************************************************
1198 * *
1199 \subsection[BackSubst-Foreign]{Foreign exports}
1200 * *
1201 ************************************************************************
1202 -}
1203
1204 zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id]
1205 zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls
1206
1207 zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id)
1208 zonkForeignExport env (ForeignExport { fd_name = i, fd_co = co, fd_fe = spec })
1209 = return (ForeignExport { fd_name = fmap (zonkIdOcc env) i
1210 , fd_sig_ty = undefined, fd_co = co
1211 , fd_fe = spec })
1212 zonkForeignExport _ for_imp
1213 = return for_imp -- Foreign imports don't need zonking
1214
1215 zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id]
1216 zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs
1217
1218 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
1219 zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
1220 = do { unbound_tkv_set <- newMutVar emptyVarSet
1221 ; let env_rule = setZonkType env (zonkTvCollecting unbound_tkv_set)
1222 -- See Note [Zonking the LHS of a RULE]
1223
1224 ; (env_inside, new_bndrs) <- mapAccumLM zonk_bndr env_rule vars
1225
1226 ; new_lhs <- zonkLExpr env_inside lhs
1227 ; new_rhs <- zonkLExpr env_inside rhs
1228
1229 ; unbound_tkvs <- readMutVar unbound_tkv_set
1230
1231 ; let final_bndrs :: [LRuleBndr Var]
1232 final_bndrs = map (noLoc . RuleBndr . noLoc)
1233 (varSetElemsKvsFirst unbound_tkvs)
1234 ++ new_bndrs
1235
1236 ; return $
1237 HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs }
1238 where
1239 zonk_bndr env (L l (RuleBndr (L loc v)))
1240 = do { (env', v') <- zonk_it env v
1241 ; return (env', L l (RuleBndr (L loc v'))) }
1242 zonk_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_bndr RuleBndrSig"
1243
1244 zonk_it env v
1245 | isId v = do { v' <- zonkIdBndr env v
1246 ; return (extendIdZonkEnv1 env v', v') }
1247 | otherwise = ASSERT( isImmutableTyVar v)
1248 zonkTyBndrX env v
1249 -- DV: used to be return (env,v) but that is plain
1250 -- wrong because we may need to go inside the kind
1251 -- of v and zonk there!
1252
1253 zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id]
1254 zonkVects env = mapM (wrapLocM (zonkVect env))
1255
1256 zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id)
1257 zonkVect env (HsVect s v e)
1258 = do { v' <- wrapLocM (zonkIdBndr env) v
1259 ; e' <- zonkLExpr env e
1260 ; return $ HsVect s v' e'
1261 }
1262 zonkVect env (HsNoVect s v)
1263 = do { v' <- wrapLocM (zonkIdBndr env) v
1264 ; return $ HsNoVect s v'
1265 }
1266 zonkVect _env (HsVectTypeOut s t rt)
1267 = return $ HsVectTypeOut s t rt
1268 zonkVect _ (HsVectTypeIn _ _ _ _) = panic "TcHsSyn.zonkVect: HsVectTypeIn"
1269 zonkVect _env (HsVectClassOut c)
1270 = return $ HsVectClassOut c
1271 zonkVect _ (HsVectClassIn _ _) = panic "TcHsSyn.zonkVect: HsVectClassIn"
1272 zonkVect _env (HsVectInstOut i)
1273 = return $ HsVectInstOut i
1274 zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn"
1275
1276 {-
1277 ************************************************************************
1278 * *
1279 Constraints and evidence
1280 * *
1281 ************************************************************************
1282 -}
1283
1284 zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
1285 zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v )
1286 return (EvId (zonkIdOcc env v))
1287 zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcCoToCo env co
1288 ; return (EvCoercion co') }
1289 zonkEvTerm env (EvCast tm co) = do { tm' <- zonkEvTerm env tm
1290 ; co' <- zonkTcCoToCo env co
1291 ; return (mkEvCast tm' co') }
1292 zonkEvTerm _ (EvLit l) = return (EvLit l)
1293
1294 zonkEvTerm env (EvTypeable ty ev) =
1295 do { ev' <- zonkEvTypeable env ev
1296 ; ty' <- zonkTcTypeToType env ty
1297 ; return (EvTypeable ty' ev') }
1298 zonkEvTerm env (EvCallStack cs)
1299 = case cs of
1300 EvCsEmpty -> return (EvCallStack cs)
1301 EvCsTop n l tm -> do { tm' <- zonkEvTerm env tm
1302 ; return (EvCallStack (EvCsTop n l tm')) }
1303 EvCsPushCall n l tm -> do { tm' <- zonkEvTerm env tm
1304 ; return (EvCallStack (EvCsPushCall n l tm')) }
1305
1306 zonkEvTerm env (EvSuperClass d n) = do { d' <- zonkEvTerm env d
1307 ; return (EvSuperClass d' n) }
1308 zonkEvTerm env (EvDFunApp df tys tms)
1309 = do { tys' <- zonkTcTypeToTypes env tys
1310 ; return (EvDFunApp (zonkIdOcc env df) tys' (zonkIdOccs env tms)) }
1311 zonkEvTerm env (EvDelayedError ty msg)
1312 = do { ty' <- zonkTcTypeToType env ty
1313 ; return (EvDelayedError ty' msg) }
1314
1315 zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
1316 zonkEvTypeable _ EvTypeableTyCon
1317 = return EvTypeableTyCon
1318 zonkEvTypeable env (EvTypeableTyApp t1 t2)
1319 = do { t1' <- zonkEvTerm env t1
1320 ; t2' <- zonkEvTerm env t2
1321 ; return (EvTypeableTyApp t1' t2') }
1322 zonkEvTypeable _ (EvTypeableTyLit t1)
1323 = return (EvTypeableTyLit t1)
1324
1325 zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])
1326 zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs
1327 ; return (env, [EvBinds (unionManyBags bs')]) }
1328
1329 zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
1330 zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs
1331 ; return (env', EvBinds bs') }
1332
1333 zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind)
1334 zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var
1335 zonk_tc_ev_binds env (EvBinds bs) = zonkEvBinds env bs
1336
1337 zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
1338 zonkEvBindsVar env (EvBindsVar ref _) = do { bs <- readMutVar ref
1339 ; zonkEvBinds env (evBindMapBinds bs) }
1340
1341 zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
1342 zonkEvBinds env binds
1343 = {-# SCC "zonkEvBinds" #-}
1344 fixM (\ ~( _, new_binds) -> do
1345 { let env1 = extendIdZonkEnv env (collect_ev_bndrs new_binds)
1346 ; binds' <- mapBagM (zonkEvBind env1) binds
1347 ; return (env1, binds') })
1348 where
1349 collect_ev_bndrs :: Bag EvBind -> [EvVar]
1350 collect_ev_bndrs = foldrBag add []
1351 add (EvBind { eb_lhs = var }) vars = var : vars
1352
1353 zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
1354 zonkEvBind env (EvBind { eb_lhs = var, eb_rhs = term, eb_is_given = is_given })
1355 = do { var' <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var
1356
1357 -- Optimise the common case of Refl coercions
1358 -- See Note [Optimise coercion zonking]
1359 -- This has a very big effect on some programs (eg Trac #5030)
1360 ; term' <- case getEqPredTys_maybe (idType var') of
1361 Just (r, ty1, ty2) | ty1 `eqType` ty2
1362 -> return (EvCoercion (mkTcReflCo r ty1))
1363 _other -> zonkEvTerm env term
1364
1365 ; return (EvBind { eb_lhs = var', eb_rhs = term', eb_is_given = is_given }) }
1366
1367 {-
1368 ************************************************************************
1369 * *
1370 Zonking types
1371 * *
1372 ************************************************************************
1373
1374 Note [Zonking the LHS of a RULE]
1375 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1376 We need to gather the type variables mentioned on the LHS so we can
1377 quantify over them. Example:
1378 data T a = C
1379
1380 foo :: T a -> Int
1381 foo C = 1
1382
1383 {-# RULES "myrule" foo C = 1 #-}
1384
1385 After type checking the LHS becomes (foo a (C a))
1386 and we do not want to zap the unbound tyvar 'a' to (), because
1387 that limits the applicability of the rule. Instead, we
1388 want to quantify over it!
1389
1390 It's easiest to get zonkTvCollecting to gather the free tyvars
1391 here. Attempts to do so earlier are tiresome, because (a) the data
1392 type is big and (b) finding the free type vars of an expression is
1393 necessarily monadic operation. (consider /\a -> f @ b, where b is
1394 side-effected to a)
1395
1396 And that in turn is why ZonkEnv carries the function to use for
1397 type variables!
1398
1399 Note [Zonking mutable unbound type or kind variables]
1400 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1401 In zonkTypeZapping, we zonk mutable but unbound type or kind variables to an
1402 arbitrary type. We know if they are unbound even though we don't carry an
1403 environment, because at the binding site for a variable we bind the mutable
1404 var to a fresh immutable one. So the mutable store plays the role of an
1405 environment. If we come across a mutable variable that isn't so bound, it
1406 must be completely free. We zonk the expected kind to make sure we don't get
1407 some unbound meta variable as the kind.
1408
1409 Note that since we have kind polymorphism, zonk_unbound_tyvar will handle both
1410 type and kind variables. Consider the following datatype:
1411
1412 data Phantom a = Phantom Int
1413
1414 The type of Phantom is (forall (k : BOX). forall (a : k). Int). Both `a` and
1415 `k` are unbound variables. We want to zonk this to
1416 (forall (k : AnyK). forall (a : Any AnyK). Int). For that we have to check if
1417 we have a type or a kind variable; for kind variables we just return AnyK (and
1418 not the ill-kinded Any BOX).
1419
1420 Note [Optimise coercion zonkind]
1421 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1422 When optimising evidence binds we may come across situations where
1423 a coercion looks like
1424 cv = ReflCo ty
1425 or cv1 = cv2
1426 where the type 'ty' is big. In such cases it is a waste of time to zonk both
1427 * The variable on the LHS
1428 * The coercion on the RHS
1429 Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just
1430 use Refl on the right, ignoring the actual coercion on the RHS.
1431
1432 This can have a very big effect, because the constraint solver sometimes does go
1433 to a lot of effort to prove Refl! (Eg when solving 10+3 = 10+3; cf Trac #5030)
1434 -}
1435
1436 zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType
1437 zonkTyVarOcc env@(ZonkEnv zonk_unbound_tyvar tv_env _) tv
1438 | isTcTyVar tv
1439 = case tcTyVarDetails tv of
1440 SkolemTv {} -> lookup_in_env
1441 RuntimeUnk {} -> lookup_in_env
1442 FlatSkol ty -> zonkTcTypeToType env ty
1443 MetaTv { mtv_ref = ref }
1444 -> do { cts <- readMutVar ref
1445 ; case cts of
1446 Flexi -> do { kind <- {-# SCC "zonkKind1" #-}
1447 zonkTcTypeToType env (tyVarKind tv)
1448 ; zonk_unbound_tyvar (setTyVarKind tv kind) }
1449 Indirect ty -> do { zty <- zonkTcTypeToType env ty
1450 -- Small optimisation: shortern-out indirect steps
1451 -- so that the old type may be more easily collected.
1452 ; writeMutVar ref (Indirect zty)
1453 ; return zty } }
1454 | otherwise
1455 = lookup_in_env
1456 where
1457 lookup_in_env -- Look up in the env just as we do for Ids
1458 = case lookupVarEnv tv_env tv of
1459 Nothing -> return (mkTyVarTy tv)
1460 Just tv' -> return (mkTyVarTy tv')
1461
1462 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
1463 zonkTcTypeToType env ty
1464 = go ty
1465 where
1466 go (TyConApp tc tys) = do tys' <- mapM go tys
1467 return (mkTyConApp tc tys')
1468 -- Establish Type invariants
1469 -- See Note [Zonking inside the knot] in TcHsType
1470
1471 go (LitTy n) = return (LitTy n)
1472
1473 go (FunTy arg res) = do arg' <- go arg
1474 res' <- go res
1475 return (FunTy arg' res')
1476
1477 go (AppTy fun arg) = do fun' <- go fun
1478 arg' <- go arg
1479 return (mkAppTy fun' arg')
1480 -- NB the mkAppTy; we might have instantiated a
1481 -- type variable to a type constructor, so we need
1482 -- to pull the TyConApp to the top.
1483
1484 -- The two interesting cases!
1485 go (TyVarTy tv) = zonkTyVarOcc env tv
1486
1487 go (ForAllTy tv ty) = ASSERT( isImmutableTyVar tv )
1488 do { (env', tv') <- zonkTyBndrX env tv
1489 ; ty' <- zonkTcTypeToType env' ty
1490 ; return (ForAllTy tv' ty') }
1491
1492 zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type]
1493 zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
1494
1495 zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion
1496 zonkCoToCo env co
1497 = go co
1498 where
1499 go (Refl r ty) = mkReflCo r <$> zonkTcTypeToType env ty
1500 go (TyConAppCo r tc args) = mkTyConAppCo r tc <$> mapM go args
1501 go (AppCo co arg) = mkAppCo <$> go co <*> go arg
1502 go (AxiomInstCo ax ind args) = AxiomInstCo ax ind <$> mapM go args
1503 go (UnivCo s r ty1 ty2) = mkUnivCo s r <$> zonkTcTypeToType env ty1
1504 <*> zonkTcTypeToType env ty2
1505 go (SymCo co) = mkSymCo <$> go co
1506 go (TransCo co1 co2) = mkTransCo <$> go co1 <*> go co2
1507 go (NthCo n co) = mkNthCo n <$> go co
1508 go (LRCo lr co) = mkLRCo lr <$> go co
1509 go (InstCo co arg) = mkInstCo <$> go co <*> zonkTcTypeToType env arg
1510 go (SubCo co) = mkSubCo <$> go co
1511 go (AxiomRuleCo ax ts cs) = AxiomRuleCo ax <$> mapM (zonkTcTypeToType env) ts
1512 <*> mapM go cs
1513
1514 -- The two interesting cases!
1515 go (CoVarCo cv) = return (mkCoVarCo $ zonkIdOcc env cv)
1516 go (ForAllCo tv co) = ASSERT( isImmutableTyVar tv )
1517 do { (env', tv') <- zonkTyBndrX env tv
1518 ; co' <- zonkCoToCo env' co
1519 ; return (mkForAllCo tv' co') }
1520
1521 zonkTvCollecting :: TcRef TyVarSet -> UnboundTyVarZonker
1522 -- This variant collects unbound type variables in a mutable variable
1523 -- Works on both types and kinds
1524 zonkTvCollecting unbound_tv_set tv
1525 = do { poly_kinds <- xoptM Opt_PolyKinds
1526 ; if isKindVar tv && not poly_kinds then defaultKindVarToStar tv
1527 else do
1528 { tv' <- zonkQuantifiedTyVar tv
1529 ; tv_set <- readMutVar unbound_tv_set
1530 ; writeMutVar unbound_tv_set (extendVarSet tv_set tv')
1531 ; return (mkTyVarTy tv') } }
1532
1533 zonkTypeZapping :: UnboundTyVarZonker
1534 -- This variant is used for everything except the LHS of rules
1535 -- It zaps unbound type variables to (), or some other arbitrary type
1536 -- Works on both types and kinds
1537 zonkTypeZapping tv
1538 = do { let ty = if isKindVar tv
1539 -- ty is actually a kind, zonk to AnyK
1540 then anyKind
1541 else anyTypeOfKind (defaultKind (tyVarKind tv))
1542 ; writeMetaTyVar tv ty
1543 ; return ty }
1544
1545
1546 zonkTcCoToCo :: ZonkEnv -> TcCoercion -> TcM TcCoercion
1547 -- NB: zonking often reveals that the coercion is an identity
1548 -- in which case the Refl-ness can propagate up to the top
1549 -- which in turn gives more efficient desugaring. So it's
1550 -- worth using the 'mk' smart constructors on the RHS
1551 zonkTcCoToCo env co
1552 = go co
1553 where
1554 go (TcLetCo bs co) = do { (env', bs') <- zonkTcEvBinds env bs
1555 ; co' <- zonkTcCoToCo env' co
1556 ; return (TcLetCo bs' co') }
1557 go (TcCoVarCo cv) = return (mkTcCoVarCo (zonkEvVarOcc env cv))
1558 go (TcRefl r ty) = do { ty' <- zonkTcTypeToType env ty
1559 ; return (TcRefl r ty') }
1560 go (TcTyConAppCo r tc cos)
1561 = do { cos' <- mapM go cos; return (mkTcTyConAppCo r tc cos') }
1562 go (TcAxiomInstCo ax ind cos)
1563 = do { cos' <- mapM go cos; return (TcAxiomInstCo ax ind cos') }
1564 go (TcAppCo co1 co2) = do { co1' <- go co1; co2' <- go co2
1565 ; return (mkTcAppCo co1' co2') }
1566 go (TcCastCo co1 co2) = do { co1' <- go co1; co2' <- go co2
1567 ; return (TcCastCo co1' co2') }
1568 go (TcPhantomCo ty1 ty2) = do { ty1' <- zonkTcTypeToType env ty1
1569 ; ty2' <- zonkTcTypeToType env ty2
1570 ; return (TcPhantomCo ty1' ty2') }
1571 go (TcSymCo co) = do { co' <- go co; return (mkTcSymCo co') }
1572 go (TcNthCo n co) = do { co' <- go co; return (mkTcNthCo n co') }
1573 go (TcLRCo lr co) = do { co' <- go co; return (mkTcLRCo lr co') }
1574 go (TcTransCo co1 co2) = do { co1' <- go co1; co2' <- go co2
1575 ; return (mkTcTransCo co1' co2') }
1576 go (TcForAllCo tv co) = ASSERT( isImmutableTyVar tv )
1577 do { co' <- go co; return (mkTcForAllCo tv co') }
1578 go (TcSubCo co) = do { co' <- go co; return (mkTcSubCo co') }
1579 go (TcAxiomRuleCo co ts cs) = do { ts' <- zonkTcTypeToTypes env ts
1580 ; cs' <- mapM go cs
1581 ; return (TcAxiomRuleCo co ts' cs')
1582 }
1583 go (TcCoercion co) = do { co' <- zonkCoToCo env co
1584 ; return (TcCoercion co') }