X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FOutputable.lhs;h=cf99e12bcf1b8f95084038c8cece8645fee64e33;hb=1f5e3b2472084434edf71a89c4764d1509e8e9b0;hp=c8e454da900b0042d4b8df209e2d53e09f26aa65;hpb=1c62b517711ac232a8024d91fd4b317a6804d28e;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index c8e454d..cf99e12 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -9,53 +9,62 @@ 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, pprDeeper, - codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle, - ifPprDebug, unqualStyle, + getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprSetDepth, + codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, + ifPprDebug, unqualStyle, + mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle, SDoc, -- Abstract + 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, 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, sep, cat, fsep, fcat, hang, punctuate, - speakNth, speakNTimes, + speakNth, speakNTimes, speakN, speakNOf, plural, printSDoc, printErrs, printDump, - printForC, printForAsm, printForIface, printForUser, - pprCode, pprCols, - showSDoc, showSDocForUser, showSDocDebug, showSDocIface, + printForC, printForAsm, printForUser, + pprCode, mkCodeStyle, + showSDoc, showSDocForUser, showSDocDebug, showSDocDump, showSDocUnqual, showsPrecSDoc, pprHsChar, pprHsString, - -- error handling - pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace, - trace, panic, panic#, assertPanic + pprPanic, assertPprPanic, pprPanic#, pprPgmError, + pprTrace, warnPprTrace, + trace, pgmError, panic, panic#, assertPanic ) where #include "HsVersions.h" -import {-# SOURCE #-} Name( Name ) +import {-# SOURCE #-} Module( Module ) +import {-# SOURCE #-} OccName( OccName ) -import IO ( Handle, hPutChar, hPutStr, stderr, stdout ) -import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength ) +import StaticFlags ( opt_PprStyle_Debug, opt_PprUserLength ) +import PackageConfig ( PackageId, packageIdString ) import FastString import qualified Pretty -import Pretty ( Doc, Mode(..), TextDetails(..), fullRender ) +import Pretty ( Doc, Mode(..) ) import Panic -import Char ( chr, ord, isDigit ) + +import DATA_WORD ( Word32 ) + +import IO ( Handle, stderr, stdout, hFlush ) +import Char ( ord ) \end{code} @@ -67,16 +76,21 @@ import Char ( chr, ord, isDigit ) \begin{code} data PprStyle - = PprUser PrintUnqualified Depth -- Pretty-print in a way that will - -- make sense to the ordinary user; - -- must be very close to Haskell - -- syntax, etc. + = PprUser PrintUnqualified Depth + -- Pretty-print in a way that will make sense to the + -- ordinary user; must be very close to Haskell + -- syntax, etc. + -- Assumes printing tidied code: non-system names are + -- printed without uniques. - | PprInterface PrintUnqualified -- Interface generation + | PprCode CodeStyle + -- Print code; either C or assembler - | PprCode CodeStyle -- Print code; either C or assembler + | PprDump -- For -ddump-foo; less verbose than PprDebug. + -- Does not assume tidied code: non-external names + -- are printed with uniques. - | PprDebug -- Standard debugging output + | PprDebug -- Full debugging output data CodeStyle = CStyle -- The format of labels differs for C and assembler | AsmStyle @@ -85,16 +99,31 @@ data Depth = AllTheWay | PartWay Int -- 0 => stop -type PrintUnqualified = Name -> Bool +type PrintUnqualified = Module -> OccName -> Bool -- This function tells when it's ok to print -- a (Global) name unqualified alwaysQualify,neverQualify :: PrintUnqualified -alwaysQualify n = False -neverQualify n = True +alwaysQualify m n = False +neverQualify m n = True defaultUserStyle = mkUserStyle alwaysQualify AllTheWay +defaultDumpStyle | opt_PprStyle_Debug = PprDebug + | otherwise = PprDump + +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} @@ -119,20 +148,26 @@ 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 unqual (PartWay 0)) = Pretty.text "..." pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1))) pprDeeper d other_sty = d other_sty +pprSetDepth :: Int -> SDoc -> SDoc +pprSetDepth n d (PprUser unqual _) = d (PprUser unqual (PartWay n)) +pprSetDepth n 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 (PprInterface unqual) n = unqual n -unqualStyle other n = False +unqualStyle :: PprStyle -> PrintUnqualified +unqualStyle (PprUser unqual _) m n = unqual m n +unqualStyle other m n = False codeStyle :: PprStyle -> Bool codeStyle (PprCode _) = True @@ -142,9 +177,9 @@ asmStyle :: PprStyle -> Bool asmStyle (PprCode AsmStyle) = True asmStyle other = False -ifaceStyle :: PprStyle -> Bool -ifaceStyle (PprInterface _) = True -ifaceStyle other = False +dumpStyle :: PprStyle -> Bool +dumpStyle PprDump = True +dumpStyle other = False debugStyle :: PprStyle -> Bool debugStyle PprDebug = True @@ -160,44 +195,42 @@ 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 :: PrintUnqualified -> SDoc -> IO () -printErrs unqual doc = 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 = 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 defaultDumpStyle) + hFlush stdout + where + better_doc = doc $$ text "" printForUser :: Handle -> PrintUnqualified -> SDoc -> IO () printForUser handle unqual doc - = printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay)) - --- printForIface prints all on one line for interface files. --- It's called repeatedly for successive lines -printForIface :: Handle -> PrintUnqualified -> SDoc -> IO () -printForIface handle unqual doc - = printDoc LeftMode handle (doc (PprInterface unqual)) + = 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)) +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 @@ -214,17 +247,21 @@ showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay)) showsPrecSDoc :: Int -> SDoc -> ShowS showsPrecSDoc p d = showsPrec p (d defaultUserStyle) -showSDocIface :: SDoc -> String -showSDocIface doc = showDocWith OneLineMode (doc (PprInterface alwaysQualify)) +showSDocDump :: SDoc -> String +showSDocDump d = show (d PprDump) 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 @@ -259,6 +296,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 '.' @@ -335,90 +373,71 @@ instance (Outputable a, Outputable b, Outputable c, Outputable d) => ppr w]) instance Outputable FastString where - ppr fs = text (unpackFS fs) -- Prints an unadorned string, - -- no double quotes or anything - -#if __GLASGOW_HASKELL__ < 410 --- Assume we have only 8-bit Chars. - -pprHsChar :: Int -> SDoc -pprHsChar c = char '\'' <> text (showCharLit c "") <> char '\'' - -pprHsString :: FAST_STRING -> SDoc -pprHsString fs = doubleQuotes (text (foldr showCharLit "" (_UNPK_INT_ fs))) - -showCharLit :: Int -> String -> String -showCharLit c rest - | c == ord '\"' = "\\\"" ++ rest - | c == ord '\'' = "\\\'" ++ rest - | c == ord '\\' = "\\\\" ++ rest - | c >= 0x20 && c <= 0x7E = chr c : rest - | c == ord '\a' = "\\a" ++ rest - | c == ord '\b' = "\\b" ++ rest - | c == ord '\f' = "\\f" ++ rest - | c == ord '\n' = "\\n" ++ rest - | c == ord '\r' = "\\r" ++ rest - | c == ord '\t' = "\\t" ++ rest - | c == ord '\v' = "\\v" ++ rest - | otherwise = ('\\':) $ shows c $ case rest of - d:_ | isDigit d -> "\\&" ++ rest - _ -> rest - -#else --- We have 31-bit Chars and will simply use Show instances --- of Char and String. + ppr fs = ftext fs -- Prints an unadorned string, + -- no double quotes or anything + +instance Outputable PackageId where + ppr pid = text (packageIdString pid) +\end{code} -pprHsChar :: Int -> SDoc -pprHsChar c = text (show (chr c)) -pprHsString :: FastString -> SDoc -pprHsString fs = text (show (unpackFS fs)) +%************************************************************************ +%* * +\subsection{The @OutputableBndr@ class} +%* * +%************************************************************************ + +When we print a binder, we often want to print its type too. +The @OutputableBndr@ class encapsulates this idea. -#endif +@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. -instance Show FastString where - showsPrec p fs = showsPrecSDoc p (ppr fs) +\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{Other helper functions} +\subsection{Random printing helpers} %* * %************************************************************************ \begin{code} -pprCols = (100 :: Int) -- could make configurable - -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 +-- We have 31-bit Chars and will simply use Show instances +-- of Char and String. - done = hPutChar hdl '\n' +pprHsChar :: Char -> SDoc +pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32)) + | otherwise = text (show c) -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 +pprHsString :: FastString -> SDoc +pprHsString fs = text (show (unpackFS fs)) \end{code} +%************************************************************************ +%* * +\subsection{Other helper functions} +%* * +%************************************************************************ + \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) +interppSP xs = sep (map ppr xs) interpp'SP :: Outputable a => [a] -> SDoc -interpp'SP xs = hsep (punctuate comma (map ppr xs)) +interpp'SP xs = sep (punctuate comma (map ppr xs)) pprQuotedList :: Outputable a => [a] -> SDoc -- [x,y,z] ==> `x', `y', `z' @@ -437,28 +456,44 @@ pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs)) \begin{code} speakNth :: Int -> SDoc - speakNth 1 = ptext SLIT("first") speakNth 2 = ptext SLIT("second") 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" + + last_dig = n `rem` 10 + +speakN :: Int -> SDoc +speakN 0 = ptext SLIT("none") -- E.g. "he has none" +speakN 1 = ptext SLIT("one") -- E.g. "he has one" +speakN 2 = ptext SLIT("two") +speakN 3 = ptext SLIT("three") +speakN 4 = ptext SLIT("four") +speakN 5 = ptext SLIT("five") +speakN 6 = ptext SLIT("six") +speakN n = int n + +speakNOf :: Int -> SDoc -> SDoc +speakNOf 0 d = ptext SLIT("no") <+> d <> char 's' -- E.g. "no arguments" +speakNOf 1 d = ptext SLIT("one") <+> d -- E.g. "one argument" +speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments" - n_rem_10 = n `rem` 10 -\end{code} - -\begin{code} speakNTimes :: Int {- >=1 -} -> SDoc speakNTimes t | t == 1 = ptext SLIT("once") | t == 2 = ptext SLIT("twice") - | otherwise = int t <+> ptext SLIT("times") + | otherwise = speakN t <+> ptext SLIT("times") + +plural [x] = empty +plural xs = char 's' \end{code} @@ -469,12 +504,13 @@ speakNTimes t | t == 1 = ptext SLIT("once") %************************************************************************ \begin{code} -pprPanic :: String -> SDoc -> a -pprError :: String -> SDoc -> a +pprPanic, pprPgmError :: String -> SDoc -> a pprTrace :: String -> SDoc -> a -> a -pprPanic = pprAndThen panic -pprError = pprAndThen error -pprTrace = pprAndThen trace +pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC" + +pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled" + -- (used for unusual pgm errors) +pprTrace = pprAndThen trace pprPanic# heading pretty_msg = panic# (show (doc PprDebug)) where