X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FOutputable.lhs;h=61ad4ddd22216a6465956639cb539d2f66480260;hb=cee4bfd3a0c0852946966333bbff47654e9e35b2;hp=85b32e46c3bb0aa343a4f5b98989707e9c200f96;hpb=1a7d1b77334529ca96ed4cbc03fcb5f55dc2de4a;p=ghc-hetmet.git diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 85b32e4..61ad4dd 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -12,12 +12,14 @@ module Outputable ( BindingSite(..), - PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, QualifyName(..), + PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify, + QualifyName(..), getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprDeeperList, pprSetDepth, codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, ifPprDebug, qualName, qualModule, mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle, + mkUserStyle, SDoc, -- Abstract docToSDoc, @@ -36,28 +38,24 @@ module Outputable ( speakNth, speakNTimes, speakN, speakNOf, plural, printSDoc, printErrs, hPrintDump, printDump, - printForC, printForAsm, printForUser, + printForC, printForAsm, printForUser, printForUserPartWay, pprCode, mkCodeStyle, showSDoc, showSDocForUser, showSDocDebug, showSDocDump, showSDocUnqual, showsPrecSDoc, pprHsChar, pprHsString, -- error handling - pprPanic, assertPprPanic, pprPanic#, pprPgmError, + pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError, pprTrace, warnPprTrace, - trace, pgmError, panic, panic#, assertPanic + trace, pgmError, panic, panicFastInt, assertPanic ) where -#include "HsVersions.h" - - import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) import {-# SOURCE #-} OccName( OccName ) -import StaticFlags ( opt_PprStyle_Debug, opt_PprUserLength ) +import StaticFlags import FastString import FastTypes -import GHC.Ptr import qualified Pretty import Pretty ( Doc, Mode(..) ) import Panic @@ -286,6 +284,10 @@ printForUser :: Handle -> PrintUnqualified -> SDoc -> IO () printForUser handle unqual doc = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay)) +printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO () +printForUserPartWay handle d unqual doc + = Pretty.printDoc PageMode handle (doc (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)) @@ -330,7 +332,7 @@ empty :: SDoc text :: String -> SDoc char :: Char -> SDoc ftext :: FastString -> SDoc -ptext :: Ptr t -> SDoc +ptext :: LitString -> SDoc int :: Int -> SDoc integer :: Integer -> SDoc float :: Float -> SDoc @@ -377,8 +379,8 @@ 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("->") +dcolon _sty = Pretty.ptext (sLit "::") +arrow _sty = Pretty.ptext (sLit "->") underscore = char '_' dot = char '.' lparen _sty = Pretty.lparen @@ -434,12 +436,15 @@ class Outputable a where \begin{code} instance Outputable Bool where - ppr True = ptext SLIT("True") - ppr False = ptext SLIT("False") + ppr True = ptext (sLit "True") + ppr False = ptext (sLit "False") instance Outputable Int where ppr n = int n +instance Outputable Word32 where + ppr n = integer $ fromIntegral n + instance Outputable () where ppr _ = text "()" @@ -450,12 +455,12 @@ 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 = ptext SLIT("Nothing") - ppr (Just x) = ptext SLIT("Just") <+> ppr x + ppr Nothing = ptext (sLit "Nothing") + ppr (Just x) = ptext (sLit "Just") <+> ppr x instance (Outputable a, Outputable b) => Outputable (Either a b) where - ppr (Left x) = ptext SLIT("Left") <+> ppr x - ppr (Right y) = ptext SLIT("Right") <+> ppr y + ppr (Left x) = ptext (sLit "Left") <+> ppr x + ppr (Right y) = ptext (sLit "Right") <+> ppr y -- ToDo: may not be used instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where @@ -466,11 +471,20 @@ instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) wher 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]) + ppr (a,b,c,d) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) => + Outputable (a, b, c, d, e) where + ppr (a,b,c,d,e) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e]) instance Outputable FastString where ppr fs = ftext fs -- Prints an unadorned string, @@ -553,12 +567,12 @@ pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs)) \begin{code} speakNth :: Int -> SDoc -speakNth 1 = ptext SLIT("first") -speakNth 2 = ptext SLIT("second") -speakNth 3 = ptext SLIT("third") -speakNth 4 = ptext SLIT("fourth") -speakNth 5 = ptext SLIT("fifth") -speakNth 6 = ptext SLIT("sixth") +speakNth 1 = ptext (sLit "first") +speakNth 2 = ptext (sLit "second") +speakNth 3 = ptext (sLit "third") +speakNth 4 = ptext (sLit "fourth") +speakNth 5 = ptext (sLit "fifth") +speakNth 6 = ptext (sLit "sixth") speakNth n = hcat [ int n, text suffix ] where suffix | n <= 20 = "th" -- 11,12,13 are non-std @@ -570,24 +584,24 @@ speakNth n = hcat [ int n, text suffix ] last_dig = n `rem` 10 speakN :: Int -> SDoc -speakN 0 = ptext SLIT("none") -- E.g. "he has none" -speakN 1 = ptext SLIT("one") -- E.g. "he has one" -speakN 2 = ptext SLIT("two") -speakN 3 = ptext SLIT("three") -speakN 4 = ptext SLIT("four") -speakN 5 = ptext SLIT("five") -speakN 6 = ptext SLIT("six") +speakN 0 = ptext (sLit "none") -- E.g. "he has none" +speakN 1 = ptext (sLit "one") -- E.g. "he has one" +speakN 2 = ptext (sLit "two") +speakN 3 = ptext (sLit "three") +speakN 4 = ptext (sLit "four") +speakN 5 = ptext (sLit "five") +speakN 6 = ptext (sLit "six") speakN n = int n speakNOf :: Int -> SDoc -> SDoc -speakNOf 0 d = ptext SLIT("no") <+> d <> char 's' -- E.g. "no arguments" -speakNOf 1 d = ptext SLIT("one") <+> d -- E.g. "one argument" +speakNOf 0 d = ptext (sLit "no") <+> d <> char 's' -- E.g. "no arguments" +speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument" speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments" speakNTimes :: Int {- >=1 -} -> SDoc -speakNTimes t | t == 1 = ptext SLIT("once") - | t == 2 = ptext SLIT("twice") - | otherwise = speakN t <+> ptext SLIT("times") +speakNTimes t | t == 1 = ptext (sLit "once") + | t == 2 = ptext (sLit "twice") + | otherwise = speakN t <+> ptext (sLit "times") plural :: [a] -> SDoc plural [_] = empty -- a bit frightening, but there you are @@ -608,10 +622,12 @@ pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC" pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled" -- (used for unusual pgm errors) -pprTrace = pprAndThen trace +pprTrace str doc x + | opt_NoDebugOutput = x + | otherwise = pprAndThen trace str doc x -pprPanic# :: String -> SDoc -> FastInt -pprPanic# heading pretty_msg = panic# (show (doc PprDebug)) +pprPanicFastInt :: String -> SDoc -> FastInt +pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug)) where doc = text heading <+> pretty_msg @@ -630,6 +646,7 @@ assertPprPanic file line msg msg] 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