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 zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr
418 zonkExpr env (HsVar id)
419 = returnM (HsVar (zonkIdOcc env id))
421 zonkExpr env (HsIPVar id)
422 = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
424 zonkExpr env (HsLit (HsRat f ty))
425 = zonkTcTypeToType env ty `thenM` \ new_ty ->
426 returnM (HsLit (HsRat f new_ty))
428 zonkExpr env (HsLit (HsLitLit lit ty))
429 = zonkTcTypeToType env ty `thenM` \ new_ty ->
430 returnM (HsLit (HsLitLit lit new_ty))
432 zonkExpr env (HsLit lit)
433 = returnM (HsLit lit)
435 -- HsOverLit doesn't appear in typechecker output
437 zonkExpr env (HsLam match)
438 = zonkMatch env match `thenM` \ new_match ->
439 returnM (HsLam new_match)
441 zonkExpr env (HsApp e1 e2)
442 = zonkExpr env e1 `thenM` \ new_e1 ->
443 zonkExpr env e2 `thenM` \ new_e2 ->
444 returnM (HsApp new_e1 new_e2)
446 zonkExpr env (HsBracketOut body bs)
447 = mappM zonk_b bs `thenM` \ bs' ->
448 returnM (HsBracketOut body bs')
450 zonk_b (n,e) = zonkExpr env e `thenM` \ e' ->
453 zonkExpr env (HsSplice n e) = WARN( True, ppr e ) -- Should not happen
454 returnM (HsSplice n e)
456 zonkExpr env (OpApp e1 op fixity e2)
457 = zonkExpr env e1 `thenM` \ new_e1 ->
458 zonkExpr env op `thenM` \ new_op ->
459 zonkExpr env e2 `thenM` \ new_e2 ->
460 returnM (OpApp new_e1 new_op fixity new_e2)
462 zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp"
464 zonkExpr env (HsPar e)
465 = zonkExpr env e `thenM` \new_e ->
466 returnM (HsPar new_e)
468 zonkExpr env (SectionL expr op)
469 = zonkExpr env expr `thenM` \ new_expr ->
470 zonkExpr env op `thenM` \ new_op ->
471 returnM (SectionL new_expr new_op)
473 zonkExpr env (SectionR op expr)
474 = zonkExpr env op `thenM` \ new_op ->
475 zonkExpr env expr `thenM` \ new_expr ->
476 returnM (SectionR new_op new_expr)
478 zonkExpr env (HsCase expr ms src_loc)
479 = zonkExpr env expr `thenM` \ new_expr ->
480 mappM (zonkMatch env) ms `thenM` \ new_ms ->
481 returnM (HsCase new_expr new_ms src_loc)
483 zonkExpr env (HsIf e1 e2 e3 src_loc)
484 = zonkExpr env e1 `thenM` \ new_e1 ->
485 zonkExpr env e2 `thenM` \ new_e2 ->
486 zonkExpr env e3 `thenM` \ new_e3 ->
487 returnM (HsIf new_e1 new_e2 new_e3 src_loc)
489 zonkExpr env (HsLet binds expr)
490 = zonkBinds env binds `thenM` \ (new_env, new_binds) ->
491 zonkExpr new_env expr `thenM` \ new_expr ->
492 returnM (HsLet new_binds new_expr)
494 zonkExpr env (HsWith expr binds is_with)
495 = mappM zonk_ip_bind binds `thenM` \ new_binds ->
497 env1 = extendZonkEnv env (map (ipNameName . fst) new_binds)
499 zonkExpr env1 expr `thenM` \ new_expr ->
500 returnM (HsWith new_expr new_binds is_with)
503 = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
504 zonkExpr env e `thenM` \ e' ->
507 zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
508 = zonkStmts env stmts `thenM` \ new_stmts ->
509 zonkTcTypeToType env ty `thenM` \ new_ty ->
510 returnM (HsDo do_or_lc new_stmts
514 zonkExpr env (ExplicitList ty exprs)
515 = zonkTcTypeToType env ty `thenM` \ new_ty ->
516 mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
517 returnM (ExplicitList new_ty new_exprs)
519 zonkExpr env (ExplicitPArr ty exprs)
520 = zonkTcTypeToType env ty `thenM` \ new_ty ->
521 mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
522 returnM (ExplicitPArr new_ty new_exprs)
524 zonkExpr env (ExplicitTuple exprs boxed)
525 = mappM (zonkExpr env) exprs `thenM` \ new_exprs ->
526 returnM (ExplicitTuple new_exprs boxed)
528 zonkExpr env (RecordConOut data_con con_expr rbinds)
529 = zonkExpr env con_expr `thenM` \ new_con_expr ->
530 zonkRbinds env rbinds `thenM` \ new_rbinds ->
531 returnM (RecordConOut data_con new_con_expr new_rbinds)
533 zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"
535 zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
536 = zonkExpr env expr `thenM` \ new_expr ->
537 zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
538 zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
539 zonkRbinds env rbinds `thenM` \ new_rbinds ->
540 returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
542 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
543 zonkExpr env (ArithSeqIn _) = panic "zonkExpr env:ArithSeqIn"
544 zonkExpr env (PArrSeqIn _) = panic "zonkExpr env:PArrSeqIn"
546 zonkExpr env (ArithSeqOut expr info)
547 = zonkExpr env expr `thenM` \ new_expr ->
548 zonkArithSeq env info `thenM` \ new_info ->
549 returnM (ArithSeqOut new_expr new_info)
551 zonkExpr env (PArrSeqOut expr info)
552 = zonkExpr env expr `thenM` \ new_expr ->
553 zonkArithSeq env info `thenM` \ new_info ->
554 returnM (PArrSeqOut new_expr new_info)
556 zonkExpr env (HsCCall fun args may_gc is_casm result_ty)
557 = mappM (zonkExpr env) args `thenM` \ new_args ->
558 zonkTcTypeToType env result_ty `thenM` \ new_result_ty ->
559 returnM (HsCCall fun new_args may_gc is_casm new_result_ty)
561 zonkExpr env (HsSCC lbl expr)
562 = zonkExpr env expr `thenM` \ new_expr ->
563 returnM (HsSCC lbl new_expr)
565 zonkExpr env (TyLam tyvars expr)
566 = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
567 -- No need to extend tyvar env; see AbsBinds
569 zonkExpr env expr `thenM` \ new_expr ->
570 returnM (TyLam new_tyvars new_expr)
572 zonkExpr env (TyApp expr tys)
573 = zonkExpr env expr `thenM` \ new_expr ->
574 mappM (zonkTcTypeToType env) tys `thenM` \ new_tys ->
575 returnM (TyApp new_expr new_tys)
577 zonkExpr env (DictLam dicts expr)
578 = zonkIdBndrs env dicts `thenM` \ new_dicts ->
580 env1 = extendZonkEnv env new_dicts
582 zonkExpr env1 expr `thenM` \ new_expr ->
583 returnM (DictLam new_dicts new_expr)
585 zonkExpr env (DictApp expr dicts)
586 = zonkExpr env expr `thenM` \ new_expr ->
587 returnM (DictApp new_expr (zonkIdOccs env dicts))
591 -------------------------------------------------------------------------
592 zonkArithSeq :: ZonkEnv -> TcArithSeqInfo -> TcM TypecheckedArithSeqInfo
594 zonkArithSeq env (From e)
595 = zonkExpr env e `thenM` \ new_e ->
598 zonkArithSeq env (FromThen e1 e2)
599 = zonkExpr env e1 `thenM` \ new_e1 ->
600 zonkExpr env e2 `thenM` \ new_e2 ->
601 returnM (FromThen new_e1 new_e2)
603 zonkArithSeq env (FromTo e1 e2)
604 = zonkExpr env e1 `thenM` \ new_e1 ->
605 zonkExpr env e2 `thenM` \ new_e2 ->
606 returnM (FromTo new_e1 new_e2)
608 zonkArithSeq env (FromThenTo e1 e2 e3)
609 = zonkExpr env e1 `thenM` \ new_e1 ->
610 zonkExpr env e2 `thenM` \ new_e2 ->
611 zonkExpr env e3 `thenM` \ new_e3 ->
612 returnM (FromThenTo new_e1 new_e2 new_e3)
615 -------------------------------------------------------------------------
616 zonkStmts :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt]
618 zonkStmts env [] = returnM []
620 zonkStmts env (ParStmtOut bndrstmtss : stmts)
621 = mappM (mappM zonkId) bndrss `thenM` \ new_bndrss ->
622 mappM (zonkStmts env) stmtss `thenM` \ new_stmtss ->
624 new_binders = concat new_bndrss
625 env1 = extendZonkEnv env new_binders
627 zonkStmts env1 stmts `thenM` \ new_stmts ->
628 returnM (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
630 (bndrss, stmtss) = unzip bndrstmtss
632 zonkStmts env (RecStmt vs segStmts : stmts)
633 = mappM zonkId vs `thenM` \ new_vs ->
635 env1 = extendZonkEnv env new_vs
637 zonkStmts env1 segStmts `thenM` \ new_segStmts ->
638 zonkStmts env1 stmts `thenM` \ new_stmts ->
639 returnM (RecStmt new_vs new_segStmts : new_stmts)
641 zonkStmts env (ResultStmt expr locn : stmts)
642 = zonkExpr env expr `thenM` \ new_expr ->
643 zonkStmts env stmts `thenM` \ new_stmts ->
644 returnM (ResultStmt new_expr locn : new_stmts)
646 zonkStmts env (ExprStmt expr ty locn : stmts)
647 = zonkExpr env expr `thenM` \ new_expr ->
648 zonkTcTypeToType env ty `thenM` \ new_ty ->
649 zonkStmts env stmts `thenM` \ new_stmts ->
650 returnM (ExprStmt new_expr new_ty locn : new_stmts)
652 zonkStmts env (LetStmt binds : stmts)
653 = zonkBinds env binds `thenM` \ (new_env, new_binds) ->
654 zonkStmts new_env stmts `thenM` \ new_stmts ->
655 returnM (LetStmt new_binds : new_stmts)
657 zonkStmts env (BindStmt pat expr locn : stmts)
658 = zonkExpr env expr `thenM` \ new_expr ->
659 zonkPat env pat `thenM` \ (new_pat, new_ids) ->
661 env1 = extendZonkEnv env (bagToList new_ids)
663 zonkStmts env1 stmts `thenM` \ new_stmts ->
664 returnM (BindStmt new_pat new_expr locn : new_stmts)
668 -------------------------------------------------------------------------
669 zonkRbinds :: ZonkEnv -> TcRecordBinds -> TcM TypecheckedRecordBinds
671 zonkRbinds env rbinds
672 = mappM zonk_rbind rbinds
674 zonk_rbind (field, expr)
675 = zonkExpr env expr `thenM` \ new_expr ->
676 returnM (zonkIdOcc env field, new_expr)
678 -------------------------------------------------------------------------
679 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
680 mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r)
681 mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r)
685 %************************************************************************
687 \subsection[BackSubst-Pats]{Patterns}
689 %************************************************************************
692 zonkPat :: ZonkEnv -> TcPat -> TcM (TypecheckedPat, Bag Id)
694 zonkPat env (ParPat p)
695 = zonkPat env p `thenM` \ (new_p, ids) ->
696 returnM (ParPat new_p, ids)
698 zonkPat env (WildPat ty)
699 = zonkTcTypeToType env ty `thenM` \ new_ty ->
700 returnM (WildPat new_ty, emptyBag)
702 zonkPat env (VarPat v)
703 = zonkIdBndr env v `thenM` \ new_v ->
704 returnM (VarPat new_v, unitBag new_v)
706 zonkPat env (LazyPat pat)
707 = zonkPat env pat `thenM` \ (new_pat, ids) ->
708 returnM (LazyPat new_pat, ids)
710 zonkPat env (AsPat n pat)
711 = zonkIdBndr env n `thenM` \ new_n ->
712 zonkPat env pat `thenM` \ (new_pat, ids) ->
713 returnM (AsPat new_n new_pat, new_n `consBag` ids)
715 zonkPat env (ListPat pats ty)
716 = zonkTcTypeToType env ty `thenM` \ new_ty ->
717 zonkPats env pats `thenM` \ (new_pats, ids) ->
718 returnM (ListPat new_pats new_ty, ids)
720 zonkPat env (PArrPat pats ty)
721 = zonkTcTypeToType env ty `thenM` \ new_ty ->
722 zonkPats env pats `thenM` \ (new_pats, ids) ->
723 returnM (PArrPat new_pats new_ty, ids)
725 zonkPat env (TuplePat pats boxed)
726 = zonkPats env pats `thenM` \ (new_pats, ids) ->
727 returnM (TuplePat new_pats boxed, ids)
729 zonkPat env (ConPatOut n stuff ty tvs dicts)
730 = zonkTcTypeToType env ty `thenM` \ new_ty ->
731 mappM zonkTcTyVarToTyVar tvs `thenM` \ new_tvs ->
732 zonkIdBndrs env dicts `thenM` \ new_dicts ->
734 env1 = extendZonkEnv env new_dicts
736 zonkConStuff env stuff `thenM` \ (new_stuff, ids) ->
737 returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts,
738 listToBag new_dicts `unionBags` ids)
740 zonkPat env (LitPat lit) = returnM (LitPat lit, emptyBag)
742 zonkPat env (SigPatOut pat ty expr)
743 = zonkPat env pat `thenM` \ (new_pat, ids) ->
744 zonkTcTypeToType env ty `thenM` \ new_ty ->
745 zonkExpr env expr `thenM` \ new_expr ->
746 returnM (SigPatOut new_pat new_ty new_expr, ids)
748 zonkPat env (NPatOut lit ty expr)
749 = zonkTcTypeToType env ty `thenM` \ new_ty ->
750 zonkExpr env expr `thenM` \ new_expr ->
751 returnM (NPatOut lit new_ty new_expr, emptyBag)
753 zonkPat env (NPlusKPatOut n k e1 e2)
754 = zonkIdBndr env n `thenM` \ new_n ->
755 zonkExpr env e1 `thenM` \ new_e1 ->
756 zonkExpr env e2 `thenM` \ new_e2 ->
757 returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag new_n)
759 zonkPat env (DictPat ds ms)
760 = zonkIdBndrs env ds `thenM` \ new_ds ->
761 zonkIdBndrs env ms `thenM` \ new_ms ->
762 returnM (DictPat new_ds new_ms,
763 listToBag new_ds `unionBags` listToBag new_ms)
765 ---------------------------
766 zonkConStuff env (PrefixCon pats)
767 = zonkPats env pats `thenM` \ (new_pats, ids) ->
768 returnM (PrefixCon new_pats, ids)
770 zonkConStuff env (InfixCon p1 p2)
771 = zonkPat env p1 `thenM` \ (new_p1, ids1) ->
772 zonkPat env p2 `thenM` \ (new_p2, ids2) ->
773 returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2)
775 zonkConStuff env (RecCon rpats)
776 = mapAndUnzipM zonk_rpat rpats `thenM` \ (new_rpats, ids_s) ->
777 returnM (RecCon new_rpats, unionManyBags ids_s)
780 = zonkPat env pat `thenM` \ (new_pat, ids) ->
781 returnM ((f, new_pat), ids)
783 ---------------------------
785 = returnM ([], emptyBag)
787 zonkPats env (pat:pats)
788 = zonkPat env pat `thenM` \ (pat', ids1) ->
789 zonkPats env pats `thenM` \ (pats', ids2) ->
790 returnM (pat':pats', ids1 `unionBags` ids2)
793 %************************************************************************
795 \subsection[BackSubst-Foreign]{Foreign exports}
797 %************************************************************************
801 zonkForeignExports :: ZonkEnv -> [TcForeignDecl] -> TcM [TypecheckedForeignDecl]
802 zonkForeignExports env ls = mappM (zonkForeignExport env) ls
804 zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl)
805 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) =
806 returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc)
810 zonkRules :: ZonkEnv -> [TcRuleDecl] -> TcM [TypecheckedRuleDecl]
811 zonkRules env rs = mappM (zonkRule env) rs
813 zonkRule env (HsRule name act vars lhs rhs loc)
814 = mappM zonk_bndr vars `thenM` \ new_bndrs ->
815 newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
817 env_rhs = extendZonkEnv env (filter isId new_bndrs)
818 -- Type variables don't need an envt
819 -- They are bound through the mutable mechanism
821 env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
822 -- We need to gather the type variables mentioned on the LHS so we can
823 -- quantify over them. Example:
829 -- {-# RULES "myrule" foo C = 1 #-}
831 -- After type checking the LHS becomes (foo a (C a))
832 -- and we do not want to zap the unbound tyvar 'a' to (), because
833 -- that limits the applicability of the rule. Instead, we
834 -- want to quantify over it!
836 -- It's easiest to find the free tyvars here. Attempts to do so earlier
837 -- are tiresome, because (a) the data type is big and (b) finding the
838 -- free type vars of an expression is necessarily monadic operation.
839 -- (consider /\a -> f @ b, where b is side-effected to a)
841 zonkExpr env_lhs lhs `thenM` \ new_lhs ->
842 zonkExpr env_rhs rhs `thenM` \ new_rhs ->
844 readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
846 final_bndrs = map RuleBndr (varSetElems unbound_tvs ++ new_bndrs)
847 -- I hate this map RuleBndr stuff
849 returnM (HsRule name act final_bndrs new_lhs new_rhs loc)
851 zonk_bndr (RuleBndr v)
852 | isId v = zonkIdBndr env v
853 | otherwise = zonkTcTyVarToTyVar v
855 zonkRule env (IfaceRuleOut fun rule)
856 = returnM (IfaceRuleOut (zonkIdOcc env fun) rule)
860 %************************************************************************
862 \subsection[BackSubst-Foreign]{Foreign exports}
864 %************************************************************************
867 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
868 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
870 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
871 -- This variant collects unbound type variables in a mutable variable
872 zonkTypeCollecting unbound_tv_set
873 = zonkType zonk_unbound_tyvar
875 zonk_unbound_tyvar tv
876 = zonkTcTyVarToTyVar tv `thenM` \ tv' ->
877 readMutVar unbound_tv_set `thenM` \ tv_set ->
878 writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
879 return (mkTyVarTy tv')
881 zonkTypeZapping :: TcType -> TcM Type
882 -- This variant is used for everything except the LHS of rules
883 -- It zaps unbound type variables to (), or some other arbitrary type
885 = zonkType zonk_unbound_tyvar ty
887 -- Zonk a mutable but unbound type variable to an arbitrary type
888 -- We know it's unbound even though we don't carry an environment,
889 -- because at the binding site for a type variable we bind the
890 -- mutable tyvar to a fresh immutable one. So the mutable store
891 -- plays the role of an environment. If we come across a mutable
892 -- type variable that isn't so bound, it must be completely free.
893 zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv)
896 -- When the type checker finds a type variable with no binding,
897 -- which means it can be instantiated with an arbitrary type, it
898 -- usually instantiates it to Void. Eg.
902 -- length Void (Nil Void)
904 -- But in really obscure programs, the type variable might have
905 -- a kind other than *, so we need to invent a suitably-kinded type.
909 -- List for kind *->*
910 -- Tuple for kind *->...*->*
912 -- which deals with most cases. (Previously, it only dealt with
915 -- In the other cases, it just makes up a TyCon with a suitable
916 -- kind. If this gets into an interface file, anyone reading that
917 -- file won't understand it. This is fixable (by making the client
918 -- of the interface file make up a TyCon too) but it is tiresome and
919 -- never happens, so I am leaving it
921 mkArbitraryType :: TcTyVar -> Type
922 -- Make up an arbitrary type whose kind is the same as the tyvar.
923 -- We'll use this to instantiate the (unbound) tyvar.
925 | isAnyTypeKind kind = voidTy -- The vastly common case
926 | otherwise = mkTyConApp tycon []
929 (args,res) = Type.splitFunTys kind -- Kinds are simple; use Type.splitFunTys
931 tycon | kind `eqKind` tyConKind listTyCon -- *->*
932 = listTyCon -- No tuples this size
934 | all isTypeKind args && isTypeKind res
935 = tupleTyCon Boxed (length args) -- *-> ... ->*->*
938 = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
939 mkPrimTyCon tc_name kind 0 [] VoidRep
940 -- Same name as the tyvar, apart from making it start with a colon (sigh)
941 -- I dread to think what will happen if this gets out into an
942 -- interface file. Catastrophe likely. Major sigh.
944 tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc