X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FOutputable.lhs;h=96d611f0dd9b7d1efa522291163765181064c034;hb=20d7560469e59d78c17992ce4be75360c91587bb;hp=1ddb112812088751c80137626ae289381f79a198;hpb=e7a80ef9f4ba0e2e6edeed04a0acc6e93cb9f91c;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 1ddb112..96d611f 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -7,24 +7,22 @@ Defines classes for pretty-printing and forcing, both forms of ``output.'' \begin{code} -{-# OPTIONS -fno-prune-tydecls #-} --- Hopefully temporary; 3.02 complained about not being able --- to see the consructors for ForeignObj module Outputable ( Outputable(..), -- Class - PprStyle, CodeStyle(..), - getPprStyle, withPprStyle, pprDeeper, + PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, + getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle, - ifPprDebug, ifNotPprForUser, + ifPprDebug, unqualStyle, SDoc, -- Abstract - interppSP, interpp'SP, pprQuotedList, + docToSDoc, + interppSP, interpp'SP, pprQuotedList, pprWithCommas, empty, nest, text, char, ptext, int, integer, float, double, rational, - parens, brackets, braces, quotes, doubleQuotes, + parens, brackets, braces, quotes, doubleQuotes, angleBrackets, semi, comma, colon, dcolon, space, equals, dot, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, (<>), (<+>), hcat, hsep, @@ -34,10 +32,12 @@ module Outputable ( hang, punctuate, speakNth, speakNTimes, - printSDoc, printErrs, printDump, - printForC, printForAsm, printForIface, - pprCode, pprCols, - showSDoc, showsPrecSDoc, pprFSAsString, + printSDoc, printErrs, printDump, + printForC, printForAsm, printForIface, printForUser, + pprCode, mkCodeStyle, + showSDoc, showSDocForUser, showSDocDebug, showSDocIface, + showSDocUnqual, showsPrecSDoc, + pprHsChar, pprHsString, -- error handling @@ -48,14 +48,20 @@ module Outputable ( #include "HsVersions.h" -import IO ( Handle, hPutChar, hPutStr, stderr, stdout ) +import {-# SOURCE #-} Name( Name ) + import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength ) import FastString import qualified Pretty import Pretty ( Doc, Mode(..), TextDetails(..), fullRender ) import Panic -import ST ( runST ) -import Foreign + +import Word ( Word32 ) +import IO ( Handle, stderr, stdout ) +import Char ( chr ) +#if __GLASGOW_HASKELL__ < 410 +import Char ( ord, isDigit ) +#endif \end{code} @@ -67,23 +73,36 @@ import Foreign \begin{code} data PprStyle - = PprUser 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. - | PprDebug -- Standard debugging output - - | PprInterface -- Interface generation + | PprInterface PrintUnqualified -- Interface generation | PprCode CodeStyle -- Print code; either C or assembler + | PprDebug -- Standard debugging output data CodeStyle = CStyle -- The format of labels differs for C and assembler | AsmStyle data Depth = AllTheWay | PartWay Int -- 0 => stop + + +type PrintUnqualified = Name -> Bool + -- This function tells when it's ok to print + -- a (Global) name unqualified + +alwaysQualify,neverQualify :: PrintUnqualified +alwaysQualify n = False +neverQualify n = True + +defaultUserStyle = mkUserStyle alwaysQualify AllTheWay + +mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug + | otherwise = PprUser unqual depth \end{code} Orthogonal to the above printing styles are (possibly) some @@ -106,16 +125,24 @@ 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 (PartWay 0)) = Pretty.text "..." -pprDeeper d (PprUser (PartWay n)) = d (PprUser (PartWay (n-1))) -pprDeeper d other_sty = d other_sty +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 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 + codeStyle :: PprStyle -> Bool codeStyle (PprCode _) = True codeStyle _ = False @@ -125,22 +152,16 @@ asmStyle (PprCode AsmStyle) = True asmStyle other = False ifaceStyle :: PprStyle -> Bool -ifaceStyle PprInterface = True -ifaceStyle other = False +ifaceStyle (PprInterface _) = True +ifaceStyle other = False debugStyle :: PprStyle -> Bool debugStyle PprDebug = True debugStyle other = False userStyle :: PprStyle -> Bool -userStyle (PprUser _) = True -userStyle other = False -\end{code} - -\begin{code} -ifNotPprForUser :: SDoc -> SDoc -- Returns empty document for User style -ifNotPprForUser d sty@(PprUser _) = Pretty.empty -ifNotPprForUser d sty = d sty +userStyle (PprUser _ _) = True +userStyle other = False ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style ifPprDebug d sty@PprDebug = d sty @@ -149,51 +170,73 @@ ifPprDebug d sty = Pretty.empty \begin{code} printSDoc :: SDoc -> PprStyle -> IO () -printSDoc d sty = printDoc PageMode stdout (d sty) +printSDoc d sty = Pretty.printDoc PageMode stdout (d sty) --- 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 :: SDoc -> IO () -printErrs doc = printDoc PageMode stderr (final_doc user_style) - where - final_doc = doc -- $$ text "" - user_style = mkUserStyle (PartWay opt_PprUserLength) +printErrs :: PrintUnqualified -> SDoc -> IO () +printErrs unqual doc = Pretty.printDoc PageMode stderr (doc style) + where + style = mkUserStyle unqual (PartWay opt_PprUserLength) printDump :: SDoc -> IO () -printDump doc = printDoc PageMode stderr (final_doc PprDebug) - where - final_doc = doc $$ text "" +printDump doc = Pretty.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 +printForUser :: Handle -> PrintUnqualified -> SDoc -> IO () +printForUser handle unqual doc + = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay)) --- printForC, printForAsm doe what they sound like +-- 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 + = Pretty.printDoc LeftMode handle (doc (PprInterface unqual)) + +-- 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)) - --- printForIface prints all on one line for interface files. --- It's called repeatedly for successive lines -printForIface :: Handle -> SDoc -> IO () -printForIface handle doc = printDoc OneLineMode handle (doc PprInterface) +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 showSDoc :: SDoc -> String -showSDoc d = show (d (mkUserStyle AllTheWay)) +showSDoc d = show (d defaultUserStyle) + +showSDocForUser :: PrintUnqualified -> SDoc -> String +showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay)) + +showSDocUnqual :: SDoc -> String +-- Only used in the gruesome HsExpr.isOperator +showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay)) showsPrecSDoc :: Int -> SDoc -> ShowS -showsPrecSDoc p d = showsPrec p (d (mkUserStyle AllTheWay)) +showsPrecSDoc p d = showsPrec p (d defaultUserStyle) + +showSDocIface :: SDoc -> String +showSDocIface doc = showDocWith OneLineMode (doc (PprInterface alwaysQualify)) -mkUserStyle depth | opt_PprStyle_Debug = PprDebug - | otherwise = PprUser depth +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 @@ -208,6 +251,7 @@ parens d sty = Pretty.parens (d sty) braces d sty = Pretty.braces (d sty) brackets d sty = Pretty.brackets (d sty) doubleQuotes d sty = Pretty.doubleQuotes (d sty) +angleBrackets d = char '<' <> d <> char '>' -- quotes encloses something in single quotes... -- but it omits them if the thing ends in a single quote @@ -277,6 +321,9 @@ instance Outputable Bool where instance Outputable Int where ppr n = int n +instance Outputable () where + ppr _ = text "()" + instance (Outputable a) => Outputable [a] where ppr xs = brackets (fsep (punctuate comma (map ppr xs))) @@ -284,8 +331,8 @@ instance (Outputable a, Outputable b) => Outputable (a, b) where ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) instance Outputable a => Outputable (Maybe a) where - ppr Nothing = text "Nothing" - ppr (Just x) = text "Just" <+> ppr x + ppr Nothing = ptext SLIT("Nothing") + ppr (Just x) = ptext SLIT("Just") <+> ppr x -- ToDo: may not be used instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where @@ -294,12 +341,56 @@ instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) wher ppr y <> comma, ppr z ]) +instance (Outputable a, Outputable b, Outputable c, Outputable d) => + Outputable (a, b, c, d) where + ppr (x,y,z,w) = + parens (sep [ppr x <> comma, + ppr y <> comma, + ppr z <> comma, + ppr w]) + instance Outputable FastString where ppr fs = text (unpackFS fs) -- Prints an unadorned string, -- no double quotes or anything -pprFSAsString :: FastString -> SDoc -- The Char instance of Show prints -pprFSAsString fs = text (showList (unpackFS fs) "") -- strings with double quotes and escapes +#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 (fromIntegral c :: Word32) $ case rest of + d:_ | isDigit d -> "\\&" ++ rest + _ -> rest + +#else +-- We have 31-bit Chars and will simply use Show instances +-- of Char and String. + +pprHsChar :: Int -> SDoc +pprHsChar c | c > 0x10ffff = char '\\' <> text (show (fromIntegral c :: Word32)) + | otherwise = text (show (chr c)) + +pprHsString :: FastString -> SDoc +pprHsString fs = text (show (unpackFS fs)) + +#endif instance Show FastString where showsPrec p fs = showsPrecSDoc p (ppr fs) @@ -313,21 +404,20 @@ instance Show FastString where %************************************************************************ \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 +showDocWith :: Mode -> Doc -> String +showDocWith mode doc + = fullRender mode 100 1.5 put "" 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 - - done = hPutChar hdl '\n' + put (Chr c) s = c:s + put (Str s1) s2 = s1 ++ s2 + put (PStr s1) s2 = _UNPK_ s1 ++ s2 \end{code} \begin{code} +pprWithCommas :: (a -> SDoc) -> [a] -> SDoc +pprWithCommas pp xs = hsep (punctuate comma (map pp xs)) + interppSP :: Outputable a => [a] -> SDoc interppSP xs = hsep (map ppr xs) @@ -397,7 +487,7 @@ pprPanic# heading pretty_msg = panic# (show (doc PprDebug)) pprAndThen :: (String -> a) -> String -> SDoc -> a pprAndThen cont heading pretty_msg = cont (show (doc PprDebug)) where - doc = text heading <+> pretty_msg + doc = sep [text heading, nest 4 pretty_msg] assertPprPanic :: String -> Int -> SDoc -> a assertPprPanic file line msg