2 % (c) The AQUA Project, Glasgow University, 1996
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 TcIdBndr(..), TcIdOcc(..),
13 TcMonoBinds(..), TcHsBinds(..), TcBind(..), TcPat(..),
14 TcExpr(..), TcGRHSsAndBinds(..), TcGRHS(..), TcMatch(..),
15 TcQual(..), TcStmt(..), TcArithSeqInfo(..), TcRecordBinds(..),
18 TypecheckedHsBinds(..), TypecheckedBind(..),
19 TypecheckedMonoBinds(..), TypecheckedPat(..),
20 TypecheckedHsExpr(..), TypecheckedArithSeqInfo(..),
21 TypecheckedQual(..), TypecheckedStmt(..),
22 TypecheckedMatch(..), TypecheckedHsModule(..),
23 TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
25 mkHsTyApp, mkHsDictApp,
26 mkHsTyLam, mkHsDictLam,
31 zonkId, -- TcIdBndr s -> NF_TcM s Id
32 unZonkId -- Id -> NF_TcM s (TcIdBndr s)
38 import HsSyn -- oodles of it
39 import Id ( GenId(..), IdDetails, PragmaInfo, -- Can meddle modestly with Ids
45 import TcType ( TcType(..), TcMaybe, TcTyVar(..),
46 zonkTcTypeToType, zonkTcTyVarToTyVar,
49 import Usage ( UVar(..) )
52 import PprType ( GenType, GenTyVar ) -- instances
53 import TyVar ( GenTyVar ) -- instances
54 import Unique ( Unique ) -- instances
61 The @Tc...@ datatypes are the ones that apply {\em during} type checking.
62 All the types in @Tc...@ things have mutable type-variables in them for
65 At the end of type checking we zonk everything to @Typechecked...@ datatypes,
66 which have immutable type variables in them.
69 type TcIdBndr s = GenId (TcType s) -- Binders are all TcTypes
70 data TcIdOcc s = TcId (TcIdBndr s) -- Bindees may be either
73 type TcHsBinds s = HsBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
74 type TcBind s = Bind (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
75 type TcMonoBinds s = MonoBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
76 type TcPat s = OutPat (TcTyVar s) UVar (TcIdOcc s)
77 type TcExpr s = HsExpr (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
78 type TcGRHSsAndBinds s = GRHSsAndBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
79 type TcGRHS s = GRHS (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
80 type TcMatch s = Match (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
81 type TcQual s = Qual (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
82 type TcStmt s = Stmt (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
83 type TcArithSeqInfo s = ArithSeqInfo (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
84 type TcRecordBinds s = HsRecordBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
85 type TcHsModule s = HsModule (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
87 type TypecheckedPat = OutPat TyVar UVar Id
88 type TypecheckedMonoBinds = MonoBinds TyVar UVar Id TypecheckedPat
89 type TypecheckedHsBinds = HsBinds TyVar UVar Id TypecheckedPat
90 type TypecheckedBind = Bind TyVar UVar Id TypecheckedPat
91 type TypecheckedHsExpr = HsExpr TyVar UVar Id TypecheckedPat
92 type TypecheckedArithSeqInfo = ArithSeqInfo TyVar UVar Id TypecheckedPat
93 type TypecheckedQual = Qual TyVar UVar Id TypecheckedPat
94 type TypecheckedStmt = Stmt TyVar UVar Id TypecheckedPat
95 type TypecheckedMatch = Match TyVar UVar Id TypecheckedPat
96 type TypecheckedGRHSsAndBinds = GRHSsAndBinds TyVar UVar Id TypecheckedPat
97 type TypecheckedGRHS = GRHS TyVar UVar Id TypecheckedPat
98 type TypecheckedHsModule = HsModule TyVar UVar Id TypecheckedPat
102 mkHsTyApp expr [] = expr
103 mkHsTyApp expr tys = TyApp expr tys
105 mkHsDictApp expr [] = expr
106 mkHsDictApp expr dict_vars = DictApp expr dict_vars
108 mkHsTyLam [] expr = expr
109 mkHsTyLam tyvars expr = TyLam tyvars expr
111 mkHsDictLam [] expr = expr
112 mkHsDictLam dicts expr = DictLam dicts expr
114 tcIdType :: TcIdOcc s -> TcType s
115 tcIdType (TcId id) = idType id
116 tcIdType other = panic "tcIdType"
122 instance Eq (TcIdOcc s) where
123 (TcId id1) == (TcId id2) = id1 == id2
124 (RealId id1) == (RealId id2) = id1 == id2
126 instance Outputable (TcIdOcc s) where
127 ppr sty (TcId id) = ppr sty id
128 ppr sty (RealId id) = ppr sty id
130 instance NamedThing (TcIdOcc s) where
131 getOccurrenceName (TcId id) = getOccurrenceName id
132 getOccurrenceName (RealId id) = getOccurrenceName id
136 %************************************************************************
138 \subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
140 %************************************************************************
143 zonkId :: TcIdOcc s -> NF_TcM s Id
144 unZonkId :: Id -> NF_TcM s (TcIdBndr s)
146 zonkId (RealId id) = returnNF_Tc id
148 zonkId (TcId (Id u ty details prags info))
149 = zonkTcTypeToType ty `thenNF_Tc` \ ty' ->
150 returnNF_Tc (Id u ty' details prags info)
152 unZonkId (Id u ty details prags info)
153 = tcInstType [] ty `thenNF_Tc` \ ty' ->
154 returnNF_Tc (Id u ty' details prags info)
158 zonkInst :: (TcIdOcc s, TcExpr s) -> NF_TcM s (Id, TypecheckedHsExpr)
160 = zonkId id `thenNF_Tc` \ id' ->
161 zonkExpr expr `thenNF_Tc` \ expr' ->
162 returnNF_Tc (id', expr')
166 zonkBinds :: TcHsBinds s -> NF_TcM s TypecheckedHsBinds
168 zonkBinds EmptyBinds = returnNF_Tc EmptyBinds
170 zonkBinds (ThenBinds binds1 binds2)
171 = zonkBinds binds1 `thenNF_Tc` \ new_binds1 ->
172 zonkBinds binds2 `thenNF_Tc` \ new_binds2 ->
173 returnNF_Tc (ThenBinds new_binds1 new_binds2)
175 zonkBinds (SingleBind bind)
176 = zonkBind bind `thenNF_Tc` \ new_bind ->
177 returnNF_Tc (SingleBind new_bind)
179 zonkBinds (AbsBinds tyvars dicts locprs dict_binds val_bind)
180 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
181 mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts ->
182 mapNF_Tc subst_pair locprs `thenNF_Tc` \ new_locprs ->
183 mapNF_Tc subst_bind dict_binds `thenNF_Tc` \ new_dict_binds ->
184 zonkBind val_bind `thenNF_Tc` \ new_val_bind ->
185 returnNF_Tc (AbsBinds new_tyvars new_dicts new_locprs new_dict_binds new_val_bind)
188 = zonkId l `thenNF_Tc` \ new_l ->
189 zonkId g `thenNF_Tc` \ new_g ->
190 returnNF_Tc (new_l, new_g)
193 = zonkId v `thenNF_Tc` \ new_v ->
194 zonkExpr e `thenNF_Tc` \ new_e ->
195 returnNF_Tc (new_v, new_e)
199 -------------------------------------------------------------------------
200 zonkBind :: TcBind s -> NF_TcM s TypecheckedBind
202 zonkBind EmptyBind = returnNF_Tc EmptyBind
204 zonkBind (NonRecBind mbinds)
205 = zonkMonoBinds mbinds `thenNF_Tc` \ new_mbinds ->
206 returnNF_Tc (NonRecBind new_mbinds)
208 zonkBind (RecBind mbinds)
209 = zonkMonoBinds mbinds `thenNF_Tc` \ new_mbinds ->
210 returnNF_Tc (RecBind new_mbinds)
212 -------------------------------------------------------------------------
213 zonkMonoBinds :: TcMonoBinds s -> NF_TcM s TypecheckedMonoBinds
215 zonkMonoBinds EmptyMonoBinds = returnNF_Tc EmptyMonoBinds
217 zonkMonoBinds (AndMonoBinds mbinds1 mbinds2)
218 = zonkMonoBinds mbinds1 `thenNF_Tc` \ new_mbinds1 ->
219 zonkMonoBinds mbinds2 `thenNF_Tc` \ new_mbinds2 ->
220 returnNF_Tc (AndMonoBinds new_mbinds1 new_mbinds2)
222 zonkMonoBinds (PatMonoBind pat grhss_w_binds locn)
223 = zonkPat pat `thenNF_Tc` \ new_pat ->
224 zonkGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
225 returnNF_Tc (PatMonoBind new_pat new_grhss_w_binds locn)
227 zonkMonoBinds (VarMonoBind var expr)
228 = zonkId var `thenNF_Tc` \ new_var ->
229 zonkExpr expr `thenNF_Tc` \ new_expr ->
230 returnNF_Tc (VarMonoBind new_var new_expr)
232 zonkMonoBinds (FunMonoBind name ms locn)
233 = zonkId name `thenNF_Tc` \ new_name ->
234 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
235 returnNF_Tc (FunMonoBind new_name new_ms locn)
238 %************************************************************************
240 \subsection[BackSubst-Match-GRHSs]{Match and GRHSsAndBinds}
242 %************************************************************************
245 zonkMatch :: TcMatch s -> NF_TcM s TypecheckedMatch
247 zonkMatch (PatMatch pat match)
248 = zonkPat pat `thenNF_Tc` \ new_pat ->
249 zonkMatch match `thenNF_Tc` \ new_match ->
250 returnNF_Tc (PatMatch new_pat new_match)
252 zonkMatch (GRHSMatch grhss_w_binds)
253 = zonkGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds ->
254 returnNF_Tc (GRHSMatch new_grhss_w_binds)
256 -------------------------------------------------------------------------
257 zonkGRHSsAndBinds :: TcGRHSsAndBinds s
258 -> NF_TcM s TypecheckedGRHSsAndBinds
260 zonkGRHSsAndBinds (GRHSsAndBindsOut grhss binds ty)
261 = mapNF_Tc zonk_grhs grhss `thenNF_Tc` \ new_grhss ->
262 zonkBinds binds `thenNF_Tc` \ new_binds ->
263 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
264 returnNF_Tc (GRHSsAndBindsOut new_grhss new_binds new_ty)
266 zonk_grhs (GRHS guard expr locn)
267 = zonkExpr guard `thenNF_Tc` \ new_guard ->
268 zonkExpr expr `thenNF_Tc` \ new_expr ->
269 returnNF_Tc (GRHS new_guard new_expr locn)
271 zonk_grhs (OtherwiseGRHS expr locn)
272 = zonkExpr expr `thenNF_Tc` \ new_expr ->
273 returnNF_Tc (OtherwiseGRHS new_expr locn)
276 %************************************************************************
278 \subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
280 %************************************************************************
282 ToDo: panic on things that can't be in @TypecheckedHsExpr@.
285 zonkExpr :: TcExpr s -> NF_TcM s TypecheckedHsExpr
287 zonkExpr (HsVar name)
288 = zonkId name `thenNF_Tc` \ new_name ->
289 returnNF_Tc (HsVar new_name)
291 zonkExpr (HsLitOut lit ty)
292 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
293 returnNF_Tc (HsLitOut lit new_ty)
295 zonkExpr (HsLam match)
296 = zonkMatch match `thenNF_Tc` \ new_match ->
297 returnNF_Tc (HsLam new_match)
299 zonkExpr (HsApp e1 e2)
300 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
301 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
302 returnNF_Tc (HsApp new_e1 new_e2)
304 zonkExpr (OpApp e1 op e2)
305 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
306 zonkExpr op `thenNF_Tc` \ new_op ->
307 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
308 returnNF_Tc (OpApp new_e1 new_op new_e2)
310 zonkExpr (SectionL expr op)
311 = zonkExpr expr `thenNF_Tc` \ new_expr ->
312 zonkExpr op `thenNF_Tc` \ new_op ->
313 returnNF_Tc (SectionL new_expr new_op)
315 zonkExpr (SectionR op expr)
316 = zonkExpr op `thenNF_Tc` \ new_op ->
317 zonkExpr expr `thenNF_Tc` \ new_expr ->
318 returnNF_Tc (SectionR new_op new_expr)
320 zonkExpr (CCall fun args may_gc is_casm result_ty)
321 = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args ->
322 zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
323 returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty)
325 zonkExpr (HsSCC label expr)
326 = zonkExpr expr `thenNF_Tc` \ new_expr ->
327 returnNF_Tc (HsSCC label new_expr)
329 zonkExpr (HsCase expr ms src_loc)
330 = zonkExpr expr `thenNF_Tc` \ new_expr ->
331 mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms ->
332 returnNF_Tc (HsCase new_expr new_ms src_loc)
334 zonkExpr (HsLet binds expr)
335 = zonkBinds binds `thenNF_Tc` \ new_binds ->
336 zonkExpr expr `thenNF_Tc` \ new_expr ->
337 returnNF_Tc (HsLet new_binds new_expr)
339 zonkExpr (HsDoOut stmts m_id mz_id src_loc)
340 = zonkStmts stmts `thenNF_Tc` \ new_stmts ->
341 zonkId m_id `thenNF_Tc` \ m_new ->
342 zonkId mz_id `thenNF_Tc` \ mz_new ->
343 returnNF_Tc (HsDoOut new_stmts m_new mz_new src_loc)
345 zonkExpr (ListComp expr quals)
346 = zonkExpr expr `thenNF_Tc` \ new_expr ->
347 zonkQuals quals `thenNF_Tc` \ new_quals ->
348 returnNF_Tc (ListComp new_expr new_quals)
350 --ExplicitList: not in typechecked exprs
352 zonkExpr (ExplicitListOut ty exprs)
353 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
354 mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
355 returnNF_Tc (ExplicitListOut new_ty new_exprs)
357 zonkExpr (ExplicitTuple exprs)
358 = mapNF_Tc zonkExpr exprs `thenNF_Tc` \ new_exprs ->
359 returnNF_Tc (ExplicitTuple new_exprs)
361 zonkExpr (RecordCon con rbinds)
362 = panic "zonkExpr:RecordCon"
363 zonkExpr (RecordUpd exp rbinds)
364 = panic "zonkExpr:RecordUpd"
366 zonkExpr (HsIf e1 e2 e3 src_loc)
367 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
368 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
369 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
370 returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc)
372 zonkExpr (ArithSeqOut expr info)
373 = zonkExpr expr `thenNF_Tc` \ new_expr ->
374 zonkArithSeq info `thenNF_Tc` \ new_info ->
375 returnNF_Tc (ArithSeqOut new_expr new_info)
377 zonkExpr (TyLam tyvars expr)
378 = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars ->
379 zonkExpr expr `thenNF_Tc` \ new_expr ->
380 returnNF_Tc (TyLam new_tyvars new_expr)
382 zonkExpr (TyApp expr tys)
383 = zonkExpr expr `thenNF_Tc` \ new_expr ->
384 mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys ->
385 returnNF_Tc (TyApp new_expr new_tys)
387 zonkExpr (DictLam dicts expr)
388 = mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts ->
389 zonkExpr expr `thenNF_Tc` \ new_expr ->
390 returnNF_Tc (DictLam new_dicts new_expr)
392 zonkExpr (DictApp expr dicts)
393 = zonkExpr expr `thenNF_Tc` \ new_expr ->
394 mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts ->
395 returnNF_Tc (DictApp new_expr new_dicts)
397 zonkExpr (ClassDictLam dicts methods expr)
398 = mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts ->
399 mapNF_Tc zonkId methods `thenNF_Tc` \ new_methods ->
400 zonkExpr expr `thenNF_Tc` \ new_expr ->
401 returnNF_Tc (ClassDictLam new_dicts new_methods new_expr)
403 zonkExpr (Dictionary dicts methods)
404 = mapNF_Tc zonkId dicts `thenNF_Tc` \ new_dicts ->
405 mapNF_Tc zonkId methods `thenNF_Tc` \ new_methods ->
406 returnNF_Tc (Dictionary new_dicts new_methods)
408 zonkExpr (SingleDict name)
409 = zonkId name `thenNF_Tc` \ new_name ->
410 returnNF_Tc (SingleDict new_name)
412 -------------------------------------------------------------------------
413 zonkArithSeq :: TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo
415 zonkArithSeq (From e)
416 = zonkExpr e `thenNF_Tc` \ new_e ->
417 returnNF_Tc (From new_e)
419 zonkArithSeq (FromThen e1 e2)
420 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
421 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
422 returnNF_Tc (FromThen new_e1 new_e2)
424 zonkArithSeq (FromTo e1 e2)
425 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
426 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
427 returnNF_Tc (FromTo new_e1 new_e2)
429 zonkArithSeq (FromThenTo e1 e2 e3)
430 = zonkExpr e1 `thenNF_Tc` \ new_e1 ->
431 zonkExpr e2 `thenNF_Tc` \ new_e2 ->
432 zonkExpr e3 `thenNF_Tc` \ new_e3 ->
433 returnNF_Tc (FromThenTo new_e1 new_e2 new_e3)
435 -------------------------------------------------------------------------
436 zonkQuals :: [TcQual s] -> NF_TcM s [TypecheckedQual]
439 = mapNF_Tc zonk_qual quals
441 zonk_qual (GeneratorQual pat expr)
442 = zonkPat pat `thenNF_Tc` \ new_pat ->
443 zonkExpr expr `thenNF_Tc` \ new_expr ->
444 returnNF_Tc (GeneratorQual new_pat new_expr)
446 zonk_qual (FilterQual expr)
447 = zonkExpr expr `thenNF_Tc` \ new_expr ->
448 returnNF_Tc (FilterQual new_expr)
450 zonk_qual (LetQual binds)
451 = zonkBinds binds `thenNF_Tc` \ new_binds ->
452 returnNF_Tc (LetQual new_binds)
454 -------------------------------------------------------------------------
455 zonkStmts :: [TcStmt s] -> NF_TcM s [TypecheckedStmt]
458 = mapNF_Tc zonk_stmt stmts
460 zonk_stmt (BindStmt pat expr src_loc)
461 = zonkPat pat `thenNF_Tc` \ new_pat ->
462 zonkExpr expr `thenNF_Tc` \ new_expr ->
463 returnNF_Tc (BindStmt new_pat new_expr src_loc)
465 zonk_stmt (ExprStmt expr src_loc)
466 = zonkExpr expr `thenNF_Tc` \ new_expr ->
467 returnNF_Tc (ExprStmt new_expr src_loc)
469 zonk_stmt (LetStmt binds)
470 = zonkBinds binds `thenNF_Tc` \ new_binds ->
471 returnNF_Tc (LetStmt new_binds)
474 %************************************************************************
476 \subsection[BackSubst-Pats]{Patterns}
478 %************************************************************************
481 zonkPat :: TcPat s -> NF_TcM s TypecheckedPat
484 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
485 returnNF_Tc (WildPat new_ty)
488 = zonkId v `thenNF_Tc` \ new_v ->
489 returnNF_Tc (VarPat new_v)
491 zonkPat (LazyPat pat)
492 = zonkPat pat `thenNF_Tc` \ new_pat ->
493 returnNF_Tc (LazyPat new_pat)
495 zonkPat (AsPat n pat)
496 = zonkId n `thenNF_Tc` \ new_n ->
497 zonkPat pat `thenNF_Tc` \ new_pat ->
498 returnNF_Tc (AsPat new_n new_pat)
500 zonkPat (ConPat n ty pats)
501 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
502 mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats ->
503 returnNF_Tc (ConPat n new_ty new_pats)
505 zonkPat (ConOpPat pat1 op pat2 ty)
506 = zonkPat pat1 `thenNF_Tc` \ new_pat1 ->
507 zonkPat pat2 `thenNF_Tc` \ new_pat2 ->
508 zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
509 returnNF_Tc (ConOpPat new_pat1 op new_pat2 new_ty)
511 zonkPat (ListPat ty pats)
512 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
513 mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats ->
514 returnNF_Tc (ListPat new_ty new_pats)
516 zonkPat (TuplePat pats)
517 = mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats ->
518 returnNF_Tc (TuplePat new_pats)
520 zonkPat (LitPat lit ty)
521 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
522 returnNF_Tc (LitPat lit new_ty)
524 zonkPat (NPat lit ty expr)
525 = zonkTcTypeToType ty `thenNF_Tc` \ new_ty ->
526 zonkExpr expr `thenNF_Tc` \ new_expr ->
527 returnNF_Tc (NPat lit new_ty new_expr)
529 zonkPat (DictPat ds ms)
530 = mapNF_Tc zonkId ds `thenNF_Tc` \ new_ds ->
531 mapNF_Tc zonkId ms `thenNF_Tc` \ new_ms ->
532 returnNF_Tc (DictPat new_ds new_ms)