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 is_rec new_bind)
320 zonkBinds env (IPBinds binds is_with)
321 = mappM zonk_ip_bind binds `thenM` \ new_binds ->
323 env1 = extendZonkEnv env (map (ipNameName . fst) new_binds)
325 returnM (env1, IPBinds new_binds is_with)
328 = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
329 zonkExpr env e `thenM` \ e' ->
333 ---------------------------------------------
334 zonkMonoBinds :: ZonkEnv -> TcMonoBinds
335 -> TcM (TypecheckedMonoBinds, Bag Id)
337 zonkMonoBinds env EmptyMonoBinds = returnM (EmptyMonoBinds, emptyBag)
339 zonkMonoBinds env (AndMonoBinds mbinds1 mbinds2)
340 = zonkMonoBinds env mbinds1 `thenM` \ (b1', ids1) ->
341 zonkMonoBinds env mbinds2 `thenM` \ (b2', ids2) ->
342 returnM (b1' `AndMonoBinds` b2',
343 ids1 `unionBags` ids2)
345 zonkMonoBinds env (PatMonoBind pat grhss locn)
346 = zonkPat env pat `thenM` \ (new_pat, ids) ->
347 zonkGRHSs env grhss `thenM` \ new_grhss ->
348 returnM (PatMonoBind new_pat new_grhss locn, ids)
350 zonkMonoBinds env (VarMonoBind var expr)
351 = zonkIdBndr env var `thenM` \ new_var ->
352 zonkExpr env expr `thenM` \ new_expr ->
353 returnM (VarMonoBind new_var new_expr, unitBag new_var)
355 zonkMonoBinds env (FunMonoBind var inf ms locn)
356 = zonkIdBndr env var `thenM` \ new_var ->
357 mappM (zonkMatch env) ms `thenM` \ new_ms ->
358 returnM (FunMonoBind new_var inf new_ms locn, unitBag new_var)
361 zonkMonoBinds env (AbsBinds tyvars dicts exports inlines val_bind)
362 = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
363 -- No need to extend tyvar env: the effects are
364 -- propagated through binding the tyvars themselves
366 zonkIdBndrs env dicts `thenM` \ new_dicts ->
367 fixM (\ ~(_, _, val_bind_ids) ->
369 env1 = extendZonkEnv (extendZonkEnv env new_dicts)
370 (bagToList val_bind_ids)
372 zonkMonoBinds env1 val_bind `thenM` \ (new_val_bind, val_bind_ids) ->
373 mappM (zonkExport env1) exports `thenM` \ new_exports ->
374 returnM (new_val_bind, new_exports, val_bind_ids)
375 ) `thenM ` \ (new_val_bind, new_exports, _) ->
377 new_globals = listToBag [global | (_, global, local) <- new_exports]
379 returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
382 zonkExport env (tyvars, global, local)
383 = zonkTcTyVars tyvars `thenM` \ tys ->
385 new_tyvars = map (tcGetTyVar "zonkExport") tys
386 -- This isn't the binding occurrence of these tyvars
387 -- but they should *be* tyvars. Hence tcGetTyVar.
389 zonkIdBndr env global `thenM` \ new_global ->
390 returnM (new_tyvars, new_global, zonkIdOcc env local)
393 %************************************************************************
395 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
397 %************************************************************************
400 zonkMatch :: ZonkEnv -> TcMatch -> TcM TypecheckedMatch
402 zonkMatch env (Match pats _ grhss)
403 = zonkPats env pats `thenM` \ (new_pats, new_ids) ->
404 zonkGRHSs (extendZonkEnv env (bagToList new_ids)) grhss `thenM` \ new_grhss ->
405 returnM (Match new_pats Nothing new_grhss)
407 -------------------------------------------------------------------------
408 zonkGRHSs :: ZonkEnv -> TcGRHSs -> TcM TypecheckedGRHSs
410 zonkGRHSs env (GRHSs grhss binds ty)
411 = zonkBinds env binds `thenM` \ (new_env, new_binds) ->
413 zonk_grhs (GRHS guarded locn)
414 = zonkStmts new_env guarded `thenM` \ new_guarded ->
415 returnM (GRHS new_guarded locn)
417 mappM zonk_grhs grhss `thenM` \ new_grhss ->
418 zonkTcTypeToType env ty `thenM` \ new_ty ->
419 returnM (GRHSs new_grhss new_binds new_ty)
422 %************************************************************************
424 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
426 %************************************************************************
429 zonkExprs :: ZonkEnv -> [TcExpr] -> TcM [TypecheckedHsExpr]
430 zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr
432 zonkExprs env exprs = mappM (zonkExpr env) exprs
435 zonkExpr env (HsVar id)
436 = returnM (HsVar (zonkIdOcc env id))
438 zonkExpr env (HsIPVar id)
439 = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
441 zonkExpr env (HsLit (HsRat f ty))
442 = zonkTcTypeToType env ty `thenM` \ new_ty ->
443 returnM (HsLit (HsRat f new_ty))
445 zonkExpr env (HsLit (HsLitLit lit ty))
446 = zonkTcTypeToType env ty `thenM` \ new_ty ->
447 returnM (HsLit (HsLitLit lit new_ty))
449 zonkExpr env (HsLit lit)
450 = returnM (HsLit lit)
452 -- HsOverLit doesn't appear in typechecker output
454 zonkExpr env (HsLam match)
455 = zonkMatch env match `thenM` \ new_match ->
456 returnM (HsLam new_match)
458 zonkExpr env (HsApp e1 e2)
459 = zonkExpr env e1 `thenM` \ new_e1 ->
460 zonkExpr env e2 `thenM` \ new_e2 ->
461 returnM (HsApp new_e1 new_e2)
463 zonkExpr env (HsBracketOut body bs)
464 = mappM zonk_b bs `thenM` \ bs' ->
465 returnM (HsBracketOut body bs')
467 zonk_b (n,e) = zonkExpr env e `thenM` \ e' ->
470 zonkExpr env (HsReify r) = returnM (HsReify r) -- Nothing to zonk; only top
471 -- level things can be reified (for now)
472 zonkExpr env (HsSplice n e loc) = WARN( True, ppr e ) -- Should not happen
473 returnM (HsSplice n e loc)
475 zonkExpr env (OpApp e1 op fixity e2)
476 = zonkExpr env e1 `thenM` \ new_e1 ->
477 zonkExpr env op `thenM` \ new_op ->
478 zonkExpr env e2 `thenM` \ new_e2 ->
479 returnM (OpApp new_e1 new_op fixity new_e2)
481 zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp"
483 zonkExpr env (HsPar e)
484 = zonkExpr env e `thenM` \new_e ->
485 returnM (HsPar new_e)
487 zonkExpr env (SectionL expr op)
488 = zonkExpr env expr `thenM` \ new_expr ->
489 zonkExpr env op `thenM` \ new_op ->
490 returnM (SectionL new_expr new_op)
492 zonkExpr env (SectionR op expr)
493 = zonkExpr env op `thenM` \ new_op ->
494 zonkExpr env expr `thenM` \ new_expr ->
495 returnM (SectionR new_op new_expr)
497 zonkExpr env (HsCase expr ms src_loc)
498 = zonkExpr env expr `thenM` \ new_expr ->
499 mappM (zonkMatch env) ms `thenM` \ new_ms ->
500 returnM (HsCase new_expr new_ms src_loc)
502 zonkExpr env (HsIf e1 e2 e3 src_loc)
503 = zonkExpr env e1 `thenM` \ new_e1 ->
504 zonkExpr env e2 `thenM` \ new_e2 ->
505 zonkExpr env e3 `thenM` \ new_e3 ->
506 returnM (HsIf new_e1 new_e2 new_e3 src_loc)
508 zonkExpr env (HsLet binds expr)
509 = zonkBinds env binds `thenM` \ (new_env, new_binds) ->
510 zonkExpr new_env expr `thenM` \ new_expr ->
511 returnM (HsLet new_binds new_expr)
513 zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
514 = zonkStmts env stmts `thenM` \ new_stmts ->
515 zonkTcTypeToType env ty `thenM` \ new_ty ->
516 returnM (HsDo do_or_lc new_stmts
520 zonkExpr env (ExplicitList ty exprs)
521 = zonkTcTypeToType env ty `thenM` \ new_ty ->
522 zonkExprs env exprs `thenM` \ new_exprs ->
523 returnM (ExplicitList new_ty new_exprs)
525 zonkExpr env (ExplicitPArr ty exprs)
526 = zonkTcTypeToType env ty `thenM` \ new_ty ->
527 zonkExprs env exprs `thenM` \ new_exprs ->
528 returnM (ExplicitPArr new_ty new_exprs)
530 zonkExpr env (ExplicitTuple exprs boxed)
531 = zonkExprs env exprs `thenM` \ new_exprs ->
532 returnM (ExplicitTuple new_exprs boxed)
534 zonkExpr env (RecordConOut data_con con_expr rbinds)
535 = zonkExpr env con_expr `thenM` \ new_con_expr ->
536 zonkRbinds env rbinds `thenM` \ new_rbinds ->
537 returnM (RecordConOut data_con new_con_expr new_rbinds)
539 zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"
541 zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
542 = zonkExpr env expr `thenM` \ new_expr ->
543 zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
544 zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
545 zonkRbinds env rbinds `thenM` \ new_rbinds ->
546 returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
548 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
549 zonkExpr env (ArithSeqIn _) = panic "zonkExpr env:ArithSeqIn"
550 zonkExpr env (PArrSeqIn _) = panic "zonkExpr env:PArrSeqIn"
552 zonkExpr env (ArithSeqOut expr info)
553 = zonkExpr env expr `thenM` \ new_expr ->
554 zonkArithSeq env info `thenM` \ new_info ->
555 returnM (ArithSeqOut new_expr new_info)
557 zonkExpr env (PArrSeqOut expr info)
558 = zonkExpr env expr `thenM` \ new_expr ->
559 zonkArithSeq env info `thenM` \ new_info ->
560 returnM (PArrSeqOut new_expr new_info)
562 zonkExpr env (HsCCall fun args may_gc is_casm result_ty)
563 = zonkExprs env args `thenM` \ new_args ->
564 zonkTcTypeToType env result_ty `thenM` \ new_result_ty ->
565 returnM (HsCCall fun new_args may_gc is_casm new_result_ty)
567 zonkExpr env (HsSCC lbl expr)
568 = zonkExpr env expr `thenM` \ new_expr ->
569 returnM (HsSCC lbl new_expr)
571 zonkExpr env (TyLam tyvars expr)
572 = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
573 -- No need to extend tyvar env; see AbsBinds
575 zonkExpr env expr `thenM` \ new_expr ->
576 returnM (TyLam new_tyvars new_expr)
578 zonkExpr env (TyApp expr tys)
579 = zonkExpr env expr `thenM` \ new_expr ->
580 mappM (zonkTcTypeToType env) tys `thenM` \ new_tys ->
581 returnM (TyApp new_expr new_tys)
583 zonkExpr env (DictLam dicts expr)
584 = zonkIdBndrs env dicts `thenM` \ new_dicts ->
586 env1 = extendZonkEnv env new_dicts
588 zonkExpr env1 expr `thenM` \ new_expr ->
589 returnM (DictLam new_dicts new_expr)
591 zonkExpr env (DictApp expr dicts)
592 = zonkExpr env expr `thenM` \ new_expr ->
593 returnM (DictApp new_expr (zonkIdOccs env dicts))
597 -------------------------------------------------------------------------
598 zonkArithSeq :: ZonkEnv -> TcArithSeqInfo -> TcM TypecheckedArithSeqInfo
600 zonkArithSeq env (From e)
601 = zonkExpr env e `thenM` \ new_e ->
604 zonkArithSeq env (FromThen e1 e2)
605 = zonkExpr env e1 `thenM` \ new_e1 ->
606 zonkExpr env e2 `thenM` \ new_e2 ->
607 returnM (FromThen new_e1 new_e2)
609 zonkArithSeq env (FromTo e1 e2)
610 = zonkExpr env e1 `thenM` \ new_e1 ->
611 zonkExpr env e2 `thenM` \ new_e2 ->
612 returnM (FromTo new_e1 new_e2)
614 zonkArithSeq env (FromThenTo e1 e2 e3)
615 = zonkExpr env e1 `thenM` \ new_e1 ->
616 zonkExpr env e2 `thenM` \ new_e2 ->
617 zonkExpr env e3 `thenM` \ new_e3 ->
618 returnM (FromThenTo new_e1 new_e2 new_e3)
621 -------------------------------------------------------------------------
622 zonkStmts :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt]
624 zonkStmts env stmts = zonk_stmts env stmts `thenM` \ (_, stmts) ->
627 zonk_stmts :: ZonkEnv -> [TcStmt] -> TcM (ZonkEnv, [TypecheckedStmt])
629 zonk_stmts env [] = returnM (env, [])
631 zonk_stmts env (ParStmtOut bndrstmtss : stmts)
632 = mappM (mappM zonkId) bndrss `thenM` \ new_bndrss ->
633 mappM (zonkStmts env) stmtss `thenM` \ new_stmtss ->
635 new_binders = concat new_bndrss
636 env1 = extendZonkEnv env new_binders
638 zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
639 returnM (env2, ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
641 (bndrss, stmtss) = unzip bndrstmtss
643 zonk_stmts env (RecStmt vs segStmts rets : stmts)
644 = mappM zonkId vs `thenM` \ new_vs ->
646 env1 = extendZonkEnv env new_vs
648 zonk_stmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
649 -- Zonk the ret-expressions in an envt that
650 -- has the polymorphic bindings in the envt
651 zonkExprs env2 rets `thenM` \ new_rets ->
652 zonk_stmts env1 stmts `thenM` \ (env3, new_stmts) ->
653 returnM (env3, RecStmt new_vs new_segStmts new_rets : new_stmts)
655 zonk_stmts env (ResultStmt expr locn : stmts)
656 = ASSERT( null stmts )
657 zonkExpr env expr `thenM` \ new_expr ->
658 returnM (env, [ResultStmt new_expr locn])
660 zonk_stmts env (ExprStmt expr ty locn : stmts)
661 = zonkExpr env expr `thenM` \ new_expr ->
662 zonkTcTypeToType env ty `thenM` \ new_ty ->
663 zonk_stmts env stmts `thenM` \ (env1, new_stmts) ->
664 returnM (env1, ExprStmt new_expr new_ty locn : new_stmts)
666 zonk_stmts env (LetStmt binds : stmts)
667 = zonkBinds env binds `thenM` \ (env1, new_binds) ->
668 zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
669 returnM (env2, LetStmt new_binds : new_stmts)
671 zonk_stmts env (BindStmt pat expr locn : stmts)
672 = zonkExpr env expr `thenM` \ new_expr ->
673 zonkPat env pat `thenM` \ (new_pat, new_ids) ->
675 env1 = extendZonkEnv env (bagToList new_ids)
677 zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
678 returnM (env2, BindStmt new_pat new_expr locn : new_stmts)
682 -------------------------------------------------------------------------
683 zonkRbinds :: ZonkEnv -> TcRecordBinds -> TcM TypecheckedRecordBinds
685 zonkRbinds env rbinds
686 = mappM zonk_rbind rbinds
688 zonk_rbind (field, expr)
689 = zonkExpr env expr `thenM` \ new_expr ->
690 returnM (zonkIdOcc env field, new_expr)
692 -------------------------------------------------------------------------
693 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
694 mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r)
695 mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r)
699 %************************************************************************
701 \subsection[BackSubst-Pats]{Patterns}
703 %************************************************************************
706 zonkPat :: ZonkEnv -> TcPat -> TcM (TypecheckedPat, Bag Id)
708 zonkPat env (ParPat p)
709 = zonkPat env p `thenM` \ (new_p, ids) ->
710 returnM (ParPat new_p, ids)
712 zonkPat env (WildPat ty)
713 = zonkTcTypeToType env ty `thenM` \ new_ty ->
714 returnM (WildPat new_ty, emptyBag)
716 zonkPat env (VarPat v)
717 = zonkIdBndr env v `thenM` \ new_v ->
718 returnM (VarPat new_v, unitBag new_v)
720 zonkPat env (LazyPat pat)
721 = zonkPat env pat `thenM` \ (new_pat, ids) ->
722 returnM (LazyPat new_pat, ids)
724 zonkPat env (AsPat n pat)
725 = zonkIdBndr env n `thenM` \ new_n ->
726 zonkPat env pat `thenM` \ (new_pat, ids) ->
727 returnM (AsPat new_n new_pat, new_n `consBag` ids)
729 zonkPat env (ListPat pats ty)
730 = zonkTcTypeToType env ty `thenM` \ new_ty ->
731 zonkPats env pats `thenM` \ (new_pats, ids) ->
732 returnM (ListPat new_pats new_ty, ids)
734 zonkPat env (PArrPat pats ty)
735 = zonkTcTypeToType env ty `thenM` \ new_ty ->
736 zonkPats env pats `thenM` \ (new_pats, ids) ->
737 returnM (PArrPat new_pats new_ty, ids)
739 zonkPat env (TuplePat pats boxed)
740 = zonkPats env pats `thenM` \ (new_pats, ids) ->
741 returnM (TuplePat new_pats boxed, ids)
743 zonkPat env (ConPatOut n stuff ty tvs dicts)
744 = zonkTcTypeToType env ty `thenM` \ new_ty ->
745 mappM zonkTcTyVarToTyVar tvs `thenM` \ new_tvs ->
746 zonkIdBndrs env dicts `thenM` \ new_dicts ->
748 env1 = extendZonkEnv env new_dicts
750 zonkConStuff env stuff `thenM` \ (new_stuff, ids) ->
751 returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts,
752 listToBag new_dicts `unionBags` ids)
754 zonkPat env (LitPat lit) = returnM (LitPat lit, emptyBag)
756 zonkPat env (SigPatOut pat ty expr)
757 = zonkPat env pat `thenM` \ (new_pat, ids) ->
758 zonkTcTypeToType env ty `thenM` \ new_ty ->
759 zonkExpr env expr `thenM` \ new_expr ->
760 returnM (SigPatOut new_pat new_ty new_expr, ids)
762 zonkPat env (NPatOut lit ty expr)
763 = zonkTcTypeToType env ty `thenM` \ new_ty ->
764 zonkExpr env expr `thenM` \ new_expr ->
765 returnM (NPatOut lit new_ty new_expr, emptyBag)
767 zonkPat env (NPlusKPatOut n k e1 e2)
768 = zonkIdBndr env n `thenM` \ new_n ->
769 zonkExpr env e1 `thenM` \ new_e1 ->
770 zonkExpr env e2 `thenM` \ new_e2 ->
771 returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag new_n)
773 zonkPat env (DictPat ds ms)
774 = zonkIdBndrs env ds `thenM` \ new_ds ->
775 zonkIdBndrs env ms `thenM` \ new_ms ->
776 returnM (DictPat new_ds new_ms,
777 listToBag new_ds `unionBags` listToBag new_ms)
779 ---------------------------
780 zonkConStuff env (PrefixCon pats)
781 = zonkPats env pats `thenM` \ (new_pats, ids) ->
782 returnM (PrefixCon new_pats, ids)
784 zonkConStuff env (InfixCon p1 p2)
785 = zonkPat env p1 `thenM` \ (new_p1, ids1) ->
786 zonkPat env p2 `thenM` \ (new_p2, ids2) ->
787 returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2)
789 zonkConStuff env (RecCon rpats)
790 = mapAndUnzipM zonk_rpat rpats `thenM` \ (new_rpats, ids_s) ->
791 returnM (RecCon new_rpats, unionManyBags ids_s)
794 = zonkPat env pat `thenM` \ (new_pat, ids) ->
795 returnM ((f, new_pat), ids)
797 ---------------------------
799 = returnM ([], emptyBag)
801 zonkPats env (pat:pats)
802 = zonkPat env pat `thenM` \ (pat', ids1) ->
803 zonkPats env pats `thenM` \ (pats', ids2) ->
804 returnM (pat':pats', ids1 `unionBags` ids2)
807 %************************************************************************
809 \subsection[BackSubst-Foreign]{Foreign exports}
811 %************************************************************************
815 zonkForeignExports :: ZonkEnv -> [TcForeignDecl] -> TcM [TypecheckedForeignDecl]
816 zonkForeignExports env ls = mappM (zonkForeignExport env) ls
818 zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl)
819 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) =
820 returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc)
824 zonkRules :: ZonkEnv -> [TcRuleDecl] -> TcM [TypecheckedRuleDecl]
825 zonkRules env rs = mappM (zonkRule env) rs
827 zonkRule env (HsRule name act vars lhs rhs loc)
828 = mappM zonk_bndr vars `thenM` \ new_bndrs ->
829 newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
831 env_rhs = extendZonkEnv env (filter isId new_bndrs)
832 -- Type variables don't need an envt
833 -- They are bound through the mutable mechanism
835 env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
836 -- We need to gather the type variables mentioned on the LHS so we can
837 -- quantify over them. Example:
843 -- {-# RULES "myrule" foo C = 1 #-}
845 -- After type checking the LHS becomes (foo a (C a))
846 -- and we do not want to zap the unbound tyvar 'a' to (), because
847 -- that limits the applicability of the rule. Instead, we
848 -- want to quantify over it!
850 -- It's easiest to find the free tyvars here. Attempts to do so earlier
851 -- are tiresome, because (a) the data type is big and (b) finding the
852 -- free type vars of an expression is necessarily monadic operation.
853 -- (consider /\a -> f @ b, where b is side-effected to a)
855 zonkExpr env_lhs lhs `thenM` \ new_lhs ->
856 zonkExpr env_rhs rhs `thenM` \ new_rhs ->
858 readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
860 final_bndrs = map RuleBndr (varSetElems unbound_tvs ++ new_bndrs)
861 -- I hate this map RuleBndr stuff
863 returnM (HsRule name act final_bndrs new_lhs new_rhs loc)
865 zonk_bndr (RuleBndr v)
866 | isId v = zonkIdBndr env v
867 | otherwise = zonkTcTyVarToTyVar v
869 zonkRule env (IfaceRuleOut fun rule)
870 = returnM (IfaceRuleOut (zonkIdOcc env fun) rule)
874 %************************************************************************
876 \subsection[BackSubst-Foreign]{Foreign exports}
878 %************************************************************************
881 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
882 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
884 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
885 -- This variant collects unbound type variables in a mutable variable
886 zonkTypeCollecting unbound_tv_set
887 = zonkType zonk_unbound_tyvar
889 zonk_unbound_tyvar tv
890 = zonkTcTyVarToTyVar tv `thenM` \ tv' ->
891 readMutVar unbound_tv_set `thenM` \ tv_set ->
892 writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
893 return (mkTyVarTy tv')
895 zonkTypeZapping :: TcType -> TcM Type
896 -- This variant is used for everything except the LHS of rules
897 -- It zaps unbound type variables to (), or some other arbitrary type
899 = zonkType zonk_unbound_tyvar ty
901 -- Zonk a mutable but unbound type variable to an arbitrary type
902 -- We know it's unbound even though we don't carry an environment,
903 -- because at the binding site for a type variable we bind the
904 -- mutable tyvar to a fresh immutable one. So the mutable store
905 -- plays the role of an environment. If we come across a mutable
906 -- type variable that isn't so bound, it must be completely free.
907 zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv)
910 -- When the type checker finds a type variable with no binding,
911 -- which means it can be instantiated with an arbitrary type, it
912 -- usually instantiates it to Void. Eg.
916 -- length Void (Nil Void)
918 -- But in really obscure programs, the type variable might have
919 -- a kind other than *, so we need to invent a suitably-kinded type.
923 -- List for kind *->*
924 -- Tuple for kind *->...*->*
926 -- which deals with most cases. (Previously, it only dealt with
929 -- In the other cases, it just makes up a TyCon with a suitable
930 -- kind. If this gets into an interface file, anyone reading that
931 -- file won't understand it. This is fixable (by making the client
932 -- of the interface file make up a TyCon too) but it is tiresome and
933 -- never happens, so I am leaving it
935 mkArbitraryType :: TcTyVar -> Type
936 -- Make up an arbitrary type whose kind is the same as the tyvar.
937 -- We'll use this to instantiate the (unbound) tyvar.
939 | isAnyTypeKind kind = voidTy -- The vastly common case
940 | otherwise = mkTyConApp tycon []
943 (args,res) = Type.splitFunTys kind -- Kinds are simple; use Type.splitFunTys
945 tycon | kind `eqKind` tyConKind listTyCon -- *->*
946 = listTyCon -- No tuples this size
948 | all isTypeKind args && isTypeKind res
949 = tupleTyCon Boxed (length args) -- *-> ... ->*->*
952 = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
953 mkPrimTyCon tc_name kind 0 [] VoidRep
954 -- Same name as the tyvar, apart from making it start with a colon (sigh)
955 -- I dread to think what will happen if this gets out into an
956 -- interface file. Catastrophe likely. Major sigh.
958 tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc