[project @ 2001-07-24 04:47:06 by ken]

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

diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index db83e15..4050a2e 100644 (file)
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -10,20 +10,24 @@ module HsBinds where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} HsExpr    ( pprExpr, HsExpr )
-import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSs, GRHSs )
+import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr,
+                              Match,  pprFunBind,
+                              GRHSs,  pprPatBind )
 
 -- friends:
 import HsTypes         ( HsType )
 import CoreSyn         ( CoreExpr )
+import PprCore         ( {- instance Outputable (Expr a) -} )
 
 --others:
-import Name            ( Name, isUnboundName )
+import Name            ( Name )
+import PrelNames       ( isUnboundName )
 import NameSet         ( NameSet, elemNameSet, nameSetToList )
 import BasicTypes      ( RecFlag(..), Fixity )
 import Outputable      
 import SrcLoc          ( SrcLoc )
 import Var             ( TyVar )
+import Class            ( DefMeth (..) )
 \end{code}
 
 %************************************************************************
@@ -71,16 +75,18 @@ instance (Outputable pat, Outputable id) =>
 
 ppr_binds EmptyBinds = empty
 ppr_binds (ThenBinds binds1 binds2)
-     = ($$) (ppr_binds binds1) (ppr_binds binds2)
+    = ppr_binds binds1 $$ ppr_binds binds2
 ppr_binds (MonoBind bind sigs is_rec)
-     = vcat [ifNotPprForUser (ptext rec_str),
+     = vcat [ppr_isrec,
             vcat (map ppr sigs),
             ppr bind
        ]
      where
-       rec_str = case is_rec of
-                  Recursive    -> SLIT("{- rec -}")
-                  NonRecursive -> SLIT("{- nonrec -}")
+       ppr_isrec = getPprStyle $ \ sty -> 
+                  if userStyle sty then empty else
+                  case is_rec of
+                       Recursive    -> ptext SLIT("{- rec -}")
+                       NonRecursive -> ptext SLIT("{- nonrec -}")
 \end{code}
 
 %************************************************************************
@@ -195,11 +201,8 @@ ppr_monobind EmptyMonoBinds = empty
 ppr_monobind (AndMonoBinds binds1 binds2)
       = ppr_monobind binds1 $$ ppr_monobind binds2
 
-ppr_monobind (PatMonoBind pat grhss locn)
-      = sep [ppr pat, nest 4 (pprGRHSs False grhss)]
-
-ppr_monobind (FunMonoBind fun inf matches locn)
-      = pprMatches (False, ppr fun) matches
+ppr_monobind (PatMonoBind pat grhss locn)      = pprPatBind pat grhss
+ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
       -- ToDo: print infix if appropriate
 
 ppr_monobind (VarMonoBind name expr)
@@ -236,9 +239,8 @@ data Sig name
                SrcLoc
 
   | ClassOpSig name            -- Selector name
-               name            -- Default-method name (if any)
-               Bool            -- True <=> there is an explicit, programmer-supplied
-                               -- default declaration in the class decl
+                (DefMeth name) -- Default-method info
+                               -- See "THE NAMING STORY" in HsDecls
                (HsType name)
                SrcLoc
 
@@ -269,7 +271,7 @@ instance Eq name => Eq (FixitySig name) where
 
 \begin{code}
 okBindSig :: NameSet -> Sig Name -> Bool
-okBindSig ns (ClassOpSig _ _ _ _ _)                            = False
+okBindSig ns (ClassOpSig _ _ _ _)                              = False
 okBindSig ns sig = sigForThisGroup ns sig
 
 okClsDclSig :: NameSet -> Sig Name -> Bool
@@ -290,7 +292,7 @@ sigForThisGroup ns sig
 
 sigName :: Sig name -> Maybe name
 sigName (Sig         n _ _)             = Just n
-sigName (ClassOpSig  n _ _ _ _)         = Just n
+sigName (ClassOpSig  n _ _ _)           = Just n
 sigName (SpecSig     n _ _)             = Just n
 sigName (InlineSig   n _   _)           = Just n
 sigName (NoInlineSig n _   _)           = Just n
@@ -302,8 +304,8 @@ isFixitySig (FixSig _) = True
 isFixitySig _         = False
 
 isClassOpSig :: Sig name -> Bool
-isClassOpSig (ClassOpSig _ _ _ _ _) = True
-isClassOpSig _                     = False
+isClassOpSig (ClassOpSig _ _ _ _) = True
+isClassOpSig _                   = False
 
 isPragSig :: Sig name -> Bool
        -- Identifies pragmas 
@@ -316,7 +318,7 @@ isPragSig other                   = False
 
 \begin{code}
 hsSigDoc (Sig        _ _ loc)        = (SLIT("type signature"),loc)
-hsSigDoc (ClassOpSig _ _ _ _ loc)     = (SLIT("class-method type signature"), loc)
+hsSigDoc (ClassOpSig _ _ _ loc)       = (SLIT("class-method type signature"), loc)
 hsSigDoc (SpecSig    _ _ loc)        = (SLIT("SPECIALISE pragma"),loc)
 hsSigDoc (InlineSig  _ _    loc)      = (SLIT("INLINE pragma"),loc)
 hsSigDoc (NoInlineSig  _ _  loc)      = (SLIT("NOINLINE pragma"),loc)
@@ -332,10 +334,13 @@ ppr_sig :: Outputable name => Sig name -> SDoc
 ppr_sig (Sig var ty _)
       = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 
-ppr_sig (ClassOpSig var _ dm ty _)
+ppr_sig (ClassOpSig var dm ty _)
       = sep [ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty)]
       where
-       pp_dm = if dm then equals else empty    -- Default-method indicator
+       pp_dm = case dm of 
+                 DefMeth _  -> equals  -- Default method indicator
+                 GenDefMeth -> semi    -- Generic method indicator
+                 NoDefMeth  -> empty   -- No Method at all
 
 ppr_sig (SpecSig var ty _)
       = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
@@ -372,10 +377,10 @@ eqHsSig (InlineSig n1 _ _)   (InlineSig n2 _ _)   = n1 == n2
 eqHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 == n2
 
 eqHsSig (SpecInstSig ty1 _)  (SpecInstSig ty2 _)  = ty1 == ty2
-eqHsSig (SpecSig n1 ty1 _)   (SpecSig n2 ty2 _) 
-  = -- may have many specialisations for one value;
+eqHsSig (SpecSig n1 ty1 _)   (SpecSig n2 ty2 _)   =
+    -- may have many specialisations for one value;
     -- but not ones that are exactly the same...
     (n1 == n2) && (ty1 == ty2)
 
-eqHsSig other_1 other_2 = False
+eqHsSig _other1 _other2 = False
 \end{code}