[project @ 2002-06-05 14:39:27 by simonpj]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcHsSyn.lhs
index fb6634a..3fda515 100644 (file)
@@ -11,7 +11,7 @@ module TcHsSyn (
        TcMonoBinds, TcHsBinds, TcPat,
        TcExpr, TcGRHSs, TcGRHS, TcMatch,
        TcStmt, TcArithSeqInfo, TcRecordBinds,
-       TcHsModule, TcCoreExpr, TcDictBinds,
+       TcHsModule, TcDictBinds,
        TcForeignExportDecl,
        
        TypecheckedHsBinds, TypecheckedRuleDecl,
@@ -21,7 +21,7 @@ module TcHsSyn (
        TypecheckedMatch, TypecheckedHsModule,
        TypecheckedGRHSs, TypecheckedGRHS,
        TypecheckedRecordBinds, TypecheckedDictBinds,
-       TypecheckedMatchContext,
+       TypecheckedMatchContext, TypecheckedCoreBind,
 
        mkHsTyApp, mkHsDictApp, mkHsConApp,
        mkHsTyLam, mkHsDictLam, mkHsLet,
@@ -48,14 +48,14 @@ import TcEnv        ( tcLookupGlobal_maybe, tcExtendGlobalValEnv, TcEnv, TcId )
 
 import TcMonad
 import Type      ( Type )
-import TcType    ( TcType )
-import TcMType   ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars )
+import TcType    ( TcType, tcGetTyVar )
+import TcMType   ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcTyVars )
 import TysPrim   ( charPrimTy, intPrimTy, floatPrimTy,
                    doublePrimTy, addrPrimTy
                  )
 import TysWiredIn ( charTy, stringTy, intTy, integerTy,
-                   mkListTy, mkTupleTy, unitTy )
-import CoreSyn    ( Expr )
+                   mkListTy, mkPArrTy, mkTupleTy, unitTy )
+import CoreSyn    ( Expr(..), CoreExpr, CoreBind, Bind(..), CoreAlt, Note(..) )
 import Var       ( isId )
 import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName )
 import Bag
@@ -88,7 +88,6 @@ type TcArithSeqInfo   = ArithSeqInfo TcId TcPat
 type TcRecordBinds     = HsRecordBinds TcId TcPat
 type TcHsModule        = HsModule TcId TcPat
 
-type TcCoreExpr        = Expr TcId
 type TcForeignExportDecl = ForeignDecl TcId
 type TcRuleDecl         = RuleDecl    TcId TcPat
 
@@ -107,6 +106,7 @@ type TypecheckedRecordBinds = HsRecordBinds Id TypecheckedPat
 type TypecheckedHsModule       = HsModule      Id TypecheckedPat
 type TypecheckedForeignDecl     = ForeignDecl Id
 type TypecheckedRuleDecl       = RuleDecl      Id TypecheckedPat
+type TypecheckedCoreBind        = (Id, CoreExpr)
 \end{code}
 
 \begin{code}
@@ -161,6 +161,7 @@ outPatType (LazyPat pat)    = outPatType pat
 outPatType (AsPat var pat)     = idType var
 outPatType (ConPat _ ty _ _ _) = ty
 outPatType (ListPat ty _)      = mkListTy ty
+outPatType (PArrPat ty _)      = mkPArrTy ty
 outPatType (TuplePat pats box) = mkTupleTy box (length pats) (map outPatType pats)
 outPatType (RecPat _ ty _ _ _)  = ty
 outPatType (SigPat _ ty _)     = ty
@@ -190,6 +191,7 @@ collectTypedPatBinders (AsPat a pat)               = a : collectTypedPatBinders pat
 collectTypedPatBinders (SigPat pat _ _)               = collectTypedPatBinders pat
 collectTypedPatBinders (ConPat _ _ _ _ pats)   = concat (map collectTypedPatBinders pats)
 collectTypedPatBinders (ListPat t pats)        = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (PArrPat t pats)        = concat (map collectTypedPatBinders pats)
 collectTypedPatBinders (TuplePat pats _)       = concat (map collectTypedPatBinders pats)
 collectTypedPatBinders (RecPat _ _ _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat)
                                                          fields)
@@ -350,9 +352,12 @@ zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind)
                 new_globals)
   where
     zonkExport (tyvars, global, local)
-       = zonkTcSigTyVars tyvars        `thenNF_Tc` \ new_tyvars ->
+       = zonkTcTyVars tyvars           `thenNF_Tc` \ tys ->
+         let
+               new_tyvars = map (tcGetTyVar "zonkExport") tys
                -- This isn't the binding occurrence of these tyvars
-               -- but they should *be* tyvars.  Hence zonkTcSigTyVars.
+               -- but they should *be* tyvars.  Hence tcGetTyVar.
+         in
          zonkIdBndr global             `thenNF_Tc` \ new_global ->
          zonkIdOcc local               `thenNF_Tc` \ new_local -> 
          returnNF_Tc (new_tyvars, new_global, new_local)
@@ -465,11 +470,11 @@ zonkExpr (HsLet binds expr)
     zonkExpr expr      `thenNF_Tc` \ new_expr ->
     returnNF_Tc (HsLet new_binds new_expr)
 
-zonkExpr (HsWith expr binds)
+zonkExpr (HsWith expr binds is_with)
   = zonkIPBinds binds                          `thenNF_Tc` \ new_binds ->
     tcExtendGlobalValEnv (map (ipNameName . fst) new_binds)    $
     zonkExpr expr                              `thenNF_Tc` \ new_expr ->
-    returnNF_Tc (HsWith new_expr new_binds)
+    returnNF_Tc (HsWith new_expr new_binds is_with)
     where
        zonkIPBinds = mapNF_Tc zonkIPBind
        zonkIPBind (n, e)
@@ -477,22 +482,22 @@ zonkExpr (HsWith expr binds)
              zonkExpr e                `thenNF_Tc` \ e' ->
              returnNF_Tc (n', e')
 
-zonkExpr (HsDo _ _ _) = panic "zonkExpr:HsDo"
-
-zonkExpr (HsDoOut do_or_lc stmts return_id then_id zero_id ty src_loc)
+zonkExpr (HsDo do_or_lc stmts ids ty src_loc)
   = zonkStmts stmts            `thenNF_Tc` \ new_stmts ->
-    zonkTcTypeToType ty        `thenNF_Tc` \ new_ty   ->
-    zonkIdOcc return_id                `thenNF_Tc` \ new_return_id ->
-    zonkIdOcc then_id          `thenNF_Tc` \ new_then_id ->
-    zonkIdOcc zero_id          `thenNF_Tc` \ new_zero_id ->
-    returnNF_Tc (HsDoOut do_or_lc new_stmts new_return_id new_then_id new_zero_id
-                        new_ty src_loc)
+    zonkTcTypeToType ty                `thenNF_Tc` \ new_ty   ->
+    mapNF_Tc zonkIdOcc ids     `thenNF_Tc` \ new_ids ->
+    returnNF_Tc (HsDo do_or_lc new_stmts new_ids new_ty src_loc)
 
 zonkExpr (ExplicitList ty exprs)
   = zonkTcTypeToType ty                `thenNF_Tc` \ new_ty ->
     mapNF_Tc zonkExpr exprs    `thenNF_Tc` \ new_exprs ->
     returnNF_Tc (ExplicitList new_ty new_exprs)
 
+zonkExpr (ExplicitPArr ty exprs)
+  = zonkTcTypeToType ty                `thenNF_Tc` \ new_ty ->
+    mapNF_Tc zonkExpr exprs    `thenNF_Tc` \ new_exprs ->
+    returnNF_Tc (ExplicitPArr new_ty new_exprs)
+
 zonkExpr (ExplicitTuple exprs boxed)
   = mapNF_Tc zonkExpr exprs    `thenNF_Tc` \ new_exprs ->
     returnNF_Tc (ExplicitTuple new_exprs boxed)
@@ -504,22 +509,27 @@ zonkExpr (RecordConOut data_con con_expr rbinds)
 
 zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
 
-zonkExpr (RecordUpdOut expr in_ty out_ty dicts rbinds)
+zonkExpr (RecordUpdOut expr in_ty out_ty rbinds)
   = zonkExpr expr              `thenNF_Tc` \ new_expr ->
     zonkTcTypeToType in_ty     `thenNF_Tc` \ new_in_ty ->
     zonkTcTypeToType out_ty    `thenNF_Tc` \ new_out_ty ->
-    mapNF_Tc zonkIdOcc dicts   `thenNF_Tc` \ new_dicts ->
     zonkRbinds rbinds  `thenNF_Tc` \ new_rbinds ->
-    returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_dicts new_rbinds)
+    returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
 
 zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
 zonkExpr (ArithSeqIn _)      = panic "zonkExpr:ArithSeqIn"
+zonkExpr (PArrSeqIn _)       = panic "zonkExpr:PArrSeqIn"
 
 zonkExpr (ArithSeqOut expr info)
   = zonkExpr expr      `thenNF_Tc` \ new_expr ->
     zonkArithSeq info  `thenNF_Tc` \ new_info ->
     returnNF_Tc (ArithSeqOut new_expr new_info)
 
+zonkExpr (PArrSeqOut expr info)
+  = zonkExpr expr      `thenNF_Tc` \ new_expr ->
+    zonkArithSeq info  `thenNF_Tc` \ new_info ->
+    returnNF_Tc (PArrSeqOut new_expr new_info)
+
 zonkExpr (HsCCall fun args may_gc is_casm result_ty)
   = mapNF_Tc zonkExpr args     `thenNF_Tc` \ new_args ->
     zonkTcTypeToType result_ty `thenNF_Tc` \ new_result_ty ->
@@ -667,12 +677,17 @@ zonkPat (ListPat ty pats)
     zonkPats pats              `thenNF_Tc` \ (new_pats, ids) ->
     returnNF_Tc (ListPat new_ty new_pats, ids)
 
+zonkPat (PArrPat ty pats)
+  = zonkTcTypeToType ty        `thenNF_Tc` \ new_ty ->
+    zonkPats pats              `thenNF_Tc` \ (new_pats, ids) ->
+    returnNF_Tc (PArrPat new_ty new_pats, ids)
+
 zonkPat (TuplePat pats boxed)
   = zonkPats pats              `thenNF_Tc` \ (new_pats, ids) ->
     returnNF_Tc (TuplePat new_pats boxed, ids)
 
 zonkPat (ConPat n ty tvs dicts pats)
-  = zonkTcTypeToType ty                `thenNF_Tc` \ new_ty ->
+  = zonkTcTypeToType ty                        `thenNF_Tc` \ new_ty ->
     mapNF_Tc zonkTcTyVarToTyVar tvs    `thenNF_Tc` \ new_tvs ->
     mapNF_Tc zonkIdBndr dicts          `thenNF_Tc` \ new_dicts ->
     tcExtendGlobalValEnv new_dicts     $
@@ -694,7 +709,7 @@ zonkPat (RecPat n ty tvs dicts rpats)
        returnNF_Tc ((f, new_pat, pun), ids)
 
 zonkPat (LitPat lit ty)
-  = zonkTcTypeToType ty            `thenNF_Tc` \ new_ty  ->
+  = zonkTcTypeToType ty                `thenNF_Tc` \ new_ty  ->
     returnNF_Tc (LitPat lit new_ty, emptyBag)
 
 zonkPat (SigPat pat ty expr)
@@ -709,15 +724,15 @@ zonkPat (NPat lit ty expr)
     returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
 
 zonkPat (NPlusKPat n k ty e1 e2)
-  = zonkIdBndr n               `thenNF_Tc` \ new_n ->
-    zonkTcTypeToType ty        `thenNF_Tc` \ new_ty ->
-    zonkExpr e1                `thenNF_Tc` \ new_e1 ->
-    zonkExpr e2                `thenNF_Tc` \ new_e2 ->
+  = zonkIdBndr n               `thenNF_Tc` \ new_n ->
+    zonkTcTypeToType ty                `thenNF_Tc` \ new_ty ->
+    zonkExpr e1                        `thenNF_Tc` \ new_e1 ->
+    zonkExpr e2                        `thenNF_Tc` \ new_e2 ->
     returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
 
 zonkPat (DictPat ds ms)
-  = mapNF_Tc zonkIdBndr ds    `thenNF_Tc` \ new_ds ->
-    mapNF_Tc zonkIdBndr ms    `thenNF_Tc` \ new_ms ->
+  = mapNF_Tc zonkIdBndr ds      `thenNF_Tc` \ new_ds ->
+    mapNF_Tc zonkIdBndr ms      `thenNF_Tc` \ new_ms ->
     returnNF_Tc (DictPat new_ds new_ms,
                 listToBag new_ds `unionBags` listToBag new_ms)
 
@@ -743,9 +758,9 @@ zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl]
 zonkForeignExports ls = mapNF_Tc zonkForeignExport ls
 
 zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl)
-zonkForeignExport (ForeignExport i hs_ty spec src_loc) =
+zonkForeignExport (ForeignExport i hs_ty spec isDeprec src_loc) =
    zonkIdOcc i `thenNF_Tc` \ i' ->
-   returnNF_Tc (ForeignExport i' undefined spec src_loc)
+   returnNF_Tc (ForeignExport i' undefined spec isDeprec src_loc)
 \end{code}
 
 \begin{code}
@@ -770,3 +785,4 @@ zonkRule (IfaceRuleOut fun rule)
   = zonkIdOcc fun      `thenNF_Tc` \ fun' ->
     returnNF_Tc (IfaceRuleOut fun' rule)
 \end{code}
+