module Outputable (
Outputable(..), -- Class
- PprStyle, CodeStyle(..),
+ PprStyle, CodeStyle(..),
getPprStyle, withPprStyle, pprDeeper,
codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle,
ifPprDebug, ifNotPprForUser,
SDoc, -- Abstract
- interppSP, interpp'SP, pprQuotedList,
+ interppSP, interpp'SP, pprQuotedList, pprWithCommas,
empty, nest,
text, char, ptext,
int, integer, float, double, rational,
- parens, brackets, braces, quotes, doubleQuotes,
- semi, comma, colon, space, equals,
- lparen, rparen, lbrack, rbrack, lbrace, rbrace,
+ parens, brackets, braces, quotes, doubleQuotes, angleBrackets,
+ semi, comma, colon, dcolon, space, equals, dot,
+ lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
(<>), (<+>), hcat, hsep,
($$), ($+$), vcat,
sep, cat,
hang, punctuate,
speakNth, speakNTimes,
- printSDoc, printErrs, printDump,
- printForC, printForAsm, printForIface,
+ printSDoc, printErrs, printDump,
+ printForC, printForAsm, printForIface, printForUser,
pprCode, pprCols,
- showSDoc, showsPrecSDoc, pprFSAsString,
+ showSDoc, showSDocDebug, showSDocIface, showsPrecSDoc,
+ pprHsChar, pprHsString,
-- error handling
- pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic,
- panic, panic#, assertPanic
+ pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace,
+ trace, panic, panic#, assertPanic
) where
#include "HsVersions.h"
import FastString
import qualified Pretty
import Pretty ( Doc, Mode(..), TextDetails(..), fullRender )
-import Util ( panic, assertPanic, panic#, trace )
-import ST ( runST )
-import Foreign
+import Panic
+import Char ( chr, ord, isDigit )
\end{code}
printErrs :: SDoc -> IO ()
printErrs doc = printDoc PageMode stderr (final_doc user_style)
where
- final_doc = doc $$ text ""
+ final_doc = doc -- $$ text ""
user_style = mkUserStyle (PartWay opt_PprUserLength)
printDump :: SDoc -> IO ()
-printDump doc = printDoc PageMode stderr (final_doc PprDebug)
- where
- final_doc = doc $$ text ""
+printDump doc = printForUser stdout (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 -> SDoc -> IO ()
+printForUser handle doc = printDoc PageMode handle (doc (mkUserStyle AllTheWay))
--- printForC, printForAsm doe what they sound like
+-- printForC, printForAsm do what they sound like
printForC :: Handle -> SDoc -> IO ()
printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle))
-- 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)
+printForIface handle doc = printDoc LeftMode handle (doc PprInterface)
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
showSDoc :: SDoc -> String
showSDoc d = show (d (mkUserStyle AllTheWay))
+showSDocIface :: SDoc -> String
+showSDocIface doc = showDocWith OneLineMode (doc PprInterface)
+
+showSDocDebug :: SDoc -> String
+showSDocDebug d = show (d PprDebug)
+
showsPrecSDoc :: Int -> SDoc -> ShowS
showsPrecSDoc p d = showsPrec p (d (mkUserStyle AllTheWay))
parens d sty = Pretty.parens (d sty)
braces d sty = Pretty.braces (d sty)
brackets d sty = Pretty.brackets (d sty)
-quotes d sty = Pretty.quotes (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
+-- so that we don't get `foo''. Instead we just have foo'.
+quotes d sty = case show pp_d of
+ ('\'' : _) -> pp_d
+ other -> Pretty.quotes pp_d
+ where
+ pp_d = d sty
semi sty = Pretty.semi
comma sty = Pretty.comma
rbrack sty = Pretty.rbrack
lbrace sty = Pretty.lbrace
rbrace sty = Pretty.rbrace
+dcolon sty = Pretty.ptext SLIT("::")
+underscore = char '_'
+dot = char '.'
nest n d sty = Pretty.nest n (d sty)
(<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
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
+
-- ToDo: may not be used
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
ppr (x,y,z) =
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 c $ 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 = 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)
put (PStr s) next = hPutFS hdl s >> next
done = hPutChar hdl '\n'
+
+showDocWith :: Mode -> Doc -> String
+showDocWith mode doc
+ = fullRender mode 100 1.5 put "" doc
+ where
+ 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)
\end{code}
-
-
%************************************************************************
%* *
\subsection{Printing numbers verbally}
| otherwise = int t <+> ptext SLIT("times")
\end{code}
+
%************************************************************************
%* *
-\subsection[Utils-errors]{Error handling}
+\subsection{Error handling}
%* *
%************************************************************************
\begin{code}
-pprPanic heading pretty_msg = panic (show (doc PprDebug))
- where
- doc = text heading <+> pretty_msg
-
-pprError heading pretty_msg = error (heading++ " " ++ (showSDoc pretty_msg))
-
-pprTrace heading pretty_msg = trace (show (doc PprDebug))
- where
- doc = text heading <+> pretty_msg
+pprPanic :: String -> SDoc -> a
+pprError :: String -> SDoc -> a
+pprTrace :: String -> SDoc -> a -> a
+pprPanic = pprAndThen panic
+pprError = pprAndThen error
+pprTrace = pprAndThen trace
pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
where
doc = text heading <+> pretty_msg
+pprAndThen :: (String -> a) -> String -> SDoc -> a
+pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
+ where
+ doc = sep [text heading, nest 4 pretty_msg]
+
assertPprPanic :: String -> Int -> SDoc -> a
assertPprPanic file line msg
= panic (show (doc PprDebug))
text file,
text "line", int line],
msg]
+
+warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
+warnPprTrace False file line msg x = x
+warnPprTrace True file line msg x
+ = trace (show (doc PprDebug)) x
+ where
+ doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
+ msg]
\end{code}
projects / ghc-hetmet.git / blobdiff