X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FOutputable.lhs;h=1dbb0c376384ae38092912fcc7175525e76b825f;hb=4e6bac1ec5a0546584c945c3232863d117496d90;hp=fd50fb510dbf8f74ca9266e1ee77dc7b0ca0f465;hpb=f96194794bf099020706c3816d1a5678b40addbb;p=ghc-hetmet.git diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index fd50fb5..1dbb0c3 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -17,13 +17,13 @@ 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, @@ -33,14 +33,18 @@ module Outputable ( hang, punctuate, ppWhen, ppUnless, speakNth, speakNTimes, speakN, speakNOf, plural, + coloured, PprColour, colType, colCoerc, colDataCon, + colGlobal, colLocal, bold, keyword, + -- * 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, showSDocUnqual, showsPrecSDoc, + renderWithStyle, pprInfixVar, pprPrefixVar, pprHsChar, pprHsString, pprHsInfix, pprHsVar, @@ -56,12 +60,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, + pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError, pprTrace, warnPprTrace, - trace, pgmError, panic, panicFastInt, assertPanic + trace, pgmError, panic, sorry, panicFastInt, assertPanic ) where import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) @@ -75,12 +79,24 @@ import Pretty ( Doc, Mode(..) ) import Panic 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 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} @@ -186,6 +202,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 @@ -203,24 +222,39 @@ code (either C or assembly), or generating interface files. %************************************************************************ \begin{code} -type SDoc = PprStyle -> Doc +type SDoc = SDocContext -> Doc + +data SDocContext = SDC + { sdocStyle :: !PprStyle + , sdocLastColour :: !PprColour + -- ^ The most recently used colour. This allows nesting colours. + } + +initSDocContext :: PprStyle -> SDocContext +initSDocContext sty = SDC + { sdocStyle = sty + , sdocLastColour = colReset + } withPprStyle :: PprStyle -> SDoc -> SDoc -withPprStyle sty d _sty' = d sty +withPprStyle sty d ctxt = d ctxt{sdocStyle=sty} withPprStyleDoc :: PprStyle -> SDoc -> Doc -withPprStyleDoc sty d = d sty +withPprStyleDoc sty d = d (initSDocContext sty) pprDeeper :: SDoc -> SDoc -pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..." -pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1))) -pprDeeper d other_sty = d other_sty +pprDeeper _ SDC{sdocStyle=PprUser _ (PartWay 0)} = + Pretty.text "..." +pprDeeper d ctx@SDC{sdocStyle=PprUser q (PartWay n)} = + d ctx{sdocStyle = PprUser q (PartWay (n-1))} +pprDeeper d other_sty = + d other_sty pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc -- Truncate a list that list that is longer than the current depth -pprDeeperList f ds (PprUser q (PartWay n)) +pprDeeperList f ds ctx@SDC{sdocStyle=PprUser q (PartWay n)} | n==0 = Pretty.text "..." - | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1))) + | otherwise = f (go 0 ds) ctx{sdocStyle = PprUser q (PartWay (n-1))} where go _ [] = [] go i (d:ds) | i >= n = [text "...."] @@ -230,11 +264,12 @@ pprDeeperList f ds other_sty = f ds other_sty pprSetDepth :: Depth -> SDoc -> SDoc -pprSetDepth depth doc (PprUser q _) = doc (PprUser q depth) +pprSetDepth depth doc ctx@SDC{sdocStyle=PprUser q _} = + doc ctx{sdocStyle = PprUser q depth} pprSetDepth _depth doc other_sty = doc other_sty getPprStyle :: (PprStyle -> SDoc) -> SDoc -getPprStyle df sty = df sty sty +getPprStyle df sty = df (sdocStyle sty) sty \end{code} \begin{code} @@ -267,47 +302,53 @@ userStyle (PprUser _ _) = True userStyle _other = False ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style -ifPprDebug d sty@PprDebug = d sty -ifPprDebug _ _ = Pretty.empty +ifPprDebug d ctx@SDC{sdocStyle=PprDebug} = d ctx +ifPprDebug _ _ = Pretty.empty \end{code} \begin{code} -- Unused [7/02 sof] printSDoc :: SDoc -> PprStyle -> IO () printSDoc d sty = do - Pretty.printDoc PageMode stdout (d sty) + Pretty.printDoc PageMode stdout (d (initSDocContext sty)) hFlush stdout -- 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 :: Doc -> IO () -printErrs doc = do Pretty.printDoc PageMode stderr doc - hFlush stderr +printErrs :: SDoc -> PprStyle -> IO () +printErrs doc sty = do + Pretty.printDoc PageMode stderr (doc (initSDocContext sty)) + hFlush stderr + +printOutput :: Doc -> IO () +printOutput doc = Pretty.printDoc PageMode stdout doc printDump :: SDoc -> IO () printDump doc = hPrintDump stdout doc hPrintDump :: Handle -> SDoc -> IO () hPrintDump h doc = do - Pretty.printDoc PageMode h (better_doc defaultDumpStyle) + Pretty.printDoc PageMode h (better_doc (initSDocContext defaultDumpStyle)) hFlush h where better_doc = doc $$ blankLine printForUser :: Handle -> PrintUnqualified -> SDoc -> IO () printForUser handle unqual doc - = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay)) + = Pretty.printDoc PageMode handle (doc (initSDocContext (mkUserStyle unqual AllTheWay))) printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO () printForUserPartWay handle d unqual doc - = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d))) + = Pretty.printDoc PageMode handle (doc (initSDocContext (mkUserStyle unqual (PartWay d)))) -- printForC, printForAsm do what they sound like printForC :: Handle -> SDoc -> IO () -printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle)) +printForC handle doc = + Pretty.printDoc LeftMode handle (doc (initSDocContext (PprCode CStyle))) printForAsm :: Handle -> SDoc -> IO () -printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle)) +printForAsm handle doc = + Pretty.printDoc LeftMode handle (doc (initSDocContext (PprCode AsmStyle))) pprCode :: CodeStyle -> SDoc -> SDoc pprCode cs d = withPprStyle (PprCode cs) d @@ -319,32 +360,40 @@ mkCodeStyle = PprCode -- However, Doc *is* an instance of Show -- showSDoc just blasts it out as a string showSDoc :: SDoc -> String -showSDoc d = Pretty.showDocWith PageMode (d defaultUserStyle) +showSDoc d = Pretty.showDocWith PageMode (d (initSDocContext defaultUserStyle)) + +renderWithStyle :: SDoc -> PprStyle -> String +renderWithStyle sdoc sty = + Pretty.render (sdoc (initSDocContext sty)) -- 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) +showSDocOneLine d = + Pretty.showDocWith PageMode (d (initSDocContext defaultUserStyle)) showSDocForUser :: PrintUnqualified -> SDoc -> String -showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay)) +showSDocForUser unqual doc = + show (doc (initSDocContext (mkUserStyle unqual AllTheWay))) showSDocUnqual :: SDoc -> String -- Only used in the gruesome isOperator -showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay)) +showSDocUnqual d = + show (d (initSDocContext (mkUserStyle neverQualify AllTheWay))) showsPrecSDoc :: Int -> SDoc -> ShowS -showsPrecSDoc p d = showsPrec p (d defaultUserStyle) +showsPrecSDoc p d = showsPrec p (d (initSDocContext defaultUserStyle)) showSDocDump :: SDoc -> String -showSDocDump d = Pretty.showDocWith PageMode (d PprDump) +showSDocDump d = Pretty.showDocWith PageMode (d (initSDocContext PprDump)) showSDocDumpOneLine :: SDoc -> String -showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump) +showSDocDumpOneLine d = + Pretty.showDocWith OneLineMode (d (initSDocContext PprDump)) showSDocDebug :: SDoc -> String -showSDocDebug d = show (d PprDebug) +showSDocDebug d = show (d (initSDocContext PprDebug)) showPpr :: Outputable a => a -> String showPpr = showSDoc . ppr @@ -398,11 +447,12 @@ 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, blankLine :: SDoc +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 @@ -481,6 +531,50 @@ ppWhen False _ = empty ppUnless True _ = empty ppUnless False doc = doc + +-- | A colour\/style for use with 'coloured'. +newtype PprColour = PprColour String + +-- Colours + +colType :: PprColour +colType = PprColour "\27[34m" + +colBold :: PprColour +colBold = PprColour "\27[;1m" + +colCoerc :: PprColour +colCoerc = PprColour "\27[34m" + +colDataCon :: PprColour +colDataCon = PprColour "\27[31;1m" + +colGlobal :: PprColour +colGlobal = PprColour "\27[32m" + +colLocal :: PprColour +colLocal = PprColour "\27[35m" + +colReset :: PprColour +colReset = PprColour "\27[0m" + +-- | Apply the given colour\/style for the argument. +-- +-- Only takes effect if colours are enabled. +coloured :: PprColour -> SDoc -> SDoc +-- TODO: coloured _ sdoc ctxt | coloursDisabled = sdoc ctxt +coloured col@(PprColour c) sdoc + ctx@SDC{ sdocLastColour = PprColour lc } = + Pretty.zeroWidthText c Pretty.<> sdoc ctx' Pretty.<> Pretty.zeroWidthText lc + where + ctx' = ctx{ sdocLastColour = col } + +bold :: SDoc -> SDoc +bold = coloured colBold + +keyword :: SDoc -> SDoc +keyword = bold + \end{code} @@ -557,6 +651,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} %************************************************************************ @@ -594,7 +693,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 @@ -660,7 +759,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} @@ -747,37 +854,47 @@ 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 + 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 +pprPanicFastInt heading pretty_msg = + panicFastInt (show (doc (initSDocContext PprDebug))) + where + doc = text heading <+> pretty_msg + pprAndThen :: (String -> a) -> String -> SDoc -> a -pprAndThen cont heading pretty_msg = cont (show (doc PprDebug)) - where +pprAndThen cont heading pretty_msg = + cont (show (doc (initSDocContext PprDebug))) + where doc = sep [text heading, nest 4 pretty_msg] assertPprPanic :: String -> Int -> SDoc -> a -- ^ Panic with an assertation failure, recording the given file and line number. -- Should typically be accessed with the ASSERT family of macros assertPprPanic file line msg - = panic (show (doc PprDebug)) + = panic (show (doc (initSDocContext PprDebug))) where doc = sep [hsep[text "ASSERT failed! file", text file, @@ -790,7 +907,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 (initSDocContext defaultDumpStyle))) x where doc = sep [hsep [text "WARNING: file", text file, text "line", int line], msg]