PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper,
- codeStyle, userStyle, debugStyle, asmStyle,
+ codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
ifPprDebug, unqualStyle,
mkErrStyle, defaultErrStyle,
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(..) )
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}
\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
| 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)
\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
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
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 ""
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}
%************************************************************************
\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}
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'
%************************************************************************
\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
projects / ghc-hetmet.git / blobdiff