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,
18 TypecheckedHsBinds, TypecheckedRuleDecl,
19 TypecheckedMonoBinds, TypecheckedPat,
20 TypecheckedHsExpr, TypecheckedArithSeqInfo,
21 TypecheckedStmt, TypecheckedForeignDecl,
22 TypecheckedMatch, TypecheckedHsModule,
23 TypecheckedGRHSs, TypecheckedGRHS,
24 TypecheckedRecordBinds, TypecheckedDictBinds,
25 TypecheckedMatchContext, TypecheckedCoreBind,
26 TypecheckedHsCmd, TypecheckedHsCmdTop,
28 mkHsTyApp, mkHsDictApp, mkHsConApp,
29 mkHsTyLam, mkHsDictLam, mkHsLet,
33 Coercion, ExprCoFn, PatCoFn,
34 (<$>), (<.>), mkCoercion,
35 idCoercion, isIdCoercion,
37 -- re-exported from TcMonad
40 zonkTopBinds, zonkTopDecls, zonkTopExpr,
44 #include "HsVersions.h"
47 import HsSyn -- oodles of it
50 import Id ( idType, setIdType, Id )
51 import DataCon ( dataConWrapId )
55 import TcType ( TcType, TcTyVar, eqKind, isTypeKind, mkTyVarTy,
56 tcGetTyVar, isAnyTypeKind, mkTyConApp )
58 import TcMType ( zonkTcTyVarToTyVar, zonkType, zonkTcType, zonkTcTyVars,
60 import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
61 doublePrimTy, addrPrimTy
63 import TysWiredIn ( charTy, stringTy, intTy,
64 mkListTy, mkPArrTy, mkTupleTy, unitTy,
65 voidTy, listTyCon, tupleTyCon )
66 import TyCon ( mkPrimTyCon, tyConKind )
67 import PrimRep ( PrimRep(VoidRep) )
68 import CoreSyn ( CoreExpr )
69 import Name ( Name, getOccName, mkInternalName, mkDerivedTyConOcc )
70 import Var ( isId, isLocalVar, tyVarKind )
73 import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName, mapIPName )
74 import Maybes ( orElse )
75 import Maybe ( isNothing )
76 import Unique ( Uniquable(..) )
77 import SrcLoc ( noSrcLoc )
86 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
87 All the types in @Tc...@ things have mutable type-variables in them for
90 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
91 which have immutable type variables in them.
94 type TcHsBinds = HsBinds TcId
95 type TcMonoBinds = MonoBinds TcId
96 type TcDictBinds = TcMonoBinds
97 type TcPat = OutPat TcId
98 type TcExpr = HsExpr TcId
99 type TcGRHSs = GRHSs TcId
100 type TcGRHS = GRHS TcId
101 type TcMatch = Match TcId
102 type TcStmt = Stmt TcId
103 type TcArithSeqInfo = ArithSeqInfo TcId
104 type TcRecordBinds = HsRecordBinds TcId
105 type TcHsModule = HsModule TcId
106 type TcForeignDecl = ForeignDecl TcId
107 type TcRuleDecl = RuleDecl TcId
108 type TcCmd = HsCmd TcId
109 type TcCmdTop = HsCmdTop TcId
111 type TypecheckedPat = OutPat Id
112 type TypecheckedMonoBinds = MonoBinds Id
113 type TypecheckedDictBinds = TypecheckedMonoBinds
114 type TypecheckedHsBinds = HsBinds Id
115 type TypecheckedHsExpr = HsExpr Id
116 type TypecheckedArithSeqInfo = ArithSeqInfo Id
117 type TypecheckedStmt = Stmt Id
118 type TypecheckedMatch = Match Id
119 type TypecheckedGRHSs = GRHSs Id
120 type TypecheckedGRHS = GRHS Id
121 type TypecheckedRecordBinds = HsRecordBinds Id
122 type TypecheckedHsModule = HsModule Id
123 type TypecheckedForeignDecl = ForeignDecl Id
124 type TypecheckedRuleDecl = RuleDecl Id
125 type TypecheckedCoreBind = (Id, CoreExpr)
126 type TypecheckedHsCmd = HsCmd Id
127 type TypecheckedHsCmdTop = HsCmdTop Id
129 type TypecheckedMatchContext = HsMatchContext Name -- Keeps consistency with
130 -- HsDo arg StmtContext
134 mkHsTyApp expr [] = expr
135 mkHsTyApp expr tys = TyApp expr tys
137 mkHsDictApp expr [] = expr
138 mkHsDictApp expr dict_vars = DictApp expr dict_vars
140 mkHsTyLam [] expr = expr
141 mkHsTyLam tyvars expr = TyLam tyvars expr
143 mkHsDictLam [] expr = expr
144 mkHsDictLam dicts expr = DictLam dicts expr
146 mkHsLet EmptyMonoBinds expr = expr
147 mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr
149 mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
153 %************************************************************************
155 \subsection[mkFailurePair]{Code for pattern-matching and other failures}
157 %************************************************************************
159 Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@,
160 then something is wrong.
162 hsPatType :: TypecheckedPat -> Type
164 hsPatType (ParPat pat) = hsPatType pat
165 hsPatType (WildPat ty) = ty
166 hsPatType (VarPat var) = idType var
167 hsPatType (LazyPat pat) = hsPatType pat
168 hsPatType (LitPat lit) = hsLitType lit
169 hsPatType (AsPat var pat) = idType var
170 hsPatType (ListPat _ ty) = mkListTy ty
171 hsPatType (PArrPat _ ty) = mkPArrTy ty
172 hsPatType (TuplePat pats box) = mkTupleTy box (length pats) (map hsPatType pats)
173 hsPatType (ConPatOut _ _ ty _ _) = ty
174 hsPatType (SigPatOut _ ty _) = ty
175 hsPatType (NPatOut lit ty _) = ty
176 hsPatType (NPlusKPatOut id _ _ _) = idType id
177 hsPatType (DictPat ds ms) = case (ds ++ ms) of
180 ds -> mkTupleTy Boxed (length ds) (map idType ds)
183 hsLitType :: HsLit -> TcType
184 hsLitType (HsChar c) = charTy
185 hsLitType (HsCharPrim c) = charPrimTy
186 hsLitType (HsString str) = stringTy
187 hsLitType (HsStringPrim s) = addrPrimTy
188 hsLitType (HsInt i) = intTy
189 hsLitType (HsIntPrim i) = intPrimTy
190 hsLitType (HsInteger i ty) = ty
191 hsLitType (HsRat _ ty) = ty
192 hsLitType (HsFloatPrim f) = floatPrimTy
193 hsLitType (HsDoublePrim d) = doublePrimTy
196 %************************************************************************
198 \subsection{Coercion functions}
200 %************************************************************************
203 type Coercion a = Maybe (a -> a)
204 -- Nothing => identity fn
206 type ExprCoFn = Coercion TypecheckedHsExpr
207 type PatCoFn = Coercion TcPat
209 (<.>) :: Coercion a -> Coercion a -> Coercion a -- Composition
210 Nothing <.> Nothing = Nothing
211 Nothing <.> Just f = Just f
212 Just f <.> Nothing = Just f
213 Just f1 <.> Just f2 = Just (f1 . f2)
215 (<$>) :: Coercion a -> a -> a
219 mkCoercion :: (a -> a) -> Coercion a
220 mkCoercion f = Just f
222 idCoercion :: Coercion a
225 isIdCoercion :: Coercion a -> Bool
226 isIdCoercion = isNothing
230 %************************************************************************
232 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
234 %************************************************************************
237 -- zonkId is used *during* typechecking just to zonk the Id's type
238 zonkId :: TcId -> TcM TcId
240 = zonkTcType (idType id) `thenM` \ ty' ->
241 returnM (setIdType id ty')
244 The rest of the zonking is done *after* typechecking.
245 The main zonking pass runs over the bindings
247 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
248 b) convert unbound TcTyVar to Void
249 c) convert each TcId to an Id by zonking its type
251 The type variables are converted by binding mutable tyvars to immutable ones
252 and then zonking as normal.
254 The Ids are converted by binding them in the normal Tc envt; that
255 way we maintain sharing; eg an Id is zonked at its binding site and they
256 all occurrences of that Id point to the common zonked copy
258 It's all pretty boring stuff, because HsSyn is such a large type, and
259 the environment manipulation is tiresome.
262 data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type
263 (IdEnv Id) -- What variables are in scope
264 -- Maps an Id to its zonked version; both have the same Name
265 -- Is only consulted lazily; hence knot-tying
267 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
269 extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
270 extendZonkEnv (ZonkEnv zonk_ty env) ids
271 = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
273 setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
274 setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
276 mkZonkEnv :: [Id] -> ZonkEnv
277 mkZonkEnv ids = extendZonkEnv emptyZonkEnv ids
279 zonkIdOcc :: ZonkEnv -> TcId -> Id
280 -- Ids defined in this module should be in the envt;
281 -- ignore others. (Actually, data constructors are also
282 -- not LocalVars, even when locally defined, but that is fine.)
284 -- Actually, Template Haskell works in 'chunks' of declarations, and
285 -- an earlier chunk won't be in the 'env' that the zonking phase
286 -- carries around. Instead it'll be in the tcg_gbl_env, already fully
287 -- zonked. There's no point in looking it up there (except for error
288 -- checking), and it's not conveniently to hand; hence the simple
289 -- 'orElse' case in the LocalVar branch.
291 -- Even without template splices, in module Main, the checking of
292 -- 'main' is done as a separte chunk.
293 zonkIdOcc (ZonkEnv zonk_ty env) id
294 | isLocalVar id = lookupVarEnv env id `orElse` id
297 zonkIdOccs env ids = map (zonkIdOcc env) ids
299 -- zonkIdBndr is used *after* typechecking to get the Id's type
300 -- to its final form. The TyVarEnv give
301 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
303 = zonkTcTypeToType env (idType id) `thenM` \ ty' ->
304 returnM (setIdType id ty')
306 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
307 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
309 zonkTopBndrs :: [TcId] -> TcM [Id]
310 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
315 zonkTopExpr :: TcExpr -> TcM TypecheckedHsExpr
316 zonkTopExpr e = zonkExpr emptyZonkEnv e
318 zonkTopDecls :: TcMonoBinds -> [TcRuleDecl] -> [TcForeignDecl]
320 TypecheckedMonoBinds,
321 [TypecheckedForeignDecl],
322 [TypecheckedRuleDecl])
323 zonkTopDecls binds rules fords -- Top level is implicitly recursive
324 = fixM (\ ~(new_ids, _, _, _) ->
326 zonk_env = mkZonkEnv new_ids
328 zonkMonoBinds zonk_env binds `thenM` \ (binds', new_ids) ->
329 zonkRules zonk_env rules `thenM` \ rules' ->
330 zonkForeignExports zonk_env fords `thenM` \ fords' ->
332 returnM (bagToList new_ids, binds', fords', rules')
335 zonkTopBinds :: TcMonoBinds -> TcM ([Id], TypecheckedMonoBinds)
337 = fixM (\ ~(new_ids, _) ->
339 zonk_env = mkZonkEnv new_ids
341 zonkMonoBinds zonk_env binds `thenM` \ (binds', new_ids) ->
342 returnM (bagToList new_ids, binds')
345 ---------------------------------------------
346 zonkBinds :: ZonkEnv -> TcHsBinds -> TcM (ZonkEnv, TypecheckedHsBinds)
347 zonkBinds env EmptyBinds = returnM (env, EmptyBinds)
349 zonkBinds env (ThenBinds b1 b2)
350 = zonkBinds env b1 `thenM` \ (env1, b1') ->
351 zonkBinds env1 b2 `thenM` \ (env2, b2') ->
352 returnM (env2, b1' `ThenBinds` b2')
354 zonkBinds env (MonoBind bind sigs is_rec)
355 = ASSERT( null sigs )
356 fixM (\ ~(_, _, new_ids) ->
358 env1 = extendZonkEnv env (bagToList new_ids)
360 zonkMonoBinds env1 bind `thenM` \ (new_bind, new_ids) ->
361 returnM (env1, new_bind, new_ids)
362 ) `thenM` \ (env1, new_bind, _) ->
363 returnM (env1, mkMonoBind is_rec new_bind)
365 zonkBinds env (IPBinds binds)
366 = mappM zonk_ip_bind binds `thenM` \ new_binds ->
368 env1 = extendZonkEnv env (map (ipNameName . fst) new_binds)
370 returnM (env1, IPBinds new_binds)
373 = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
374 zonkExpr env e `thenM` \ e' ->
378 ---------------------------------------------
379 zonkMonoBinds :: ZonkEnv -> TcMonoBinds
380 -> TcM (TypecheckedMonoBinds, Bag Id)
382 zonkMonoBinds env EmptyMonoBinds = returnM (EmptyMonoBinds, emptyBag)
384 zonkMonoBinds env (AndMonoBinds mbinds1 mbinds2)
385 = zonkMonoBinds env mbinds1 `thenM` \ (b1', ids1) ->
386 zonkMonoBinds env mbinds2 `thenM` \ (b2', ids2) ->
387 returnM (b1' `AndMonoBinds` b2',
388 ids1 `unionBags` ids2)
390 zonkMonoBinds env (PatMonoBind pat grhss locn)
391 = zonkPat env pat `thenM` \ (new_pat, ids) ->
392 zonkGRHSs env grhss `thenM` \ new_grhss ->
393 returnM (PatMonoBind new_pat new_grhss locn, ids)
395 zonkMonoBinds env (VarMonoBind var expr)
396 = zonkIdBndr env var `thenM` \ new_var ->
397 zonkExpr env expr `thenM` \ new_expr ->
398 returnM (VarMonoBind new_var new_expr, unitBag new_var)
400 zonkMonoBinds env (FunMonoBind var inf ms locn)
401 = zonkIdBndr env var `thenM` \ new_var ->
402 mappM (zonkMatch env) ms `thenM` \ new_ms ->
403 returnM (FunMonoBind new_var inf new_ms locn, unitBag new_var)
406 zonkMonoBinds env (AbsBinds tyvars dicts exports inlines val_bind)
407 = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
408 -- No need to extend tyvar env: the effects are
409 -- propagated through binding the tyvars themselves
411 zonkIdBndrs env dicts `thenM` \ new_dicts ->
412 fixM (\ ~(_, _, val_bind_ids) ->
414 env1 = extendZonkEnv (extendZonkEnv env new_dicts)
415 (bagToList val_bind_ids)
417 zonkMonoBinds env1 val_bind `thenM` \ (new_val_bind, val_bind_ids) ->
418 mappM (zonkExport env1) exports `thenM` \ new_exports ->
419 returnM (new_val_bind, new_exports, val_bind_ids)
420 ) `thenM ` \ (new_val_bind, new_exports, _) ->
422 new_globals = listToBag [global | (_, global, local) <- new_exports]
424 returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
427 zonkExport env (tyvars, global, local)
428 = zonkTcTyVars tyvars `thenM` \ tys ->
430 new_tyvars = map (tcGetTyVar "zonkExport") tys
431 -- This isn't the binding occurrence of these tyvars
432 -- but they should *be* tyvars. Hence tcGetTyVar.
434 zonkIdBndr env global `thenM` \ new_global ->
435 returnM (new_tyvars, new_global, zonkIdOcc env local)
438 %************************************************************************
440 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
442 %************************************************************************
445 zonkMatch :: ZonkEnv -> TcMatch -> TcM TypecheckedMatch
447 zonkMatch env (Match pats _ grhss)
448 = zonkPats env pats `thenM` \ (new_pats, new_ids) ->
449 zonkGRHSs (extendZonkEnv env (bagToList new_ids)) grhss `thenM` \ new_grhss ->
450 returnM (Match new_pats Nothing new_grhss)
452 -------------------------------------------------------------------------
453 zonkGRHSs :: ZonkEnv -> TcGRHSs -> TcM TypecheckedGRHSs
455 zonkGRHSs env (GRHSs grhss binds ty)
456 = zonkBinds env binds `thenM` \ (new_env, new_binds) ->
458 zonk_grhs (GRHS guarded locn)
459 = zonkStmts new_env guarded `thenM` \ new_guarded ->
460 returnM (GRHS new_guarded locn)
462 mappM zonk_grhs grhss `thenM` \ new_grhss ->
463 zonkTcTypeToType env ty `thenM` \ new_ty ->
464 returnM (GRHSs new_grhss new_binds new_ty)
467 %************************************************************************
469 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
471 %************************************************************************
474 zonkExprs :: ZonkEnv -> [TcExpr] -> TcM [TypecheckedHsExpr]
475 zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr
477 zonkExprs env exprs = mappM (zonkExpr env) exprs
480 zonkExpr env (HsVar id)
481 = returnM (HsVar (zonkIdOcc env id))
483 zonkExpr env (HsIPVar id)
484 = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
486 zonkExpr env (HsLit (HsRat f ty))
487 = zonkTcTypeToType env ty `thenM` \ new_ty ->
488 returnM (HsLit (HsRat f new_ty))
490 zonkExpr env (HsLit lit)
491 = returnM (HsLit lit)
493 -- HsOverLit doesn't appear in typechecker output
495 zonkExpr env (HsLam match)
496 = zonkMatch env match `thenM` \ new_match ->
497 returnM (HsLam new_match)
499 zonkExpr env (HsApp e1 e2)
500 = zonkExpr env e1 `thenM` \ new_e1 ->
501 zonkExpr env e2 `thenM` \ new_e2 ->
502 returnM (HsApp new_e1 new_e2)
504 zonkExpr env (HsBracketOut body bs)
505 = mappM zonk_b bs `thenM` \ bs' ->
506 returnM (HsBracketOut body bs')
508 zonk_b (n,e) = zonkExpr env e `thenM` \ e' ->
511 zonkExpr env (HsReify r) = returnM (HsReify r) -- Nothing to zonk; only top
512 -- level things can be reified (for now)
513 zonkExpr env (HsSplice n e loc) = WARN( True, ppr e ) -- Should not happen
514 returnM (HsSplice n e loc)
516 zonkExpr env (OpApp e1 op fixity e2)
517 = zonkExpr env e1 `thenM` \ new_e1 ->
518 zonkExpr env op `thenM` \ new_op ->
519 zonkExpr env e2 `thenM` \ new_e2 ->
520 returnM (OpApp new_e1 new_op fixity new_e2)
522 zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp"
524 zonkExpr env (HsPar e)
525 = zonkExpr env e `thenM` \new_e ->
526 returnM (HsPar new_e)
528 zonkExpr env (SectionL expr op)
529 = zonkExpr env expr `thenM` \ new_expr ->
530 zonkExpr env op `thenM` \ new_op ->
531 returnM (SectionL new_expr new_op)
533 zonkExpr env (SectionR op expr)
534 = zonkExpr env op `thenM` \ new_op ->
535 zonkExpr env expr `thenM` \ new_expr ->
536 returnM (SectionR new_op new_expr)
538 zonkExpr env (HsCase expr ms src_loc)
539 = zonkExpr env expr `thenM` \ new_expr ->
540 mappM (zonkMatch env) ms `thenM` \ new_ms ->
541 returnM (HsCase new_expr new_ms src_loc)
543 zonkExpr env (HsIf e1 e2 e3 src_loc)
544 = zonkExpr env e1 `thenM` \ new_e1 ->
545 zonkExpr env e2 `thenM` \ new_e2 ->
546 zonkExpr env e3 `thenM` \ new_e3 ->
547 returnM (HsIf new_e1 new_e2 new_e3 src_loc)
549 zonkExpr env (HsLet binds expr)
550 = zonkBinds env binds `thenM` \ (new_env, new_binds) ->
551 zonkExpr new_env expr `thenM` \ new_expr ->
552 returnM (HsLet new_binds new_expr)
554 zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
555 = zonkStmts env stmts `thenM` \ new_stmts ->
556 zonkTcTypeToType env ty `thenM` \ new_ty ->
557 zonkReboundNames env ids `thenM` \ new_ids ->
558 returnM (HsDo do_or_lc new_stmts new_ids
561 zonkExpr env (ExplicitList ty exprs)
562 = zonkTcTypeToType env ty `thenM` \ new_ty ->
563 zonkExprs env exprs `thenM` \ new_exprs ->
564 returnM (ExplicitList new_ty new_exprs)
566 zonkExpr env (ExplicitPArr ty exprs)
567 = zonkTcTypeToType env ty `thenM` \ new_ty ->
568 zonkExprs env exprs `thenM` \ new_exprs ->
569 returnM (ExplicitPArr new_ty new_exprs)
571 zonkExpr env (ExplicitTuple exprs boxed)
572 = zonkExprs env exprs `thenM` \ new_exprs ->
573 returnM (ExplicitTuple new_exprs boxed)
575 zonkExpr env (RecordConOut data_con con_expr rbinds)
576 = zonkExpr env con_expr `thenM` \ new_con_expr ->
577 zonkRbinds env rbinds `thenM` \ new_rbinds ->
578 returnM (RecordConOut data_con new_con_expr new_rbinds)
580 zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"
582 zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
583 = zonkExpr env expr `thenM` \ new_expr ->
584 zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
585 zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
586 zonkRbinds env rbinds `thenM` \ new_rbinds ->
587 returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
589 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
590 zonkExpr env (ArithSeqIn _) = panic "zonkExpr env:ArithSeqIn"
591 zonkExpr env (PArrSeqIn _) = panic "zonkExpr env:PArrSeqIn"
593 zonkExpr env (ArithSeqOut expr info)
594 = zonkExpr env expr `thenM` \ new_expr ->
595 zonkArithSeq env info `thenM` \ new_info ->
596 returnM (ArithSeqOut new_expr new_info)
598 zonkExpr env (PArrSeqOut expr info)
599 = zonkExpr env expr `thenM` \ new_expr ->
600 zonkArithSeq env info `thenM` \ new_info ->
601 returnM (PArrSeqOut new_expr new_info)
603 zonkExpr env (HsSCC lbl expr)
604 = zonkExpr env expr `thenM` \ new_expr ->
605 returnM (HsSCC lbl new_expr)
607 -- hdaume: core annotations
608 zonkExpr env (HsCoreAnn lbl expr)
609 = zonkExpr env expr `thenM` \ new_expr ->
610 returnM (HsCoreAnn lbl new_expr)
612 zonkExpr env (TyLam tyvars expr)
613 = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
614 -- No need to extend tyvar env; see AbsBinds
616 zonkExpr env expr `thenM` \ new_expr ->
617 returnM (TyLam new_tyvars new_expr)
619 zonkExpr env (TyApp expr tys)
620 = zonkExpr env expr `thenM` \ new_expr ->
621 mappM (zonkTcTypeToType env) tys `thenM` \ new_tys ->
622 returnM (TyApp new_expr new_tys)
624 zonkExpr env (DictLam dicts expr)
625 = zonkIdBndrs env dicts `thenM` \ new_dicts ->
627 env1 = extendZonkEnv env new_dicts
629 zonkExpr env1 expr `thenM` \ new_expr ->
630 returnM (DictLam new_dicts new_expr)
632 zonkExpr env (DictApp expr dicts)
633 = zonkExpr env expr `thenM` \ new_expr ->
634 returnM (DictApp new_expr (zonkIdOccs env dicts))
636 -- arrow notation extensions
637 zonkExpr env (HsProc pat body src_loc)
638 = zonkPat env pat `thenM` \ (new_pat, new_ids) ->
640 env1 = extendZonkEnv env (bagToList new_ids)
642 zonkCmdTop env1 body `thenM` \ new_body ->
643 returnM (HsProc new_pat new_body src_loc)
645 zonkExpr env (HsArrApp e1 e2 ty ho rl src_loc)
646 = zonkExpr env e1 `thenM` \ new_e1 ->
647 zonkExpr env e2 `thenM` \ new_e2 ->
648 zonkTcTypeToType env ty `thenM` \ new_ty ->
649 returnM (HsArrApp new_e1 new_e2 new_ty ho rl src_loc)
651 zonkExpr env (HsArrForm op fixity args src_loc)
652 = zonkExpr env op `thenM` \ new_op ->
653 mappM (zonkCmdTop env) args `thenM` \ new_args ->
654 returnM (HsArrForm new_op fixity new_args src_loc)
656 zonkCmdTop :: ZonkEnv -> TcCmdTop -> TcM TypecheckedHsCmdTop
657 zonkCmdTop env (HsCmdTop cmd stack_tys ty ids)
658 = zonkExpr env cmd `thenM` \ new_cmd ->
659 mappM (zonkTcTypeToType env) stack_tys
660 `thenM` \ new_stack_tys ->
661 zonkTcTypeToType env ty `thenM` \ new_ty ->
662 zonkReboundNames env ids `thenM` \ new_ids ->
663 returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
665 -------------------------------------------------------------------------
666 zonkReboundNames :: ZonkEnv -> ReboundNames Id -> TcM (ReboundNames Id)
667 zonkReboundNames env prs
670 zonk (n, e) = zonkExpr env e `thenM` \ new_e ->
674 -------------------------------------------------------------------------
675 zonkArithSeq :: ZonkEnv -> TcArithSeqInfo -> TcM TypecheckedArithSeqInfo
677 zonkArithSeq env (From e)
678 = zonkExpr env e `thenM` \ new_e ->
681 zonkArithSeq env (FromThen e1 e2)
682 = zonkExpr env e1 `thenM` \ new_e1 ->
683 zonkExpr env e2 `thenM` \ new_e2 ->
684 returnM (FromThen new_e1 new_e2)
686 zonkArithSeq env (FromTo e1 e2)
687 = zonkExpr env e1 `thenM` \ new_e1 ->
688 zonkExpr env e2 `thenM` \ new_e2 ->
689 returnM (FromTo new_e1 new_e2)
691 zonkArithSeq env (FromThenTo e1 e2 e3)
692 = zonkExpr env e1 `thenM` \ new_e1 ->
693 zonkExpr env e2 `thenM` \ new_e2 ->
694 zonkExpr env e3 `thenM` \ new_e3 ->
695 returnM (FromThenTo new_e1 new_e2 new_e3)
698 -------------------------------------------------------------------------
699 zonkStmts :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt]
701 zonkStmts env stmts = zonk_stmts env stmts `thenM` \ (_, stmts) ->
704 zonk_stmts :: ZonkEnv -> [TcStmt] -> TcM (ZonkEnv, [TypecheckedStmt])
706 zonk_stmts env [] = returnM (env, [])
708 zonk_stmts env (ParStmt stmts_w_bndrs : stmts)
709 = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
711 new_binders = concat (map snd new_stmts_w_bndrs)
712 env1 = extendZonkEnv env new_binders
714 zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
715 returnM (env2, ParStmt new_stmts_w_bndrs : new_stmts)
717 zonk_branch (stmts, bndrs) = zonk_stmts env stmts `thenM` \ (env1, new_stmts) ->
718 returnM (new_stmts, zonkIdOccs env1 bndrs)
720 zonk_stmts env (RecStmt segStmts lvs rvs rets : stmts)
721 = zonkIdBndrs env rvs `thenM` \ new_rvs ->
723 env1 = extendZonkEnv env new_rvs
725 zonk_stmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
726 -- Zonk the ret-expressions in an envt that
727 -- has the polymorphic bindings in the envt
728 zonkExprs env2 rets `thenM` \ new_rets ->
730 new_lvs = zonkIdOccs env2 lvs
731 env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
733 zonk_stmts env3 stmts `thenM` \ (env4, new_stmts) ->
734 returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets : new_stmts)
736 zonk_stmts env (ResultStmt expr locn : stmts)
737 = ASSERT( null stmts )
738 zonkExpr env expr `thenM` \ new_expr ->
739 returnM (env, [ResultStmt new_expr locn])
741 zonk_stmts env (ExprStmt expr ty locn : stmts)
742 = zonkExpr env expr `thenM` \ new_expr ->
743 zonkTcTypeToType env ty `thenM` \ new_ty ->
744 zonk_stmts env stmts `thenM` \ (env1, new_stmts) ->
745 returnM (env1, ExprStmt new_expr new_ty locn : new_stmts)
747 zonk_stmts env (LetStmt binds : stmts)
748 = zonkBinds env binds `thenM` \ (env1, new_binds) ->
749 zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
750 returnM (env2, LetStmt new_binds : new_stmts)
752 zonk_stmts env (BindStmt pat expr locn : stmts)
753 = zonkExpr env expr `thenM` \ new_expr ->
754 zonkPat env pat `thenM` \ (new_pat, new_ids) ->
756 env1 = extendZonkEnv env (bagToList new_ids)
758 zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
759 returnM (env2, BindStmt new_pat new_expr locn : new_stmts)
763 -------------------------------------------------------------------------
764 zonkRbinds :: ZonkEnv -> TcRecordBinds -> TcM TypecheckedRecordBinds
766 zonkRbinds env rbinds
767 = mappM zonk_rbind rbinds
769 zonk_rbind (field, expr)
770 = zonkExpr env expr `thenM` \ new_expr ->
771 returnM (zonkIdOcc env field, new_expr)
773 -------------------------------------------------------------------------
774 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
775 mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r)
776 mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r)
780 %************************************************************************
782 \subsection[BackSubst-Pats]{Patterns}
784 %************************************************************************
787 zonkPat :: ZonkEnv -> TcPat -> TcM (TypecheckedPat, Bag Id)
789 zonkPat env (ParPat p)
790 = zonkPat env p `thenM` \ (new_p, ids) ->
791 returnM (ParPat new_p, ids)
793 zonkPat env (WildPat ty)
794 = zonkTcTypeToType env ty `thenM` \ new_ty ->
795 returnM (WildPat new_ty, emptyBag)
797 zonkPat env (VarPat v)
798 = zonkIdBndr env v `thenM` \ new_v ->
799 returnM (VarPat new_v, unitBag new_v)
801 zonkPat env (LazyPat pat)
802 = zonkPat env pat `thenM` \ (new_pat, ids) ->
803 returnM (LazyPat new_pat, ids)
805 zonkPat env (AsPat n pat)
806 = zonkIdBndr env n `thenM` \ new_n ->
807 zonkPat env pat `thenM` \ (new_pat, ids) ->
808 returnM (AsPat new_n new_pat, new_n `consBag` ids)
810 zonkPat env (ListPat pats ty)
811 = zonkTcTypeToType env ty `thenM` \ new_ty ->
812 zonkPats env pats `thenM` \ (new_pats, ids) ->
813 returnM (ListPat new_pats new_ty, ids)
815 zonkPat env (PArrPat pats ty)
816 = zonkTcTypeToType env ty `thenM` \ new_ty ->
817 zonkPats env pats `thenM` \ (new_pats, ids) ->
818 returnM (PArrPat new_pats new_ty, ids)
820 zonkPat env (TuplePat pats boxed)
821 = zonkPats env pats `thenM` \ (new_pats, ids) ->
822 returnM (TuplePat new_pats boxed, ids)
824 zonkPat env (ConPatOut n stuff ty tvs dicts)
825 = zonkTcTypeToType env ty `thenM` \ new_ty ->
826 mappM zonkTcTyVarToTyVar tvs `thenM` \ new_tvs ->
827 zonkIdBndrs env dicts `thenM` \ new_dicts ->
829 env1 = extendZonkEnv env new_dicts
831 zonkConStuff env1 stuff `thenM` \ (new_stuff, ids) ->
832 returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts,
833 listToBag new_dicts `unionBags` ids)
835 zonkPat env (LitPat lit) = returnM (LitPat lit, emptyBag)
837 zonkPat env (SigPatOut pat ty expr)
838 = zonkPat env pat `thenM` \ (new_pat, ids) ->
839 zonkTcTypeToType env ty `thenM` \ new_ty ->
840 zonkExpr env expr `thenM` \ new_expr ->
841 returnM (SigPatOut new_pat new_ty new_expr, ids)
843 zonkPat env (NPatOut lit ty expr)
844 = zonkTcTypeToType env ty `thenM` \ new_ty ->
845 zonkExpr env expr `thenM` \ new_expr ->
846 returnM (NPatOut lit new_ty new_expr, emptyBag)
848 zonkPat env (NPlusKPatOut n k e1 e2)
849 = zonkIdBndr env n `thenM` \ new_n ->
850 zonkExpr env e1 `thenM` \ new_e1 ->
851 zonkExpr env e2 `thenM` \ new_e2 ->
852 returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag new_n)
854 zonkPat env (DictPat ds ms)
855 = zonkIdBndrs env ds `thenM` \ new_ds ->
856 zonkIdBndrs env ms `thenM` \ new_ms ->
857 returnM (DictPat new_ds new_ms,
858 listToBag new_ds `unionBags` listToBag new_ms)
860 ---------------------------
861 zonkConStuff env (PrefixCon pats)
862 = zonkPats env pats `thenM` \ (new_pats, ids) ->
863 returnM (PrefixCon new_pats, ids)
865 zonkConStuff env (InfixCon p1 p2)
866 = zonkPat env p1 `thenM` \ (new_p1, ids1) ->
867 zonkPat env p2 `thenM` \ (new_p2, ids2) ->
868 returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2)
870 zonkConStuff env (RecCon rpats)
871 = mapAndUnzipM zonk_rpat rpats `thenM` \ (new_rpats, ids_s) ->
872 returnM (RecCon new_rpats, unionManyBags ids_s)
875 = zonkPat env pat `thenM` \ (new_pat, ids) ->
876 returnM ((f, new_pat), ids)
878 ---------------------------
880 = returnM ([], emptyBag)
882 zonkPats env (pat:pats)
883 = zonkPat env pat `thenM` \ (pat', ids1) ->
884 zonkPats env pats `thenM` \ (pats', ids2) ->
885 returnM (pat':pats', ids1 `unionBags` ids2)
888 %************************************************************************
890 \subsection[BackSubst-Foreign]{Foreign exports}
892 %************************************************************************
896 zonkForeignExports :: ZonkEnv -> [TcForeignDecl] -> TcM [TypecheckedForeignDecl]
897 zonkForeignExports env ls = mappM (zonkForeignExport env) ls
899 zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl)
900 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) =
901 returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc)
902 zonkForeignExport env for_imp
903 = returnM for_imp -- Foreign imports don't need zonking
907 zonkRules :: ZonkEnv -> [TcRuleDecl] -> TcM [TypecheckedRuleDecl]
908 zonkRules env rs = mappM (zonkRule env) rs
910 zonkRule env (HsRule name act vars lhs rhs loc)
911 = mappM zonk_bndr vars `thenM` \ new_bndrs ->
912 newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
914 env_rhs = extendZonkEnv env (filter isId new_bndrs)
915 -- Type variables don't need an envt
916 -- They are bound through the mutable mechanism
918 env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
919 -- We need to gather the type variables mentioned on the LHS so we can
920 -- quantify over them. Example:
926 -- {-# RULES "myrule" foo C = 1 #-}
928 -- After type checking the LHS becomes (foo a (C a))
929 -- and we do not want to zap the unbound tyvar 'a' to (), because
930 -- that limits the applicability of the rule. Instead, we
931 -- want to quantify over it!
933 -- It's easiest to find the free tyvars here. Attempts to do so earlier
934 -- are tiresome, because (a) the data type is big and (b) finding the
935 -- free type vars of an expression is necessarily monadic operation.
936 -- (consider /\a -> f @ b, where b is side-effected to a)
938 zonkExpr env_lhs lhs `thenM` \ new_lhs ->
939 zonkExpr env_rhs rhs `thenM` \ new_rhs ->
941 readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
943 final_bndrs = map RuleBndr (varSetElems unbound_tvs ++ new_bndrs)
944 -- I hate this map RuleBndr stuff
946 returnM (HsRule name act final_bndrs new_lhs new_rhs loc)
948 zonk_bndr (RuleBndr v)
949 | isId v = zonkIdBndr env v
950 | otherwise = zonkTcTyVarToTyVar v
954 %************************************************************************
956 \subsection[BackSubst-Foreign]{Foreign exports}
958 %************************************************************************
961 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
962 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
964 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
965 -- This variant collects unbound type variables in a mutable variable
966 zonkTypeCollecting unbound_tv_set
967 = zonkType zonk_unbound_tyvar
969 zonk_unbound_tyvar tv
970 = zonkTcTyVarToTyVar tv `thenM` \ tv' ->
971 readMutVar unbound_tv_set `thenM` \ tv_set ->
972 writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
973 return (mkTyVarTy tv')
975 zonkTypeZapping :: TcType -> TcM Type
976 -- This variant is used for everything except the LHS of rules
977 -- It zaps unbound type variables to (), or some other arbitrary type
979 = zonkType zonk_unbound_tyvar ty
981 -- Zonk a mutable but unbound type variable to an arbitrary type
982 -- We know it's unbound even though we don't carry an environment,
983 -- because at the binding site for a type variable we bind the
984 -- mutable tyvar to a fresh immutable one. So the mutable store
985 -- plays the role of an environment. If we come across a mutable
986 -- type variable that isn't so bound, it must be completely free.
987 zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv)
990 -- When the type checker finds a type variable with no binding,
991 -- which means it can be instantiated with an arbitrary type, it
992 -- usually instantiates it to Void. Eg.
996 -- length Void (Nil Void)
998 -- But in really obscure programs, the type variable might have
999 -- a kind other than *, so we need to invent a suitably-kinded type.
1003 -- List for kind *->*
1004 -- Tuple for kind *->...*->*
1006 -- which deals with most cases. (Previously, it only dealt with
1009 -- In the other cases, it just makes up a TyCon with a suitable
1010 -- kind. If this gets into an interface file, anyone reading that
1011 -- file won't understand it. This is fixable (by making the client
1012 -- of the interface file make up a TyCon too) but it is tiresome and
1013 -- never happens, so I am leaving it
1015 mkArbitraryType :: TcTyVar -> Type
1016 -- Make up an arbitrary type whose kind is the same as the tyvar.
1017 -- We'll use this to instantiate the (unbound) tyvar.
1019 | isAnyTypeKind kind = voidTy -- The vastly common case
1020 | otherwise = mkTyConApp tycon []
1023 (args,res) = Type.splitFunTys kind -- Kinds are simple; use Type.splitFunTys
1025 tycon | kind `eqKind` tyConKind listTyCon -- *->*
1026 = listTyCon -- No tuples this size
1028 | all isTypeKind args && isTypeKind res
1029 = tupleTyCon Boxed (length args) -- *-> ... ->*->*
1032 = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
1033 mkPrimTyCon tc_name kind 0 [] VoidRep
1034 -- Same name as the tyvar, apart from making it start with a colon (sigh)
1035 -- I dread to think what will happen if this gets out into an
1036 -- interface file. Catastrophe likely. Major sigh.
1038 tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc