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, integerTy,
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) = integerTy
191 hsLitType (HsRat _ ty) = ty
192 hsLitType (HsFloatPrim f) = floatPrimTy
193 hsLitType (HsDoublePrim d) = doublePrimTy
194 hsLitType (HsLitLit _ ty) = ty
197 %************************************************************************
199 \subsection{Coercion functions}
201 %************************************************************************
204 type Coercion a = Maybe (a -> a)
205 -- Nothing => identity fn
207 type ExprCoFn = Coercion TypecheckedHsExpr
208 type PatCoFn = Coercion TcPat
210 (<.>) :: Coercion a -> Coercion a -> Coercion a -- Composition
211 Nothing <.> Nothing = Nothing
212 Nothing <.> Just f = Just f
213 Just f <.> Nothing = Just f
214 Just f1 <.> Just f2 = Just (f1 . f2)
216 (<$>) :: Coercion a -> a -> a
220 mkCoercion :: (a -> a) -> Coercion a
221 mkCoercion f = Just f
223 idCoercion :: Coercion a
226 isIdCoercion :: Coercion a -> Bool
227 isIdCoercion = isNothing
231 %************************************************************************
233 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
235 %************************************************************************
238 -- zonkId is used *during* typechecking just to zonk the Id's type
239 zonkId :: TcId -> TcM TcId
241 = zonkTcType (idType id) `thenM` \ ty' ->
242 returnM (setIdType id ty')
245 The rest of the zonking is done *after* typechecking.
246 The main zonking pass runs over the bindings
248 a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
249 b) convert unbound TcTyVar to Void
250 c) convert each TcId to an Id by zonking its type
252 The type variables are converted by binding mutable tyvars to immutable ones
253 and then zonking as normal.
255 The Ids are converted by binding them in the normal Tc envt; that
256 way we maintain sharing; eg an Id is zonked at its binding site and they
257 all occurrences of that Id point to the common zonked copy
259 It's all pretty boring stuff, because HsSyn is such a large type, and
260 the environment manipulation is tiresome.
263 data ZonkEnv = ZonkEnv (TcType -> TcM Type) -- How to zonk a type
264 (IdEnv Id) -- What variables are in scope
265 -- Maps an Id to its zonked version; both have the same Name
266 -- Is only consulted lazily; hence knot-tying
268 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
270 extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
271 extendZonkEnv (ZonkEnv zonk_ty env) ids
272 = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
274 setZonkType :: ZonkEnv -> (TcType -> TcM Type) -> ZonkEnv
275 setZonkType (ZonkEnv _ env) zonk_ty = ZonkEnv zonk_ty env
277 mkZonkEnv :: [Id] -> ZonkEnv
278 mkZonkEnv ids = extendZonkEnv emptyZonkEnv ids
280 zonkIdOcc :: ZonkEnv -> TcId -> Id
281 -- Ids defined in this module should be in the envt;
282 -- ignore others. (Actually, data constructors are also
283 -- not LocalVars, even when locally defined, but that is fine.)
285 -- Actually, Template Haskell works in 'chunks' of declarations, and
286 -- an earlier chunk won't be in the 'env' that the zonking phase
287 -- carries around. Instead it'll be in the tcg_gbl_env, already fully
288 -- zonked. There's no point in looking it up there (except for error
289 -- checking), and it's not conveniently to hand; hence the simple
290 -- 'orElse' case in the LocalVar branch.
292 -- Even without template splices, in module Main, the checking of
293 -- 'main' is done as a separte chunk.
294 zonkIdOcc (ZonkEnv zonk_ty env) id
295 | isLocalVar id = lookupVarEnv env id `orElse` id
298 zonkIdOccs env ids = map (zonkIdOcc env) ids
300 -- zonkIdBndr is used *after* typechecking to get the Id's type
301 -- to its final form. The TyVarEnv give
302 zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
304 = zonkTcTypeToType env (idType id) `thenM` \ ty' ->
305 returnM (setIdType id ty')
307 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
308 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
310 zonkTopBndrs :: [TcId] -> TcM [Id]
311 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
316 zonkTopExpr :: TcExpr -> TcM TypecheckedHsExpr
317 zonkTopExpr e = zonkExpr emptyZonkEnv e
319 zonkTopDecls :: TcMonoBinds -> [TcRuleDecl] -> [TcForeignDecl]
321 TypecheckedMonoBinds,
322 [TypecheckedForeignDecl],
323 [TypecheckedRuleDecl])
324 zonkTopDecls binds rules fords -- Top level is implicitly recursive
325 = fixM (\ ~(new_ids, _, _, _) ->
327 zonk_env = mkZonkEnv new_ids
329 zonkMonoBinds zonk_env binds `thenM` \ (binds', new_ids) ->
330 zonkRules zonk_env rules `thenM` \ rules' ->
331 zonkForeignExports zonk_env fords `thenM` \ fords' ->
333 returnM (bagToList new_ids, binds', fords', rules')
336 zonkTopBinds :: TcMonoBinds -> TcM ([Id], TypecheckedMonoBinds)
338 = fixM (\ ~(new_ids, _) ->
340 zonk_env = mkZonkEnv new_ids
342 zonkMonoBinds zonk_env binds `thenM` \ (binds', new_ids) ->
343 returnM (bagToList new_ids, binds')
346 ---------------------------------------------
347 zonkBinds :: ZonkEnv -> TcHsBinds -> TcM (ZonkEnv, TypecheckedHsBinds)
348 zonkBinds env EmptyBinds = returnM (env, EmptyBinds)
350 zonkBinds env (ThenBinds b1 b2)
351 = zonkBinds env b1 `thenM` \ (env1, b1') ->
352 zonkBinds env1 b2 `thenM` \ (env2, b2') ->
353 returnM (env2, b1' `ThenBinds` b2')
355 zonkBinds env (MonoBind bind sigs is_rec)
356 = ASSERT( null sigs )
357 fixM (\ ~(_, _, new_ids) ->
359 env1 = extendZonkEnv env (bagToList new_ids)
361 zonkMonoBinds env1 bind `thenM` \ (new_bind, new_ids) ->
362 returnM (env1, new_bind, new_ids)
363 ) `thenM` \ (env1, new_bind, _) ->
364 returnM (env1, mkMonoBind is_rec new_bind)
366 zonkBinds env (IPBinds binds is_with)
367 = mappM zonk_ip_bind binds `thenM` \ new_binds ->
369 env1 = extendZonkEnv env (map (ipNameName . fst) new_binds)
371 returnM (env1, IPBinds new_binds is_with)
374 = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' ->
375 zonkExpr env e `thenM` \ e' ->
379 ---------------------------------------------
380 zonkMonoBinds :: ZonkEnv -> TcMonoBinds
381 -> TcM (TypecheckedMonoBinds, Bag Id)
383 zonkMonoBinds env EmptyMonoBinds = returnM (EmptyMonoBinds, emptyBag)
385 zonkMonoBinds env (AndMonoBinds mbinds1 mbinds2)
386 = zonkMonoBinds env mbinds1 `thenM` \ (b1', ids1) ->
387 zonkMonoBinds env mbinds2 `thenM` \ (b2', ids2) ->
388 returnM (b1' `AndMonoBinds` b2',
389 ids1 `unionBags` ids2)
391 zonkMonoBinds env (PatMonoBind pat grhss locn)
392 = zonkPat env pat `thenM` \ (new_pat, ids) ->
393 zonkGRHSs env grhss `thenM` \ new_grhss ->
394 returnM (PatMonoBind new_pat new_grhss locn, ids)
396 zonkMonoBinds env (VarMonoBind var expr)
397 = zonkIdBndr env var `thenM` \ new_var ->
398 zonkExpr env expr `thenM` \ new_expr ->
399 returnM (VarMonoBind new_var new_expr, unitBag new_var)
401 zonkMonoBinds env (FunMonoBind var inf ms locn)
402 = zonkIdBndr env var `thenM` \ new_var ->
403 mappM (zonkMatch env) ms `thenM` \ new_ms ->
404 returnM (FunMonoBind new_var inf new_ms locn, unitBag new_var)
407 zonkMonoBinds env (AbsBinds tyvars dicts exports inlines val_bind)
408 = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
409 -- No need to extend tyvar env: the effects are
410 -- propagated through binding the tyvars themselves
412 zonkIdBndrs env dicts `thenM` \ new_dicts ->
413 fixM (\ ~(_, _, val_bind_ids) ->
415 env1 = extendZonkEnv (extendZonkEnv env new_dicts)
416 (bagToList val_bind_ids)
418 zonkMonoBinds env1 val_bind `thenM` \ (new_val_bind, val_bind_ids) ->
419 mappM (zonkExport env1) exports `thenM` \ new_exports ->
420 returnM (new_val_bind, new_exports, val_bind_ids)
421 ) `thenM ` \ (new_val_bind, new_exports, _) ->
423 new_globals = listToBag [global | (_, global, local) <- new_exports]
425 returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind,
428 zonkExport env (tyvars, global, local)
429 = zonkTcTyVars tyvars `thenM` \ tys ->
431 new_tyvars = map (tcGetTyVar "zonkExport") tys
432 -- This isn't the binding occurrence of these tyvars
433 -- but they should *be* tyvars. Hence tcGetTyVar.
435 zonkIdBndr env global `thenM` \ new_global ->
436 returnM (new_tyvars, new_global, zonkIdOcc env local)
439 %************************************************************************
441 \subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
443 %************************************************************************
446 zonkMatch :: ZonkEnv -> TcMatch -> TcM TypecheckedMatch
448 zonkMatch env (Match pats _ grhss)
449 = zonkPats env pats `thenM` \ (new_pats, new_ids) ->
450 zonkGRHSs (extendZonkEnv env (bagToList new_ids)) grhss `thenM` \ new_grhss ->
451 returnM (Match new_pats Nothing new_grhss)
453 -------------------------------------------------------------------------
454 zonkGRHSs :: ZonkEnv -> TcGRHSs -> TcM TypecheckedGRHSs
456 zonkGRHSs env (GRHSs grhss binds ty)
457 = zonkBinds env binds `thenM` \ (new_env, new_binds) ->
459 zonk_grhs (GRHS guarded locn)
460 = zonkStmts new_env guarded `thenM` \ new_guarded ->
461 returnM (GRHS new_guarded locn)
463 mappM zonk_grhs grhss `thenM` \ new_grhss ->
464 zonkTcTypeToType env ty `thenM` \ new_ty ->
465 returnM (GRHSs new_grhss new_binds new_ty)
468 %************************************************************************
470 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
472 %************************************************************************
475 zonkExprs :: ZonkEnv -> [TcExpr] -> TcM [TypecheckedHsExpr]
476 zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr
478 zonkExprs env exprs = mappM (zonkExpr env) exprs
481 zonkExpr env (HsVar id)
482 = returnM (HsVar (zonkIdOcc env id))
484 zonkExpr env (HsIPVar id)
485 = returnM (HsIPVar (mapIPName (zonkIdOcc env) id))
487 zonkExpr env (HsLit (HsRat f ty))
488 = zonkTcTypeToType env ty `thenM` \ new_ty ->
489 returnM (HsLit (HsRat f new_ty))
491 zonkExpr env (HsLit (HsLitLit lit ty))
492 = zonkTcTypeToType env ty `thenM` \ new_ty ->
493 returnM (HsLit (HsLitLit lit new_ty))
495 zonkExpr env (HsLit lit)
496 = returnM (HsLit lit)
498 -- HsOverLit doesn't appear in typechecker output
500 zonkExpr env (HsLam match)
501 = zonkMatch env match `thenM` \ new_match ->
502 returnM (HsLam new_match)
504 zonkExpr env (HsApp e1 e2)
505 = zonkExpr env e1 `thenM` \ new_e1 ->
506 zonkExpr env e2 `thenM` \ new_e2 ->
507 returnM (HsApp new_e1 new_e2)
509 zonkExpr env (HsBracketOut body bs)
510 = mappM zonk_b bs `thenM` \ bs' ->
511 returnM (HsBracketOut body bs')
513 zonk_b (n,e) = zonkExpr env e `thenM` \ e' ->
516 zonkExpr env (HsReify r) = returnM (HsReify r) -- Nothing to zonk; only top
517 -- level things can be reified (for now)
518 zonkExpr env (HsSplice n e loc) = WARN( True, ppr e ) -- Should not happen
519 returnM (HsSplice n e loc)
521 zonkExpr env (OpApp e1 op fixity e2)
522 = zonkExpr env e1 `thenM` \ new_e1 ->
523 zonkExpr env op `thenM` \ new_op ->
524 zonkExpr env e2 `thenM` \ new_e2 ->
525 returnM (OpApp new_e1 new_op fixity new_e2)
527 zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp"
529 zonkExpr env (HsPar e)
530 = zonkExpr env e `thenM` \new_e ->
531 returnM (HsPar new_e)
533 zonkExpr env (SectionL expr op)
534 = zonkExpr env expr `thenM` \ new_expr ->
535 zonkExpr env op `thenM` \ new_op ->
536 returnM (SectionL new_expr new_op)
538 zonkExpr env (SectionR op expr)
539 = zonkExpr env op `thenM` \ new_op ->
540 zonkExpr env expr `thenM` \ new_expr ->
541 returnM (SectionR new_op new_expr)
543 zonkExpr env (HsCase expr ms src_loc)
544 = zonkExpr env expr `thenM` \ new_expr ->
545 mappM (zonkMatch env) ms `thenM` \ new_ms ->
546 returnM (HsCase new_expr new_ms src_loc)
548 zonkExpr env (HsIf e1 e2 e3 src_loc)
549 = zonkExpr env e1 `thenM` \ new_e1 ->
550 zonkExpr env e2 `thenM` \ new_e2 ->
551 zonkExpr env e3 `thenM` \ new_e3 ->
552 returnM (HsIf new_e1 new_e2 new_e3 src_loc)
554 zonkExpr env (HsLet binds expr)
555 = zonkBinds env binds `thenM` \ (new_env, new_binds) ->
556 zonkExpr new_env expr `thenM` \ new_expr ->
557 returnM (HsLet new_binds new_expr)
559 zonkExpr env (HsDo do_or_lc stmts ids ty src_loc)
560 = zonkStmts env stmts `thenM` \ new_stmts ->
561 zonkTcTypeToType env ty `thenM` \ new_ty ->
562 zonkReboundNames env ids `thenM` \ new_ids ->
563 returnM (HsDo do_or_lc new_stmts new_ids
566 zonkExpr env (ExplicitList ty exprs)
567 = zonkTcTypeToType env ty `thenM` \ new_ty ->
568 zonkExprs env exprs `thenM` \ new_exprs ->
569 returnM (ExplicitList new_ty new_exprs)
571 zonkExpr env (ExplicitPArr ty exprs)
572 = zonkTcTypeToType env ty `thenM` \ new_ty ->
573 zonkExprs env exprs `thenM` \ new_exprs ->
574 returnM (ExplicitPArr new_ty new_exprs)
576 zonkExpr env (ExplicitTuple exprs boxed)
577 = zonkExprs env exprs `thenM` \ new_exprs ->
578 returnM (ExplicitTuple new_exprs boxed)
580 zonkExpr env (RecordConOut data_con con_expr rbinds)
581 = zonkExpr env con_expr `thenM` \ new_con_expr ->
582 zonkRbinds env rbinds `thenM` \ new_rbinds ->
583 returnM (RecordConOut data_con new_con_expr new_rbinds)
585 zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd"
587 zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds)
588 = zonkExpr env expr `thenM` \ new_expr ->
589 zonkTcTypeToType env in_ty `thenM` \ new_in_ty ->
590 zonkTcTypeToType env out_ty `thenM` \ new_out_ty ->
591 zonkRbinds env rbinds `thenM` \ new_rbinds ->
592 returnM (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
594 zonkExpr env (ExprWithTySig _ _) = panic "zonkExpr env:ExprWithTySig"
595 zonkExpr env (ArithSeqIn _) = panic "zonkExpr env:ArithSeqIn"
596 zonkExpr env (PArrSeqIn _) = panic "zonkExpr env:PArrSeqIn"
598 zonkExpr env (ArithSeqOut expr info)
599 = zonkExpr env expr `thenM` \ new_expr ->
600 zonkArithSeq env info `thenM` \ new_info ->
601 returnM (ArithSeqOut new_expr new_info)
603 zonkExpr env (PArrSeqOut expr info)
604 = zonkExpr env expr `thenM` \ new_expr ->
605 zonkArithSeq env info `thenM` \ new_info ->
606 returnM (PArrSeqOut new_expr new_info)
608 zonkExpr env (HsCCall fun args may_gc is_casm result_ty)
609 = zonkExprs env args `thenM` \ new_args ->
610 zonkTcTypeToType env result_ty `thenM` \ new_result_ty ->
611 returnM (HsCCall fun new_args may_gc is_casm new_result_ty)
613 zonkExpr env (HsSCC lbl expr)
614 = zonkExpr env expr `thenM` \ new_expr ->
615 returnM (HsSCC lbl new_expr)
617 -- hdaume: core annotations
618 zonkExpr env (HsCoreAnn lbl expr)
619 = zonkExpr env expr `thenM` \ new_expr ->
620 returnM (HsCoreAnn lbl new_expr)
622 zonkExpr env (TyLam tyvars expr)
623 = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars ->
624 -- No need to extend tyvar env; see AbsBinds
626 zonkExpr env expr `thenM` \ new_expr ->
627 returnM (TyLam new_tyvars new_expr)
629 zonkExpr env (TyApp expr tys)
630 = zonkExpr env expr `thenM` \ new_expr ->
631 mappM (zonkTcTypeToType env) tys `thenM` \ new_tys ->
632 returnM (TyApp new_expr new_tys)
634 zonkExpr env (DictLam dicts expr)
635 = zonkIdBndrs env dicts `thenM` \ new_dicts ->
637 env1 = extendZonkEnv env new_dicts
639 zonkExpr env1 expr `thenM` \ new_expr ->
640 returnM (DictLam new_dicts new_expr)
642 zonkExpr env (DictApp expr dicts)
643 = zonkExpr env expr `thenM` \ new_expr ->
644 returnM (DictApp new_expr (zonkIdOccs env dicts))
646 -- arrow notation extensions
647 zonkExpr env (HsProc pat body src_loc)
648 = zonkPat env pat `thenM` \ (new_pat, new_ids) ->
650 env1 = extendZonkEnv env (bagToList new_ids)
652 zonkCmdTop env1 body `thenM` \ new_body ->
653 returnM (HsProc new_pat new_body src_loc)
655 zonkExpr env (HsArrApp e1 e2 ty ho rl src_loc)
656 = zonkExpr env e1 `thenM` \ new_e1 ->
657 zonkExpr env e2 `thenM` \ new_e2 ->
658 zonkTcTypeToType env ty `thenM` \ new_ty ->
659 returnM (HsArrApp new_e1 new_e2 new_ty ho rl src_loc)
661 zonkExpr env (HsArrForm op fixity args src_loc)
662 = zonkExpr env op `thenM` \ new_op ->
663 mappM (zonkCmdTop env) args `thenM` \ new_args ->
664 returnM (HsArrForm new_op fixity new_args src_loc)
666 zonkCmdTop :: ZonkEnv -> TcCmdTop -> TcM TypecheckedHsCmdTop
667 zonkCmdTop env (HsCmdTop cmd stack_tys ty ids)
668 = zonkExpr env cmd `thenM` \ new_cmd ->
669 mappM (zonkTcTypeToType env) stack_tys
670 `thenM` \ new_stack_tys ->
671 zonkTcTypeToType env ty `thenM` \ new_ty ->
672 zonkReboundNames env ids `thenM` \ new_ids ->
673 returnM (HsCmdTop new_cmd new_stack_tys new_ty new_ids)
675 -------------------------------------------------------------------------
676 zonkReboundNames :: ZonkEnv -> ReboundNames Id -> TcM (ReboundNames Id)
677 zonkReboundNames env prs
680 zonk (n, e) = zonkExpr env e `thenM` \ new_e ->
684 -------------------------------------------------------------------------
685 zonkArithSeq :: ZonkEnv -> TcArithSeqInfo -> TcM TypecheckedArithSeqInfo
687 zonkArithSeq env (From e)
688 = zonkExpr env e `thenM` \ new_e ->
691 zonkArithSeq env (FromThen e1 e2)
692 = zonkExpr env e1 `thenM` \ new_e1 ->
693 zonkExpr env e2 `thenM` \ new_e2 ->
694 returnM (FromThen new_e1 new_e2)
696 zonkArithSeq env (FromTo e1 e2)
697 = zonkExpr env e1 `thenM` \ new_e1 ->
698 zonkExpr env e2 `thenM` \ new_e2 ->
699 returnM (FromTo new_e1 new_e2)
701 zonkArithSeq env (FromThenTo e1 e2 e3)
702 = zonkExpr env e1 `thenM` \ new_e1 ->
703 zonkExpr env e2 `thenM` \ new_e2 ->
704 zonkExpr env e3 `thenM` \ new_e3 ->
705 returnM (FromThenTo new_e1 new_e2 new_e3)
708 -------------------------------------------------------------------------
709 zonkStmts :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt]
711 zonkStmts env stmts = zonk_stmts env stmts `thenM` \ (_, stmts) ->
714 zonk_stmts :: ZonkEnv -> [TcStmt] -> TcM (ZonkEnv, [TypecheckedStmt])
716 zonk_stmts env [] = returnM (env, [])
718 zonk_stmts env (ParStmt stmts_w_bndrs : stmts)
719 = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs ->
721 new_binders = concat (map snd new_stmts_w_bndrs)
722 env1 = extendZonkEnv env new_binders
724 zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
725 returnM (env2, ParStmt new_stmts_w_bndrs : new_stmts)
727 zonk_branch (stmts, bndrs) = zonk_stmts env stmts `thenM` \ (env1, new_stmts) ->
728 returnM (new_stmts, zonkIdOccs env1 bndrs)
730 zonk_stmts env (RecStmt segStmts lvs rvs rets : stmts)
731 = zonkIdBndrs env rvs `thenM` \ new_rvs ->
733 env1 = extendZonkEnv env new_rvs
735 zonk_stmts env1 segStmts `thenM` \ (env2, new_segStmts) ->
736 -- Zonk the ret-expressions in an envt that
737 -- has the polymorphic bindings in the envt
738 zonkExprs env2 rets `thenM` \ new_rets ->
740 new_lvs = zonkIdOccs env2 lvs
741 env3 = extendZonkEnv env new_lvs -- Only the lvs are needed
743 zonk_stmts env3 stmts `thenM` \ (env4, new_stmts) ->
744 returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets : new_stmts)
746 zonk_stmts env (ResultStmt expr locn : stmts)
747 = ASSERT( null stmts )
748 zonkExpr env expr `thenM` \ new_expr ->
749 returnM (env, [ResultStmt new_expr locn])
751 zonk_stmts env (ExprStmt expr ty locn : stmts)
752 = zonkExpr env expr `thenM` \ new_expr ->
753 zonkTcTypeToType env ty `thenM` \ new_ty ->
754 zonk_stmts env stmts `thenM` \ (env1, new_stmts) ->
755 returnM (env1, ExprStmt new_expr new_ty locn : new_stmts)
757 zonk_stmts env (LetStmt binds : stmts)
758 = zonkBinds env binds `thenM` \ (env1, new_binds) ->
759 zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
760 returnM (env2, LetStmt new_binds : new_stmts)
762 zonk_stmts env (BindStmt pat expr locn : stmts)
763 = zonkExpr env expr `thenM` \ new_expr ->
764 zonkPat env pat `thenM` \ (new_pat, new_ids) ->
766 env1 = extendZonkEnv env (bagToList new_ids)
768 zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) ->
769 returnM (env2, BindStmt new_pat new_expr locn : new_stmts)
773 -------------------------------------------------------------------------
774 zonkRbinds :: ZonkEnv -> TcRecordBinds -> TcM TypecheckedRecordBinds
776 zonkRbinds env rbinds
777 = mappM zonk_rbind rbinds
779 zonk_rbind (field, expr)
780 = zonkExpr env expr `thenM` \ new_expr ->
781 returnM (zonkIdOcc env field, new_expr)
783 -------------------------------------------------------------------------
784 mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
785 mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r)
786 mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r)
790 %************************************************************************
792 \subsection[BackSubst-Pats]{Patterns}
794 %************************************************************************
797 zonkPat :: ZonkEnv -> TcPat -> TcM (TypecheckedPat, Bag Id)
799 zonkPat env (ParPat p)
800 = zonkPat env p `thenM` \ (new_p, ids) ->
801 returnM (ParPat new_p, ids)
803 zonkPat env (WildPat ty)
804 = zonkTcTypeToType env ty `thenM` \ new_ty ->
805 returnM (WildPat new_ty, emptyBag)
807 zonkPat env (VarPat v)
808 = zonkIdBndr env v `thenM` \ new_v ->
809 returnM (VarPat new_v, unitBag new_v)
811 zonkPat env (LazyPat pat)
812 = zonkPat env pat `thenM` \ (new_pat, ids) ->
813 returnM (LazyPat new_pat, ids)
815 zonkPat env (AsPat n pat)
816 = zonkIdBndr env n `thenM` \ new_n ->
817 zonkPat env pat `thenM` \ (new_pat, ids) ->
818 returnM (AsPat new_n new_pat, new_n `consBag` ids)
820 zonkPat env (ListPat pats ty)
821 = zonkTcTypeToType env ty `thenM` \ new_ty ->
822 zonkPats env pats `thenM` \ (new_pats, ids) ->
823 returnM (ListPat new_pats new_ty, ids)
825 zonkPat env (PArrPat pats ty)
826 = zonkTcTypeToType env ty `thenM` \ new_ty ->
827 zonkPats env pats `thenM` \ (new_pats, ids) ->
828 returnM (PArrPat new_pats new_ty, ids)
830 zonkPat env (TuplePat pats boxed)
831 = zonkPats env pats `thenM` \ (new_pats, ids) ->
832 returnM (TuplePat new_pats boxed, ids)
834 zonkPat env (ConPatOut n stuff ty tvs dicts)
835 = zonkTcTypeToType env ty `thenM` \ new_ty ->
836 mappM zonkTcTyVarToTyVar tvs `thenM` \ new_tvs ->
837 zonkIdBndrs env dicts `thenM` \ new_dicts ->
839 env1 = extendZonkEnv env new_dicts
841 zonkConStuff env stuff `thenM` \ (new_stuff, ids) ->
842 returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts,
843 listToBag new_dicts `unionBags` ids)
845 zonkPat env (LitPat lit) = returnM (LitPat lit, emptyBag)
847 zonkPat env (SigPatOut pat ty expr)
848 = zonkPat env pat `thenM` \ (new_pat, ids) ->
849 zonkTcTypeToType env ty `thenM` \ new_ty ->
850 zonkExpr env expr `thenM` \ new_expr ->
851 returnM (SigPatOut new_pat new_ty new_expr, ids)
853 zonkPat env (NPatOut lit ty expr)
854 = zonkTcTypeToType env ty `thenM` \ new_ty ->
855 zonkExpr env expr `thenM` \ new_expr ->
856 returnM (NPatOut lit new_ty new_expr, emptyBag)
858 zonkPat env (NPlusKPatOut n k e1 e2)
859 = zonkIdBndr env n `thenM` \ new_n ->
860 zonkExpr env e1 `thenM` \ new_e1 ->
861 zonkExpr env e2 `thenM` \ new_e2 ->
862 returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag new_n)
864 zonkPat env (DictPat ds ms)
865 = zonkIdBndrs env ds `thenM` \ new_ds ->
866 zonkIdBndrs env ms `thenM` \ new_ms ->
867 returnM (DictPat new_ds new_ms,
868 listToBag new_ds `unionBags` listToBag new_ms)
870 ---------------------------
871 zonkConStuff env (PrefixCon pats)
872 = zonkPats env pats `thenM` \ (new_pats, ids) ->
873 returnM (PrefixCon new_pats, ids)
875 zonkConStuff env (InfixCon p1 p2)
876 = zonkPat env p1 `thenM` \ (new_p1, ids1) ->
877 zonkPat env p2 `thenM` \ (new_p2, ids2) ->
878 returnM (InfixCon new_p1 new_p2, ids1 `unionBags` ids2)
880 zonkConStuff env (RecCon rpats)
881 = mapAndUnzipM zonk_rpat rpats `thenM` \ (new_rpats, ids_s) ->
882 returnM (RecCon new_rpats, unionManyBags ids_s)
885 = zonkPat env pat `thenM` \ (new_pat, ids) ->
886 returnM ((f, new_pat), ids)
888 ---------------------------
890 = returnM ([], emptyBag)
892 zonkPats env (pat:pats)
893 = zonkPat env pat `thenM` \ (pat', ids1) ->
894 zonkPats env pats `thenM` \ (pats', ids2) ->
895 returnM (pat':pats', ids1 `unionBags` ids2)
898 %************************************************************************
900 \subsection[BackSubst-Foreign]{Foreign exports}
902 %************************************************************************
906 zonkForeignExports :: ZonkEnv -> [TcForeignDecl] -> TcM [TypecheckedForeignDecl]
907 zonkForeignExports env ls = mappM (zonkForeignExport env) ls
909 zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl)
910 zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) =
911 returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc)
912 zonkForeignExport env for_imp
913 = returnM for_imp -- Foreign imports don't need zonking
917 zonkRules :: ZonkEnv -> [TcRuleDecl] -> TcM [TypecheckedRuleDecl]
918 zonkRules env rs = mappM (zonkRule env) rs
920 zonkRule env (HsRule name act vars lhs rhs loc)
921 = mappM zonk_bndr vars `thenM` \ new_bndrs ->
922 newMutVar emptyVarSet `thenM` \ unbound_tv_set ->
924 env_rhs = extendZonkEnv env (filter isId new_bndrs)
925 -- Type variables don't need an envt
926 -- They are bound through the mutable mechanism
928 env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
929 -- We need to gather the type variables mentioned on the LHS so we can
930 -- quantify over them. Example:
936 -- {-# RULES "myrule" foo C = 1 #-}
938 -- After type checking the LHS becomes (foo a (C a))
939 -- and we do not want to zap the unbound tyvar 'a' to (), because
940 -- that limits the applicability of the rule. Instead, we
941 -- want to quantify over it!
943 -- It's easiest to find the free tyvars here. Attempts to do so earlier
944 -- are tiresome, because (a) the data type is big and (b) finding the
945 -- free type vars of an expression is necessarily monadic operation.
946 -- (consider /\a -> f @ b, where b is side-effected to a)
948 zonkExpr env_lhs lhs `thenM` \ new_lhs ->
949 zonkExpr env_rhs rhs `thenM` \ new_rhs ->
951 readMutVar unbound_tv_set `thenM` \ unbound_tvs ->
953 final_bndrs = map RuleBndr (varSetElems unbound_tvs ++ new_bndrs)
954 -- I hate this map RuleBndr stuff
956 returnM (HsRule name act final_bndrs new_lhs new_rhs loc)
958 zonk_bndr (RuleBndr v)
959 | isId v = zonkIdBndr env v
960 | otherwise = zonkTcTyVarToTyVar v
962 zonkRule env (IfaceRuleOut fun rule)
963 = returnM (IfaceRuleOut (zonkIdOcc env fun) rule)
967 %************************************************************************
969 \subsection[BackSubst-Foreign]{Foreign exports}
971 %************************************************************************
974 zonkTcTypeToType :: ZonkEnv -> TcType -> TcM Type
975 zonkTcTypeToType (ZonkEnv zonk_ty _) ty = zonk_ty ty
977 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
978 -- This variant collects unbound type variables in a mutable variable
979 zonkTypeCollecting unbound_tv_set
980 = zonkType zonk_unbound_tyvar
982 zonk_unbound_tyvar tv
983 = zonkTcTyVarToTyVar tv `thenM` \ tv' ->
984 readMutVar unbound_tv_set `thenM` \ tv_set ->
985 writeMutVar unbound_tv_set (extendVarSet tv_set tv') `thenM_`
986 return (mkTyVarTy tv')
988 zonkTypeZapping :: TcType -> TcM Type
989 -- This variant is used for everything except the LHS of rules
990 -- It zaps unbound type variables to (), or some other arbitrary type
992 = zonkType zonk_unbound_tyvar ty
994 -- Zonk a mutable but unbound type variable to an arbitrary type
995 -- We know it's unbound even though we don't carry an environment,
996 -- because at the binding site for a type variable we bind the
997 -- mutable tyvar to a fresh immutable one. So the mutable store
998 -- plays the role of an environment. If we come across a mutable
999 -- type variable that isn't so bound, it must be completely free.
1000 zonk_unbound_tyvar tv = putTcTyVar tv (mkArbitraryType tv)
1003 -- When the type checker finds a type variable with no binding,
1004 -- which means it can be instantiated with an arbitrary type, it
1005 -- usually instantiates it to Void. Eg.
1009 -- length Void (Nil Void)
1011 -- But in really obscure programs, the type variable might have
1012 -- a kind other than *, so we need to invent a suitably-kinded type.
1016 -- List for kind *->*
1017 -- Tuple for kind *->...*->*
1019 -- which deals with most cases. (Previously, it only dealt with
1022 -- In the other cases, it just makes up a TyCon with a suitable
1023 -- kind. If this gets into an interface file, anyone reading that
1024 -- file won't understand it. This is fixable (by making the client
1025 -- of the interface file make up a TyCon too) but it is tiresome and
1026 -- never happens, so I am leaving it
1028 mkArbitraryType :: TcTyVar -> Type
1029 -- Make up an arbitrary type whose kind is the same as the tyvar.
1030 -- We'll use this to instantiate the (unbound) tyvar.
1032 | isAnyTypeKind kind = voidTy -- The vastly common case
1033 | otherwise = mkTyConApp tycon []
1036 (args,res) = Type.splitFunTys kind -- Kinds are simple; use Type.splitFunTys
1038 tycon | kind `eqKind` tyConKind listTyCon -- *->*
1039 = listTyCon -- No tuples this size
1041 | all isTypeKind args && isTypeKind res
1042 = tupleTyCon Boxed (length args) -- *-> ... ->*->*
1045 = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
1046 mkPrimTyCon tc_name kind 0 [] VoidRep
1047 -- Same name as the tyvar, apart from making it start with a colon (sigh)
1048 -- I dread to think what will happen if this gets out into an
1049 -- interface file. Catastrophe likely. Major sigh.
1051 tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc