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