2 % (c) The GRASP Project, Glasgow University, 1992-1998
4 \section[Outputable]{Classes for pretty-printing}
6 Defines classes for pretty-printing and forcing, both forms of
10 {-# OPTIONS -fno-prune-tydecls #-}
11 -- Hopefully temporary; 3.02 complained about not being able
12 -- to see the consructors for ForeignObj
15 Outputable(..), -- Class
17 PprStyle, CodeStyle(..),
18 getPprStyle, withPprStyle, pprDeeper,
19 codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle,
20 ifPprDebug, ifNotPprForUser,
23 interppSP, interpp'SP, pprQuotedList, pprWithCommas,
26 int, integer, float, double, rational,
27 parens, brackets, braces, quotes, doubleQuotes, angleBrackets,
28 semi, comma, colon, dcolon, space, equals, dot,
29 lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
30 (<>), (<+>), hcat, hsep,
35 speakNth, speakNTimes,
37 printSDoc, printErrs, printDump,
38 printForC, printForAsm, printForIface, printForUser,
40 showSDoc, showSDocDebug, showSDocIface, showsPrecSDoc,
45 pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace,
46 trace, panic, panic#, assertPanic
49 #include "HsVersions.h"
52 import IO ( Handle, hPutChar, hPutStr, stderr, stdout )
53 import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
55 import qualified Pretty
56 import Pretty ( Doc, Mode(..), TextDetails(..), fullRender )
63 %************************************************************************
65 \subsection{The @PprStyle@ data type}
67 %************************************************************************
71 = PprUser Depth -- Pretty-print in a way that will
72 -- make sense to the ordinary user;
73 -- must be very close to Haskell
76 | PprDebug -- Standard debugging output
78 | PprInterface -- Interface generation
80 | PprCode CodeStyle -- Print code; either C or assembler
83 data CodeStyle = CStyle -- The format of labels differs for C and assembler
86 data Depth = AllTheWay
87 | PartWay Int -- 0 => stop
90 Orthogonal to the above printing styles are (possibly) some
91 command-line flags that affect printing (often carried with the
92 style). The most likely ones are variations on how much type info is
95 The following test decides whether or not we are actually generating
96 code (either C or assembly), or generating interface files.
98 %************************************************************************
100 \subsection{The @SDoc@ data type}
102 %************************************************************************
105 type SDoc = PprStyle -> Doc
107 withPprStyle :: PprStyle -> SDoc -> SDoc
108 withPprStyle sty d sty' = d sty
110 pprDeeper :: SDoc -> SDoc
111 pprDeeper d (PprUser (PartWay 0)) = Pretty.text "..."
112 pprDeeper d (PprUser (PartWay n)) = d (PprUser (PartWay (n-1)))
113 pprDeeper d other_sty = d other_sty
115 getPprStyle :: (PprStyle -> SDoc) -> SDoc
116 getPprStyle df sty = df sty sty
120 codeStyle :: PprStyle -> Bool
121 codeStyle (PprCode _) = True
124 asmStyle :: PprStyle -> Bool
125 asmStyle (PprCode AsmStyle) = True
126 asmStyle other = False
128 ifaceStyle :: PprStyle -> Bool
129 ifaceStyle PprInterface = True
130 ifaceStyle other = False
132 debugStyle :: PprStyle -> Bool
133 debugStyle PprDebug = True
134 debugStyle other = False
136 userStyle :: PprStyle -> Bool
137 userStyle (PprUser _) = True
138 userStyle other = False
142 ifNotPprForUser :: SDoc -> SDoc -- Returns empty document for User style
143 ifNotPprForUser d sty@(PprUser _) = Pretty.empty
144 ifNotPprForUser d sty = d sty
146 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
147 ifPprDebug d sty@PprDebug = d sty
148 ifPprDebug d sty = Pretty.empty
152 printSDoc :: SDoc -> PprStyle -> IO ()
153 printSDoc d sty = printDoc PageMode stdout (d sty)
155 -- I'm not sure whether the direct-IO approach of printDoc
156 -- above is better or worse than the put-big-string approach here
157 printErrs :: SDoc -> IO ()
158 printErrs doc = printDoc PageMode stderr (final_doc user_style)
160 final_doc = doc -- $$ text ""
161 user_style = mkUserStyle (PartWay opt_PprUserLength)
163 printDump :: SDoc -> IO ()
164 printDump doc = printForUser stderr (doc $$ text "")
165 -- We used to always print in debug style, but I want
166 -- to try the effect of a more user-ish style (unless you
169 printForUser :: Handle -> SDoc -> IO ()
170 printForUser handle doc = printDoc PageMode handle (doc (mkUserStyle AllTheWay))
172 -- printForC, printForAsm do what they sound like
173 printForC :: Handle -> SDoc -> IO ()
174 printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle))
176 printForAsm :: Handle -> SDoc -> IO ()
177 printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle))
179 -- printForIface prints all on one line for interface files.
180 -- It's called repeatedly for successive lines
181 printForIface :: Handle -> SDoc -> IO ()
182 printForIface handle doc = printDoc OneLineMode handle (doc PprInterface)
184 pprCode :: CodeStyle -> SDoc -> SDoc
185 pprCode cs d = withPprStyle (PprCode cs) d
187 -- Can't make SDoc an instance of Show because SDoc is just a function type
188 -- However, Doc *is* an instance of Show
189 -- showSDoc just blasts it out as a string
190 showSDoc :: SDoc -> String
191 showSDoc d = show (d (mkUserStyle AllTheWay))
193 showSDocIface :: SDoc -> String
194 showSDocIface doc = showDocWith OneLineMode (doc PprInterface)
196 showSDocDebug :: SDoc -> String
197 showSDocDebug d = show (d PprDebug)
199 showsPrecSDoc :: Int -> SDoc -> ShowS
200 showsPrecSDoc p d = showsPrec p (d (mkUserStyle AllTheWay))
202 mkUserStyle depth | opt_PprStyle_Debug = PprDebug
203 | otherwise = PprUser depth
207 empty sty = Pretty.empty
208 text s sty = Pretty.text s
209 char c sty = Pretty.char c
210 ptext s sty = Pretty.ptext s
211 int n sty = Pretty.int n
212 integer n sty = Pretty.integer n
213 float n sty = Pretty.float n
214 double n sty = Pretty.double n
215 rational n sty = Pretty.rational n
217 parens d sty = Pretty.parens (d sty)
218 braces d sty = Pretty.braces (d sty)
219 brackets d sty = Pretty.brackets (d sty)
220 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
221 angleBrackets d = char '<' <> d <> char '>'
223 -- quotes encloses something in single quotes...
224 -- but it omits them if the thing ends in a single quote
225 -- so that we don't get `foo''. Instead we just have foo'.
226 quotes d sty = case show pp_d of
228 other -> Pretty.quotes pp_d
232 semi sty = Pretty.semi
233 comma sty = Pretty.comma
234 colon sty = Pretty.colon
235 equals sty = Pretty.equals
236 space sty = Pretty.space
237 lparen sty = Pretty.lparen
238 rparen sty = Pretty.rparen
239 lbrack sty = Pretty.lbrack
240 rbrack sty = Pretty.rbrack
241 lbrace sty = Pretty.lbrace
242 rbrace sty = Pretty.rbrace
243 dcolon sty = Pretty.ptext SLIT("::")
244 underscore = char '_'
247 nest n d sty = Pretty.nest n (d sty)
248 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
249 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
250 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
251 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
253 hcat ds sty = Pretty.hcat [d sty | d <- ds]
254 hsep ds sty = Pretty.hsep [d sty | d <- ds]
255 vcat ds sty = Pretty.vcat [d sty | d <- ds]
256 sep ds sty = Pretty.sep [d sty | d <- ds]
257 cat ds sty = Pretty.cat [d sty | d <- ds]
258 fsep ds sty = Pretty.fsep [d sty | d <- ds]
259 fcat ds sty = Pretty.fcat [d sty | d <- ds]
261 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
263 punctuate :: SDoc -> [SDoc] -> [SDoc]
265 punctuate p (d:ds) = go d ds
268 go d (e:es) = (d <> p) : go e es
272 %************************************************************************
274 \subsection[Outputable-class]{The @Outputable@ class}
276 %************************************************************************
279 class Outputable a where
284 instance Outputable Bool where
285 ppr True = ptext SLIT("True")
286 ppr False = ptext SLIT("False")
288 instance Outputable Int where
291 instance (Outputable a) => Outputable [a] where
292 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
294 instance (Outputable a, Outputable b) => Outputable (a, b) where
295 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
297 instance Outputable a => Outputable (Maybe a) where
298 ppr Nothing = text "Nothing"
299 ppr (Just x) = text "Just" <+> ppr x
301 -- ToDo: may not be used
302 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
304 parens (sep [ppr x <> comma,
308 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
309 Outputable (a, b, c, d) where
311 parens (sep [ppr x <> comma,
316 instance Outputable FastString where
317 ppr fs = text (unpackFS fs) -- Prints an unadorned string,
318 -- no double quotes or anything
320 pprFSAsString :: FastString -> SDoc -- The Char instance of Show prints
321 pprFSAsString fs = text (showList (unpackFS fs) "") -- strings with double quotes and escapes
323 instance Show FastString where
324 showsPrec p fs = showsPrecSDoc p (ppr fs)
328 %************************************************************************
330 \subsection{Other helper functions}
332 %************************************************************************
335 pprCols = (100 :: Int) -- could make configurable
337 printDoc :: Mode -> Handle -> Doc -> IO ()
338 printDoc mode hdl doc
339 = fullRender mode pprCols 1.5 put done doc
341 put (Chr c) next = hPutChar hdl c >> next
342 put (Str s) next = hPutStr hdl s >> next
343 put (PStr s) next = hPutFS hdl s >> next
345 done = hPutChar hdl '\n'
347 showDocWith :: Mode -> Doc -> String
349 = fullRender PageMode 100 1.5 put "" doc
352 put (Str s1) s2 = s1 ++ s2
353 put (PStr s1) s2 = _UNPK_ s1 ++ s2
358 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
359 pprWithCommas pp xs = hsep (punctuate comma (map pp xs))
361 interppSP :: Outputable a => [a] -> SDoc
362 interppSP xs = hsep (map ppr xs)
364 interpp'SP :: Outputable a => [a] -> SDoc
365 interpp'SP xs = hsep (punctuate comma (map ppr xs))
367 pprQuotedList :: Outputable a => [a] -> SDoc
368 -- [x,y,z] ==> `x', `y', `z'
369 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
373 %************************************************************************
375 \subsection{Printing numbers verbally}
377 %************************************************************************
379 @speakNth@ converts an integer to a verbal index; eg 1 maps to
383 speakNth :: Int -> SDoc
385 speakNth 1 = ptext SLIT("first")
386 speakNth 2 = ptext SLIT("second")
387 speakNth 3 = ptext SLIT("third")
388 speakNth 4 = ptext SLIT("fourth")
389 speakNth 5 = ptext SLIT("fifth")
390 speakNth 6 = ptext SLIT("sixth")
391 speakNth n = hcat [ int n, text st_nd_rd_th ]
393 st_nd_rd_th | n_rem_10 == 1 = "st"
394 | n_rem_10 == 2 = "nd"
395 | n_rem_10 == 3 = "rd"
398 n_rem_10 = n `rem` 10
402 speakNTimes :: Int {- >=1 -} -> SDoc
403 speakNTimes t | t == 1 = ptext SLIT("once")
404 | t == 2 = ptext SLIT("twice")
405 | otherwise = int t <+> ptext SLIT("times")
409 %************************************************************************
411 \subsection{Error handling}
413 %************************************************************************
416 pprPanic :: String -> SDoc -> a
417 pprError :: String -> SDoc -> a
418 pprTrace :: String -> SDoc -> a -> a
419 pprPanic = pprAndThen panic
420 pprError = pprAndThen error
421 pprTrace = pprAndThen trace
423 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
425 doc = text heading <+> pretty_msg
427 pprAndThen :: (String -> a) -> String -> SDoc -> a
428 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
430 doc = sep [text heading, nest 4 pretty_msg]
432 assertPprPanic :: String -> Int -> SDoc -> a
433 assertPprPanic file line msg
434 = panic (show (doc PprDebug))
436 doc = sep [hsep[text "ASSERT failed! file",
438 text "line", int line],
441 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
442 warnPprTrace False file line msg x = x
443 warnPprTrace True file line msg x
444 = trace (show (doc PprDebug)) x
446 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],