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, 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 showsPrecSDoc :: Int -> SDoc -> ShowS
190 showsPrecSDoc p d = showsPrec p (d (mkUserStyle AllTheWay))
192 mkUserStyle depth | opt_PprStyle_Debug = PprDebug
193 | otherwise = PprUser depth
197 empty sty = Pretty.empty
198 text s sty = Pretty.text s
199 char c sty = Pretty.char c
200 ptext s sty = Pretty.ptext s
201 int n sty = Pretty.int n
202 integer n sty = Pretty.integer n
203 float n sty = Pretty.float n
204 double n sty = Pretty.double n
205 rational n sty = Pretty.rational n
207 parens d sty = Pretty.parens (d sty)
208 braces d sty = Pretty.braces (d sty)
209 brackets d sty = Pretty.brackets (d sty)
210 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
212 -- quotes encloses something in single quotes...
213 -- but it omits them if the thing ends in a single quote
214 -- so that we don't get `foo''. Instead we just have foo'.
215 quotes d sty = case show pp_d of
217 other -> Pretty.quotes pp_d
221 semi sty = Pretty.semi
222 comma sty = Pretty.comma
223 colon sty = Pretty.colon
224 equals sty = Pretty.equals
225 space sty = Pretty.space
226 lparen sty = Pretty.lparen
227 rparen sty = Pretty.rparen
228 lbrack sty = Pretty.lbrack
229 rbrack sty = Pretty.rbrack
230 lbrace sty = Pretty.lbrace
231 rbrace sty = Pretty.rbrace
232 dcolon sty = Pretty.ptext SLIT("::")
233 underscore = char '_'
236 nest n d sty = Pretty.nest n (d sty)
237 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
238 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
239 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
240 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
242 hcat ds sty = Pretty.hcat [d sty | d <- ds]
243 hsep ds sty = Pretty.hsep [d sty | d <- ds]
244 vcat ds sty = Pretty.vcat [d sty | d <- ds]
245 sep ds sty = Pretty.sep [d sty | d <- ds]
246 cat ds sty = Pretty.cat [d sty | d <- ds]
247 fsep ds sty = Pretty.fsep [d sty | d <- ds]
248 fcat ds sty = Pretty.fcat [d sty | d <- ds]
250 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
252 punctuate :: SDoc -> [SDoc] -> [SDoc]
254 punctuate p (d:ds) = go d ds
257 go d (e:es) = (d <> p) : go e es
261 %************************************************************************
263 \subsection[Outputable-class]{The @Outputable@ class}
265 %************************************************************************
268 class Outputable a where
273 instance Outputable Bool where
274 ppr True = ptext SLIT("True")
275 ppr False = ptext SLIT("False")
277 instance Outputable Int where
280 instance (Outputable a) => Outputable [a] where
281 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
283 instance (Outputable a, Outputable b) => Outputable (a, b) where
284 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
286 instance Outputable a => Outputable (Maybe a) where
287 ppr Nothing = text "Nothing"
288 ppr (Just x) = text "Just" <+> ppr x
290 -- ToDo: may not be used
291 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
293 parens (sep [ppr x <> comma,
297 instance Outputable FastString where
298 ppr fs = text (unpackFS fs) -- Prints an unadorned string,
299 -- no double quotes or anything
301 pprFSAsString :: FastString -> SDoc -- The Char instance of Show prints
302 pprFSAsString fs = text (showList (unpackFS fs) "") -- strings with double quotes and escapes
304 instance Show FastString where
305 showsPrec p fs = showsPrecSDoc p (ppr fs)
309 %************************************************************************
311 \subsection{Other helper functions}
313 %************************************************************************
316 pprCols = (100 :: Int) -- could make configurable
318 printDoc :: Mode -> Handle -> Doc -> IO ()
319 printDoc mode hdl doc
320 = fullRender mode pprCols 1.5 put done doc
322 put (Chr c) next = hPutChar hdl c >> next
323 put (Str s) next = hPutStr hdl s >> next
324 put (PStr s) next = hPutFS hdl s >> next
326 done = hPutChar hdl '\n'
331 interppSP :: Outputable a => [a] -> SDoc
332 interppSP xs = hsep (map ppr xs)
334 interpp'SP :: Outputable a => [a] -> SDoc
335 interpp'SP xs = hsep (punctuate comma (map ppr xs))
337 pprQuotedList :: Outputable a => [a] -> SDoc
338 -- [x,y,z] ==> `x', `y', `z'
339 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
345 %************************************************************************
347 \subsection{Printing numbers verbally}
349 %************************************************************************
351 @speakNth@ converts an integer to a verbal index; eg 1 maps to
355 speakNth :: Int -> SDoc
357 speakNth 1 = ptext SLIT("first")
358 speakNth 2 = ptext SLIT("second")
359 speakNth 3 = ptext SLIT("third")
360 speakNth 4 = ptext SLIT("fourth")
361 speakNth 5 = ptext SLIT("fifth")
362 speakNth 6 = ptext SLIT("sixth")
363 speakNth n = hcat [ int n, text st_nd_rd_th ]
365 st_nd_rd_th | n_rem_10 == 1 = "st"
366 | n_rem_10 == 2 = "nd"
367 | n_rem_10 == 3 = "rd"
370 n_rem_10 = n `rem` 10
374 speakNTimes :: Int {- >=1 -} -> SDoc
375 speakNTimes t | t == 1 = ptext SLIT("once")
376 | t == 2 = ptext SLIT("twice")
377 | otherwise = int t <+> ptext SLIT("times")
381 %************************************************************************
383 \subsection{Error handling}
385 %************************************************************************
388 pprPanic :: String -> SDoc -> a
389 pprPanic heading pretty_msg = panic (show (doc PprDebug))
391 doc = text heading <+> pretty_msg
393 pprError :: String -> SDoc -> a
394 pprError heading pretty_msg = error (heading++ " " ++ (showSDoc pretty_msg))
396 pprTrace :: String -> SDoc -> a -> a
397 pprTrace heading pretty_msg = trace (show (doc PprDebug))
399 doc = text heading <+> pretty_msg
401 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
403 doc = text heading <+> 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],