X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FOutputable.lhs;h=7a643d7eb40fb210f6164bb1a729d4507227793d;hp=548dc2ca8b53b72f94675506318e22d9a579f0b8;hb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;hpb=6e5eafac797562bc2a72068dd27f19adc75bdb41 diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 548dc2c..7a643d7 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -17,31 +17,34 @@ module Outputable ( -- * Pretty printing combinators SDoc, docToSDoc, - interppSP, interpp'SP, pprQuotedList, pprWithCommas, + interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr, empty, nest, char, text, ftext, ptext, int, integer, float, double, rational, parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets, - semi, comma, colon, dcolon, space, equals, dot, arrow, + semi, comma, colon, dcolon, space, equals, dot, arrow, darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, + blankLine, (<>), (<+>), hcat, hsep, ($$), ($+$), vcat, sep, cat, fsep, fcat, - hang, punctuate, + hang, punctuate, ppWhen, ppUnless, speakNth, speakNTimes, speakN, speakNOf, plural, -- * Converting 'SDoc' into strings and outputing it - printSDoc, printErrs, hPrintDump, printDump, + printSDoc, printErrs, printOutput, hPrintDump, printDump, printForC, printForAsm, printForUser, printForUserPartWay, pprCode, mkCodeStyle, - showSDoc, showSDocForUser, showSDocDebug, showSDocDump, + showSDoc, showSDocOneLine, + showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, + showPpr, showSDocUnqual, showsPrecSDoc, pprInfixVar, pprPrefixVar, pprHsChar, pprHsString, pprHsInfix, pprHsVar, - pprFastFilePath, + pprFastFilePath, -- * Controlling the style in which output is printed BindingSite(..), @@ -53,8 +56,8 @@ module Outputable ( codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, ifPprDebug, qualName, qualModule, mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle, - mkUserStyle, Depth(..), - + mkUserStyle, cmdlineParserStyle, Depth(..), + -- * Error handling and debugging utilities pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError, pprTrace, warnPprTrace, @@ -69,12 +72,11 @@ import FastString import FastTypes import qualified Pretty import Pretty ( Doc, Mode(..) ) -import Char ( isAlpha ) import Panic -import Data.Word ( Word32 ) +import Data.Char +import Data.Word import System.IO ( Handle, stderr, stdout, hFlush ) -import Data.Char ( ord ) import System.FilePath \end{code} @@ -127,6 +129,7 @@ data Depth = AllTheWay -- in source code, names are qualified by ModuleNames. type QueryQualifyName = Module -> OccName -> QualifyName +-- See Note [Printing original names] in HscTypes data QualifyName -- given P:M.T = NameUnqual -- refer to it as "T" | NameQual ModuleName -- refer to it as "X.T" for the supplied X @@ -183,6 +186,9 @@ mkUserStyle :: PrintUnqualified -> Depth -> PprStyle mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug | otherwise = PprUser unqual depth + +cmdlineParserStyle :: PprStyle +cmdlineParserStyle = PprUser alwaysQualify AllTheWay \end{code} Orthogonal to the above printing styles are (possibly) some @@ -226,9 +232,9 @@ pprDeeperList f ds (PprUser q (PartWay n)) pprDeeperList f ds other_sty = f ds other_sty -pprSetDepth :: Int -> SDoc -> SDoc -pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n)) -pprSetDepth _n d other_sty = d other_sty +pprSetDepth :: Depth -> SDoc -> SDoc +pprSetDepth depth doc (PprUser q _) = doc (PprUser q depth) +pprSetDepth _depth doc other_sty = doc other_sty getPprStyle :: (PprStyle -> SDoc) -> SDoc getPprStyle df sty = df sty sty @@ -281,6 +287,9 @@ printErrs :: Doc -> IO () printErrs doc = do Pretty.printDoc PageMode stderr doc hFlush stderr +printOutput :: Doc -> IO () +printOutput doc = Pretty.printDoc PageMode stdout doc + printDump :: SDoc -> IO () printDump doc = hPrintDump stdout doc @@ -289,7 +298,7 @@ hPrintDump h doc = do Pretty.printDoc PageMode h (better_doc defaultDumpStyle) hFlush h where - better_doc = doc $$ text "" + better_doc = doc $$ blankLine printForUser :: Handle -> PrintUnqualified -> SDoc -> IO () printForUser handle unqual doc @@ -316,7 +325,13 @@ mkCodeStyle = PprCode -- However, Doc *is* an instance of Show -- showSDoc just blasts it out as a string showSDoc :: SDoc -> String -showSDoc d = show (d defaultUserStyle) +showSDoc d = Pretty.showDocWith PageMode (d defaultUserStyle) + +-- This shows an SDoc, but on one line only. It's cheaper than a full +-- showSDoc, designed for when we're getting results like "Foo.bar" +-- and "foo{uniq strictness}" so we don't want fancy layout anyway. +showSDocOneLine :: SDoc -> String +showSDocOneLine d = Pretty.showDocWith PageMode (d defaultUserStyle) showSDocForUser :: PrintUnqualified -> SDoc -> String showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay)) @@ -329,10 +344,16 @@ showsPrecSDoc :: Int -> SDoc -> ShowS showsPrecSDoc p d = showsPrec p (d defaultUserStyle) showSDocDump :: SDoc -> String -showSDocDump d = show (d PprDump) +showSDocDump d = Pretty.showDocWith PageMode (d PprDump) + +showSDocDumpOneLine :: SDoc -> String +showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump) showSDocDebug :: SDoc -> String showSDocDebug d = show (d PprDebug) + +showPpr :: Outputable a => a -> String +showPpr = showSDoc . ppr \end{code} \begin{code} @@ -383,23 +404,25 @@ quotes d sty = case show pp_d of pp_d = d sty semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc -lparen, rparen, lbrack, rbrack, lbrace, rbrace :: SDoc - -semi _sty = Pretty.semi -comma _sty = Pretty.comma -colon _sty = Pretty.colon -equals _sty = Pretty.equals -space _sty = Pretty.space -dcolon _sty = Pretty.ptext (sLit "::") -arrow _sty = Pretty.ptext (sLit "->") -underscore = char '_' -dot = char '.' -lparen _sty = Pretty.lparen -rparen _sty = Pretty.rparen -lbrack _sty = Pretty.lbrack -rbrack _sty = Pretty.rbrack -lbrace _sty = Pretty.lbrace -rbrace _sty = Pretty.rbrace +darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc + +blankLine _sty = Pretty.ptext (sLit "") +dcolon _sty = Pretty.ptext (sLit "::") +arrow _sty = Pretty.ptext (sLit "->") +darrow _sty = Pretty.ptext (sLit "=>") +semi _sty = Pretty.semi +comma _sty = Pretty.comma +colon _sty = Pretty.colon +equals _sty = Pretty.equals +space _sty = Pretty.space +underscore = char '_' +dot = char '.' +lparen _sty = Pretty.lparen +rparen _sty = Pretty.rparen +lbrack _sty = Pretty.lbrack +rbrack _sty = Pretty.rbrack +lbrace _sty = Pretty.lbrace +rbrace _sty = Pretty.rbrace nest :: Int -> SDoc -> SDoc -- ^ Indent 'SDoc' some specified amount @@ -458,6 +481,13 @@ punctuate p (d:ds) = go d ds where go d [] = [d] go d (e:es) = (d <> p) : go e es + +ppWhen, ppUnless :: Bool -> SDoc -> SDoc +ppWhen True doc = doc +ppWhen False _ = empty + +ppUnless True _ = empty +ppUnless False doc = doc \end{code} @@ -481,9 +511,15 @@ instance Outputable Bool where instance Outputable Int where ppr n = int n +instance Outputable Word16 where + ppr n = integer $ fromIntegral n + instance Outputable Word32 where ppr n = integer $ fromIntegral n +instance Outputable Word where + ppr n = integer $ fromIntegral n + instance Outputable () where ppr _ = text "()" @@ -631,7 +667,15 @@ interpp'SP xs = sep (punctuate comma (map ppr xs)) -- -- > [x,y,z] ==> `x', `y', `z' pprQuotedList :: Outputable a => [a] -> SDoc -pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs)) +pprQuotedList = quotedList . map ppr + +quotedList :: [SDoc] -> SDoc +quotedList xs = hsep (punctuate comma (map quotes xs)) + +quotedListWithOr :: [SDoc] -> SDoc +-- [x,y,z] ==> `x', `y' or `z' +quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs) +quotedListWithOr xs = quotedList xs \end{code} @@ -761,7 +805,7 @@ warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x warnPprTrace False _file _line _msg x = x warnPprTrace True file line msg x - = trace (show (doc PprDebug)) x + = trace (show (doc defaultDumpStyle)) x where doc = sep [hsep [text "WARNING: file", text file, text "line", int line], msg]