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,
26 int, integer, float, double, rational,
27 parens, brackets, braces, quotes, doubleQuotes,
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,
40 showSDoc, showSDocDebug, showsPrecSDoc, pprFSAsString,
44 pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace,
45 trace, panic, panic#, assertPanic
48 #include "HsVersions.h"
51 import IO ( Handle, hPutChar, hPutStr, stderr, stdout )
52 import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
54 import qualified Pretty
55 import Pretty ( Doc, Mode(..), TextDetails(..), fullRender )
62 %************************************************************************
64 \subsection{The @PprStyle@ data type}
66 %************************************************************************
70 = PprUser Depth -- Pretty-print in a way that will
71 -- make sense to the ordinary user;
72 -- must be very close to Haskell
75 | PprDebug -- Standard debugging output
77 | PprInterface -- Interface generation
79 | PprCode CodeStyle -- Print code; either C or assembler
82 data CodeStyle = CStyle -- The format of labels differs for C and assembler
85 data Depth = AllTheWay
86 | PartWay Int -- 0 => stop
89 Orthogonal to the above printing styles are (possibly) some
90 command-line flags that affect printing (often carried with the
91 style). The most likely ones are variations on how much type info is
94 The following test decides whether or not we are actually generating
95 code (either C or assembly), or generating interface files.
97 %************************************************************************
99 \subsection{The @SDoc@ data type}
101 %************************************************************************
104 type SDoc = PprStyle -> Doc
106 withPprStyle :: PprStyle -> SDoc -> SDoc
107 withPprStyle sty d sty' = d sty
109 pprDeeper :: SDoc -> SDoc
110 pprDeeper d (PprUser (PartWay 0)) = Pretty.text "..."
111 pprDeeper d (PprUser (PartWay n)) = d (PprUser (PartWay (n-1)))
112 pprDeeper d other_sty = d other_sty
114 getPprStyle :: (PprStyle -> SDoc) -> SDoc
115 getPprStyle df sty = df sty sty
119 codeStyle :: PprStyle -> Bool
120 codeStyle (PprCode _) = True
123 asmStyle :: PprStyle -> Bool
124 asmStyle (PprCode AsmStyle) = True
125 asmStyle other = False
127 ifaceStyle :: PprStyle -> Bool
128 ifaceStyle PprInterface = True
129 ifaceStyle other = False
131 debugStyle :: PprStyle -> Bool
132 debugStyle PprDebug = True
133 debugStyle other = False
135 userStyle :: PprStyle -> Bool
136 userStyle (PprUser _) = True
137 userStyle other = False
141 ifNotPprForUser :: SDoc -> SDoc -- Returns empty document for User style
142 ifNotPprForUser d sty@(PprUser _) = Pretty.empty
143 ifNotPprForUser d sty = d sty
145 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
146 ifPprDebug d sty@PprDebug = d sty
147 ifPprDebug d sty = Pretty.empty
151 printSDoc :: SDoc -> PprStyle -> IO ()
152 printSDoc d sty = printDoc PageMode stdout (d sty)
154 -- I'm not sure whether the direct-IO approach of printDoc
155 -- above is better or worse than the put-big-string approach here
156 printErrs :: SDoc -> IO ()
157 printErrs doc = printDoc PageMode stderr (final_doc user_style)
159 final_doc = doc -- $$ text ""
160 user_style = mkUserStyle (PartWay opt_PprUserLength)
162 printDump :: SDoc -> IO ()
163 printDump doc = printDoc PageMode stderr (final_doc PprDebug)
165 final_doc = doc $$ text ""
168 -- printForC, printForAsm doe what they sound like
169 printForC :: Handle -> SDoc -> IO ()
170 printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle))
172 printForAsm :: Handle -> SDoc -> IO ()
173 printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle))
175 -- printForIface prints all on one line for interface files.
176 -- It's called repeatedly for successive lines
177 printForIface :: Handle -> SDoc -> IO ()
178 printForIface handle doc = printDoc OneLineMode handle (doc PprInterface)
180 pprCode :: CodeStyle -> SDoc -> SDoc
181 pprCode cs d = withPprStyle (PprCode cs) d
183 -- Can't make SDoc an instance of Show because SDoc is just a function type
184 -- However, Doc *is* an instance of Show
185 -- showSDoc just blasts it out as a string
186 showSDoc :: SDoc -> String
187 showSDoc d = show (d (mkUserStyle AllTheWay))
189 showSDocDebug :: SDoc -> String
190 showSDocDebug d = show (d PprDebug)
192 showsPrecSDoc :: Int -> SDoc -> ShowS
193 showsPrecSDoc p d = showsPrec p (d (mkUserStyle AllTheWay))
195 mkUserStyle depth | opt_PprStyle_Debug = PprDebug
196 | otherwise = PprUser depth
200 empty sty = Pretty.empty
201 text s sty = Pretty.text s
202 char c sty = Pretty.char c
203 ptext s sty = Pretty.ptext s
204 int n sty = Pretty.int n
205 integer n sty = Pretty.integer n
206 float n sty = Pretty.float n
207 double n sty = Pretty.double n
208 rational n sty = Pretty.rational n
210 parens d sty = Pretty.parens (d sty)
211 braces d sty = Pretty.braces (d sty)
212 brackets d sty = Pretty.brackets (d sty)
213 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
215 -- quotes encloses something in single quotes...
216 -- but it omits them if the thing ends in a single quote
217 -- so that we don't get `foo''. Instead we just have foo'.
218 quotes d sty = case show pp_d of
220 other -> Pretty.quotes pp_d
224 semi sty = Pretty.semi
225 comma sty = Pretty.comma
226 colon sty = Pretty.colon
227 equals sty = Pretty.equals
228 space sty = Pretty.space
229 lparen sty = Pretty.lparen
230 rparen sty = Pretty.rparen
231 lbrack sty = Pretty.lbrack
232 rbrack sty = Pretty.rbrack
233 lbrace sty = Pretty.lbrace
234 rbrace sty = Pretty.rbrace
235 dcolon sty = Pretty.ptext SLIT("::")
236 underscore = char '_'
239 nest n d sty = Pretty.nest n (d sty)
240 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
241 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
242 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
243 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
245 hcat ds sty = Pretty.hcat [d sty | d <- ds]
246 hsep ds sty = Pretty.hsep [d sty | d <- ds]
247 vcat ds sty = Pretty.vcat [d sty | d <- ds]
248 sep ds sty = Pretty.sep [d sty | d <- ds]
249 cat ds sty = Pretty.cat [d sty | d <- ds]
250 fsep ds sty = Pretty.fsep [d sty | d <- ds]
251 fcat ds sty = Pretty.fcat [d sty | d <- ds]
253 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
255 punctuate :: SDoc -> [SDoc] -> [SDoc]
257 punctuate p (d:ds) = go d ds
260 go d (e:es) = (d <> p) : go e es
264 %************************************************************************
266 \subsection[Outputable-class]{The @Outputable@ class}
268 %************************************************************************
271 class Outputable a where
276 instance Outputable Bool where
277 ppr True = ptext SLIT("True")
278 ppr False = ptext SLIT("False")
280 instance Outputable Int where
283 instance (Outputable a) => Outputable [a] where
284 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
286 instance (Outputable a, Outputable b) => Outputable (a, b) where
287 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
289 instance Outputable a => Outputable (Maybe a) where
290 ppr Nothing = text "Nothing"
291 ppr (Just x) = text "Just" <+> ppr x
293 -- ToDo: may not be used
294 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
296 parens (sep [ppr x <> comma,
300 instance Outputable FastString where
301 ppr fs = text (unpackFS fs) -- Prints an unadorned string,
302 -- no double quotes or anything
304 pprFSAsString :: FastString -> SDoc -- The Char instance of Show prints
305 pprFSAsString fs = text (showList (unpackFS fs) "") -- strings with double quotes and escapes
307 instance Show FastString where
308 showsPrec p fs = showsPrecSDoc p (ppr fs)
312 %************************************************************************
314 \subsection{Other helper functions}
316 %************************************************************************
319 pprCols = (100 :: Int) -- could make configurable
321 printDoc :: Mode -> Handle -> Doc -> IO ()
322 printDoc mode hdl doc
323 = fullRender mode pprCols 1.5 put done doc
325 put (Chr c) next = hPutChar hdl c >> next
326 put (Str s) next = hPutStr hdl s >> next
327 put (PStr s) next = hPutFS hdl s >> next
329 done = hPutChar hdl '\n'
334 interppSP :: Outputable a => [a] -> SDoc
335 interppSP xs = hsep (map ppr xs)
337 interpp'SP :: Outputable a => [a] -> SDoc
338 interpp'SP xs = hsep (punctuate comma (map ppr xs))
340 pprQuotedList :: Outputable a => [a] -> SDoc
341 -- [x,y,z] ==> `x', `y', `z'
342 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
346 %************************************************************************
348 \subsection{Printing numbers verbally}
350 %************************************************************************
352 @speakNth@ converts an integer to a verbal index; eg 1 maps to
356 speakNth :: Int -> SDoc
358 speakNth 1 = ptext SLIT("first")
359 speakNth 2 = ptext SLIT("second")
360 speakNth 3 = ptext SLIT("third")
361 speakNth 4 = ptext SLIT("fourth")
362 speakNth 5 = ptext SLIT("fifth")
363 speakNth 6 = ptext SLIT("sixth")
364 speakNth n = hcat [ int n, text st_nd_rd_th ]
366 st_nd_rd_th | n_rem_10 == 1 = "st"
367 | n_rem_10 == 2 = "nd"
368 | n_rem_10 == 3 = "rd"
371 n_rem_10 = n `rem` 10
375 speakNTimes :: Int {- >=1 -} -> SDoc
376 speakNTimes t | t == 1 = ptext SLIT("once")
377 | t == 2 = ptext SLIT("twice")
378 | otherwise = int t <+> ptext SLIT("times")
382 %************************************************************************
384 \subsection{Error handling}
386 %************************************************************************
389 pprPanic :: String -> SDoc -> a
390 pprError :: String -> SDoc -> a
391 pprTrace :: String -> SDoc -> a -> a
392 pprPanic = pprAndThen panic
393 pprError = pprAndThen error
394 pprTrace = pprAndThen trace
396 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
398 doc = text heading <+> pretty_msg
400 pprAndThen :: (String -> a) -> String -> SDoc -> a
401 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
403 doc = sep [text heading, nest 4 pretty_msg]
405 assertPprPanic :: String -> Int -> SDoc -> a
406 assertPprPanic file line msg
407 = panic (show (doc PprDebug))
409 doc = sep [hsep[text "ASSERT failed! file",
411 text "line", int line],
414 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
415 warnPprTrace False file line msg x = x
416 warnPprTrace True file line msg x
417 = trace (show (doc PprDebug)) x
419 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],