[project @ 2000-04-03 16:46:41 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 bd33b86..19ad666 100644 (file)
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -14,17 +14,17 @@ Defines classes for pretty-printing and forcing, both forms of
 module Outputable (
        Outputable(..),                 -- Class
 
-       PprStyle, CodeStyle(..),
+       PprStyle, CodeStyle(..), 
        getPprStyle, withPprStyle, pprDeeper,
        codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle,
        ifPprDebug, ifNotPprForUser,
 
        SDoc,           -- Abstract
-       interppSP, interpp'SP, pprQuotedList,
+       interppSP, interpp'SP, pprQuotedList, pprWithCommas,
        empty, nest,
        text, char, ptext,
        int, integer, float, double, rational,
-       parens, brackets, braces, quotes, doubleQuotes,
+       parens, brackets, braces, quotes, doubleQuotes, angleBrackets,
        semi, comma, colon, dcolon, space, equals, dot,
        lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
        (<>), (<+>), hcat, hsep, 
@@ -35,9 +35,10 @@ module Outputable (
        speakNth, speakNTimes,
 
        printSDoc, printErrs, printDump, 
-       printForC, printForAsm, printForIface,
+       printForC, printForAsm, printForIface, printForUser,
        pprCode, pprCols,
-       showSDoc, showsPrecSDoc, pprFSAsString,
+       showSDoc, showSDocDebug, showSDocIface, showsPrecSDoc, 
+       pprFSAsString,
 
 
        -- error handling
@@ -160,12 +161,15 @@ printErrs doc = printDoc PageMode stderr (final_doc user_style)
                user_style = mkUserStyle (PartWay opt_PprUserLength)
 
 printDump :: SDoc -> IO ()
-printDump doc = printDoc PageMode stderr (final_doc PprDebug)
-             where
-               final_doc = doc $$ text ""
+printDump doc = printForUser stdout (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 -> SDoc -> IO ()
+printForUser handle doc = printDoc PageMode handle (doc (mkUserStyle AllTheWay))
 
--- printForC, printForAsm doe what they sound like
+-- printForC, printForAsm do what they sound like
 printForC :: Handle -> SDoc -> IO ()
 printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle))
 
@@ -186,6 +190,12 @@ pprCode cs d = withPprStyle (PprCode cs) d
 showSDoc :: SDoc -> String
 showSDoc d = show (d (mkUserStyle AllTheWay))
 
+showSDocIface :: SDoc -> String
+showSDocIface doc = showDocWith OneLineMode (doc PprInterface)
+
+showSDocDebug :: SDoc -> String
+showSDocDebug d = show (d PprDebug)
+
 showsPrecSDoc :: Int -> SDoc -> ShowS
 showsPrecSDoc p d = showsPrec p (d (mkUserStyle AllTheWay))
 
@@ -208,6 +218,7 @@ parens d sty       = Pretty.parens (d sty)
 braces d sty       = Pretty.braces (d sty)
 brackets d sty     = Pretty.brackets (d sty)
 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
+angleBrackets d    = char '<' <> d <> char '>'
 
 -- quotes encloses something in single quotes...
 -- but it omits them if the thing ends in a single quote
@@ -294,6 +305,14 @@ instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) wher
                   ppr y <> comma,
                   ppr z ])
 
+instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
+        Outputable (a, b, c, d) where
+    ppr (x,y,z,w) =
+      parens (sep [ppr x <> comma,
+                  ppr y <> comma,
+                  ppr z <> comma,
+                  ppr w])
+
 instance Outputable FastString where
     ppr fs = text (unpackFS fs)                -- Prints an unadorned string,
                                        -- no double quotes or anything
@@ -324,10 +343,21 @@ printDoc mode hdl doc
     put (PStr s) next = hPutFS   hdl s >> next 
 
     done = hPutChar hdl '\n'
+
+showDocWith :: Mode -> Doc -> String
+showDocWith mode doc
+  = fullRender mode 100 1.5 put "" doc
+  where
+    put (Chr c)   s  = c:s
+    put (Str s1)  s2 = s1 ++ s2
+    put (PStr s1) s2 = _UNPK_ s1 ++ s2
 \end{code}
 
 
 \begin{code}
+pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
+pprWithCommas pp xs = hsep (punctuate comma (map pp xs))
+
 interppSP  :: Outputable a => [a] -> SDoc
 interppSP  xs = hsep (map ppr xs)
 
@@ -340,8 +370,6 @@ pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 \end{code}
 
 
-
-
 %************************************************************************
 %*                                                                     *
 \subsection{Printing numbers verbally}
@@ -386,22 +414,21 @@ speakNTimes t | t == 1       = ptext SLIT("once")
 
 \begin{code}
 pprPanic :: String -> SDoc -> a
-pprPanic heading pretty_msg = panic (show (doc PprDebug))
-                           where
-                             doc = text heading <+> pretty_msg
-
 pprError :: String -> SDoc -> a
-pprError heading pretty_msg = error (heading++ " " ++ (showSDoc pretty_msg))
-
 pprTrace :: String -> SDoc -> a -> a
-pprTrace heading pretty_msg = trace (show (doc PprDebug))
-                           where
-                             doc = text heading <+> pretty_msg
+pprPanic  = pprAndThen panic
+pprError  = pprAndThen error
+pprTrace  = pprAndThen trace
 
 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
                             where
                               doc = text heading <+> pretty_msg
 
+pprAndThen :: (String -> a) -> String -> SDoc -> a
+pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
+    where
+     doc = sep [text heading, nest 4 pretty_msg]
+
 assertPprPanic :: String -> Int -> SDoc -> a
 assertPprPanic file line msg
   = panic (show (doc PprDebug))