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 (HsSplice n e loc) = WARN( True, ppr e ) -- Should not happen
512 returnM (HsSplice n e loc)
514 zonkExpr env (OpApp e1 op fixity e2)
515 = zonkExpr env e1 `thenM` \ new_e1 ->
516 zonkExpr env op `thenM` \ new_op ->
517 zonkExpr env e2 `thenM` \ new_e2 ->
518 returnM (OpApp new_e1 new_op fixity new_e2)
520 zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp"
522 zonkExpr env (HsPar e)
523 = zonkExpr env e `thenM` \new_e ->
524 returnM (HsPar new_e)
526 zonkExpr env (SectionL expr op)
527 = zonkExpr env expr `thenM` \ new_expr ->
528 zonkExpr env op `thenM` \ new_op ->
529 returnM (SectionL new_expr new_op)
531 zonkExpr env (SectionR op expr)
532 = zonkExpr env op `thenM` \ new_op ->
533 zonkExpr env expr `thenM` \ new_expr ->
534 returnM (SectionR new_op new_expr)
536 zonkExpr env (HsCase expr ms src_loc)
537 = zonkExpr env expr `thenM` \ new_expr ->
538 mappM (zonkMatch env) ms `thenM` \ new_ms ->
539 returnM (HsCase new_expr new_ms src_loc)
541 zonkExpr env (HsIf e1 e2 e3 src_loc)
542 = zonkExpr env e1 `thenM` \ new_e1 ->
543 zonkExpr env e2 `thenM` \ new_e2 ->
544 zonkExpr env e3 `thenM` \ new_e3 ->
545 returnM (HsIf new_e1 new_e2 new_e3 src_loc)
547 zonkExpr env (HsLet binds expr)
548 = zonkBinds env binds `thenM` \ (new_env, new_binds) ->
549 zonkExpr new_env expr `thenM` \ new_expr ->
550 returnM (HsLet new_binds new_expr)
552 zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
553 = zonkStmts env stmts `thenM` \ new_stmts ->
554 zonkTcTypeToType env ty `thenM` \ new_ty ->
555 zonkReboundNames env ids `thenM` \ new_ids ->
556 returnM (HsDo do_or_lc new_stmts new_ids
559 zonkExpr env (ExplicitList ty exprs)
560 = zonkTcTypeToType env ty `thenM` \ new_ty ->
561 zonkExprs env exprs `thenM` \ new_exprs ->
562 returnM (ExplicitList new_ty new_exprs)
564 zonkExpr env (ExplicitPArr ty exprs)
565 = zonkTcTypeToType env ty `thenM` \ new_ty ->
566 zonkExprs env exprs `thenM` \ new_exprs ->
567 returnM (ExplicitPArr new_ty new_exprs)
569 zonkExpr env (ExplicitTuple exprs boxed)
570 = zonkExprs env exprs `thenM` \ new_exprs ->
571 returnM (ExplicitTuple new_exprs boxed)
573 zonkExpr env (RecordConOut data_con con_expr rbinds)
574 = zonkExpr env con_expr `thenM` \ new_con_expr ->
575 zonkRbinds env rbinds `thenM` \ new_rbinds ->
576 returnM (RecordConOut data_con new_con_expr new_rbinds)
578 zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"
580 zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
581 = zonkExpr env expr `thenM` \ new_expr ->
582 zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
583 zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
584 zonkRbinds env rbinds `thenM` \ new_rbinds ->
585 returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
587 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
588 zonkExpr env (ArithSeqIn _) = panic "zonkExpr env:ArithSeqIn"
589 zonkExpr env (PArrSeqIn _) = panic "zonkExpr env:PArrSeqIn"
591 zonkExpr env (ArithSeqOut expr info)
592 = zonkExpr env expr `thenM` \ new_expr ->
593 zonkArithSeq env info `thenM` \ new_info ->
594 returnM (ArithSeqOut new_expr new_info)
596 zonkExpr env (PArrSeqOut expr info)
597 = zonkExpr env expr `thenM` \ new_expr ->
598 zonkArithSeq env info `thenM` \ new_info ->
599 returnM (PArrSeqOut new_expr new_info)
601 zonkExpr env (HsSCC lbl expr)
602 = zonkExpr env expr `thenM` \ new_expr ->
603 returnM (HsSCC lbl new_expr)
605 -- hdaume: core annotations
606 zonkExpr env (HsCoreAnn lbl expr)
607 = zonkExpr env expr `thenM` \ new_expr ->
608 returnM (HsCoreAnn lbl new_expr)
610 zonkExpr env (TyLam tyvars expr)
611 = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
612 -- No need to extend tyvar env; see AbsBinds
614 zonkExpr env expr `thenM` \ new_expr ->
615 returnM (TyLam new_tyvars new_expr)
617 zonkExpr env (TyApp expr tys)
618 = zonkExpr env expr `thenM` \ new_expr ->
619 mappM (zonkTcTypeToType env) tys `thenM` \ new_tys ->
620 returnM (TyApp new_expr new_tys)
622 zonkExpr env (DictLam dicts expr)
623 = zonkIdBndrs env dicts `thenM` \ new_dicts ->
625 env1 = extendZonkEnv env new_dicts
627 zonkExpr env1 expr `thenM` \ new_expr ->
628 returnM (DictLam new_dicts new_expr)
630 zonkExpr env (DictApp expr dicts)
631 = zonkExpr env expr `thenM` \ new_expr ->
632 returnM (DictApp new_expr (zonkIdOccs env dicts))
634 -- arrow notation extensions
635 zonkExpr env (HsProc pat body src_loc)
636 = zonkPat env pat `thenM` \ (new_pat, new_ids) ->
638 env1 = extendZonkEnv env (bagToList new_ids)
640 zonkCmdTop env1 body `thenM` \ new_body ->
641 returnM (HsProc new_pat new_body src_loc)
643 zonkExpr env (HsArrApp e1 e2 ty ho rl src_loc)
644 = zonkExpr env e1 `thenM` \ new_e1 ->
645 zonkExpr env e2 `thenM` \ new_e2 ->
646 zonkTcTypeToType env ty `thenM` \ new_ty ->
647 returnM (HsArrApp new_e1 new_e2 new_ty ho rl src_loc)
649 zonkExpr env (HsArrForm op fixity args src_loc)
650 = zonkExpr env op `thenM` \ new_op ->
651 mappM (zonkCmdTop env) args `thenM` \ new_args ->
652 returnM (HsArrForm new_op fixity new_args src_loc)
654 zonkCmdTop :: ZonkEnv -> TcCmdTop -> TcM TypecheckedHsCmdTop
655 zonkCmdTop env (HsCmdTop cmd stack_tys ty ids)
656 = zonkExpr env cmd `thenM` \ new_cmd ->
657 mappM (zonkTcTypeToType env) stack_tys
658 `thenM` \ new_stack_tys ->
659 zonkTcTypeToType env ty `thenM` \ new_ty ->
660 zonkReboundNames env ids `thenM` \ new_ids ->
661 returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
663 -------------------------------------------------------------------------
664 zonkReboundNames :: ZonkEnv -> ReboundNames Id -> TcM (ReboundNames Id)
665 zonkReboundNames env prs
668 zonk (n, e) = zonkExpr env e `thenM` \ new_e ->
672 -------------------------------------------------------------------------
673 zonkArithSeq :: ZonkEnv -> TcArithSeqInfo -> TcM TypecheckedArithSeqInfo
675 zonkArithSeq env (From e)
676 = zonkExpr env e `thenM` \ new_e ->
679 zonkArithSeq env (FromThen e1 e2)
680 = zonkExpr env e1 `thenM` \ new_e1 ->
681 zonkExpr env e2 `thenM` \ new_e2 ->
682 returnM (FromThen new_e1 new_e2)
684 zonkArithSeq env (FromTo e1 e2)
685 = zonkExpr env e1 `thenM` \ new_e1 ->
686 zonkExpr env e2 `thenM` \ new_e2 ->
687 returnM (FromTo new_e1 new_e2)
689 zonkArithSeq env (FromThenTo e1 e2 e3)
690 = zonkExpr env e1 `thenM` \ new_e1 ->
691 zonkExpr env e2 `thenM` \ new_e2 ->
692 zonkExpr env e3 `thenM` \ new_e3 ->
693 returnM (FromThenTo new_e1 new_e2 new_e3)
696 -------------------------------------------------------------------------
697 zonkStmts :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt]
699 zonkStmts env stmts = zonk_stmts env stmts `thenM` \ (_, stmts) ->
702 zonk_stmts :: ZonkEnv -> [TcStmt] -> TcM (ZonkEnv, [TypecheckedStmt])
704 zonk_stmts env [] = returnM (env, [])
706 zonk_stmts env (ParStmt stmts_w_bndrs : stmts)
707 = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
709 new_binders = concat (map snd new_stmts_w_bndrs)
710 env1 = extendZonkEnv env new_binders
712 zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
713 returnM (env2, ParStmt new_stmts_w_bndrs : new_stmts)
715 zonk_branch (stmts, bndrs) = zonk_stmts env stmts `thenM` \ (env1, new_stmts) ->
716 returnM (new_stmts, zonkIdOccs env1 bndrs)
718 zonk_stmts env (RecStmt segStmts lvs rvs rets : stmts)
719 = zonkIdBndrs env rvs `thenM` \ new_rvs ->
721 env1 = extendZonkEnv env new_rvs
723 zonk_stmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
724 -- Zonk the ret-expressions in an envt that
725 -- has the polymorphic bindings in the envt
726 zonkExprs env2 rets `thenM` \ new_rets ->
728 new_lvs = zonkIdOccs env2 lvs
729 env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
731 zonk_stmts env3 stmts `thenM` \ (env4, new_stmts) ->
732 returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets : new_stmts)
734 zonk_stmts env (ResultStmt expr locn : stmts)
735 = ASSERT( null stmts )
736 zonkExpr env expr `thenM` \ new_expr ->
737 returnM (env, [ResultStmt new_expr locn])
739 zonk_stmts env (ExprStmt expr ty locn : stmts)
740 = zonkExpr env expr `thenM` \ new_expr ->
741 zonkTcTypeToType env ty `thenM` \ new_ty ->
742 zonk_stmts env stmts `thenM` \ (env1, new_stmts) ->
743 returnM (env1, ExprStmt new_expr new_ty locn : new_stmts)
745 zonk_stmts env (LetStmt binds : stmts)
746 = zonkBinds env binds `thenM` \ (env1, new_binds) ->
747 zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
748 returnM (env2, LetStmt new_binds : new_stmts)
750 zonk_stmts env (BindStmt pat expr locn : stmts)
751 = zonkExpr env expr `thenM` \ new_expr ->
752 zonkPat env pat `thenM` \ (new_pat, new_ids) ->
754 env1 = extendZonkEnv env (bagToList new_ids)
756 zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
757 returnM (env2, BindStmt new_pat new_expr locn : new_stmts)
761 -------------------------------------------------------------------------
762 zonkRbinds :: ZonkEnv -> TcRecordBinds -> TcM TypecheckedRecordBinds
764 zonkRbinds env rbinds
765 = mappM zonk_rbind rbinds
767 zonk_rbind (field, expr)
768 = zonkExpr env expr `thenM` \ new_expr ->
769 returnM (zonkIdOcc env field, new_expr)
771 -------------------------------------------------------------------------
772 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
773 mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r)
774 mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r)
778 %************************************************************************
780 \subsection[BackSubst-Pats]{Patterns}
782 %************************************************************************
785 zonkPat :: ZonkEnv -> TcPat -> TcM (TypecheckedPat, Bag Id)
787 zonkPat env (ParPat p)
788 = zonkPat env p `thenM` \ (new_p, ids) ->
789 returnM (ParPat new_p, ids)
791 zonkPat env (WildPat ty)
792 = zonkTcTypeToType env ty `thenM` \ new_ty ->
793 returnM (WildPat new_ty, emptyBag)
795 zonkPat env (VarPat v)
796 = zonkIdBndr env v `thenM` \ new_v ->
797 returnM (VarPat new_v, unitBag new_v)
799 zonkPat env (LazyPat pat)
800 = zonkPat env pat `thenM` \ (new_pat, ids) ->
801 returnM (LazyPat new_pat, ids)
803 zonkPat env (AsPat n pat)
804 = zonkIdBndr env n `thenM` \ new_n ->
805 zonkPat env pat `thenM` \ (new_pat, ids) ->
806 returnM (AsPat new_n new_pat, new_n `consBag` ids)
808 zonkPat env (ListPat pats ty)
809 = zonkTcTypeToType env ty `thenM` \ new_ty ->
810 zonkPats env pats `thenM` \ (new_pats, ids) ->
811 returnM (ListPat new_pats new_ty, ids)
813 zonkPat env (PArrPat pats ty)
814 = zonkTcTypeToType env ty `thenM` \ new_ty ->
815 zonkPats env pats `thenM` \ (new_pats, ids) ->
816 returnM (PArrPat new_pats new_ty, ids)
818 zonkPat env (TuplePat pats boxed)
819 = zonkPats env pats `thenM` \ (new_pats, ids) ->
820 returnM (TuplePat new_pats boxed, ids)
822 zonkPat env (ConPatOut n stuff ty tvs dicts)
823 = zonkTcTypeToType env ty `thenM` \ new_ty ->
824 mappM zonkTcTyVarToTyVar tvs `thenM` \ new_tvs ->
825 zonkIdBndrs env dicts `thenM` \ new_dicts ->
827 env1 = extendZonkEnv env new_dicts
829 zonkConStuff env1 stuff `thenM` \ (new_stuff, ids) ->
830 returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts,
831 listToBag new_dicts `unionBags` ids)
833 zonkPat env (LitPat lit) = returnM (LitPat lit, emptyBag)
835 zonkPat env (SigPatOut pat ty expr)
836 = zonkPat env pat `thenM` \ (new_pat, ids) ->
837 zonkTcTypeToType env ty `thenM` \ new_ty ->
838 zonkExpr env expr `thenM` \ new_expr ->
839 returnM (SigPatOut new_pat new_ty new_expr, ids)
841 zonkPat env (NPatOut lit ty expr)
842 = zonkTcTypeToType env ty `thenM` \ new_ty ->
843 zonkExpr env expr `thenM` \ new_expr ->
844 returnM (NPatOut lit new_ty new_expr, emptyBag)
846 zonkPat env (NPlusKPatOut n k e1 e2)
847 = zonkIdBndr env n `thenM` \ new_n ->
848 zonkExpr env e1 `thenM` \ new_e1 ->
849 zonkExpr env e2 `thenM` \ new_e2 ->
850 returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag new_n)
852 zonkPat env (DictPat ds ms)
853 = zonkIdBndrs env ds `thenM` \ new_ds ->
854 zonkIdBndrs env ms `thenM` \ new_ms ->
855 returnM (DictPat new_ds new_ms,
856 listToBag new_ds `unionBags` listToBag new_ms)
858 ---------------------------
859 zonkConStuff env (PrefixCon pats)
860 = zonkPats env pats `thenM` \ (new_pats, ids) ->
861 returnM (PrefixCon new_pats, ids)
863 zonkConStuff env (InfixCon p1 p2)
864 = zonkPat env p1 `thenM` \ (new_p1, ids1) ->
865 zonkPat env p2 `thenM` \ (new_p2, ids2) ->
866 returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2)
868 zonkConStuff env (RecCon rpats)
869 = mapAndUnzipM zonk_rpat rpats `thenM` \ (new_rpats, ids_s) ->
870 returnM (RecCon new_rpats, unionManyBags ids_s)
873 = zonkPat env pat `thenM` \ (new_pat, ids) ->
874 returnM ((f, new_pat), ids)
876 ---------------------------
878 = returnM ([], emptyBag)
880 zonkPats env (pat:pats)
881 = zonkPat env pat `thenM` \ (pat', ids1) ->
882 zonkPats env pats `thenM` \ (pats', ids2) ->
883 returnM (pat':pats', ids1 `unionBags` ids2)
886 %************************************************************************
888 \subsection[BackSubst-Foreign]{Foreign exports}
890 %************************************************************************
894 zonkForeignExports :: ZonkEnv -> [TcForeignDecl] -> TcM [TypecheckedForeignDecl]
895 zonkForeignExports env ls = mappM (zonkForeignExport env) ls
897 zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl)
898 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) =
899 returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc)
900 zonkForeignExport env for_imp
901 = returnM for_imp -- Foreign imports don't need zonking
905 zonkRules :: ZonkEnv -> [TcRuleDecl] -> TcM [TypecheckedRuleDecl]
906 zonkRules env rs = mappM (zonkRule env) rs
908 zonkRule env (HsRule name act vars lhs rhs loc)
909 = mappM zonk_bndr vars `thenM` \ new_bndrs ->
910 newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
912 env_rhs = extendZonkEnv env (filter isId new_bndrs)
913 -- Type variables don't need an envt
914 -- They are bound through the mutable mechanism
916 env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
917 -- We need to gather the type variables mentioned on the LHS so we can
918 -- quantify over them. Example:
924 -- {-# RULES "myrule" foo C = 1 #-}
926 -- After type checking the LHS becomes (foo a (C a))
927 -- and we do not want to zap the unbound tyvar 'a' to (), because
928 -- that limits the applicability of the rule. Instead, we
929 -- want to quantify over it!
931 -- It's easiest to find the free tyvars here. Attempts to do so earlier
932 -- are tiresome, because (a) the data type is big and (b) finding the
933 -- free type vars of an expression is necessarily monadic operation.
934 -- (consider /\a -> f @ b, where b is side-effected to a)
936 zonkExpr env_lhs lhs `thenM` \ new_lhs ->
937 zonkExpr env_rhs rhs `thenM` \ new_rhs ->
939 readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
941 final_bndrs = map RuleBndr (varSetElems unbound_tvs ++ new_bndrs)
942 -- I hate this map RuleBndr stuff
944 returnM (HsRule name act final_bndrs new_lhs new_rhs loc)
946 zonk_bndr (RuleBndr v)
947 | isId v = zonkIdBndr env v
948 | otherwise = zonkTcTyVarToTyVar v
952 %************************************************************************
954 \subsection[BackSubst-Foreign]{Foreign exports}
956 %************************************************************************
959 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
960 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
962 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
963 -- This variant collects unbound type variables in a mutable variable
964 zonkTypeCollecting unbound_tv_set
965 = zonkType zonk_unbound_tyvar
967 zonk_unbound_tyvar tv
968 = zonkTcTyVarToTyVar tv `thenM` \ tv' ->
969 readMutVar unbound_tv_set `thenM` \ tv_set ->
970 writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
971 return (mkTyVarTy tv')
973 zonkTypeZapping :: TcType -> TcM Type
974 -- This variant is used for everything except the LHS of rules
975 -- It zaps unbound type variables to (), or some other arbitrary type
977 = zonkType zonk_unbound_tyvar ty
979 -- Zonk a mutable but unbound type variable to an arbitrary type
980 -- We know it's unbound even though we don't carry an environment,
981 -- because at the binding site for a type variable we bind the
982 -- mutable tyvar to a fresh immutable one. So the mutable store
983 -- plays the role of an environment. If we come across a mutable
984 -- type variable that isn't so bound, it must be completely free.
985 zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv)
988 -- When the type checker finds a type variable with no binding,
989 -- which means it can be instantiated with an arbitrary type, it
990 -- usually instantiates it to Void. Eg.
994 -- length Void (Nil Void)
996 -- But in really obscure programs, the type variable might have
997 -- a kind other than *, so we need to invent a suitably-kinded type.
1001 -- List for kind *->*
1002 -- Tuple for kind *->...*->*
1004 -- which deals with most cases. (Previously, it only dealt with
1007 -- In the other cases, it just makes up a TyCon with a suitable
1008 -- kind. If this gets into an interface file, anyone reading that
1009 -- file won't understand it. This is fixable (by making the client
1010 -- of the interface file make up a TyCon too) but it is tiresome and
1011 -- never happens, so I am leaving it
1013 mkArbitraryType :: TcTyVar -> Type
1014 -- Make up an arbitrary type whose kind is the same as the tyvar.
1015 -- We'll use this to instantiate the (unbound) tyvar.
1017 | isAnyTypeKind kind = voidTy -- The vastly common case
1018 | otherwise = mkTyConApp tycon []
1021 (args,res) = Type.splitFunTys kind -- Kinds are simple; use Type.splitFunTys
1023 tycon | kind `eqKind` tyConKind listTyCon -- *->*
1024 = listTyCon -- No tuples this size
1026 | all isTypeKind args && isTypeKind res
1027 = tupleTyCon Boxed (length args) -- *-> ... ->*->*
1030 = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
1031 mkPrimTyCon tc_name kind 0 [] VoidRep
1032 -- Same name as the tyvar, apart from making it start with a colon (sigh)
1033 -- I dread to think what will happen if this gets out into an
1034 -- interface file. Catastrophe likely. Major sigh.
1036 tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc