X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FOutputable.lhs;h=c4a685b3b5e3ab05029bb68ab7a3ea0e7f502e0c;hp=023d7d01d183fe5ae7ce2332e2d049a09f8a7fda;hb=b187c221cc97679e28118ae8ac2997d6a686ba14;hpb=174dccda5a8213f9a777ddf5230effef6b5f464d diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 023d7d0..c4a685b 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -17,33 +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, showSDocOneLine, - showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, - showPpr, + showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, + showPpr, showSDocUnqual, showsPrecSDoc, pprInfixVar, pprPrefixVar, pprHsChar, pprHsString, pprHsInfix, pprHsVar, - pprFastFilePath, + pprFastFilePath, -- * Controlling the style in which output is printed BindingSite(..), @@ -55,12 +56,12 @@ 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, - trace, pgmError, panic, panicFastInt, assertPanic + pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError, + pprTrace, pprDefiniteTrace, warnPprTrace, + trace, pgmError, panic, sorry, panicFastInt, assertPanic ) where import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) @@ -71,16 +72,27 @@ import FastString import FastTypes import qualified Pretty import Pretty ( Doc, Mode(..) ) -import Char ( isAlpha ) import Panic -import Data.Word ( Word32 ) +import Data.Char +import qualified Data.Map as M +import qualified Data.IntMap as IM +import Data.Word import System.IO ( Handle, stderr, stdout, hFlush ) -import Data.Char ( ord ) import System.FilePath + + +#if __GLASGOW_HASKELL__ >= 701 +import GHC.Show ( showMultiLineString ) +#else +showMultiLineString :: String -> [String] +-- Crude version +showMultiLineString s = [ showList s "" ] +#endif \end{code} + %************************************************************************ %* * \subsection{The @PprStyle@ data type} @@ -129,6 +141,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 @@ -185,6 +198,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 @@ -228,9 +244,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 @@ -283,6 +299,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 @@ -291,7 +310,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 @@ -397,23 +416,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 @@ -472,6 +493,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} @@ -495,9 +523,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 "()" @@ -542,6 +576,11 @@ instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) instance Outputable FastString where ppr fs = ftext fs -- Prints an unadorned string, -- no double quotes or anything + +instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where + ppr m = ppr (M.toList m) +instance (Outputable elt) => Outputable (IM.IntMap elt) where + ppr m = ppr (IM.toList m) \end{code} %************************************************************************ @@ -579,7 +618,7 @@ pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: -- | Special combinator for showing string literals. pprHsString :: FastString -> SDoc -pprHsString fs = text (show (unpackFS fs)) +pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs))) --------------------- -- Put a name in parens if it's an operator @@ -645,7 +684,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} @@ -732,27 +779,38 @@ plural _ = char 's' %************************************************************************ \begin{code} + pprPanic :: String -> SDoc -> a -- ^ Throw an exception saying "bug in GHC" -pprPgmError :: String -> SDoc -> a --- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors) -pprTrace :: String -> SDoc -> a -> a --- ^ If debug output is on, show some 'SDoc' on the screen - pprPanic = pprAndThen panic +pprSorry :: String -> SDoc -> a +-- ^ Throw an exceptio saying "this isn't finished yet" +pprSorry = pprAndThen sorry + + +pprPgmError :: String -> SDoc -> a +-- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors) pprPgmError = pprAndThen pgmError + +pprTrace :: String -> SDoc -> a -> a +-- ^ If debug output is on, show some 'SDoc' on the screen pprTrace str doc x | opt_NoDebugOutput = x | otherwise = pprAndThen trace str doc x +pprDefiniteTrace :: String -> SDoc -> a -> a +-- ^ Same as pprTrace, but show even if -dno-debug-output is on +pprDefiniteTrace str doc x = pprAndThen trace str doc x + pprPanicFastInt :: String -> SDoc -> FastInt -- ^ Specialization of pprPanic that can be safely used with 'FastInt' pprPanicFastInt heading pretty_msg = panicFastInt (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 @@ -775,7 +833,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]