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 (FunMonoBind var inf ms locn)
343 = zonkIdBndr env var `thenM` \ new_var ->
344 mappM (zonkMatch env) ms `thenM` \ new_ms ->
345 returnM (FunMonoBind new_var inf new_ms locn, unitBag new_var)
348 zonkMonoBinds env (AbsBinds tyvars dicts exports inlines val_bind)
349 = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
350 -- No need to extend tyvar env: the effects are
351 -- propagated through binding the tyvars themselves
353 zonkIdBndrs env dicts `thenM` \ new_dicts ->
354 fixM (\ ~(_, _, val_bind_ids) ->
356 env1 = extendZonkEnv (extendZonkEnv env new_dicts)
357 (bagToList val_bind_ids)
359 zonkMonoBinds env1 val_bind `thenM` \ (new_val_bind, val_bind_ids) ->
360 mappM (zonkExport env1) exports `thenM` \ new_exports ->
361 returnM (new_val_bind, new_exports, val_bind_ids)
362 ) `thenM ` \ (new_val_bind, new_exports, _) ->
364 new_globals = listToBag [global | (_, global, local) <- new_exports]
366 returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
369 zonkExport env (tyvars, global, local)
370 = zonkTcTyVars tyvars `thenM` \ tys ->
372 new_tyvars = map (tcGetTyVar "zonkExport") tys
373 -- This isn't the binding occurrence of these tyvars
374 -- but they should *be* tyvars. Hence tcGetTyVar.
376 zonkIdBndr env global `thenM` \ new_global ->
377 returnM (new_tyvars, new_global, zonkIdOcc env local)
380 %************************************************************************
382 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
384 %************************************************************************
387 zonkMatch :: ZonkEnv -> TcMatch -> TcM TypecheckedMatch
389 zonkMatch env (Match pats _ grhss)
390 = zonkPats env pats `thenM` \ (new_pats, new_ids) ->
391 zonkGRHSs (extendZonkEnv env (bagToList new_ids)) grhss `thenM` \ new_grhss ->
392 returnM (Match new_pats Nothing new_grhss)
394 -------------------------------------------------------------------------
395 zonkGRHSs :: ZonkEnv -> TcGRHSs -> TcM TypecheckedGRHSs
397 zonkGRHSs env (GRHSs grhss binds ty)
398 = zonkBinds env binds `thenM` \ (new_env, new_binds) ->
400 zonk_grhs (GRHS guarded locn)
401 = zonkStmts new_env guarded `thenM` \ new_guarded ->
402 returnM (GRHS new_guarded locn)
404 mappM zonk_grhs grhss `thenM` \ new_grhss ->
405 zonkTcTypeToType env ty `thenM` \ new_ty ->
406 returnM (GRHSs new_grhss new_binds new_ty)
409 %************************************************************************
411 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
413 %************************************************************************
416 zonkExprs :: ZonkEnv -> [TcExpr] -> TcM [TypecheckedHsExpr]
417 zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr
419 zonkExprs env exprs = mappM (zonkExpr env) exprs
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 loc) = WARN( True, ppr e ) -- Should not happen
458 returnM (HsSplice n e loc)
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 zonkExprs 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 zonkExprs env exprs `thenM` \ new_exprs ->
526 returnM (ExplicitPArr new_ty new_exprs)
528 zonkExpr env (ExplicitTuple exprs boxed)
529 = zonkExprs 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 = zonkExprs 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 stmts = zonk_stmts env stmts `thenM` \ (_, stmts) ->
625 zonk_stmts :: ZonkEnv -> [TcStmt] -> TcM (ZonkEnv, [TypecheckedStmt])
627 zonk_stmts env [] = returnM (env, [])
629 zonk_stmts env (ParStmtOut bndrstmtss : stmts)
630 = mappM (mappM zonkId) bndrss `thenM` \ new_bndrss ->
631 mappM (zonkStmts env) stmtss `thenM` \ new_stmtss ->
633 new_binders = concat new_bndrss
634 env1 = extendZonkEnv env new_binders
636 zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
637 returnM (env2, ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
639 (bndrss, stmtss) = unzip bndrstmtss
641 zonk_stmts env (RecStmt vs segStmts rets : stmts)
642 = mappM zonkId vs `thenM` \ new_vs ->
644 env1 = extendZonkEnv env new_vs
646 zonk_stmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
647 -- Zonk the ret-expressions in an envt that
648 -- has the polymorphic bindings in the envt
649 zonkExprs env2 rets `thenM` \ new_rets ->
650 zonk_stmts env1 stmts `thenM` \ (env3, new_stmts) ->
651 returnM (env3, RecStmt new_vs new_segStmts new_rets : new_stmts)
653 zonk_stmts env (ResultStmt expr locn : stmts)
654 = ASSERT( null stmts )
655 zonkExpr env expr `thenM` \ new_expr ->
656 returnM (env, [ResultStmt new_expr locn])
658 zonk_stmts env (ExprStmt expr ty locn : stmts)
659 = zonkExpr env expr `thenM` \ new_expr ->
660 zonkTcTypeToType env ty `thenM` \ new_ty ->
661 zonk_stmts env stmts `thenM` \ (env1, new_stmts) ->
662 returnM (env1, ExprStmt new_expr new_ty locn : new_stmts)
664 zonk_stmts env (LetStmt binds : stmts)
665 = zonkBinds env binds `thenM` \ (env1, new_binds) ->
666 zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
667 returnM (env2, LetStmt new_binds : new_stmts)
669 zonk_stmts env (BindStmt pat expr locn : stmts)
670 = zonkExpr env expr `thenM` \ new_expr ->
671 zonkPat env pat `thenM` \ (new_pat, new_ids) ->
673 env1 = extendZonkEnv env (bagToList new_ids)
675 zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
676 returnM (env2, BindStmt new_pat new_expr locn : new_stmts)
680 -------------------------------------------------------------------------
681 zonkRbinds :: ZonkEnv -> TcRecordBinds -> TcM TypecheckedRecordBinds
683 zonkRbinds env rbinds
684 = mappM zonk_rbind rbinds
686 zonk_rbind (field, expr)
687 = zonkExpr env expr `thenM` \ new_expr ->
688 returnM (zonkIdOcc env field, new_expr)
690 -------------------------------------------------------------------------
691 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
692 mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r)
693 mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r)
697 %************************************************************************
699 \subsection[BackSubst-Pats]{Patterns}
701 %************************************************************************
704 zonkPat :: ZonkEnv -> TcPat -> TcM (TypecheckedPat, Bag Id)
706 zonkPat env (ParPat p)
707 = zonkPat env p `thenM` \ (new_p, ids) ->
708 returnM (ParPat new_p, ids)
710 zonkPat env (WildPat ty)
711 = zonkTcTypeToType env ty `thenM` \ new_ty ->
712 returnM (WildPat new_ty, emptyBag)
714 zonkPat env (VarPat v)
715 = zonkIdBndr env v `thenM` \ new_v ->
716 returnM (VarPat new_v, unitBag new_v)
718 zonkPat env (LazyPat pat)
719 = zonkPat env pat `thenM` \ (new_pat, ids) ->
720 returnM (LazyPat new_pat, ids)
722 zonkPat env (AsPat n pat)
723 = zonkIdBndr env n `thenM` \ new_n ->
724 zonkPat env pat `thenM` \ (new_pat, ids) ->
725 returnM (AsPat new_n new_pat, new_n `consBag` ids)
727 zonkPat env (ListPat pats ty)
728 = zonkTcTypeToType env ty `thenM` \ new_ty ->
729 zonkPats env pats `thenM` \ (new_pats, ids) ->
730 returnM (ListPat new_pats new_ty, ids)
732 zonkPat env (PArrPat pats ty)
733 = zonkTcTypeToType env ty `thenM` \ new_ty ->
734 zonkPats env pats `thenM` \ (new_pats, ids) ->
735 returnM (PArrPat new_pats new_ty, ids)
737 zonkPat env (TuplePat pats boxed)
738 = zonkPats env pats `thenM` \ (new_pats, ids) ->
739 returnM (TuplePat new_pats boxed, ids)
741 zonkPat env (ConPatOut n stuff ty tvs dicts)
742 = zonkTcTypeToType env ty `thenM` \ new_ty ->
743 mappM zonkTcTyVarToTyVar tvs `thenM` \ new_tvs ->
744 zonkIdBndrs env dicts `thenM` \ new_dicts ->
746 env1 = extendZonkEnv env new_dicts
748 zonkConStuff env stuff `thenM` \ (new_stuff, ids) ->
749 returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts,
750 listToBag new_dicts `unionBags` ids)
752 zonkPat env (LitPat lit) = returnM (LitPat lit, emptyBag)
754 zonkPat env (SigPatOut pat ty expr)
755 = zonkPat env pat `thenM` \ (new_pat, ids) ->
756 zonkTcTypeToType env ty `thenM` \ new_ty ->
757 zonkExpr env expr `thenM` \ new_expr ->
758 returnM (SigPatOut new_pat new_ty new_expr, ids)
760 zonkPat env (NPatOut lit ty expr)
761 = zonkTcTypeToType env ty `thenM` \ new_ty ->
762 zonkExpr env expr `thenM` \ new_expr ->
763 returnM (NPatOut lit new_ty new_expr, emptyBag)
765 zonkPat env (NPlusKPatOut n k e1 e2)
766 = zonkIdBndr env n `thenM` \ new_n ->
767 zonkExpr env e1 `thenM` \ new_e1 ->
768 zonkExpr env e2 `thenM` \ new_e2 ->
769 returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag new_n)
771 zonkPat env (DictPat ds ms)
772 = zonkIdBndrs env ds `thenM` \ new_ds ->
773 zonkIdBndrs env ms `thenM` \ new_ms ->
774 returnM (DictPat new_ds new_ms,
775 listToBag new_ds `unionBags` listToBag new_ms)
777 ---------------------------
778 zonkConStuff env (PrefixCon pats)
779 = zonkPats env pats `thenM` \ (new_pats, ids) ->
780 returnM (PrefixCon new_pats, ids)
782 zonkConStuff env (InfixCon p1 p2)
783 = zonkPat env p1 `thenM` \ (new_p1, ids1) ->
784 zonkPat env p2 `thenM` \ (new_p2, ids2) ->
785 returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2)
787 zonkConStuff env (RecCon rpats)
788 = mapAndUnzipM zonk_rpat rpats `thenM` \ (new_rpats, ids_s) ->
789 returnM (RecCon new_rpats, unionManyBags ids_s)
792 = zonkPat env pat `thenM` \ (new_pat, ids) ->
793 returnM ((f, new_pat), ids)
795 ---------------------------
797 = returnM ([], emptyBag)
799 zonkPats env (pat:pats)
800 = zonkPat env pat `thenM` \ (pat', ids1) ->
801 zonkPats env pats `thenM` \ (pats', ids2) ->
802 returnM (pat':pats', ids1 `unionBags` ids2)
805 %************************************************************************
807 \subsection[BackSubst-Foreign]{Foreign exports}
809 %************************************************************************
813 zonkForeignExports :: ZonkEnv -> [TcForeignDecl] -> TcM [TypecheckedForeignDecl]
814 zonkForeignExports env ls = mappM (zonkForeignExport env) ls
816 zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl)
817 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) =
818 returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc)
822 zonkRules :: ZonkEnv -> [TcRuleDecl] -> TcM [TypecheckedRuleDecl]
823 zonkRules env rs = mappM (zonkRule env) rs
825 zonkRule env (HsRule name act vars lhs rhs loc)
826 = mappM zonk_bndr vars `thenM` \ new_bndrs ->
827 newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
829 env_rhs = extendZonkEnv env (filter isId new_bndrs)
830 -- Type variables don't need an envt
831 -- They are bound through the mutable mechanism
833 env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
834 -- We need to gather the type variables mentioned on the LHS so we can
835 -- quantify over them. Example:
841 -- {-# RULES "myrule" foo C = 1 #-}
843 -- After type checking the LHS becomes (foo a (C a))
844 -- and we do not want to zap the unbound tyvar 'a' to (), because
845 -- that limits the applicability of the rule. Instead, we
846 -- want to quantify over it!
848 -- It's easiest to find the free tyvars here. Attempts to do so earlier
849 -- are tiresome, because (a) the data type is big and (b) finding the
850 -- free type vars of an expression is necessarily monadic operation.
851 -- (consider /\a -> f @ b, where b is side-effected to a)
853 zonkExpr env_lhs lhs `thenM` \ new_lhs ->
854 zonkExpr env_rhs rhs `thenM` \ new_rhs ->
856 readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
858 final_bndrs = map RuleBndr (varSetElems unbound_tvs ++ new_bndrs)
859 -- I hate this map RuleBndr stuff
861 returnM (HsRule name act final_bndrs new_lhs new_rhs loc)
863 zonk_bndr (RuleBndr v)
864 | isId v = zonkIdBndr env v
865 | otherwise = zonkTcTyVarToTyVar v
867 zonkRule env (IfaceRuleOut fun rule)
868 = returnM (IfaceRuleOut (zonkIdOcc env fun) rule)
872 %************************************************************************
874 \subsection[BackSubst-Foreign]{Foreign exports}
876 %************************************************************************
879 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
880 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
882 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
883 -- This variant collects unbound type variables in a mutable variable
884 zonkTypeCollecting unbound_tv_set
885 = zonkType zonk_unbound_tyvar
887 zonk_unbound_tyvar tv
888 = zonkTcTyVarToTyVar tv `thenM` \ tv' ->
889 readMutVar unbound_tv_set `thenM` \ tv_set ->
890 writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
891 return (mkTyVarTy tv')
893 zonkTypeZapping :: TcType -> TcM Type
894 -- This variant is used for everything except the LHS of rules
895 -- It zaps unbound type variables to (), or some other arbitrary type
897 = zonkType zonk_unbound_tyvar ty
899 -- Zonk a mutable but unbound type variable to an arbitrary type
900 -- We know it's unbound even though we don't carry an environment,
901 -- because at the binding site for a type variable we bind the
902 -- mutable tyvar to a fresh immutable one. So the mutable store
903 -- plays the role of an environment. If we come across a mutable
904 -- type variable that isn't so bound, it must be completely free.
905 zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv)
908 -- When the type checker finds a type variable with no binding,
909 -- which means it can be instantiated with an arbitrary type, it
910 -- usually instantiates it to Void. Eg.
914 -- length Void (Nil Void)
916 -- But in really obscure programs, the type variable might have
917 -- a kind other than *, so we need to invent a suitably-kinded type.
921 -- List for kind *->*
922 -- Tuple for kind *->...*->*
924 -- which deals with most cases. (Previously, it only dealt with
927 -- In the other cases, it just makes up a TyCon with a suitable
928 -- kind. If this gets into an interface file, anyone reading that
929 -- file won't understand it. This is fixable (by making the client
930 -- of the interface file make up a TyCon too) but it is tiresome and
931 -- never happens, so I am leaving it
933 mkArbitraryType :: TcTyVar -> Type
934 -- Make up an arbitrary type whose kind is the same as the tyvar.
935 -- We'll use this to instantiate the (unbound) tyvar.
937 | isAnyTypeKind kind = voidTy -- The vastly common case
938 | otherwise = mkTyConApp tycon []
941 (args,res) = Type.splitFunTys kind -- Kinds are simple; use Type.splitFunTys
943 tycon | kind `eqKind` tyConKind listTyCon -- *->*
944 = listTyCon -- No tuples this size
946 | all isTypeKind args && isTypeKind res
947 = tupleTyCon Boxed (length args) -- *-> ... ->*->*
950 = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
951 mkPrimTyCon tc_name kind 0 [] VoidRep
952 -- Same name as the tyvar, apart from making it start with a colon (sigh)
953 -- I dread to think what will happen if this gets out into an
954 -- interface file. Catastrophe likely. Major sigh.
956 tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc