projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 1996-04-30 17:34:02 by partain]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcHsSyn.lhs
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 996658b..d70b25c 100644 (file)
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -21,6 +21,7 @@ module TcHsSyn (
        TypecheckedQual(..), TypecheckedStmt(..),
        TypecheckedMatch(..), TypecheckedHsModule(..),
        TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..),
+       TypecheckedRecordBinds(..),
 
        mkHsTyApp, mkHsDictApp,
        mkHsTyLam, mkHsDictLam,
@@ -95,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}
 
@@ -122,14 +124,15 @@ tcIdType other     = panic "tcIdType"
 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}
 
 
@@ -229,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}
 
 %************************************************************************
@@ -253,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
@@ -279,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
 
@@ -288,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)
@@ -307,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 ->
@@ -317,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 ->
@@ -347,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 ->
@@ -359,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 ->
@@ -409,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
 
@@ -469,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}
 
 %************************************************************************
@@ -514,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)
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)