X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcHsSyn.lhs;h=3c86baf7eb4dd6d444395d4795c3cf4eab7e50db;hb=ca5a4a480d10d61e5b7a52eb4d556e8b8c33e69d;hp=005fec5b706127e0256d88bc3458e27ce7f5ffd8;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 005fec5..3c86baf 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -10,16 +10,22 @@ checker. module TcHsSyn ( TcIdBndr(..), TcIdOcc(..), - TcMonoBinds(..), TcHsBinds(..), TcBind(..), TcPat(..), TcExpr(..), TcGRHSsAndBinds(..), - TcGRHS(..), TcMatch(..), TcQual(..), TcStmt(..), TcArithSeqInfo(..), TcHsModule(..), + TcMonoBinds(..), TcHsBinds(..), TcBind(..), TcPat(..), + TcExpr(..), TcGRHSsAndBinds(..), TcGRHS(..), TcMatch(..), + TcQual(..), TcStmt(..), TcArithSeqInfo(..), TcRecordBinds(..), + TcHsModule(..), - TypecheckedHsBinds(..), TypecheckedBind(..), TypecheckedMonoBinds(..), - TypecheckedPat(..), TypecheckedHsExpr(..), TypecheckedArithSeqInfo(..), - TypecheckedQual(..), TypecheckedStmt(..), TypecheckedMatch(..), - TypecheckedHsModule(..), TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..), + TypecheckedHsBinds(..), TypecheckedBind(..), + TypecheckedMonoBinds(..), TypecheckedPat(..), + TypecheckedHsExpr(..), TypecheckedArithSeqInfo(..), + TypecheckedQual(..), TypecheckedStmt(..), + TypecheckedMatch(..), TypecheckedHsModule(..), + TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..), + TypecheckedRecordBinds(..), mkHsTyApp, mkHsDictApp, mkHsTyLam, mkHsDictLam, + tcIdType, zonkBinds, zonkInst, @@ -32,11 +38,11 @@ import Ubiq{-uitous-} -- friends: import HsSyn -- oodles of it import Id ( GenId(..), IdDetails, PragmaInfo, -- Can meddle modestly with Ids - DictVar(..) + DictVar(..), idType ) -- others: -import TcMonad +import TcMonad hiding ( rnMtoTcM ) import TcType ( TcType(..), TcMaybe, TcTyVar(..), zonkTcTypeToType, zonkTcTyVarToTyVar, tcInstType @@ -76,6 +82,7 @@ type TcMatch s = Match (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TcQual s = Qual (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TcStmt s = Stmt (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TcArithSeqInfo s = ArithSeqInfo (TcTyVar s) UVar (TcIdOcc s) (TcPat s) +type TcRecordBinds s = HsRecordBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TcHsModule s = HsModule (TcTyVar s) UVar (TcIdOcc s) (TcPat s) type TypecheckedPat = OutPat TyVar UVar Id @@ -89,6 +96,7 @@ type TypecheckedStmt = Stmt TyVar UVar Id TypecheckedPat type TypecheckedMatch = Match TyVar UVar Id TypecheckedPat type TypecheckedGRHSsAndBinds = GRHSsAndBinds TyVar UVar Id TypecheckedPat type TypecheckedGRHS = GRHS TyVar UVar Id TypecheckedPat +type TypecheckedRecordBinds = HsRecordBinds TyVar UVar Id TypecheckedPat type TypecheckedHsModule = HsModule TyVar UVar Id TypecheckedPat \end{code} @@ -104,6 +112,10 @@ mkHsTyLam tyvars expr = TyLam tyvars expr mkHsDictLam [] expr = expr mkHsDictLam dicts expr = DictLam dicts expr + +tcIdType :: TcIdOcc s -> TcType s +tcIdType (TcId id) = idType id +tcIdType other = panic "tcIdType" \end{code} @@ -112,14 +124,15 @@ mkHsDictLam dicts expr = DictLam dicts expr instance Eq (TcIdOcc s) where (TcId id1) == (TcId id2) = id1 == id2 (RealId id1) == (RealId id2) = id1 == id2 + _ == _ = False instance Outputable (TcIdOcc s) where ppr sty (TcId id) = ppr sty id ppr sty (RealId id) = ppr sty id instance NamedThing (TcIdOcc s) where - getOccurrenceName (TcId id) = getOccurrenceName id - getOccurrenceName (RealId id) = getOccurrenceName id + getName (TcId id) = getName id + getName (RealId id) = getName id \end{code} @@ -219,10 +232,10 @@ zonkMonoBinds (VarMonoBind var expr) zonkExpr expr `thenNF_Tc` \ new_expr -> returnNF_Tc (VarMonoBind new_var new_expr) -zonkMonoBinds (FunMonoBind name ms locn) +zonkMonoBinds (FunMonoBind name inf ms locn) = zonkId name `thenNF_Tc` \ new_name -> mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms -> - returnNF_Tc (FunMonoBind new_name new_ms locn) + returnNF_Tc (FunMonoBind new_name inf new_ms locn) \end{code} %************************************************************************ @@ -243,6 +256,10 @@ zonkMatch (GRHSMatch grhss_w_binds) = zonkGRHSsAndBinds grhss_w_binds `thenNF_Tc` \ new_grhss_w_binds -> returnNF_Tc (GRHSMatch new_grhss_w_binds) +zonkMatch (SimpleMatch expr) + = zonkExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (SimpleMatch new_expr) + ------------------------------------------------------------------------- zonkGRHSsAndBinds :: TcGRHSsAndBinds s -> NF_TcM s TypecheckedGRHSsAndBinds @@ -269,8 +286,6 @@ zonkGRHSsAndBinds (GRHSsAndBindsOut grhss binds ty) %* * %************************************************************************ -ToDo: panic on things that can't be in @TypecheckedHsExpr@. - \begin{code} zonkExpr :: TcExpr s -> NF_TcM s TypecheckedHsExpr @@ -278,6 +293,8 @@ zonkExpr (HsVar name) = zonkId name `thenNF_Tc` \ new_name -> returnNF_Tc (HsVar new_name) +zonkExpr (HsLit _) = panic "zonkExpr:HsLit" + zonkExpr (HsLitOut lit ty) = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> returnNF_Tc (HsLitOut lit new_ty) @@ -297,6 +314,9 @@ zonkExpr (OpApp e1 op e2) zonkExpr e2 `thenNF_Tc` \ new_e2 -> returnNF_Tc (OpApp new_e1 new_op new_e2) +zonkExpr (NegApp _ _) = panic "zonkExpr:NegApp" +zonkExpr (HsPar _) = panic "zonkExpr:HsPar" + zonkExpr (SectionL expr op) = zonkExpr expr `thenNF_Tc` \ new_expr -> zonkExpr op `thenNF_Tc` \ new_op -> @@ -307,25 +327,24 @@ zonkExpr (SectionR op expr) zonkExpr expr `thenNF_Tc` \ new_expr -> returnNF_Tc (SectionR new_op new_expr) -zonkExpr (CCall fun args may_gc is_casm result_ty) - = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args -> - zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty -> - returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty) - -zonkExpr (HsSCC label expr) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc (HsSCC label new_expr) - zonkExpr (HsCase expr ms src_loc) = zonkExpr expr `thenNF_Tc` \ new_expr -> mapNF_Tc zonkMatch ms `thenNF_Tc` \ new_ms -> returnNF_Tc (HsCase new_expr new_ms src_loc) +zonkExpr (HsIf e1 e2 e3 src_loc) + = zonkExpr e1 `thenNF_Tc` \ new_e1 -> + zonkExpr e2 `thenNF_Tc` \ new_e2 -> + zonkExpr e3 `thenNF_Tc` \ new_e3 -> + returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc) + zonkExpr (HsLet binds expr) = zonkBinds binds `thenNF_Tc` \ new_binds -> zonkExpr expr `thenNF_Tc` \ new_expr -> returnNF_Tc (HsLet new_binds new_expr) +zonkExpr (HsDo _ _) = panic "zonkExpr:HsDo" + zonkExpr (HsDoOut stmts m_id mz_id src_loc) = zonkStmts stmts `thenNF_Tc` \ new_stmts -> zonkId m_id `thenNF_Tc` \ m_new -> @@ -337,7 +356,7 @@ zonkExpr (ListComp expr quals) zonkQuals quals `thenNF_Tc` \ new_quals -> returnNF_Tc (ListComp new_expr new_quals) ---ExplicitList: not in typechecked exprs +zonkExpr (ExplicitList _) = panic "zonkExpr:ExplicitList" zonkExpr (ExplicitListOut ty exprs) = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> @@ -349,21 +368,35 @@ zonkExpr (ExplicitTuple exprs) returnNF_Tc (ExplicitTuple new_exprs) zonkExpr (RecordCon con rbinds) - = panic "zonkExpr:RecordCon" -zonkExpr (RecordUpd exp rbinds) - = panic "zonkExpr:RecordUpd" + = zonkExpr con `thenNF_Tc` \ new_con -> + zonkRbinds rbinds `thenNF_Tc` \ new_rbinds -> + returnNF_Tc (RecordCon new_con new_rbinds) -zonkExpr (HsIf e1 e2 e3 src_loc) - = zonkExpr e1 `thenNF_Tc` \ new_e1 -> - zonkExpr e2 `thenNF_Tc` \ new_e2 -> - zonkExpr e3 `thenNF_Tc` \ new_e3 -> - returnNF_Tc (HsIf new_e1 new_e2 new_e3 src_loc) +zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd" + +zonkExpr (RecordUpdOut expr ids rbinds) + = zonkExpr expr `thenNF_Tc` \ new_expr -> + mapNF_Tc zonkId ids `thenNF_Tc` \ new_ids -> + zonkRbinds rbinds `thenNF_Tc` \ new_rbinds -> + returnNF_Tc (RecordUpdOut new_expr new_ids new_rbinds) + +zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig" +zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn" zonkExpr (ArithSeqOut expr info) = zonkExpr expr `thenNF_Tc` \ new_expr -> zonkArithSeq info `thenNF_Tc` \ new_info -> returnNF_Tc (ArithSeqOut new_expr new_info) +zonkExpr (CCall fun args may_gc is_casm result_ty) + = mapNF_Tc zonkExpr args `thenNF_Tc` \ new_args -> + zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty -> + returnNF_Tc (CCall fun new_args may_gc is_casm new_result_ty) + +zonkExpr (HsSCC label expr) + = zonkExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (HsSCC label new_expr) + zonkExpr (TyLam tyvars expr) = mapNF_Tc zonkTcTyVarToTyVar tyvars `thenNF_Tc` \ new_tyvars -> zonkExpr expr `thenNF_Tc` \ new_expr -> @@ -399,6 +432,11 @@ zonkExpr (SingleDict name) = zonkId name `thenNF_Tc` \ new_name -> returnNF_Tc (SingleDict new_name) +zonkExpr (HsCon con tys vargs) + = mapNF_Tc zonkTcTypeToType tys `thenNF_Tc` \ new_tys -> + mapNF_Tc zonkExpr vargs `thenNF_Tc` \ new_vargs -> + returnNF_Tc (HsCon con new_tys new_vargs) + ------------------------------------------------------------------------- zonkArithSeq :: TcArithSeqInfo s -> NF_TcM s TypecheckedArithSeqInfo @@ -459,6 +497,17 @@ zonkStmts stmts zonk_stmt (LetStmt binds) = zonkBinds binds `thenNF_Tc` \ new_binds -> returnNF_Tc (LetStmt new_binds) + +------------------------------------------------------------------------- +zonkRbinds :: TcRecordBinds s -> NF_TcM s TypecheckedRecordBinds + +zonkRbinds rbinds + = mapNF_Tc zonk_rbind rbinds + where + zonk_rbind (field, expr, pun) + = zonkId field `thenNF_Tc` \ new_field -> + zonkExpr expr `thenNF_Tc` \ new_expr -> + returnNF_Tc (new_field, new_expr, pun) \end{code} %************************************************************************ @@ -504,9 +553,18 @@ zonkPat (ListPat ty pats) returnNF_Tc (ListPat new_ty new_pats) zonkPat (TuplePat pats) - = mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats -> + = mapNF_Tc zonkPat pats `thenNF_Tc` \ new_pats -> returnNF_Tc (TuplePat new_pats) +zonkPat (RecPat n ty rpats) + = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> + mapNF_Tc zonk_rpat rpats `thenNF_Tc` \ new_rpats -> + returnNF_Tc (RecPat n new_ty new_rpats) + where + zonk_rpat (f, pat, pun) + = zonkPat pat `thenNF_Tc` \ new_pat -> + returnNF_Tc (f, new_pat, pun) + zonkPat (LitPat lit ty) = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> returnNF_Tc (LitPat lit new_ty)