[project @ 1998-12-02 13:17:09 by simonm]

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

diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs
index ae3380e..24cbda2 100644 (file)
--- a/ghc/compiler/hsSyn/HsCore.lhs
+++ b/ghc/compiler/hsSyn/HsCore.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
 %
 %************************************************************************
 %*                                                                     *
@@ -12,20 +12,18 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
 
 \begin{code}
 module HsCore (
-       UfExpr(..), UfAlts(..), UfBinder(..), UfNote(..),
-       UfDefault(..), UfBinding(..),
-       UfArg(..), UfPrimOp(..)
+       UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
+       UfBinding(..), UfCon(..)
     ) where
 
 #include "HsVersions.h"
 
 -- friends:
 import HsTypes         ( HsType, pprParendHsType )
-import Kind            ( Kind {- instance Outputable -} )
 
 -- others:
-import Literal         ( Literal )
-import Util            ( panic )
+import Const           ( Literal )
+import Type            ( Kind )
 import CostCentre
 import Outputable
 \end{code}
@@ -39,38 +37,29 @@ import Outputable
 \begin{code}
 data UfExpr name
   = UfVar      name
-  | UfLit      Literal
-  | UfCon      name [UfArg name]
-  | UfPrim     (UfPrimOp name) [UfArg name]
+  | UfType      (HsType name)
+  | UfCon      (UfCon name) [UfExpr name]
+  | UfTuple    name [UfExpr name]              -- Type arguments omitted
   | UfLam      (UfBinder name)   (UfExpr name)
-  | UfApp      (UfExpr name) (UfArg name)
-  | UfCase     (UfExpr name) (UfAlts name)
+  | UfApp      (UfExpr name) (UfExpr name)
+  | UfCase     (UfExpr name) name [UfAlt name]
   | UfLet      (UfBinding name)  (UfExpr name)
   | UfNote     (UfNote name) (UfExpr name)
 
-data UfPrimOp name
-  = UfCCallOp  FAST_STRING          -- callee
-               Bool                 -- True <=> casm, rather than ccall
-               Bool                 -- True <=> might cause GC
-               [HsType name] -- arg types, incl state token
-                                    -- (which will be first)
-               (HsType name) -- return type
-
-  | UfOtherOp  name
-
 data UfNote name = UfSCC CostCentre
                 | UfCoerce (HsType name)
                 | UfInlineCall
 
-data UfAlts name
-  = UfAlgAlts  [(name, [name], UfExpr name)]
-               (UfDefault name)
-  | UfPrimAlts [(Literal, UfExpr name)]
-               (UfDefault name)
+type UfAlt name = (UfCon name, [name], UfExpr name)
 
-data UfDefault name
-  = UfNoDefault
-  | UfBindDefault name (UfExpr name)
+data UfCon name = UfDefault
+               | UfDataCon name
+               | UfLitCon Literal
+               | UfLitLitCon FAST_STRING (HsType name)
+               | UfPrimOp name
+               | UfCCallOp FAST_STRING    -- callee
+                           Bool           -- True <=> casm, rather than ccall
+                           Bool           -- True <=> might cause GC
 
 data UfBinding name
   = UfNonRec   (UfBinder name)
@@ -80,13 +69,9 @@ data UfBinding name
 data UfBinder name
   = UfValBinder        name (HsType name)
   | UfTyBinder name Kind
-
-data UfArg name
-  = UfVarArg   name
-  | UfLitArg   Literal
-  | UfTyArg    (HsType name)
 \end{code}
 
+
 %************************************************************************
 %*                                                                     *
 \subsection[HsCore-print]{Printing Core unfoldings}
@@ -96,39 +81,23 @@ data UfArg name
 \begin{code}
 instance Outputable name => Outputable (UfExpr name) where
     ppr (UfVar v) = ppr v
-    ppr (UfLit l) = ppr l
+    ppr (UfType ty) = char '@' <+> pprParendHsType ty
 
     ppr (UfCon c as)
-      = hsep [text "UfCon", ppr c, ppr as, char ')']
-    ppr (UfPrim o as)
-      = hsep [text "UfPrim", ppr o, ppr as, char ')']
+      = hsep [text "UfCon", ppr c, ppr as]
+
+    ppr (UfTuple c as) = parens (hsep (punctuate comma (map ppr as)))
 
     ppr (UfLam b body)
       = hsep [char '\\', ppr b, ptext SLIT("->"), ppr body]
 
-    ppr (UfApp fun (UfTyArg ty))
-      = hsep [ppr fun, char '@', pprParendHsType ty]
+    ppr (UfApp fun arg) = ppr fun <+> ppr arg 
 
-    ppr (UfApp fun (UfLitArg lit))
-      = hsep [ppr fun, ppr lit]
-
-    ppr (UfApp fun (UfVarArg var))
-      = hsep [ppr fun, ppr var]
-
-    ppr (UfCase scrut alts)
-      = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of {"), pp_alts alts, char '}']
+    ppr (UfCase scrut bndr alts)
+      = hsep [ptext SLIT("case"), ppr scrut, ptext SLIT("of"), ppr bndr,
+             braces (hsep (punctuate semi (map pp_alt alts)))]
       where
-       pp_alts (UfAlgAlts alts deflt)
-         = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
-         where
-          pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
-       pp_alts (UfPrimAlts alts deflt)
-         = hsep [hsep (punctuate semi (map pp_alt alts)), pp_deflt deflt]
-         where
-          pp_alt (l,rhs) = hsep [ppr l, ppr_arrow, ppr rhs]
-
-       pp_deflt UfNoDefault = empty
-       pp_deflt (UfBindDefault b rhs) = hsep [ppr b, ppr_arrow, ppr rhs]
+       pp_alt (c,bs,rhs) = hsep [ppr c, ppr bs, ppr_arrow, ppr rhs]
 
         ppr_arrow = ptext SLIT("->")
 
@@ -142,22 +111,15 @@ instance Outputable name => Outputable (UfExpr name) where
     ppr (UfNote note body)
       = hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body]
 
-instance Outputable name => Outputable (UfPrimOp name) where
-    ppr (UfCCallOp str is_casm can_gc arg_tys result_ty)
-      = let
+instance Outputable name => Outputable (UfCon name) where
+    ppr UfDefault      = text "DEFAULT"
+    ppr (UfDataCon d)  = ppr d
+    ppr (UfPrimOp p)   = ppr p
+    ppr (UfCCallOp str is_casm can_gc)
+      =        hcat [before, ptext str, after]
+      where
            before = ptext (if is_casm then SLIT("_casm_ ``") else SLIT("_ccall_ "))
            after  = if is_casm then text "'' " else space
-       in
-       hcat [before, ptext str, after,
-                  brackets (ppr arg_tys), space, ppr result_ty]
-
-    ppr (UfOtherOp op)
-      = ppr op
-
-instance Outputable name => Outputable (UfArg name) where
-    ppr (UfVarArg v)   = ppr v
-    ppr (UfLitArg l)   = ppr l
-    ppr (UfTyArg ty)   = pprParendHsType ty
 
 instance Outputable name => Outputable (UfBinder name) where
     ppr (UfValBinder name ty)  = hsep [ppr name, ptext SLIT("::"), ppr ty]