[project @ 2005-03-05 13:48:42 by panne]

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

diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index 458a713..5a0da8f 100644 (file)
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -11,21 +11,18 @@ module HsBinds where
 #include "HsVersions.h"
 
 import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr,
-                              LMatch, pprFunBind,
+                              MatchGroup, pprFunBind,
                               GRHSs, pprPatBind )
+import {-# SOURCE #-} HsPat  ( LPat )
 
--- friends:
-import HsPat           ( LPat )
-import HsTypes         ( LHsType )
-
---others:
+import HsTypes         ( LHsType, PostTcType )
 import Name            ( Name )
 import NameSet         ( NameSet, elemNameSet, nameSetToList )
 import BasicTypes      ( IPName, RecFlag(..), Activation(..), Fixity )
 import Outputable      
 import SrcLoc          ( Located(..), unLoc )
 import Var             ( TyVar )
-import Bag             ( Bag, bagToList )
+import Bag             ( Bag, emptyBag, isEmptyBag, bagToList )
 \end{code}
 
 %************************************************************************
@@ -50,7 +47,10 @@ instance OutputableBndr id => Outputable (HsBindGroup id) where
   ppr (HsBindGroup binds sigs is_rec)
      = vcat [ppr_isrec,
             vcat (map ppr sigs),
-            pprLHsBinds binds
+            vcat (map ppr (bagToList binds))
+               -- *not* pprLHsBinds because we don't want braces; 'let' and
+               -- 'where' include a list of HsBindGroups and we don't want
+               -- several groups of bindings each with braces around.
        ]
      where
        ppr_isrec = getPprStyle $ \ sty -> 
@@ -78,11 +78,20 @@ instance (OutputableBndr id) => Outputable (IPBind id) where
 
 -- -----------------------------------------------------------------------------
 
-type LHsBinds id = Bag (LHsBind id)
-type LHsBind  id = Located (HsBind id)
+type LHsBinds id  = Bag (LHsBind id)
+type DictBinds id = LHsBinds id                -- Used for dictionary or method bindings
+type LHsBind  id  = Located (HsBind id)
+
+emptyLHsBinds :: LHsBinds id
+emptyLHsBinds = emptyBag
+
+isEmptyLHsBinds :: LHsBinds id -> Bool
+isEmptyLHsBinds = isEmptyBag
 
 pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc
-pprLHsBinds binds = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace
+pprLHsBinds binds 
+  | isEmptyLHsBinds binds = empty
+  | otherwise = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace
 
 data HsBind id
   = FunBind     (Located id)
@@ -95,11 +104,12 @@ data HsBind id
                        -- FunBinds, so if you change this, you'll need to
                        -- change e.g. rnMethodBinds
                Bool    -- True => infix declaration
-               [LMatch id]
+               (MatchGroup id)
 
   | PatBind     (LPat id)      -- The pattern is never a simple variable;
                                -- That case is done by FunBind
                (GRHSs id)
+               PostTcType      -- Type of the GRHSs
 
   | VarBind id (Located (HsExpr id))   -- Dictionary binding and suchlike;
                                        -- located only for consistency
@@ -149,7 +159,7 @@ instance OutputableBndr id => Outputable (HsBind id) where
 
 ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
 
-ppr_monobind (PatBind pat grhss)       = pprPatBind pat grhss
+ppr_monobind (PatBind pat grhss ty)    = pprPatBind pat grhss
 ppr_monobind (VarBind var rhs)         = ppr var <+> equals <+> pprExpr (unLoc rhs)
 ppr_monobind (FunBind fun inf matches) = pprFunBind (unLoc fun) matches
       -- ToDo: print infix if appropriate
@@ -232,16 +242,20 @@ sigName (L _ sig) = f sig
     f (FixSig (FixitySig n _)) = Just (unLoc n)
     f other                    = Nothing
 
-isFixitySig :: Sig name -> Bool
-isFixitySig (FixSig _) = True
-isFixitySig _         = False
+isFixityLSig :: LSig name -> Bool
+isFixityLSig (L _ (FixSig _)) = True
+isFixityLSig _               = False
+
+isVanillaLSig :: LSig name -> Bool
+isVanillaLSig (L _(Sig name _)) = True
+isVanillaLSig sig              = False
 
-isPragSig :: Sig name -> Bool
+isPragLSig :: LSig name -> Bool
        -- Identifies pragmas 
-isPragSig (SpecSig _ _)     = True
-isPragSig (InlineSig _ _ _) = True
-isPragSig (SpecInstSig _)   = True
-isPragSig other                    = False
+isPragLSig (L _ (SpecSig _ _))     = True
+isPragLSig (L _ (InlineSig _ _ _)) = True
+isPragLSig (L _ (SpecInstSig _))   = True
+isPragLSig other                  = False
 
 hsSigDoc (Sig        _ _)        = ptext SLIT("type signature")
 hsSigDoc (SpecSig    _ _)        = ptext SLIT("SPECIALISE pragma")