X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Futils%2FOutputable.lhs;h=19ad6666776d7e8c70529c129e9f229dc1e72a15;hb=66e87ae1ac00d54df5024033fda5d08db99177a4;hp=582a0b63bf97f3abe14319ae435b3d39f6e867c5;hpb=98152b16320b59bbf96560dd10edd7e8ee41ccfe;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 582a0b6..19ad666 100644 --- 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,14 +35,15 @@ 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 - pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, - trace, panic, panic#, assertPanic, warnPprTrace + pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace, + trace, panic, panic#, assertPanic ) where #include "HsVersions.h" @@ -156,16 +157,19 @@ printSDoc d sty = printDoc PageMode stdout (d sty) printErrs :: SDoc -> IO () printErrs doc = printDoc PageMode stderr (final_doc user_style) where - final_doc = doc $$ text "" + final_doc = doc -- $$ text "" 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)) @@ -207,8 +217,17 @@ rational n sty = Pretty.rational n parens d sty = Pretty.parens (d sty) braces d sty = Pretty.braces (d sty) brackets d sty = Pretty.brackets (d sty) -quotes d sty = Pretty.quotes (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 +-- so that we don't get `foo''. Instead we just have foo'. +quotes d sty = case show pp_d of + ('\'' : _) -> pp_d + other -> Pretty.quotes pp_d + where + pp_d = d sty semi sty = Pretty.semi comma sty = Pretty.comma @@ -286,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 @@ -316,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) @@ -332,8 +370,6 @@ pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs)) \end{code} - - %************************************************************************ %* * \subsection{Printing numbers verbally} @@ -378,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))