[project @ 2003-10-09 11:58:39 by simonpj]

[ghc-hetmet.git] / ghc / compiler / utils / Outputable.lhs

diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index 2be035c..dcfe8c2 100644 (file)
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -9,12 +9,15 @@ Defines classes for pretty-printing and forcing, both forms of
 \begin{code}
 
 module Outputable (
-       Outputable(..),                 -- Class
+       Outputable(..), OutputableBndr(..),     -- Class
+
+       BindingSite(..),
 
        PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
        getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper,
        codeStyle, userStyle, debugStyle, asmStyle,
-       ifPprDebug, unqualStyle,
+       ifPprDebug, unqualStyle, 
+       mkErrStyle, defaultErrStyle,
 
        SDoc,           -- Abstract
        docToSDoc,
@@ -23,7 +26,7 @@ module Outputable (
        text, char, ftext, ptext,
        int, integer, float, double, rational,
        parens, brackets, braces, quotes, doubleQuotes, angleBrackets,
-       semi, comma, colon, dcolon, space, equals, dot,
+       semi, comma, colon, dcolon, space, equals, dot, arrow,
        lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
        (<>), (<+>), hcat, hsep, 
        ($$), ($+$), vcat, 
@@ -56,8 +59,9 @@ import qualified Pretty
 import Pretty          ( Doc, Mode(..) )
 import Panic
 
-import Word            ( Word32 )
-import IO              ( Handle, stderr, stdout )
+import DATA_WORD       ( Word32 )
+
+import IO              ( Handle, stderr, stdout, hFlush )
 import Char             ( chr )
 #if __GLASGOW_HASKELL__ < 410
 import Char            ( ord, isDigit )
@@ -78,8 +82,6 @@ data PprStyle
                                        -- must be very close to Haskell
                                        -- syntax, etc.
 
-  | PprInterface PrintUnqualified      -- Interface generation
-
   | PprCode CodeStyle          -- Print code; either C or assembler
 
   | PprDebug                   -- Standard debugging output
@@ -101,6 +103,18 @@ neverQualify  n = True
 
 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
 
+mkErrStyle :: PrintUnqualified -> PprStyle
+-- Style for printing error messages
+mkErrStyle print_unqual = mkUserStyle print_unqual (PartWay opt_PprUserLength)
+
+defaultErrStyle :: PprStyle
+-- Default style for error messages
+-- It's a bit of a hack because it doesn't take into account what's in scope
+-- Only used for desugarer warnings, and typechecker errors in interface sigs
+defaultErrStyle 
+  | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
+  | otherwise         = mkUserStyle neverQualify  (PartWay opt_PprUserLength)
+
 mkUserStyle unqual depth |  opt_PprStyle_Debug = PprDebug
                         |  otherwise          = PprUser unqual depth
 \end{code}
@@ -140,7 +154,6 @@ getPprStyle df sty = df sty sty
 \begin{code}
 unqualStyle :: PprStyle -> Name -> Bool
 unqualStyle (PprUser    unqual _) n = unqual n
-unqualStyle (PprInterface unqual) n = unqual n
 unqualStyle other                n = False
 
 codeStyle :: PprStyle -> Bool
@@ -165,23 +178,27 @@ ifPprDebug d sty    = Pretty.empty
 \end{code}
 
 \begin{code}
+-- Unused [7/02 sof]
 printSDoc :: SDoc -> PprStyle -> IO ()
-printSDoc d sty = Pretty.printDoc PageMode stdout (d sty)
+printSDoc d sty = do
+  Pretty.printDoc PageMode stdout (d sty)
+  hFlush stdout
 
 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
 -- above is better or worse than the put-big-string approach here
-printErrs :: PrintUnqualified -> SDoc -> IO ()
-printErrs unqual doc = Pretty.printDoc PageMode stderr (doc style)
-                    where
-                      style = mkUserStyle unqual (PartWay opt_PprUserLength)
+printErrs :: Doc -> IO ()
+printErrs doc = do Pretty.printDoc PageMode stderr doc
+                  hFlush stderr
 
 printDump :: SDoc -> IO ()
-printDump doc = Pretty.printDoc PageMode stdout (better_doc defaultUserStyle)
-             where
-               better_doc = doc $$ text ""
-       -- We used to always print in debug style, but I want
-       -- to try the effect of a more user-ish style (unless you
-       -- say -dppr-debug
+printDump doc = do
+   Pretty.printDoc PageMode stdout (better_doc defaultUserStyle)
+   hFlush stdout
+ where
+   better_doc = doc $$ text ""
+    -- We used to always print in debug style, but I want
+    -- to try the effect of a more user-ish style (unless you
+    -- say -dppr-debug)
 
 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
 printForUser handle unqual doc 
@@ -262,6 +279,7 @@ rbrack sty = Pretty.rbrack
 lbrace sty = Pretty.lbrace
 rbrace sty = Pretty.rbrace
 dcolon sty = Pretty.ptext SLIT("::")
+arrow  sty = Pretty.ptext SLIT("->")
 underscore = char '_'
 dot       = char '.'
 
@@ -340,7 +358,39 @@ instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
 instance Outputable FastString where
     ppr fs = text (unpackFS fs)                -- Prints an unadorned string,
                                        -- no double quotes or anything
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+\subsection{The @OutputableBndr@ class}
+%*                                                                     *
+%************************************************************************
+
+When we print a binder, we often want to print its type too.
+The @OutputableBndr@ class encapsulates this idea.
 
+@BindingSite@ is used to tell the thing that prints binder what
+language construct is binding the identifier.  This can be used
+to decide how much info to print.
+
+\begin{code}
+data BindingSite = LambdaBind | CaseBind | LetBind
+
+class Outputable a => OutputableBndr a where
+   pprBndr :: BindingSite -> a -> SDoc
+   pprBndr b x = ppr x
+\end{code}
+
+
+
+%************************************************************************
+%*                                                                     *
+\subsection{Random printing helpers}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
 #if __GLASGOW_HASKELL__ < 410
 -- Assume we have only 8-bit Chars.
 
@@ -393,7 +443,7 @@ instance Show FastString  where
 
 \begin{code}
 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
-pprWithCommas pp xs = hsep (punctuate comma (map pp xs))
+pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
 
 interppSP  :: Outputable a => [a] -> SDoc
 interppSP  xs = hsep (map ppr xs)