X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FOutputable.lhs;h=339a3bccc3516c3f413267cf1d92e8439146b9e8;hb=9e90a28e134b8e5af3f6ec9b7300bc41324fea9c;hp=2bc535e5eecf8abfe18d907b87085a0ae28b4bcc;hpb=384ab1783d093c85465a72fe00f2a4289bf44084;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 2bc535e..339a3bc 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP Project, Glasgow University, 1992-1996 +% (c) The GRASP Project, Glasgow University, 1992-1998 % \section[Outputable]{Classes for pretty-printing} @@ -7,22 +7,27 @@ Defines classes for pretty-printing and forcing, both forms of ``output.'' \begin{code} + module Outputable ( - Outputable(..), -- Class + Outputable(..), OutputableBndr(..), -- Class + + BindingSite(..), - PprStyle, CodeStyle(..), - getPprStyle, withPprStyle, pprDeeper, - codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle, - ifPprDebug, ifNotPprForUser, + PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, + getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, + codeStyle, userStyle, debugStyle, asmStyle, + ifPprDebug, unqualStyle, + mkErrStyle, defaultErrStyle, SDoc, -- Abstract - interppSP, interpp'SP, pprQuotedList, + docToSDoc, + interppSP, interpp'SP, pprQuotedList, pprWithCommas, empty, nest, - text, char, ptext, + text, char, ftext, ptext, int, integer, float, double, rational, - parens, brackets, braces, quotes, doubleQuotes, - semi, comma, colon, space, equals, - lparen, rparen, lbrack, rbrack, lbrace, rbrace, + parens, brackets, braces, quotes, doubleQuotes, angleBrackets, + semi, comma, colon, dcolon, space, equals, dot, arrow, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, (<>), (<+>), hcat, hsep, ($$), ($+$), vcat, sep, cat, @@ -30,23 +35,34 @@ module Outputable ( hang, punctuate, speakNth, speakNTimes, - showSDoc, printSDoc, printErrs, printDump, - printForC, printForAsm, printForIface, - pprCode, pprCols, + printSDoc, printErrs, printDump, + printForC, printForAsm, printForUser, + pprCode, mkCodeStyle, + showSDoc, showSDocForUser, showSDocDebug, + showSDocUnqual, showsPrecSDoc, + pprHsChar, pprHsString, + -- error handling - pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, - panic, panic#, assertPanic + pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace, + trace, panic, panic#, assertPanic ) where #include "HsVersions.h" -import IO ( Handle, hPutChar, hPutStr, stderr, stdout ) -import CmdLineOpts ( opt_PprStyle_All, opt_PprStyle_Debug, opt_PprUserLength ) + +import {-# SOURCE #-} Name( Name ) + +import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength ) import FastString import qualified Pretty -import Pretty ( Doc, Mode(..), TextDetails(..), fullRender ) -import Util ( panic, assertPanic, panic#, trace ) +import Pretty ( Doc, Mode(..) ) +import Panic + +import DATA_WORD ( Word32 ) + +import IO ( Handle, stderr, stdout, hFlush ) +import Char ( ord ) \end{code} @@ -58,23 +74,46 @@ import Util ( panic, assertPanic, panic#, trace ) \begin{code} data PprStyle - = PprUser Depth -- Pretty-print in a way that will - -- make sense to the ordinary user; - -- must be very close to Haskell - -- syntax, etc. - - | PprDebug -- Standard debugging output - - | PprInterface -- Interface generation + = PprUser PrintUnqualified Depth -- Pretty-print in a way that will + -- make sense to the ordinary user; + -- must be very close to Haskell + -- syntax, etc. | PprCode CodeStyle -- Print code; either C or assembler + | PprDebug -- Standard debugging output data CodeStyle = CStyle -- The format of labels differs for C and assembler | AsmStyle data Depth = AllTheWay | PartWay Int -- 0 => stop + + +type PrintUnqualified = Name -> Bool + -- This function tells when it's ok to print + -- a (Global) name unqualified + +alwaysQualify,neverQualify :: PrintUnqualified +alwaysQualify n = False +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 alwaysQualify (PartWay opt_PprUserLength) + +mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug + | otherwise = PprUser unqual depth \end{code} Orthogonal to the above printing styles are (possibly) some @@ -97,16 +136,23 @@ type SDoc = PprStyle -> Doc withPprStyle :: PprStyle -> SDoc -> SDoc withPprStyle sty d sty' = d sty +withPprStyleDoc :: PprStyle -> SDoc -> Doc +withPprStyleDoc sty d = d sty + pprDeeper :: SDoc -> SDoc -pprDeeper d (PprUser (PartWay 0)) = Pretty.text "..." -pprDeeper d (PprUser (PartWay n)) = d (PprUser (PartWay (n-1))) -pprDeeper d other_sty = d other_sty +pprDeeper d (PprUser unqual (PartWay 0)) = Pretty.text "..." +pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1))) +pprDeeper d other_sty = d other_sty getPprStyle :: (PprStyle -> SDoc) -> SDoc getPprStyle df sty = df sty sty \end{code} \begin{code} +unqualStyle :: PprStyle -> Name -> Bool +unqualStyle (PprUser unqual _) n = unqual n +unqualStyle other n = False + codeStyle :: PprStyle -> Bool codeStyle (PprCode _) = True codeStyle _ = False @@ -115,23 +161,13 @@ asmStyle :: PprStyle -> Bool asmStyle (PprCode AsmStyle) = True asmStyle other = False -ifaceStyle :: PprStyle -> Bool -ifaceStyle PprInterface = True -ifaceStyle other = False - debugStyle :: PprStyle -> Bool debugStyle PprDebug = True debugStyle other = False userStyle :: PprStyle -> Bool -userStyle (PprUser _) = True -userStyle other = False -\end{code} - -\begin{code} -ifNotPprForUser :: SDoc -> SDoc -- Returns empty document for User style -ifNotPprForUser d sty@(PprUser _) = Pretty.empty -ifNotPprForUser d sty = d sty +userStyle (PprUser _ _) = True +userStyle other = False ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style ifPprDebug d sty@PprDebug = d sty @@ -139,51 +175,73 @@ ifPprDebug d sty = Pretty.empty \end{code} \begin{code} +-- Unused [7/02 sof] printSDoc :: SDoc -> PprStyle -> IO () -printSDoc d sty = 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 printDoc +-- 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 :: SDoc -> IO () -printErrs doc = printDoc PageMode stderr (final_doc user_style) - where - final_doc = doc $$ text "" - user_style = mkUserStyle (PartWay opt_PprUserLength) +printErrs :: Doc -> IO () +printErrs doc = do Pretty.printDoc PageMode stderr doc + hFlush stderr printDump :: SDoc -> IO () -printDump doc = printDoc PageMode stderr (final_doc PprDebug) - where - final_doc = doc $$ text "" - - --- printForC, printForAsm doe what they sound like +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 + = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay)) + +-- printForC, printForAsm do what they sound like printForC :: Handle -> SDoc -> IO () -printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle)) +printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle)) printForAsm :: Handle -> SDoc -> IO () -printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle)) - --- printForIface prints all on one line for interface files. --- It's called repeatedly for successive lines -printForIface :: Handle -> SDoc -> IO () -printForIface handle doc = printDoc OneLineMode handle (doc PprInterface) +printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle)) pprCode :: CodeStyle -> SDoc -> SDoc pprCode cs d = withPprStyle (PprCode cs) d +mkCodeStyle :: CodeStyle -> PprStyle +mkCodeStyle = PprCode + +-- Can't make SDoc an instance of Show because SDoc is just a function type +-- However, Doc *is* an instance of Show -- showSDoc just blasts it out as a string showSDoc :: SDoc -> String -showSDoc d = show (d (mkUserStyle AllTheWay)) +showSDoc d = show (d defaultUserStyle) + +showSDocForUser :: PrintUnqualified -> SDoc -> String +showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay)) -mkUserStyle depth | opt_PprStyle_Debug - || opt_PprStyle_All = PprDebug - | otherwise = PprUser depth +showSDocUnqual :: SDoc -> String +-- Only used in the gruesome HsExpr.isOperator +showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay)) + +showsPrecSDoc :: Int -> SDoc -> ShowS +showsPrecSDoc p d = showsPrec p (d defaultUserStyle) + +showSDocDebug :: SDoc -> String +showSDocDebug d = show (d PprDebug) \end{code} \begin{code} +docToSDoc :: Doc -> SDoc +docToSDoc d = \_ -> d + empty sty = Pretty.empty text s sty = Pretty.text s char c sty = Pretty.char c +ftext s sty = Pretty.ftext s ptext s sty = Pretty.ptext s int n sty = Pretty.int n integer n sty = Pretty.integer n @@ -194,8 +252,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 @@ -208,6 +275,10 @@ lbrack sty = Pretty.lbrack 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 '.' nest n d sty = Pretty.nest n (d sty) (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty) @@ -253,44 +324,95 @@ instance Outputable Bool where instance Outputable Int where ppr n = int n +instance Outputable () where + ppr _ = text "()" + instance (Outputable a) => Outputable [a] where ppr xs = brackets (fsep (punctuate comma (map ppr xs))) instance (Outputable a, Outputable b) => Outputable (a, b) where - ppr (x,y) = - hang (hcat [lparen, ppr x, comma]) 4 ((<>) (ppr y) rparen) + ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) + +instance Outputable a => Outputable (Maybe a) where + ppr Nothing = ptext SLIT("Nothing") + ppr (Just x) = ptext SLIT("Just") <+> ppr x -- ToDo: may not be used instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where ppr (x,y,z) = - parens (sep [ (<>) (ppr x) comma, - (<>) (ppr y) comma, - ppr z ]) + parens (sep [ppr x <> comma, + 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 \end{code} %************************************************************************ %* * -\subsection{Other helper functions} +\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} -pprCols = (100 :: Int) -- could make configurable +data BindingSite = LambdaBind | CaseBind | LetBind -printDoc :: Mode -> Handle -> Doc -> IO () -printDoc mode hdl doc - = fullRender mode pprCols 1.5 put done doc - where - put (Chr c) next = hPutChar hdl c >> next - put (Str s) next = hPutStr hdl s >> next - put (PStr s) next = hPutFS hdl s >> next +class Outputable a => OutputableBndr a where + pprBndr :: BindingSite -> a -> SDoc + pprBndr b x = ppr x +\end{code} + + + +%************************************************************************ +%* * +\subsection{Random printing helpers} +%* * +%************************************************************************ + +\begin{code} +-- We have 31-bit Chars and will simply use Show instances +-- of Char and String. + +pprHsChar :: Char -> SDoc +pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32)) + | otherwise = text (show c) - done = hPutChar hdl '\n' +pprHsString :: FastString -> SDoc +pprHsString fs = text (show (unpackFS fs)) + +instance Show FastString where + showsPrec p fs = showsPrecSDoc p (ppr fs) \end{code} +%************************************************************************ +%* * +\subsection{Other helper functions} +%* * +%************************************************************************ + \begin{code} +pprWithCommas :: (a -> SDoc) -> [a] -> SDoc +pprWithCommas pp xs = fsep (punctuate comma (map pp xs)) + interppSP :: Outputable a => [a] -> SDoc interppSP xs = hsep (map ppr xs) @@ -303,8 +425,6 @@ pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs)) \end{code} - - %************************************************************************ %* * \subsection{Printing numbers verbally} @@ -323,14 +443,15 @@ speakNth 3 = ptext SLIT("third") speakNth 4 = ptext SLIT("fourth") speakNth 5 = ptext SLIT("fifth") speakNth 6 = ptext SLIT("sixth") -speakNth n = hcat [ int n, text st_nd_rd_th ] +speakNth n = hcat [ int n, text suffix ] where - st_nd_rd_th | n_rem_10 == 1 = "st" - | n_rem_10 == 2 = "nd" - | n_rem_10 == 3 = "rd" - | otherwise = "th" + suffix | n <= 20 = "th" -- 11,12,13 are non-std + | last_dig == 1 = "st" + | last_dig == 2 = "nd" + | last_dig == 3 = "rd" + | otherwise = "th" - n_rem_10 = n `rem` 10 + last_dig = n `rem` 10 \end{code} \begin{code} @@ -340,27 +461,30 @@ speakNTimes t | t == 1 = ptext SLIT("once") | otherwise = int t <+> ptext SLIT("times") \end{code} + %************************************************************************ %* * -\subsection[Utils-errors]{Error handling} +\subsection{Error handling} %* * %************************************************************************ \begin{code} -pprPanic heading pretty_msg = panic (show (doc PprDebug)) - where - doc = text heading <+> pretty_msg - -pprError heading pretty_msg = error (heading++ " " ++ (show pretty_msg)) - -pprTrace heading pretty_msg = trace (show (doc PprDebug)) - where - doc = text heading <+> pretty_msg +pprPanic :: String -> SDoc -> a +pprError :: String -> SDoc -> a +pprTrace :: String -> SDoc -> a -> a +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)) @@ -369,4 +493,12 @@ assertPprPanic file line msg text file, text "line", int line], msg] + +warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a +warnPprTrace False file line msg x = x +warnPprTrace True file line msg x + = trace (show (doc PprDebug)) x + where + doc = sep [hsep [text "WARNING: file", text file, text "line", int line], + msg] \end{code}