X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FOutputable.lhs;h=84e8b9d1d48b0db7e307f305d363968166401db0;hb=e9f9ec1e57d53b9302a395ce0d02c0fa59e28341;hp=548dc2ca8b53b72f94675506318e22d9a579f0b8;hpb=6e5eafac797562bc2a72068dd27f19adc75bdb41;p=ghc-hetmet.git diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 548dc2c..84e8b9d 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -25,23 +25,26 @@ module Outputable ( parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets, semi, comma, colon, dcolon, space, equals, dot, arrow, 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, 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(..), @@ -54,7 +57,7 @@ module Outputable ( ifPprDebug, qualName, qualModule, mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle, mkUserStyle, 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 @@ -226,9 +229,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 @@ -289,7 +292,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 +319,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 +338,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 +398,24 @@ 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 +lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc + +blankLine _sty = Pretty.ptext (sLit "") +dcolon _sty = Pretty.ptext (sLit "::") +arrow _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 +474,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 +504,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 "()" @@ -761,7 +790,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]