``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,
hang, punctuate,
speakNth, speakNTimes,
- printSDoc, printErrs, printDump,
- printForC, printForAsm, printForIface,
- pprCode, pprCols,
- showSDoc, showSDocDebug, showsPrecSDoc, pprFSAsString,
+ printSDoc, printErrs, printDump,
+ printForC, printForAsm, printForIface, printForUser,
+ pprCode, mkCodeStyle,
+ showSDoc, showSDocForUser, showSDocDebug, showSDocIface,
+ showSDocUnqual, showsPrecSDoc,
+ pprHsChar, pprHsString,
-- error handling
#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}
\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
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
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
\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 user_style)
- where
- final_doc = doc $$ text ""
- user_style = mkUserStyle (PartWay opt_PprUserLength)
- -- 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
+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))
+-- 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 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))
+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)
-showSDocDebug :: SDoc -> String
-showSDocDebug d = show (d PprDebug)
+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)
-mkUserStyle depth | opt_PprStyle_Debug = PprDebug
- | otherwise = PprUser depth
+showSDocIface :: SDoc -> String
+showSDocIface doc = showDocWith OneLineMode (doc (PprInterface alwaysQualify))
+
+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
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
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)))
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
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)
%************************************************************************
\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)
projects / ghc-hetmet.git / blobdiff