2 % (c) The AQUA Project, Glasgow University, 1996-1998
4 \section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker}
6 This module is an extension of @HsSyn@ syntax, for use in the type
11 TcMonoBinds, TcHsBinds, TcPat,
12 TcExpr, TcGRHSs, TcGRHS, TcMatch,
13 TcStmt, TcArithSeqInfo, TcRecordBinds,
14 TcHsModule, TcDictBinds,
17 TypecheckedHsBinds, TypecheckedRuleDecl,
18 TypecheckedMonoBinds, TypecheckedPat,
19 TypecheckedHsExpr, TypecheckedArithSeqInfo,
20 TypecheckedStmt, TypecheckedForeignDecl,
21 TypecheckedMatch, TypecheckedHsModule,
22 TypecheckedGRHSs, TypecheckedGRHS,
23 TypecheckedRecordBinds, TypecheckedDictBinds,
24 TypecheckedMatchContext, TypecheckedCoreBind,
26 mkHsTyApp, mkHsDictApp, mkHsConApp,
27 mkHsTyLam, mkHsDictLam, mkHsLet,
30 -- re-exported from TcMonad
33 zonkTopBinds, zonkTopDecls, zonkTopExpr,
37 #include "HsVersions.h"
40 import HsSyn -- oodles of it
43 import Id ( idType, setIdType, Id )
44 import DataCon ( dataConWrapId )
48 import TcType ( TcType, TcTyVar, eqKind, isTypeKind, mkTyVarTy,
49 tcGetTyVar, isAnyTypeKind, mkTyConApp )
51 import TcMType ( zonkTcTyVarToTyVar, zonkType, zonkTcType, zonkTcTyVars,
53 import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
54 doublePrimTy, addrPrimTy
56 import TysWiredIn ( charTy, stringTy, intTy, integerTy,
57 mkListTy, mkPArrTy, mkTupleTy, unitTy,
58 voidTy, listTyCon, tupleTyCon )
59 import TyCon ( mkPrimTyCon, tyConKind )
60 import PrimRep ( PrimRep(VoidRep) )
61 import CoreSyn ( CoreExpr )
62 import Name ( Name, getOccName, mkInternalName, mkDerivedTyConOcc )
63 import Var ( isId, isLocalVar, tyVarKind )
66 import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName, mapIPName )
67 import Maybes ( orElse )
68 import Unique ( Uniquable(..) )
69 import SrcLoc ( noSrcLoc )
78 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
79 All the types in @Tc...@ things have mutable type-variables in them for
82 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
83 which have immutable type variables in them.
86 type TcHsBinds = HsBinds TcId
87 type TcMonoBinds = MonoBinds TcId
88 type TcDictBinds = TcMonoBinds
89 type TcPat = OutPat TcId
90 type TcExpr = HsExpr TcId
91 type TcGRHSs = GRHSs TcId
92 type TcGRHS = GRHS TcId
93 type TcMatch = Match TcId
94 type TcStmt = Stmt TcId
95 type TcArithSeqInfo = ArithSeqInfo TcId
96 type TcRecordBinds = HsRecordBinds TcId
97 type TcHsModule = HsModule TcId
98 type TcForeignDecl = ForeignDecl TcId
99 type TcRuleDecl = RuleDecl TcId
101 type TypecheckedPat = OutPat Id
102 type TypecheckedMonoBinds = MonoBinds Id
103 type TypecheckedDictBinds = TypecheckedMonoBinds
104 type TypecheckedHsBinds = HsBinds Id
105 type TypecheckedHsExpr = HsExpr Id
106 type TypecheckedArithSeqInfo = ArithSeqInfo Id
107 type TypecheckedStmt = Stmt Id
108 type TypecheckedMatch = Match Id
109 type TypecheckedGRHSs = GRHSs Id
110 type TypecheckedGRHS = GRHS Id
111 type TypecheckedRecordBinds = HsRecordBinds Id
112 type TypecheckedHsModule = HsModule Id
113 type TypecheckedForeignDecl = ForeignDecl Id
114 type TypecheckedRuleDecl = RuleDecl Id
115 type TypecheckedCoreBind = (Id, CoreExpr)
117 type TypecheckedMatchContext = HsMatchContext Name -- Keeps consistency with
118 -- HsDo arg StmtContext
122 mkHsTyApp expr [] = expr
123 mkHsTyApp expr tys = TyApp expr tys
125 mkHsDictApp expr [] = expr
126 mkHsDictApp expr dict_vars = DictApp expr dict_vars
128 mkHsTyLam [] expr = expr
129 mkHsTyLam tyvars expr = TyLam tyvars expr
131 mkHsDictLam [] expr = expr
132 mkHsDictLam dicts expr = DictLam dicts expr
134 mkHsLet EmptyMonoBinds expr = expr
135 mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr
137 mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
141 %************************************************************************
143 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
145 %************************************************************************
147 Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@,
148 then something is wrong.
150 hsPatType :: TypecheckedPat -> Type
152 hsPatType (ParPat pat) = hsPatType pat
153 hsPatType (WildPat ty) = ty
154 hsPatType (VarPat var) = idType var
155 hsPatType (LazyPat pat) = hsPatType pat
156 hsPatType (LitPat lit) = hsLitType lit
157 hsPatType (AsPat var pat) = idType var
158 hsPatType (ListPat _ ty) = mkListTy ty
159 hsPatType (PArrPat _ ty) = mkPArrTy ty
160 hsPatType (TuplePat pats box) = mkTupleTy box (length pats) (map hsPatType pats)
161 hsPatType (ConPatOut _ _ ty _ _) = ty
162 hsPatType (SigPatOut _ ty _) = ty
163 hsPatType (NPatOut lit ty _) = ty
164 hsPatType (NPlusKPatOut id _ _ _) = idType id
165 hsPatType (DictPat ds ms) = case (ds ++ ms) of
168 ds -> mkTupleTy Boxed (length ds) (map idType ds)
171 hsLitType :: HsLit -> TcType
172 hsLitType (HsChar c) = charTy
173 hsLitType (HsCharPrim c) = charPrimTy
174 hsLitType (HsString str) = stringTy
175 hsLitType (HsStringPrim s) = addrPrimTy
176 hsLitType (HsInt i) = intTy
177 hsLitType (HsIntPrim i) = intPrimTy
178 hsLitType (HsInteger i) = integerTy
179 hsLitType (HsRat _ ty) = ty
180 hsLitType (HsFloatPrim f) = floatPrimTy
181 hsLitType (HsDoublePrim d) = doublePrimTy
182 hsLitType (HsLitLit _ ty) = ty
186 -- zonkId is used *during* typechecking just to zonk the Id's type
187 zonkId :: TcId -> TcM TcId
189 = zonkTcType (idType id) `thenM` \ ty' ->
190 returnM (setIdType id ty')
194 %************************************************************************
196 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
198 %************************************************************************
200 This zonking pass runs over the bindings
202 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
203 b) convert unbound TcTyVar to Void
204 c) convert each TcId to an Id by zonking its type
206 The type variables are converted by binding mutable tyvars to immutable ones
207 and then zonking as normal.
209 The Ids are converted by binding them in the normal Tc envt; that
210 way we maintain sharing; eg an Id is zonked at its binding site and they
211 all occurrences of that Id point to the common zonked copy
213 It's all pretty boring stuff, because HsSyn is such a large type, and
214 the environment manipulation is tiresome.
217 data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type
218 (IdEnv Id) -- What variables are in scope
219 -- Maps an Id to its zonked version; both have the same Name
220 -- Is only consulted lazily; hence knot-tying
222 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
224 extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
225 extendZonkEnv (ZonkEnv zonk_ty env) ids
226 = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
228 setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
229 setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
231 mkZonkEnv :: [Id] -> ZonkEnv
232 mkZonkEnv ids = extendZonkEnv emptyZonkEnv ids
234 zonkIdOcc :: ZonkEnv -> TcId -> Id
235 -- Ids defined in this module should be in the envt;
236 -- ignore others. (Actually, data constructors are also
237 -- not LocalVars, even when locally defined, but that is fine.)
239 -- Actually, Template Haskell works in 'chunks' of declarations, and
240 -- an earlier chunk won't be in the 'env' that the zonking phase
241 -- carries around. Instead it'll be in the tcg_gbl_env, already fully
242 -- zonked. There's no point in looking it up there (except for error
243 -- checking), and it's not conveniently to hand; hence the simple
244 -- 'orElse' case in the LocalVar branch.
246 -- Even without template splices, in module Main, the checking of
247 -- 'main' is done as a separte chunk.
248 zonkIdOcc (ZonkEnv zonk_ty env) id
249 | isLocalVar id = lookupVarEnv env id `orElse` id
252 zonkIdOccs env ids = map (zonkIdOcc env) ids
254 -- zonkIdBndr is used *after* typechecking to get the Id's type
255 -- to its final form. The TyVarEnv give
256 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
258 = zonkTcTypeToType env (idType id) `thenM` \ ty' ->
259 returnM (setIdType id ty')
261 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
262 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
264 zonkTopBndrs :: [TcId] -> TcM [Id]
265 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
270 zonkTopExpr :: TcExpr -> TcM TypecheckedHsExpr
271 zonkTopExpr e = zonkExpr emptyZonkEnv e
273 zonkTopDecls :: TcMonoBinds -> [TcRuleDecl] -> [TcForeignDecl]
275 TypecheckedMonoBinds,
276 [TypecheckedForeignDecl],
277 [TypecheckedRuleDecl])
278 zonkTopDecls binds rules fords -- Top level is implicitly recursive
279 = fixM (\ ~(new_ids, _, _, _) ->
281 zonk_env = mkZonkEnv new_ids
283 zonkMonoBinds zonk_env binds `thenM` \ (binds', new_ids) ->
284 zonkRules zonk_env rules `thenM` \ rules' ->
285 zonkForeignExports zonk_env fords `thenM` \ fords' ->
287 returnM (bagToList new_ids, binds', fords', rules')
290 zonkTopBinds :: TcMonoBinds -> TcM ([Id], TypecheckedMonoBinds)
292 = fixM (\ ~(new_ids, _) ->
294 zonk_env = mkZonkEnv new_ids
296 zonkMonoBinds zonk_env binds `thenM` \ (binds', new_ids) ->
297 returnM (bagToList new_ids, binds')
300 ---------------------------------------------
301 zonkBinds :: ZonkEnv -> TcHsBinds -> TcM (ZonkEnv, TypecheckedHsBinds)
302 zonkBinds env EmptyBinds = returnM (env, EmptyBinds)
304 zonkBinds env (ThenBinds b1 b2)
305 = zonkBinds env b1 `thenM` \ (env1, b1') ->
306 zonkBinds env1 b2 `thenM` \ (env2, b2') ->
307 returnM (env2, b1' `ThenBinds` b2')
309 zonkBinds env (MonoBind bind sigs is_rec)
310 = ASSERT( null sigs )
311 fixM (\ ~(_, _, new_ids) ->
313 env1 = extendZonkEnv env (bagToList new_ids)
315 zonkMonoBinds env1 bind `thenM` \ (new_bind, new_ids) ->
316 returnM (env1, new_bind, new_ids)
317 ) `thenM` \ (env1, new_bind, _) ->
318 returnM (env1, mkMonoBind new_bind [] is_rec)
320 ---------------------------------------------
321 zonkMonoBinds :: ZonkEnv -> TcMonoBinds
322 -> TcM (TypecheckedMonoBinds, Bag Id)
324 zonkMonoBinds env EmptyMonoBinds = returnM (EmptyMonoBinds, emptyBag)
326 zonkMonoBinds env (AndMonoBinds mbinds1 mbinds2)
327 = zonkMonoBinds env mbinds1 `thenM` \ (b1', ids1) ->
328 zonkMonoBinds env mbinds2 `thenM` \ (b2', ids2) ->
329 returnM (b1' `AndMonoBinds` b2',
330 ids1 `unionBags` ids2)
332 zonkMonoBinds env (PatMonoBind pat grhss locn)
333 = zonkPat env pat `thenM` \ (new_pat, ids) ->
334 zonkGRHSs env grhss `thenM` \ new_grhss ->
335 returnM (PatMonoBind new_pat new_grhss locn, ids)
337 zonkMonoBinds env (VarMonoBind var expr)
338 = zonkIdBndr env var `thenM` \ new_var ->
339 zonkExpr env expr `thenM` \ new_expr ->
340 returnM (VarMonoBind new_var new_expr, unitBag new_var)
342 zonkMonoBinds env (CoreMonoBind var core_expr)
343 = zonkIdBndr env var `thenM` \ new_var ->
344 returnM (CoreMonoBind new_var core_expr, unitBag new_var)
346 zonkMonoBinds env (FunMonoBind var inf ms locn)
347 = zonkIdBndr env var `thenM` \ new_var ->
348 mappM (zonkMatch env) ms `thenM` \ new_ms ->
349 returnM (FunMonoBind new_var inf new_ms locn, unitBag new_var)
352 zonkMonoBinds env (AbsBinds tyvars dicts exports inlines val_bind)
353 = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
354 -- No need to extend tyvar env: the effects are
355 -- propagated through binding the tyvars themselves
357 zonkIdBndrs env dicts `thenM` \ new_dicts ->
358 fixM (\ ~(_, _, val_bind_ids) ->
360 env1 = extendZonkEnv (extendZonkEnv env new_dicts)
361 (bagToList val_bind_ids)
363 zonkMonoBinds env1 val_bind `thenM` \ (new_val_bind, val_bind_ids) ->
364 mappM (zonkExport env1) exports `thenM` \ new_exports ->
365 returnM (new_val_bind, new_exports, val_bind_ids)
366 ) `thenM ` \ (new_val_bind, new_exports, _) ->
368 new_globals = listToBag [global | (_, global, local) <- new_exports]
370 returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
373 zonkExport env (tyvars, global, local)
374 = zonkTcTyVars tyvars `thenM` \ tys ->
376 new_tyvars = map (tcGetTyVar "zonkExport") tys
377 -- This isn't the binding occurrence of these tyvars
378 -- but they should *be* tyvars. Hence tcGetTyVar.
380 zonkIdBndr env global `thenM` \ new_global ->
381 returnM (new_tyvars, new_global, zonkIdOcc env local)
384 %************************************************************************
386 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
388 %************************************************************************
391 zonkMatch :: ZonkEnv -> TcMatch -> TcM TypecheckedMatch
393 zonkMatch env (Match pats _ grhss)
394 = zonkPats env pats `thenM` \ (new_pats, new_ids) ->
395 zonkGRHSs (extendZonkEnv env (bagToList new_ids)) grhss `thenM` \ new_grhss ->
396 returnM (Match new_pats Nothing new_grhss)
398 -------------------------------------------------------------------------
399 zonkGRHSs :: ZonkEnv -> TcGRHSs -> TcM TypecheckedGRHSs
401 zonkGRHSs env (GRHSs grhss binds ty)
402 = zonkBinds env binds `thenM` \ (new_env, new_binds) ->
404 zonk_grhs (GRHS guarded locn)
405 = zonkStmts new_env guarded `thenM` \ new_guarded ->
406 returnM (GRHS new_guarded locn)
408 mappM zonk_grhs grhss `thenM` \ new_grhss ->
409 zonkTcTypeToType env ty `thenM` \ new_ty ->
410 returnM (GRHSs new_grhss new_binds new_ty)
413 %************************************************************************
415 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
417 %************************************************************************
420 zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr
422 zonkExpr env (HsVar id)
423 = returnM (HsVar (zonkIdOcc env id))
425 zonkExpr env (HsIPVar id)
426 = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
428 zonkExpr env (HsLit (HsRat f ty))
429 = zonkTcTypeToType env ty `thenM` \ new_ty ->
430 returnM (HsLit (HsRat f new_ty))
432 zonkExpr env (HsLit (HsLitLit lit ty))
433 = zonkTcTypeToType env ty `thenM` \ new_ty ->
434 returnM (HsLit (HsLitLit lit new_ty))
436 zonkExpr env (HsLit lit)
437 = returnM (HsLit lit)
439 -- HsOverLit doesn't appear in typechecker output
441 zonkExpr env (HsLam match)
442 = zonkMatch env match `thenM` \ new_match ->
443 returnM (HsLam new_match)
445 zonkExpr env (HsApp e1 e2)
446 = zonkExpr env e1 `thenM` \ new_e1 ->
447 zonkExpr env e2 `thenM` \ new_e2 ->
448 returnM (HsApp new_e1 new_e2)
450 zonkExpr env (HsBracketOut body bs)
451 = mappM zonk_b bs `thenM` \ bs' ->
452 returnM (HsBracketOut body bs')
454 zonk_b (n,e) = zonkExpr env e `thenM` \ e' ->
457 zonkExpr env (HsSplice n e) = WARN( True, ppr e ) -- Should not happen
458 returnM (HsSplice n e)
460 zonkExpr env (OpApp e1 op fixity e2)
461 = zonkExpr env e1 `thenM` \ new_e1 ->
462 zonkExpr env op `thenM` \ new_op ->
463 zonkExpr env e2 `thenM` \ new_e2 ->
464 returnM (OpApp new_e1 new_op fixity new_e2)
466 zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp"
468 zonkExpr env (HsPar e)
469 = zonkExpr env e `thenM` \new_e ->
470 returnM (HsPar new_e)
472 zonkExpr env (SectionL expr op)
473 = zonkExpr env expr `thenM` \ new_expr ->
474 zonkExpr env op `thenM` \ new_op ->
475 returnM (SectionL new_expr new_op)
477 zonkExpr env (SectionR op expr)
478 = zonkExpr env op `thenM` \ new_op ->
479 zonkExpr env expr `thenM` \ new_expr ->
480 returnM (SectionR new_op new_expr)
482 zonkExpr env (HsCase expr ms src_loc)
483 = zonkExpr env expr `thenM` \ new_expr ->
484 mappM (zonkMatch env) ms `thenM` \ new_ms ->
485 returnM (HsCase new_expr new_ms src_loc)
487 zonkExpr env (HsIf e1 e2 e3 src_loc)
488 = zonkExpr env e1 `thenM` \ new_e1 ->
489 zonkExpr env e2 `thenM` \ new_e2 ->
490 zonkExpr env e3 `thenM` \ new_e3 ->
491 returnM (HsIf new_e1 new_e2 new_e3 src_loc)
493 zonkExpr env (HsLet binds expr)
494 = zonkBinds env binds `thenM` \ (new_env, new_binds) ->
495 zonkExpr new_env expr `thenM` \ new_expr ->
496 returnM (HsLet new_binds new_expr)
498 zonkExpr env (HsWith expr binds is_with)
499 = mappM zonk_ip_bind binds `thenM` \ new_binds ->
501 env1 = extendZonkEnv env (map (ipNameName . fst) new_binds)
503 zonkExpr env1 expr `thenM` \ new_expr ->
504 returnM (HsWith new_expr new_binds is_with)
507 = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
508 zonkExpr env e `thenM` \ e' ->
511 zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
512 = zonkStmts env stmts `thenM` \ new_stmts ->
513 zonkTcTypeToType env ty `thenM` \ new_ty ->
514 returnM (HsDo do_or_lc new_stmts
518 zonkExpr env (ExplicitList ty exprs)
519 = zonkTcTypeToType env ty `thenM` \ new_ty ->
520 mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
521 returnM (ExplicitList new_ty new_exprs)
523 zonkExpr env (ExplicitPArr ty exprs)
524 = zonkTcTypeToType env ty `thenM` \ new_ty ->
525 mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
526 returnM (ExplicitPArr new_ty new_exprs)
528 zonkExpr env (ExplicitTuple exprs boxed)
529 = mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
530 returnM (ExplicitTuple new_exprs boxed)
532 zonkExpr env (RecordConOut data_con con_expr rbinds)
533 = zonkExpr env con_expr `thenM` \ new_con_expr ->
534 zonkRbinds env rbinds `thenM` \ new_rbinds ->
535 returnM (RecordConOut data_con new_con_expr new_rbinds)
537 zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"
539 zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
540 = zonkExpr env expr `thenM` \ new_expr ->
541 zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
542 zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
543 zonkRbinds env rbinds `thenM` \ new_rbinds ->
544 returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
546 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
547 zonkExpr env (ArithSeqIn _) = panic "zonkExpr env:ArithSeqIn"
548 zonkExpr env (PArrSeqIn _) = panic "zonkExpr env:PArrSeqIn"
550 zonkExpr env (ArithSeqOut expr info)
551 = zonkExpr env expr `thenM` \ new_expr ->
552 zonkArithSeq env info `thenM` \ new_info ->
553 returnM (ArithSeqOut new_expr new_info)
555 zonkExpr env (PArrSeqOut expr info)
556 = zonkExpr env expr `thenM` \ new_expr ->
557 zonkArithSeq env info `thenM` \ new_info ->
558 returnM (PArrSeqOut new_expr new_info)
560 zonkExpr env (HsCCall fun args may_gc is_casm result_ty)
561 = mappM (zonkExpr env) args `thenM` \ new_args ->
562 zonkTcTypeToType env result_ty `thenM` \ new_result_ty ->
563 returnM (HsCCall fun new_args may_gc is_casm new_result_ty)
565 zonkExpr env (HsSCC lbl expr)
566 = zonkExpr env expr `thenM` \ new_expr ->
567 returnM (HsSCC lbl new_expr)
569 zonkExpr env (TyLam tyvars expr)
570 = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
571 -- No need to extend tyvar env; see AbsBinds
573 zonkExpr env expr `thenM` \ new_expr ->
574 returnM (TyLam new_tyvars new_expr)
576 zonkExpr env (TyApp expr tys)
577 = zonkExpr env expr `thenM` \ new_expr ->
578 mappM (zonkTcTypeToType env) tys `thenM` \ new_tys ->
579 returnM (TyApp new_expr new_tys)
581 zonkExpr env (DictLam dicts expr)
582 = zonkIdBndrs env dicts `thenM` \ new_dicts ->
584 env1 = extendZonkEnv env new_dicts
586 zonkExpr env1 expr `thenM` \ new_expr ->
587 returnM (DictLam new_dicts new_expr)
589 zonkExpr env (DictApp expr dicts)
590 = zonkExpr env expr `thenM` \ new_expr ->
591 returnM (DictApp new_expr (zonkIdOccs env dicts))
595 -------------------------------------------------------------------------
596 zonkArithSeq :: ZonkEnv -> TcArithSeqInfo -> TcM TypecheckedArithSeqInfo
598 zonkArithSeq env (From e)
599 = zonkExpr env e `thenM` \ new_e ->
602 zonkArithSeq env (FromThen e1 e2)
603 = zonkExpr env e1 `thenM` \ new_e1 ->
604 zonkExpr env e2 `thenM` \ new_e2 ->
605 returnM (FromThen new_e1 new_e2)
607 zonkArithSeq env (FromTo e1 e2)
608 = zonkExpr env e1 `thenM` \ new_e1 ->
609 zonkExpr env e2 `thenM` \ new_e2 ->
610 returnM (FromTo new_e1 new_e2)
612 zonkArithSeq env (FromThenTo e1 e2 e3)
613 = zonkExpr env e1 `thenM` \ new_e1 ->
614 zonkExpr env e2 `thenM` \ new_e2 ->
615 zonkExpr env e3 `thenM` \ new_e3 ->
616 returnM (FromThenTo new_e1 new_e2 new_e3)
619 -------------------------------------------------------------------------
620 zonkStmts :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt]
622 zonkStmts env [] = returnM []
624 zonkStmts env (ParStmtOut bndrstmtss : stmts)
625 = mappM (mappM zonkId) bndrss `thenM` \ new_bndrss ->
626 mappM (zonkStmts env) stmtss `thenM` \ new_stmtss ->
628 new_binders = concat new_bndrss
629 env1 = extendZonkEnv env new_binders
631 zonkStmts env1 stmts `thenM` \ new_stmts ->
632 returnM (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
634 (bndrss, stmtss) = unzip bndrstmtss
636 zonkStmts env (RecStmt vs segStmts : stmts)
637 = mappM zonkId vs `thenM` \ new_vs ->
639 env1 = extendZonkEnv env new_vs
641 zonkStmts env1 segStmts `thenM` \ new_segStmts ->
642 zonkStmts env1 stmts `thenM` \ new_stmts ->
643 returnM (RecStmt new_vs new_segStmts : new_stmts)
645 zonkStmts env (ResultStmt expr locn : stmts)
646 = zonkExpr env expr `thenM` \ new_expr ->
647 zonkStmts env stmts `thenM` \ new_stmts ->
648 returnM (ResultStmt new_expr locn : new_stmts)
650 zonkStmts env (ExprStmt expr ty locn : stmts)
651 = zonkExpr env expr `thenM` \ new_expr ->
652 zonkTcTypeToType env ty `thenM` \ new_ty ->
653 zonkStmts env stmts `thenM` \ new_stmts ->
654 returnM (ExprStmt new_expr new_ty locn : new_stmts)
656 zonkStmts env (LetStmt binds : stmts)
657 = zonkBinds env binds `thenM` \ (new_env, new_binds) ->
658 zonkStmts new_env stmts `thenM` \ new_stmts ->
659 returnM (LetStmt new_binds : new_stmts)
661 zonkStmts env (BindStmt pat expr locn : stmts)
662 = zonkExpr env expr `thenM` \ new_expr ->
663 zonkPat env pat `thenM` \ (new_pat, new_ids) ->
665 env1 = extendZonkEnv env (bagToList new_ids)
667 zonkStmts env1 stmts `thenM` \ new_stmts ->
668 returnM (BindStmt new_pat new_expr locn : new_stmts)
672 -------------------------------------------------------------------------
673 zonkRbinds :: ZonkEnv -> TcRecordBinds -> TcM TypecheckedRecordBinds
675 zonkRbinds env rbinds
676 = mappM zonk_rbind rbinds
678 zonk_rbind (field, expr)
679 = zonkExpr env expr `thenM` \ new_expr ->
680 returnM (zonkIdOcc env field, new_expr)
682 -------------------------------------------------------------------------
683 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
684 mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r)
685 mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r)
689 %************************************************************************
691 \subsection[BackSubst-Pats]{Patterns}
693 %************************************************************************
696 zonkPat :: ZonkEnv -> TcPat -> TcM (TypecheckedPat, Bag Id)
698 zonkPat env (ParPat p)
699 = zonkPat env p `thenM` \ (new_p, ids) ->
700 returnM (ParPat new_p, ids)
702 zonkPat env (WildPat ty)
703 = zonkTcTypeToType env ty `thenM` \ new_ty ->
704 returnM (WildPat new_ty, emptyBag)
706 zonkPat env (VarPat v)
707 = zonkIdBndr env v `thenM` \ new_v ->
708 returnM (VarPat new_v, unitBag new_v)
710 zonkPat env (LazyPat pat)
711 = zonkPat env pat `thenM` \ (new_pat, ids) ->
712 returnM (LazyPat new_pat, ids)
714 zonkPat env (AsPat n pat)
715 = zonkIdBndr env n `thenM` \ new_n ->
716 zonkPat env pat `thenM` \ (new_pat, ids) ->
717 returnM (AsPat new_n new_pat, new_n `consBag` ids)
719 zonkPat env (ListPat pats ty)
720 = zonkTcTypeToType env ty `thenM` \ new_ty ->
721 zonkPats env pats `thenM` \ (new_pats, ids) ->
722 returnM (ListPat new_pats new_ty, ids)
724 zonkPat env (PArrPat pats ty)
725 = zonkTcTypeToType env ty `thenM` \ new_ty ->
726 zonkPats env pats `thenM` \ (new_pats, ids) ->
727 returnM (PArrPat new_pats new_ty, ids)
729 zonkPat env (TuplePat pats boxed)
730 = zonkPats env pats `thenM` \ (new_pats, ids) ->
731 returnM (TuplePat new_pats boxed, ids)
733 zonkPat env (ConPatOut n stuff ty tvs dicts)
734 = zonkTcTypeToType env ty `thenM` \ new_ty ->
735 mappM zonkTcTyVarToTyVar tvs `thenM` \ new_tvs ->
736 zonkIdBndrs env dicts `thenM` \ new_dicts ->
738 env1 = extendZonkEnv env new_dicts
740 zonkConStuff env stuff `thenM` \ (new_stuff, ids) ->
741 returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts,
742 listToBag new_dicts `unionBags` ids)
744 zonkPat env (LitPat lit) = returnM (LitPat lit, emptyBag)
746 zonkPat env (SigPatOut pat ty expr)
747 = zonkPat env pat `thenM` \ (new_pat, ids) ->
748 zonkTcTypeToType env ty `thenM` \ new_ty ->
749 zonkExpr env expr `thenM` \ new_expr ->
750 returnM (SigPatOut new_pat new_ty new_expr, ids)
752 zonkPat env (NPatOut lit ty expr)
753 = zonkTcTypeToType env ty `thenM` \ new_ty ->
754 zonkExpr env expr `thenM` \ new_expr ->
755 returnM (NPatOut lit new_ty new_expr, emptyBag)
757 zonkPat env (NPlusKPatOut n k e1 e2)
758 = zonkIdBndr env n `thenM` \ new_n ->
759 zonkExpr env e1 `thenM` \ new_e1 ->
760 zonkExpr env e2 `thenM` \ new_e2 ->
761 returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag new_n)
763 zonkPat env (DictPat ds ms)
764 = zonkIdBndrs env ds `thenM` \ new_ds ->
765 zonkIdBndrs env ms `thenM` \ new_ms ->
766 returnM (DictPat new_ds new_ms,
767 listToBag new_ds `unionBags` listToBag new_ms)
769 ---------------------------
770 zonkConStuff env (PrefixCon pats)
771 = zonkPats env pats `thenM` \ (new_pats, ids) ->
772 returnM (PrefixCon new_pats, ids)
774 zonkConStuff env (InfixCon p1 p2)
775 = zonkPat env p1 `thenM` \ (new_p1, ids1) ->
776 zonkPat env p2 `thenM` \ (new_p2, ids2) ->
777 returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2)
779 zonkConStuff env (RecCon rpats)
780 = mapAndUnzipM zonk_rpat rpats `thenM` \ (new_rpats, ids_s) ->
781 returnM (RecCon new_rpats, unionManyBags ids_s)
784 = zonkPat env pat `thenM` \ (new_pat, ids) ->
785 returnM ((f, new_pat), ids)
787 ---------------------------
789 = returnM ([], emptyBag)
791 zonkPats env (pat:pats)
792 = zonkPat env pat `thenM` \ (pat', ids1) ->
793 zonkPats env pats `thenM` \ (pats', ids2) ->
794 returnM (pat':pats', ids1 `unionBags` ids2)
797 %************************************************************************
799 \subsection[BackSubst-Foreign]{Foreign exports}
801 %************************************************************************
805 zonkForeignExports :: ZonkEnv -> [TcForeignDecl] -> TcM [TypecheckedForeignDecl]
806 zonkForeignExports env ls = mappM (zonkForeignExport env) ls
808 zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl)
809 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) =
810 returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc)
814 zonkRules :: ZonkEnv -> [TcRuleDecl] -> TcM [TypecheckedRuleDecl]
815 zonkRules env rs = mappM (zonkRule env) rs
817 zonkRule env (HsRule name act vars lhs rhs loc)
818 = mappM zonk_bndr vars `thenM` \ new_bndrs ->
819 newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
821 env_rhs = extendZonkEnv env (filter isId new_bndrs)
822 -- Type variables don't need an envt
823 -- They are bound through the mutable mechanism
825 env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
826 -- We need to gather the type variables mentioned on the LHS so we can
827 -- quantify over them. Example:
833 -- {-# RULES "myrule" foo C = 1 #-}
835 -- After type checking the LHS becomes (foo a (C a))
836 -- and we do not want to zap the unbound tyvar 'a' to (), because
837 -- that limits the applicability of the rule. Instead, we
838 -- want to quantify over it!
840 -- It's easiest to find the free tyvars here. Attempts to do so earlier
841 -- are tiresome, because (a) the data type is big and (b) finding the
842 -- free type vars of an expression is necessarily monadic operation.
843 -- (consider /\a -> f @ b, where b is side-effected to a)
845 zonkExpr env_lhs lhs `thenM` \ new_lhs ->
846 zonkExpr env_rhs rhs `thenM` \ new_rhs ->
848 readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
850 final_bndrs = map RuleBndr (varSetElems unbound_tvs ++ new_bndrs)
851 -- I hate this map RuleBndr stuff
853 returnM (HsRule name act final_bndrs new_lhs new_rhs loc)
855 zonk_bndr (RuleBndr v)
856 | isId v = zonkIdBndr env v
857 | otherwise = zonkTcTyVarToTyVar v
859 zonkRule env (IfaceRuleOut fun rule)
860 = returnM (IfaceRuleOut (zonkIdOcc env fun) rule)
864 %************************************************************************
866 \subsection[BackSubst-Foreign]{Foreign exports}
868 %************************************************************************
871 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
872 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
874 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
875 -- This variant collects unbound type variables in a mutable variable
876 zonkTypeCollecting unbound_tv_set
877 = zonkType zonk_unbound_tyvar
879 zonk_unbound_tyvar tv
880 = zonkTcTyVarToTyVar tv `thenM` \ tv' ->
881 readMutVar unbound_tv_set `thenM` \ tv_set ->
882 writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
883 return (mkTyVarTy tv')
885 zonkTypeZapping :: TcType -> TcM Type
886 -- This variant is used for everything except the LHS of rules
887 -- It zaps unbound type variables to (), or some other arbitrary type
889 = zonkType zonk_unbound_tyvar ty
891 -- Zonk a mutable but unbound type variable to an arbitrary type
892 -- We know it's unbound even though we don't carry an environment,
893 -- because at the binding site for a type variable we bind the
894 -- mutable tyvar to a fresh immutable one. So the mutable store
895 -- plays the role of an environment. If we come across a mutable
896 -- type variable that isn't so bound, it must be completely free.
897 zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv)
900 -- When the type checker finds a type variable with no binding,
901 -- which means it can be instantiated with an arbitrary type, it
902 -- usually instantiates it to Void. Eg.
906 -- length Void (Nil Void)
908 -- But in really obscure programs, the type variable might have
909 -- a kind other than *, so we need to invent a suitably-kinded type.
913 -- List for kind *->*
914 -- Tuple for kind *->...*->*
916 -- which deals with most cases. (Previously, it only dealt with
919 -- In the other cases, it just makes up a TyCon with a suitable
920 -- kind. If this gets into an interface file, anyone reading that
921 -- file won't understand it. This is fixable (by making the client
922 -- of the interface file make up a TyCon too) but it is tiresome and
923 -- never happens, so I am leaving it
925 mkArbitraryType :: TcTyVar -> Type
926 -- Make up an arbitrary type whose kind is the same as the tyvar.
927 -- We'll use this to instantiate the (unbound) tyvar.
929 | isAnyTypeKind kind = voidTy -- The vastly common case
930 | otherwise = mkTyConApp tycon []
933 (args,res) = Type.splitFunTys kind -- Kinds are simple; use Type.splitFunTys
935 tycon | kind `eqKind` tyConKind listTyCon -- *->*
936 = listTyCon -- No tuples this size
938 | all isTypeKind args && isTypeKind res
939 = tupleTyCon Boxed (length args) -- *-> ... ->*->*
942 = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
943 mkPrimTyCon tc_name kind 0 [] VoidRep
944 -- Same name as the tyvar, apart from making it start with a colon (sigh)
945 -- I dread to think what will happen if this gets out into an
946 -- interface file. Catastrophe likely. Major sigh.
948 tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc