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