X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FOutputable.lhs;h=5a4368c09ab6e5dc6fdfe66dfe40d3b6bea3e30a;hb=2daf91758edf8a9a1116ad2ad1468627cf151303;hp=dcfe8c2dbcf346f5ec327bd1bae13ac15cb16cd7;hpb=98688c6e8fd33f31c51218cf93cbf03fe3a5e73d;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index dcfe8c2..5a4368c 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -15,7 +15,7 @@ module Outputable ( PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, - codeStyle, userStyle, debugStyle, asmStyle, + codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, ifPprDebug, unqualStyle, mkErrStyle, defaultErrStyle, @@ -42,18 +42,20 @@ module Outputable ( showSDocUnqual, showsPrecSDoc, pprHsChar, pprHsString, - -- error handling - pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace, - trace, panic, panic#, assertPanic + pprPanic, assertPprPanic, pprPanic#, pprPgmError, + pprTrace, warnPprTrace, + trace, pgmError, panic, panic#, assertPanic ) where #include "HsVersions.h" -import {-# SOURCE #-} Name( Name ) +import {-# SOURCE #-} Module( Module ) +import {-# SOURCE #-} OccName( OccName ) import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength ) +import PackageConfig ( PackageId, packageIdString ) import FastString import qualified Pretty import Pretty ( Doc, Mode(..) ) @@ -62,10 +64,7 @@ import Panic import DATA_WORD ( Word32 ) import IO ( Handle, stderr, stdout, hFlush ) -import Char ( chr ) -#if __GLASGOW_HASKELL__ < 410 -import Char ( ord, isDigit ) -#endif +import Char ( ord ) \end{code} @@ -77,14 +76,21 @@ import Char ( ord, isDigit ) \begin{code} data PprStyle - = PprUser PrintUnqualified 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. + -- Assumes printing tidied code: non-system names are + -- printed without uniques. + + | PprCode CodeStyle + -- Print code; either C or assembler - | PprCode CodeStyle -- Print code; either C or assembler + | PprDump -- For -ddump-foo; less verbose than PprDebug. + -- Does not assume tidied code: non-external names + -- are printed with uniques. - | PprDebug -- Standard debugging output + | PprDebug -- Full debugging output data CodeStyle = CStyle -- The format of labels differs for C and assembler | AsmStyle @@ -93,16 +99,19 @@ data Depth = AllTheWay | PartWay Int -- 0 => stop -type PrintUnqualified = Name -> Bool +type PrintUnqualified = Module -> OccName -> Bool -- This function tells when it's ok to print -- a (Global) name unqualified alwaysQualify,neverQualify :: PrintUnqualified -alwaysQualify n = False -neverQualify n = True +alwaysQualify m n = False +neverQualify m n = True defaultUserStyle = mkUserStyle alwaysQualify AllTheWay +defaultDumpStyle | opt_PprStyle_Debug = PprDebug + | otherwise = PprDump + mkErrStyle :: PrintUnqualified -> PprStyle -- Style for printing error messages mkErrStyle print_unqual = mkUserStyle print_unqual (PartWay opt_PprUserLength) @@ -113,7 +122,7 @@ defaultErrStyle :: PprStyle -- Only used for desugarer warnings, and typechecker errors in interface sigs defaultErrStyle | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay - | otherwise = mkUserStyle neverQualify (PartWay opt_PprUserLength) + | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength) mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug | otherwise = PprUser unqual depth @@ -152,9 +161,9 @@ getPprStyle df sty = df sty sty \end{code} \begin{code} -unqualStyle :: PprStyle -> Name -> Bool -unqualStyle (PprUser unqual _) n = unqual n -unqualStyle other n = False +unqualStyle :: PprStyle -> PrintUnqualified +unqualStyle (PprUser unqual _) m n = unqual m n +unqualStyle other m n = False codeStyle :: PprStyle -> Bool codeStyle (PprCode _) = True @@ -164,6 +173,10 @@ asmStyle :: PprStyle -> Bool asmStyle (PprCode AsmStyle) = True asmStyle other = False +dumpStyle :: PprStyle -> Bool +dumpStyle PprDump = True +dumpStyle other = False + debugStyle :: PprStyle -> Bool debugStyle PprDebug = True debugStyle other = False @@ -192,7 +205,7 @@ printErrs doc = do Pretty.printDoc PageMode stderr doc printDump :: SDoc -> IO () printDump doc = do - Pretty.printDoc PageMode stdout (better_doc defaultUserStyle) + Pretty.printDoc PageMode stdout (better_doc defaultDumpStyle) hFlush stdout where better_doc = doc $$ text "" @@ -358,6 +371,9 @@ instance (Outputable a, Outputable b, Outputable c, Outputable d) => instance Outputable FastString where ppr fs = text (unpackFS fs) -- Prints an unadorned string, -- no double quotes or anything + +instance Outputable PackageId where + ppr pid = text (packageIdString pid) \end{code} @@ -391,45 +407,16 @@ class Outputable a => OutputableBndr a where %************************************************************************ \begin{code} -#if __GLASGOW_HASKELL__ < 410 --- Assume we have only 8-bit Chars. - -pprHsChar :: Int -> SDoc -pprHsChar c = char '\'' <> text (showCharLit c "") <> char '\'' - -pprHsString :: FastString -> SDoc -pprHsString fs = doubleQuotes (text (foldr showCharLit "" (unpackIntFS 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)) +pprHsChar :: Char -> SDoc +pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32)) + | otherwise = text (show c) pprHsString :: FastString -> SDoc pprHsString fs = text (show (unpackFS fs)) -#endif - instance Show FastString where showsPrec p fs = showsPrecSDoc p (ppr fs) \end{code} @@ -446,10 +433,10 @@ pprWithCommas :: (a -> SDoc) -> [a] -> SDoc pprWithCommas pp xs = fsep (punctuate comma (map pp xs)) interppSP :: Outputable a => [a] -> SDoc -interppSP xs = hsep (map ppr xs) +interppSP xs = sep (map ppr xs) interpp'SP :: Outputable a => [a] -> SDoc -interpp'SP xs = hsep (punctuate comma (map ppr xs)) +interpp'SP xs = sep (punctuate comma (map ppr xs)) pprQuotedList :: Outputable a => [a] -> SDoc -- [x,y,z] ==> `x', `y', `z' @@ -501,12 +488,13 @@ speakNTimes t | t == 1 = ptext SLIT("once") %************************************************************************ \begin{code} -pprPanic :: String -> SDoc -> a -pprError :: String -> SDoc -> a +pprPanic, pprPgmError :: String -> SDoc -> a pprTrace :: String -> SDoc -> a -> a -pprPanic = pprAndThen panic -pprError = pprAndThen error -pprTrace = pprAndThen trace +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 pprPanic# heading pretty_msg = panic# (show (doc PprDebug)) where