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