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