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,
31 Coercion, ExprCoFn, PatCoFn,
32 (<$>), (<.>), mkCoercion,
33 idCoercion, isIdCoercion,
35 -- re-exported from TcMonad
38 zonkTopBinds, zonkTopDecls, zonkTopExpr,
42 #include "HsVersions.h"
45 import HsSyn -- oodles of it
48 import Id ( idType, setIdType, Id )
49 import DataCon ( dataConWrapId )
53 import TcType ( TcType, TcTyVar, eqKind, isTypeKind, mkTyVarTy,
54 tcGetTyVar, isAnyTypeKind, mkTyConApp )
56 import TcMType ( zonkTcTyVarToTyVar, zonkType, zonkTcType, zonkTcTyVars,
58 import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
59 doublePrimTy, addrPrimTy
61 import TysWiredIn ( charTy, stringTy, intTy, integerTy,
62 mkListTy, mkPArrTy, mkTupleTy, unitTy,
63 voidTy, listTyCon, tupleTyCon )
64 import TyCon ( mkPrimTyCon, tyConKind )
65 import PrimRep ( PrimRep(VoidRep) )
66 import CoreSyn ( CoreExpr )
67 import Name ( Name, getOccName, mkInternalName, mkDerivedTyConOcc )
68 import Var ( isId, isLocalVar, tyVarKind )
71 import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName, mapIPName )
72 import Maybes ( orElse )
73 import Maybe ( isNothing )
74 import Unique ( Uniquable(..) )
75 import SrcLoc ( noSrcLoc )
84 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
85 All the types in @Tc...@ things have mutable type-variables in them for
88 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
89 which have immutable type variables in them.
92 type TcHsBinds = HsBinds TcId
93 type TcMonoBinds = MonoBinds TcId
94 type TcDictBinds = TcMonoBinds
95 type TcPat = OutPat TcId
96 type TcExpr = HsExpr TcId
97 type TcGRHSs = GRHSs TcId
98 type TcGRHS = GRHS TcId
99 type TcMatch = Match TcId
100 type TcStmt = Stmt TcId
101 type TcArithSeqInfo = ArithSeqInfo TcId
102 type TcRecordBinds = HsRecordBinds TcId
103 type TcHsModule = HsModule TcId
104 type TcForeignDecl = ForeignDecl TcId
105 type TcRuleDecl = RuleDecl TcId
107 type TypecheckedPat = OutPat Id
108 type TypecheckedMonoBinds = MonoBinds Id
109 type TypecheckedDictBinds = TypecheckedMonoBinds
110 type TypecheckedHsBinds = HsBinds Id
111 type TypecheckedHsExpr = HsExpr Id
112 type TypecheckedArithSeqInfo = ArithSeqInfo Id
113 type TypecheckedStmt = Stmt Id
114 type TypecheckedMatch = Match Id
115 type TypecheckedGRHSs = GRHSs Id
116 type TypecheckedGRHS = GRHS Id
117 type TypecheckedRecordBinds = HsRecordBinds Id
118 type TypecheckedHsModule = HsModule Id
119 type TypecheckedForeignDecl = ForeignDecl Id
120 type TypecheckedRuleDecl = RuleDecl Id
121 type TypecheckedCoreBind = (Id, CoreExpr)
123 type TypecheckedMatchContext = HsMatchContext Name -- Keeps consistency with
124 -- HsDo arg StmtContext
128 mkHsTyApp expr [] = expr
129 mkHsTyApp expr tys = TyApp expr tys
131 mkHsDictApp expr [] = expr
132 mkHsDictApp expr dict_vars = DictApp expr dict_vars
134 mkHsTyLam [] expr = expr
135 mkHsTyLam tyvars expr = TyLam tyvars expr
137 mkHsDictLam [] expr = expr
138 mkHsDictLam dicts expr = DictLam dicts expr
140 mkHsLet EmptyMonoBinds expr = expr
141 mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr
143 mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
147 %************************************************************************
149 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
151 %************************************************************************
153 Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@,
154 then something is wrong.
156 hsPatType :: TypecheckedPat -> Type
158 hsPatType (ParPat pat) = hsPatType pat
159 hsPatType (WildPat ty) = ty
160 hsPatType (VarPat var) = idType var
161 hsPatType (LazyPat pat) = hsPatType pat
162 hsPatType (LitPat lit) = hsLitType lit
163 hsPatType (AsPat var pat) = idType var
164 hsPatType (ListPat _ ty) = mkListTy ty
165 hsPatType (PArrPat _ ty) = mkPArrTy ty
166 hsPatType (TuplePat pats box) = mkTupleTy box (length pats) (map hsPatType pats)
167 hsPatType (ConPatOut _ _ ty _ _) = ty
168 hsPatType (SigPatOut _ ty _) = ty
169 hsPatType (NPatOut lit ty _) = ty
170 hsPatType (NPlusKPatOut id _ _ _) = idType id
171 hsPatType (DictPat ds ms) = case (ds ++ ms) of
174 ds -> mkTupleTy Boxed (length ds) (map idType ds)
177 hsLitType :: HsLit -> TcType
178 hsLitType (HsChar c) = charTy
179 hsLitType (HsCharPrim c) = charPrimTy
180 hsLitType (HsString str) = stringTy
181 hsLitType (HsStringPrim s) = addrPrimTy
182 hsLitType (HsInt i) = intTy
183 hsLitType (HsIntPrim i) = intPrimTy
184 hsLitType (HsInteger i) = integerTy
185 hsLitType (HsRat _ ty) = ty
186 hsLitType (HsFloatPrim f) = floatPrimTy
187 hsLitType (HsDoublePrim d) = doublePrimTy
188 hsLitType (HsLitLit _ ty) = ty
191 %************************************************************************
193 \subsection{Coercion functions}
195 %************************************************************************
198 type Coercion a = Maybe (a -> a)
199 -- Nothing => identity fn
201 type ExprCoFn = Coercion TypecheckedHsExpr
202 type PatCoFn = Coercion TcPat
204 (<.>) :: Coercion a -> Coercion a -> Coercion a -- Composition
205 Nothing <.> Nothing = Nothing
206 Nothing <.> Just f = Just f
207 Just f <.> Nothing = Just f
208 Just f1 <.> Just f2 = Just (f1 . f2)
210 (<$>) :: Coercion a -> a -> a
214 mkCoercion :: (a -> a) -> Coercion a
215 mkCoercion f = Just f
217 idCoercion :: Coercion a
220 isIdCoercion :: Coercion a -> Bool
221 isIdCoercion = isNothing
225 %************************************************************************
227 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
229 %************************************************************************
232 -- zonkId is used *during* typechecking just to zonk the Id's type
233 zonkId :: TcId -> TcM TcId
235 = zonkTcType (idType id) `thenM` \ ty' ->
236 returnM (setIdType id ty')
239 The rest of the zonking is done *after* typechecking.
240 The main zonking pass runs over the bindings
242 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
243 b) convert unbound TcTyVar to Void
244 c) convert each TcId to an Id by zonking its type
246 The type variables are converted by binding mutable tyvars to immutable ones
247 and then zonking as normal.
249 The Ids are converted by binding them in the normal Tc envt; that
250 way we maintain sharing; eg an Id is zonked at its binding site and they
251 all occurrences of that Id point to the common zonked copy
253 It's all pretty boring stuff, because HsSyn is such a large type, and
254 the environment manipulation is tiresome.
257 data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type
258 (IdEnv Id) -- What variables are in scope
259 -- Maps an Id to its zonked version; both have the same Name
260 -- Is only consulted lazily; hence knot-tying
262 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
264 extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
265 extendZonkEnv (ZonkEnv zonk_ty env) ids
266 = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
268 setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
269 setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
271 mkZonkEnv :: [Id] -> ZonkEnv
272 mkZonkEnv ids = extendZonkEnv emptyZonkEnv ids
274 zonkIdOcc :: ZonkEnv -> TcId -> Id
275 -- Ids defined in this module should be in the envt;
276 -- ignore others. (Actually, data constructors are also
277 -- not LocalVars, even when locally defined, but that is fine.)
279 -- Actually, Template Haskell works in 'chunks' of declarations, and
280 -- an earlier chunk won't be in the 'env' that the zonking phase
281 -- carries around. Instead it'll be in the tcg_gbl_env, already fully
282 -- zonked. There's no point in looking it up there (except for error
283 -- checking), and it's not conveniently to hand; hence the simple
284 -- 'orElse' case in the LocalVar branch.
286 -- Even without template splices, in module Main, the checking of
287 -- 'main' is done as a separte chunk.
288 zonkIdOcc (ZonkEnv zonk_ty env) id
289 | isLocalVar id = lookupVarEnv env id `orElse` id
292 zonkIdOccs env ids = map (zonkIdOcc env) ids
294 -- zonkIdBndr is used *after* typechecking to get the Id's type
295 -- to its final form. The TyVarEnv give
296 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
298 = zonkTcTypeToType env (idType id) `thenM` \ ty' ->
299 returnM (setIdType id ty')
301 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
302 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
304 zonkTopBndrs :: [TcId] -> TcM [Id]
305 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
310 zonkTopExpr :: TcExpr -> TcM TypecheckedHsExpr
311 zonkTopExpr e = zonkExpr emptyZonkEnv e
313 zonkTopDecls :: TcMonoBinds -> [TcRuleDecl] -> [TcForeignDecl]
315 TypecheckedMonoBinds,
316 [TypecheckedForeignDecl],
317 [TypecheckedRuleDecl])
318 zonkTopDecls binds rules fords -- Top level is implicitly recursive
319 = fixM (\ ~(new_ids, _, _, _) ->
321 zonk_env = mkZonkEnv new_ids
323 zonkMonoBinds zonk_env binds `thenM` \ (binds', new_ids) ->
324 zonkRules zonk_env rules `thenM` \ rules' ->
325 zonkForeignExports zonk_env fords `thenM` \ fords' ->
327 returnM (bagToList new_ids, binds', fords', rules')
330 zonkTopBinds :: TcMonoBinds -> TcM ([Id], TypecheckedMonoBinds)
332 = fixM (\ ~(new_ids, _) ->
334 zonk_env = mkZonkEnv new_ids
336 zonkMonoBinds zonk_env binds `thenM` \ (binds', new_ids) ->
337 returnM (bagToList new_ids, binds')
340 ---------------------------------------------
341 zonkBinds :: ZonkEnv -> TcHsBinds -> TcM (ZonkEnv, TypecheckedHsBinds)
342 zonkBinds env EmptyBinds = returnM (env, EmptyBinds)
344 zonkBinds env (ThenBinds b1 b2)
345 = zonkBinds env b1 `thenM` \ (env1, b1') ->
346 zonkBinds env1 b2 `thenM` \ (env2, b2') ->
347 returnM (env2, b1' `ThenBinds` b2')
349 zonkBinds env (MonoBind bind sigs is_rec)
350 = ASSERT( null sigs )
351 fixM (\ ~(_, _, new_ids) ->
353 env1 = extendZonkEnv env (bagToList new_ids)
355 zonkMonoBinds env1 bind `thenM` \ (new_bind, new_ids) ->
356 returnM (env1, new_bind, new_ids)
357 ) `thenM` \ (env1, new_bind, _) ->
358 returnM (env1, mkMonoBind is_rec new_bind)
360 zonkBinds env (IPBinds binds is_with)
361 = mappM zonk_ip_bind binds `thenM` \ new_binds ->
363 env1 = extendZonkEnv env (map (ipNameName . fst) new_binds)
365 returnM (env1, IPBinds new_binds is_with)
368 = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
369 zonkExpr env e `thenM` \ e' ->
373 ---------------------------------------------
374 zonkMonoBinds :: ZonkEnv -> TcMonoBinds
375 -> TcM (TypecheckedMonoBinds, Bag Id)
377 zonkMonoBinds env EmptyMonoBinds = returnM (EmptyMonoBinds, emptyBag)
379 zonkMonoBinds env (AndMonoBinds mbinds1 mbinds2)
380 = zonkMonoBinds env mbinds1 `thenM` \ (b1', ids1) ->
381 zonkMonoBinds env mbinds2 `thenM` \ (b2', ids2) ->
382 returnM (b1' `AndMonoBinds` b2',
383 ids1 `unionBags` ids2)
385 zonkMonoBinds env (PatMonoBind pat grhss locn)
386 = zonkPat env pat `thenM` \ (new_pat, ids) ->
387 zonkGRHSs env grhss `thenM` \ new_grhss ->
388 returnM (PatMonoBind new_pat new_grhss locn, ids)
390 zonkMonoBinds env (VarMonoBind var expr)
391 = zonkIdBndr env var `thenM` \ new_var ->
392 zonkExpr env expr `thenM` \ new_expr ->
393 returnM (VarMonoBind new_var new_expr, unitBag new_var)
395 zonkMonoBinds env (FunMonoBind var inf ms locn)
396 = zonkIdBndr env var `thenM` \ new_var ->
397 mappM (zonkMatch env) ms `thenM` \ new_ms ->
398 returnM (FunMonoBind new_var inf new_ms locn, unitBag new_var)
401 zonkMonoBinds env (AbsBinds tyvars dicts exports inlines val_bind)
402 = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
403 -- No need to extend tyvar env: the effects are
404 -- propagated through binding the tyvars themselves
406 zonkIdBndrs env dicts `thenM` \ new_dicts ->
407 fixM (\ ~(_, _, val_bind_ids) ->
409 env1 = extendZonkEnv (extendZonkEnv env new_dicts)
410 (bagToList val_bind_ids)
412 zonkMonoBinds env1 val_bind `thenM` \ (new_val_bind, val_bind_ids) ->
413 mappM (zonkExport env1) exports `thenM` \ new_exports ->
414 returnM (new_val_bind, new_exports, val_bind_ids)
415 ) `thenM ` \ (new_val_bind, new_exports, _) ->
417 new_globals = listToBag [global | (_, global, local) <- new_exports]
419 returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
422 zonkExport env (tyvars, global, local)
423 = zonkTcTyVars tyvars `thenM` \ tys ->
425 new_tyvars = map (tcGetTyVar "zonkExport") tys
426 -- This isn't the binding occurrence of these tyvars
427 -- but they should *be* tyvars. Hence tcGetTyVar.
429 zonkIdBndr env global `thenM` \ new_global ->
430 returnM (new_tyvars, new_global, zonkIdOcc env local)
433 %************************************************************************
435 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
437 %************************************************************************
440 zonkMatch :: ZonkEnv -> TcMatch -> TcM TypecheckedMatch
442 zonkMatch env (Match pats _ grhss)
443 = zonkPats env pats `thenM` \ (new_pats, new_ids) ->
444 zonkGRHSs (extendZonkEnv env (bagToList new_ids)) grhss `thenM` \ new_grhss ->
445 returnM (Match new_pats Nothing new_grhss)
447 -------------------------------------------------------------------------
448 zonkGRHSs :: ZonkEnv -> TcGRHSs -> TcM TypecheckedGRHSs
450 zonkGRHSs env (GRHSs grhss binds ty)
451 = zonkBinds env binds `thenM` \ (new_env, new_binds) ->
453 zonk_grhs (GRHS guarded locn)
454 = zonkStmts new_env guarded `thenM` \ new_guarded ->
455 returnM (GRHS new_guarded locn)
457 mappM zonk_grhs grhss `thenM` \ new_grhss ->
458 zonkTcTypeToType env ty `thenM` \ new_ty ->
459 returnM (GRHSs new_grhss new_binds new_ty)
462 %************************************************************************
464 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
466 %************************************************************************
469 zonkExprs :: ZonkEnv -> [TcExpr] -> TcM [TypecheckedHsExpr]
470 zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr
472 zonkExprs env exprs = mappM (zonkExpr env) exprs
475 zonkExpr env (HsVar id)
476 = returnM (HsVar (zonkIdOcc env id))
478 zonkExpr env (HsIPVar id)
479 = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
481 zonkExpr env (HsLit (HsRat f ty))
482 = zonkTcTypeToType env ty `thenM` \ new_ty ->
483 returnM (HsLit (HsRat f new_ty))
485 zonkExpr env (HsLit (HsLitLit lit ty))
486 = zonkTcTypeToType env ty `thenM` \ new_ty ->
487 returnM (HsLit (HsLitLit lit new_ty))
489 zonkExpr env (HsLit lit)
490 = returnM (HsLit lit)
492 -- HsOverLit doesn't appear in typechecker output
494 zonkExpr env (HsLam match)
495 = zonkMatch env match `thenM` \ new_match ->
496 returnM (HsLam new_match)
498 zonkExpr env (HsApp e1 e2)
499 = zonkExpr env e1 `thenM` \ new_e1 ->
500 zonkExpr env e2 `thenM` \ new_e2 ->
501 returnM (HsApp new_e1 new_e2)
503 zonkExpr env (HsBracketOut body bs)
504 = mappM zonk_b bs `thenM` \ bs' ->
505 returnM (HsBracketOut body bs')
507 zonk_b (n,e) = zonkExpr env e `thenM` \ e' ->
510 zonkExpr env (HsReify r) = returnM (HsReify r) -- Nothing to zonk; only top
511 -- level things can be reified (for now)
512 zonkExpr env (HsSplice n e loc) = WARN( True, ppr e ) -- Should not happen
513 returnM (HsSplice n e loc)
515 zonkExpr env (OpApp e1 op fixity e2)
516 = zonkExpr env e1 `thenM` \ new_e1 ->
517 zonkExpr env op `thenM` \ new_op ->
518 zonkExpr env e2 `thenM` \ new_e2 ->
519 returnM (OpApp new_e1 new_op fixity new_e2)
521 zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp"
523 zonkExpr env (HsPar e)
524 = zonkExpr env e `thenM` \new_e ->
525 returnM (HsPar new_e)
527 zonkExpr env (SectionL expr op)
528 = zonkExpr env expr `thenM` \ new_expr ->
529 zonkExpr env op `thenM` \ new_op ->
530 returnM (SectionL new_expr new_op)
532 zonkExpr env (SectionR op expr)
533 = zonkExpr env op `thenM` \ new_op ->
534 zonkExpr env expr `thenM` \ new_expr ->
535 returnM (SectionR new_op new_expr)
537 zonkExpr env (HsCase expr ms src_loc)
538 = zonkExpr env expr `thenM` \ new_expr ->
539 mappM (zonkMatch env) ms `thenM` \ new_ms ->
540 returnM (HsCase new_expr new_ms src_loc)
542 zonkExpr env (HsIf e1 e2 e3 src_loc)
543 = zonkExpr env e1 `thenM` \ new_e1 ->
544 zonkExpr env e2 `thenM` \ new_e2 ->
545 zonkExpr env e3 `thenM` \ new_e3 ->
546 returnM (HsIf new_e1 new_e2 new_e3 src_loc)
548 zonkExpr env (HsLet binds expr)
549 = zonkBinds env binds `thenM` \ (new_env, new_binds) ->
550 zonkExpr new_env expr `thenM` \ new_expr ->
551 returnM (HsLet new_binds new_expr)
553 zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
554 = zonkStmts env stmts `thenM` \ new_stmts ->
555 zonkTcTypeToType env ty `thenM` \ new_ty ->
556 returnM (HsDo do_or_lc new_stmts
560 zonkExpr env (ExplicitList ty exprs)
561 = zonkTcTypeToType env ty `thenM` \ new_ty ->
562 zonkExprs env exprs `thenM` \ new_exprs ->
563 returnM (ExplicitList new_ty new_exprs)
565 zonkExpr env (ExplicitPArr ty exprs)
566 = zonkTcTypeToType env ty `thenM` \ new_ty ->
567 zonkExprs env exprs `thenM` \ new_exprs ->
568 returnM (ExplicitPArr new_ty new_exprs)
570 zonkExpr env (ExplicitTuple exprs boxed)
571 = zonkExprs env exprs `thenM` \ new_exprs ->
572 returnM (ExplicitTuple new_exprs boxed)
574 zonkExpr env (RecordConOut data_con con_expr rbinds)
575 = zonkExpr env con_expr `thenM` \ new_con_expr ->
576 zonkRbinds env rbinds `thenM` \ new_rbinds ->
577 returnM (RecordConOut data_con new_con_expr new_rbinds)
579 zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"
581 zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
582 = zonkExpr env expr `thenM` \ new_expr ->
583 zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
584 zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
585 zonkRbinds env rbinds `thenM` \ new_rbinds ->
586 returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
588 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
589 zonkExpr env (ArithSeqIn _) = panic "zonkExpr env:ArithSeqIn"
590 zonkExpr env (PArrSeqIn _) = panic "zonkExpr env:PArrSeqIn"
592 zonkExpr env (ArithSeqOut expr info)
593 = zonkExpr env expr `thenM` \ new_expr ->
594 zonkArithSeq env info `thenM` \ new_info ->
595 returnM (ArithSeqOut new_expr new_info)
597 zonkExpr env (PArrSeqOut expr info)
598 = zonkExpr env expr `thenM` \ new_expr ->
599 zonkArithSeq env info `thenM` \ new_info ->
600 returnM (PArrSeqOut new_expr new_info)
602 zonkExpr env (HsCCall fun args may_gc is_casm result_ty)
603 = zonkExprs env args `thenM` \ new_args ->
604 zonkTcTypeToType env result_ty `thenM` \ new_result_ty ->
605 returnM (HsCCall fun new_args may_gc is_casm new_result_ty)
607 zonkExpr env (HsSCC lbl expr)
608 = zonkExpr env expr `thenM` \ new_expr ->
609 returnM (HsSCC lbl new_expr)
611 -- hdaume: core annotations
612 zonkExpr env (HsCoreAnn lbl expr)
613 = zonkExpr env expr `thenM` \ new_expr ->
614 returnM (HsCoreAnn lbl new_expr)
616 zonkExpr env (TyLam tyvars expr)
617 = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
618 -- No need to extend tyvar env; see AbsBinds
620 zonkExpr env expr `thenM` \ new_expr ->
621 returnM (TyLam new_tyvars new_expr)
623 zonkExpr env (TyApp expr tys)
624 = zonkExpr env expr `thenM` \ new_expr ->
625 mappM (zonkTcTypeToType env) tys `thenM` \ new_tys ->
626 returnM (TyApp new_expr new_tys)
628 zonkExpr env (DictLam dicts expr)
629 = zonkIdBndrs env dicts `thenM` \ new_dicts ->
631 env1 = extendZonkEnv env new_dicts
633 zonkExpr env1 expr `thenM` \ new_expr ->
634 returnM (DictLam new_dicts new_expr)
636 zonkExpr env (DictApp expr dicts)
637 = zonkExpr env expr `thenM` \ new_expr ->
638 returnM (DictApp new_expr (zonkIdOccs env dicts))
642 -------------------------------------------------------------------------
643 zonkArithSeq :: ZonkEnv -> TcArithSeqInfo -> TcM TypecheckedArithSeqInfo
645 zonkArithSeq env (From e)
646 = zonkExpr env e `thenM` \ new_e ->
649 zonkArithSeq env (FromThen e1 e2)
650 = zonkExpr env e1 `thenM` \ new_e1 ->
651 zonkExpr env e2 `thenM` \ new_e2 ->
652 returnM (FromThen new_e1 new_e2)
654 zonkArithSeq env (FromTo e1 e2)
655 = zonkExpr env e1 `thenM` \ new_e1 ->
656 zonkExpr env e2 `thenM` \ new_e2 ->
657 returnM (FromTo new_e1 new_e2)
659 zonkArithSeq env (FromThenTo e1 e2 e3)
660 = zonkExpr env e1 `thenM` \ new_e1 ->
661 zonkExpr env e2 `thenM` \ new_e2 ->
662 zonkExpr env e3 `thenM` \ new_e3 ->
663 returnM (FromThenTo new_e1 new_e2 new_e3)
666 -------------------------------------------------------------------------
667 zonkStmts :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt]
669 zonkStmts env stmts = zonk_stmts env stmts `thenM` \ (_, stmts) ->
672 zonk_stmts :: ZonkEnv -> [TcStmt] -> TcM (ZonkEnv, [TypecheckedStmt])
674 zonk_stmts env [] = returnM (env, [])
676 zonk_stmts env (ParStmtOut bndrstmtss : stmts)
677 = mappM (mappM zonkId) bndrss `thenM` \ new_bndrss ->
678 mappM (zonkStmts env) stmtss `thenM` \ new_stmtss ->
680 new_binders = concat new_bndrss
681 env1 = extendZonkEnv env new_binders
683 zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
684 returnM (env2, ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
686 (bndrss, stmtss) = unzip bndrstmtss
688 zonk_stmts env (RecStmt vs segStmts rets : stmts)
689 = mappM zonkId vs `thenM` \ new_vs ->
691 env1 = extendZonkEnv env new_vs
693 zonk_stmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
694 -- Zonk the ret-expressions in an envt that
695 -- has the polymorphic bindings in the envt
696 zonkExprs env2 rets `thenM` \ new_rets ->
697 zonk_stmts env1 stmts `thenM` \ (env3, new_stmts) ->
698 returnM (env3, RecStmt new_vs new_segStmts new_rets : new_stmts)
700 zonk_stmts env (ResultStmt expr locn : stmts)
701 = ASSERT( null stmts )
702 zonkExpr env expr `thenM` \ new_expr ->
703 returnM (env, [ResultStmt new_expr locn])
705 zonk_stmts env (ExprStmt expr ty locn : stmts)
706 = zonkExpr env expr `thenM` \ new_expr ->
707 zonkTcTypeToType env ty `thenM` \ new_ty ->
708 zonk_stmts env stmts `thenM` \ (env1, new_stmts) ->
709 returnM (env1, ExprStmt new_expr new_ty locn : new_stmts)
711 zonk_stmts env (LetStmt binds : stmts)
712 = zonkBinds env binds `thenM` \ (env1, new_binds) ->
713 zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
714 returnM (env2, LetStmt new_binds : new_stmts)
716 zonk_stmts env (BindStmt pat expr locn : stmts)
717 = zonkExpr env expr `thenM` \ new_expr ->
718 zonkPat env pat `thenM` \ (new_pat, new_ids) ->
720 env1 = extendZonkEnv env (bagToList new_ids)
722 zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
723 returnM (env2, BindStmt new_pat new_expr locn : new_stmts)
727 -------------------------------------------------------------------------
728 zonkRbinds :: ZonkEnv -> TcRecordBinds -> TcM TypecheckedRecordBinds
730 zonkRbinds env rbinds
731 = mappM zonk_rbind rbinds
733 zonk_rbind (field, expr)
734 = zonkExpr env expr `thenM` \ new_expr ->
735 returnM (zonkIdOcc env field, new_expr)
737 -------------------------------------------------------------------------
738 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
739 mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r)
740 mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r)
744 %************************************************************************
746 \subsection[BackSubst-Pats]{Patterns}
748 %************************************************************************
751 zonkPat :: ZonkEnv -> TcPat -> TcM (TypecheckedPat, Bag Id)
753 zonkPat env (ParPat p)
754 = zonkPat env p `thenM` \ (new_p, ids) ->
755 returnM (ParPat new_p, ids)
757 zonkPat env (WildPat ty)
758 = zonkTcTypeToType env ty `thenM` \ new_ty ->
759 returnM (WildPat new_ty, emptyBag)
761 zonkPat env (VarPat v)
762 = zonkIdBndr env v `thenM` \ new_v ->
763 returnM (VarPat new_v, unitBag new_v)
765 zonkPat env (LazyPat pat)
766 = zonkPat env pat `thenM` \ (new_pat, ids) ->
767 returnM (LazyPat new_pat, ids)
769 zonkPat env (AsPat n pat)
770 = zonkIdBndr env n `thenM` \ new_n ->
771 zonkPat env pat `thenM` \ (new_pat, ids) ->
772 returnM (AsPat new_n new_pat, new_n `consBag` ids)
774 zonkPat env (ListPat pats ty)
775 = zonkTcTypeToType env ty `thenM` \ new_ty ->
776 zonkPats env pats `thenM` \ (new_pats, ids) ->
777 returnM (ListPat new_pats new_ty, ids)
779 zonkPat env (PArrPat pats ty)
780 = zonkTcTypeToType env ty `thenM` \ new_ty ->
781 zonkPats env pats `thenM` \ (new_pats, ids) ->
782 returnM (PArrPat new_pats new_ty, ids)
784 zonkPat env (TuplePat pats boxed)
785 = zonkPats env pats `thenM` \ (new_pats, ids) ->
786 returnM (TuplePat new_pats boxed, ids)
788 zonkPat env (ConPatOut n stuff ty tvs dicts)
789 = zonkTcTypeToType env ty `thenM` \ new_ty ->
790 mappM zonkTcTyVarToTyVar tvs `thenM` \ new_tvs ->
791 zonkIdBndrs env dicts `thenM` \ new_dicts ->
793 env1 = extendZonkEnv env new_dicts
795 zonkConStuff env stuff `thenM` \ (new_stuff, ids) ->
796 returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts,
797 listToBag new_dicts `unionBags` ids)
799 zonkPat env (LitPat lit) = returnM (LitPat lit, emptyBag)
801 zonkPat env (SigPatOut pat ty expr)
802 = zonkPat env pat `thenM` \ (new_pat, ids) ->
803 zonkTcTypeToType env ty `thenM` \ new_ty ->
804 zonkExpr env expr `thenM` \ new_expr ->
805 returnM (SigPatOut new_pat new_ty new_expr, ids)
807 zonkPat env (NPatOut lit ty expr)
808 = zonkTcTypeToType env ty `thenM` \ new_ty ->
809 zonkExpr env expr `thenM` \ new_expr ->
810 returnM (NPatOut lit new_ty new_expr, emptyBag)
812 zonkPat env (NPlusKPatOut n k e1 e2)
813 = zonkIdBndr env n `thenM` \ new_n ->
814 zonkExpr env e1 `thenM` \ new_e1 ->
815 zonkExpr env e2 `thenM` \ new_e2 ->
816 returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag new_n)
818 zonkPat env (DictPat ds ms)
819 = zonkIdBndrs env ds `thenM` \ new_ds ->
820 zonkIdBndrs env ms `thenM` \ new_ms ->
821 returnM (DictPat new_ds new_ms,
822 listToBag new_ds `unionBags` listToBag new_ms)
824 ---------------------------
825 zonkConStuff env (PrefixCon pats)
826 = zonkPats env pats `thenM` \ (new_pats, ids) ->
827 returnM (PrefixCon new_pats, ids)
829 zonkConStuff env (InfixCon p1 p2)
830 = zonkPat env p1 `thenM` \ (new_p1, ids1) ->
831 zonkPat env p2 `thenM` \ (new_p2, ids2) ->
832 returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2)
834 zonkConStuff env (RecCon rpats)
835 = mapAndUnzipM zonk_rpat rpats `thenM` \ (new_rpats, ids_s) ->
836 returnM (RecCon new_rpats, unionManyBags ids_s)
839 = zonkPat env pat `thenM` \ (new_pat, ids) ->
840 returnM ((f, new_pat), ids)
842 ---------------------------
844 = returnM ([], emptyBag)
846 zonkPats env (pat:pats)
847 = zonkPat env pat `thenM` \ (pat', ids1) ->
848 zonkPats env pats `thenM` \ (pats', ids2) ->
849 returnM (pat':pats', ids1 `unionBags` ids2)
852 %************************************************************************
854 \subsection[BackSubst-Foreign]{Foreign exports}
856 %************************************************************************
860 zonkForeignExports :: ZonkEnv -> [TcForeignDecl] -> TcM [TypecheckedForeignDecl]
861 zonkForeignExports env ls = mappM (zonkForeignExport env) ls
863 zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl)
864 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) =
865 returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc)
866 zonkForeignExport env for_imp
867 = returnM for_imp -- Foreign imports don't need zonking
871 zonkRules :: ZonkEnv -> [TcRuleDecl] -> TcM [TypecheckedRuleDecl]
872 zonkRules env rs = mappM (zonkRule env) rs
874 zonkRule env (HsRule name act vars lhs rhs loc)
875 = mappM zonk_bndr vars `thenM` \ new_bndrs ->
876 newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
878 env_rhs = extendZonkEnv env (filter isId new_bndrs)
879 -- Type variables don't need an envt
880 -- They are bound through the mutable mechanism
882 env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
883 -- We need to gather the type variables mentioned on the LHS so we can
884 -- quantify over them. Example:
890 -- {-# RULES "myrule" foo C = 1 #-}
892 -- After type checking the LHS becomes (foo a (C a))
893 -- and we do not want to zap the unbound tyvar 'a' to (), because
894 -- that limits the applicability of the rule. Instead, we
895 -- want to quantify over it!
897 -- It's easiest to find the free tyvars here. Attempts to do so earlier
898 -- are tiresome, because (a) the data type is big and (b) finding the
899 -- free type vars of an expression is necessarily monadic operation.
900 -- (consider /\a -> f @ b, where b is side-effected to a)
902 zonkExpr env_lhs lhs `thenM` \ new_lhs ->
903 zonkExpr env_rhs rhs `thenM` \ new_rhs ->
905 readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
907 final_bndrs = map RuleBndr (varSetElems unbound_tvs ++ new_bndrs)
908 -- I hate this map RuleBndr stuff
910 returnM (HsRule name act final_bndrs new_lhs new_rhs loc)
912 zonk_bndr (RuleBndr v)
913 | isId v = zonkIdBndr env v
914 | otherwise = zonkTcTyVarToTyVar v
916 zonkRule env (IfaceRuleOut fun rule)
917 = returnM (IfaceRuleOut (zonkIdOcc env fun) rule)
921 %************************************************************************
923 \subsection[BackSubst-Foreign]{Foreign exports}
925 %************************************************************************
928 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
929 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
931 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
932 -- This variant collects unbound type variables in a mutable variable
933 zonkTypeCollecting unbound_tv_set
934 = zonkType zonk_unbound_tyvar
936 zonk_unbound_tyvar tv
937 = zonkTcTyVarToTyVar tv `thenM` \ tv' ->
938 readMutVar unbound_tv_set `thenM` \ tv_set ->
939 writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
940 return (mkTyVarTy tv')
942 zonkTypeZapping :: TcType -> TcM Type
943 -- This variant is used for everything except the LHS of rules
944 -- It zaps unbound type variables to (), or some other arbitrary type
946 = zonkType zonk_unbound_tyvar ty
948 -- Zonk a mutable but unbound type variable to an arbitrary type
949 -- We know it's unbound even though we don't carry an environment,
950 -- because at the binding site for a type variable we bind the
951 -- mutable tyvar to a fresh immutable one. So the mutable store
952 -- plays the role of an environment. If we come across a mutable
953 -- type variable that isn't so bound, it must be completely free.
954 zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv)
957 -- When the type checker finds a type variable with no binding,
958 -- which means it can be instantiated with an arbitrary type, it
959 -- usually instantiates it to Void. Eg.
963 -- length Void (Nil Void)
965 -- But in really obscure programs, the type variable might have
966 -- a kind other than *, so we need to invent a suitably-kinded type.
970 -- List for kind *->*
971 -- Tuple for kind *->...*->*
973 -- which deals with most cases. (Previously, it only dealt with
976 -- In the other cases, it just makes up a TyCon with a suitable
977 -- kind. If this gets into an interface file, anyone reading that
978 -- file won't understand it. This is fixable (by making the client
979 -- of the interface file make up a TyCon too) but it is tiresome and
980 -- never happens, so I am leaving it
982 mkArbitraryType :: TcTyVar -> Type
983 -- Make up an arbitrary type whose kind is the same as the tyvar.
984 -- We'll use this to instantiate the (unbound) tyvar.
986 | isAnyTypeKind kind = voidTy -- The vastly common case
987 | otherwise = mkTyConApp tycon []
990 (args,res) = Type.splitFunTys kind -- Kinds are simple; use Type.splitFunTys
992 tycon | kind `eqKind` tyConKind listTyCon -- *->*
993 = listTyCon -- No tuples this size
995 | all isTypeKind args && isTypeKind res
996 = tupleTyCon Boxed (length args) -- *-> ... ->*->*
999 = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
1000 mkPrimTyCon tc_name kind 0 [] VoidRep
1001 -- Same name as the tyvar, apart from making it start with a colon (sigh)
1002 -- I dread to think what will happen if this gets out into an
1003 -- interface file. Catastrophe likely. Major sigh.
1005 tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc