[project @ 2000-05-08 17:24:10 by panne]

[ghc-hetmet.git] / ghc / compiler / hsSyn / HsExpr.lhs

diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index 128c812..620f060 100644 (file)
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -23,6 +23,7 @@ import PprType                ( pprType, pprParendType )
 import Type            ( Type )
 import Var             ( TyVar, Id )
 import DataCon         ( DataCon )
+import CStrings                ( CLabelString, pprCLabelString )
 import SrcLoc          ( SrcLoc )
 \end{code}
 
@@ -35,6 +36,7 @@ import SrcLoc         ( SrcLoc )
 \begin{code}
 data HsExpr id pat
   = HsVar      id                              -- variable
+  | HsIPVar    id                              -- implicit parameter
   | HsLit      HsLit                           -- literal
   | HsLitOut   HsLit                           -- TRANSLATION
                Type            -- (with its type)
@@ -79,6 +81,9 @@ data HsExpr id pat
   | HsLet      (HsBinds id pat)        -- let(rec)
                (HsExpr  id pat)
 
+  | HsWith     (HsExpr id pat) -- implicit parameter binding
+               [(id, HsExpr id pat)]
+
   | HsDo       StmtCtxt
                [Stmt id pat]   -- "do":one or more stmts
                SrcLoc
@@ -104,9 +109,6 @@ data HsExpr id pat
                                -- direct from the components
                Bool            -- boxed?
 
-  | HsCon DataCon              -- TRANSLATION; a saturated constructor application
-         [Type]
-         [HsExpr id pat]
 
        -- Record construction
   | RecordCon  id                              -- The constructor
@@ -122,9 +124,9 @@ data HsExpr id pat
                (HsRecordBinds id pat)
 
   | RecordUpdOut (HsExpr id pat)       -- TRANSLATION
-                Type           -- Type of *result* record (may differ from
+                Type                   -- Type of *result* record (may differ from
                                                -- type of input record)
-                [id]                           -- Dicts needed for construction
+                [id]                   -- Dicts needed for construction
                 (HsRecordBinds id pat)
 
   | ExprWithTySig                      -- signature binding
@@ -136,7 +138,7 @@ data HsExpr id pat
                (HsExpr id pat)         -- (typechecked, of course)
                (ArithSeqInfo id pat)
 
-  | CCall      FAST_STRING     -- call into the C world; string is
+  | HsCCall    CLabelString    -- call into the C world; string is
                [HsExpr id pat] -- the C function; exprs are the
                                -- arguments to pass.
                Bool            -- True <=> might cause Haskell
@@ -209,6 +211,7 @@ pprExpr e = pprDeeper (ppr_expr e)
 pprBinds b = pprDeeper (ppr b)
 
 ppr_expr (HsVar v) = ppr v
+ppr_expr (HsIPVar v) = {- char '?' <> -} ppr v
 
 ppr_expr (HsLit    lit)   = ppr lit
 ppr_expr (HsLitOut lit _) = ppr lit
@@ -292,6 +295,9 @@ ppr_expr (HsLet binds expr)
   = sep [hang (ptext SLIT("let")) 2 (pprBinds binds),
         hang (ptext SLIT("in"))  2 (ppr expr)]
 
+ppr_expr (HsWith expr binds)
+  = hsep [ppr expr, ptext SLIT("with"), ppr binds]
+
 ppr_expr (HsDo do_or_list_comp stmts _)            = pprDo do_or_list_comp stmts
 ppr_expr (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp stmts
 
@@ -307,10 +313,6 @@ ppr_expr (ExplicitTuple exprs True)
 ppr_expr (ExplicitTuple exprs False)
   = ptext SLIT("(#") <> sep (punctuate comma (map ppr_expr exprs)) <> ptext SLIT("#)")
 
-ppr_expr (HsCon con_id tys args)
-  = ppr con_id <+> sep (map pprParendType tys ++
-                       map pprParendExpr args)
-
 ppr_expr (RecordCon con_id rbinds)
   = pp_rbinds (ppr con_id) rbinds
 ppr_expr (RecordConOut data_con con rbinds)
@@ -334,10 +336,10 @@ ppr_expr EWildPat = char '_'
 ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e
 ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e
 
-ppr_expr (CCall fun args _ is_asm result_ty)
+ppr_expr (HsCCall fun args _ is_asm result_ty)
   = hang (if is_asm
-         then ptext SLIT("_casm_ ``") <> ptext fun <> ptext SLIT("''")
-         else ptext SLIT("_ccall_") <+> ptext fun)
+         then ptext SLIT("_casm_ ``") <> pprCLabelString fun <> ptext SLIT("''")
+         else ptext SLIT("_ccall_") <+> pprCLabelString fun)
        4 (sep (map pprParendExpr args))
 
 ppr_expr (HsSCC lbl expr)
@@ -381,6 +383,7 @@ pprParendExpr expr
       HsLitOut l _         -> ppr l
 
       HsVar _              -> pp_as_was
+      HsIPVar _                    -> pp_as_was
       ExplicitList _       -> pp_as_was
       ExplicitListOut _ _   -> pp_as_was
       ExplicitTuple _ _            -> pp_as_was
@@ -402,7 +405,7 @@ pp_rbinds :: (Outputable id, Outputable pat)
 
 pp_rbinds thing rbinds
   = hang thing 
-        4 (braces (hsep (punctuate comma (map (pp_rbind) rbinds))))
+        4 (braces (sep (punctuate comma (map (pp_rbind) rbinds))))
   where
     pp_rbind (v, e, pun_flag) 
       = getPprStyle $ \ sty ->
@@ -453,6 +456,10 @@ data Stmt id pat
                SrcLoc
 
   | ReturnStmt (HsExpr id pat)         -- List comps only, at the end
+
+consLetStmt :: HsBinds id pat -> [Stmt id pat] -> [Stmt id pat]
+consLetStmt EmptyBinds stmts = stmts
+consLetStmt binds      stmts = LetStmt binds : stmts
 \end{code}
 
 \begin{code}