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,
45 trace, panic, panic#, assertPanic, warnPprTrace
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 quotes d sty = Pretty.quotes (d sty)
211 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
213 semi sty = Pretty.semi
214 comma sty = Pretty.comma
215 colon sty = Pretty.colon
216 equals sty = Pretty.equals
217 space sty = Pretty.space
218 lparen sty = Pretty.lparen
219 rparen sty = Pretty.rparen
220 lbrack sty = Pretty.lbrack
221 rbrack sty = Pretty.rbrack
222 lbrace sty = Pretty.lbrace
223 rbrace sty = Pretty.rbrace
224 dcolon sty = Pretty.ptext SLIT("::")
225 underscore = char '_'
228 nest n d sty = Pretty.nest n (d sty)
229 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
230 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
231 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
232 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
234 hcat ds sty = Pretty.hcat [d sty | d <- ds]
235 hsep ds sty = Pretty.hsep [d sty | d <- ds]
236 vcat ds sty = Pretty.vcat [d sty | d <- ds]
237 sep ds sty = Pretty.sep [d sty | d <- ds]
238 cat ds sty = Pretty.cat [d sty | d <- ds]
239 fsep ds sty = Pretty.fsep [d sty | d <- ds]
240 fcat ds sty = Pretty.fcat [d sty | d <- ds]
242 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
244 punctuate :: SDoc -> [SDoc] -> [SDoc]
246 punctuate p (d:ds) = go d ds
249 go d (e:es) = (d <> p) : go e es
253 %************************************************************************
255 \subsection[Outputable-class]{The @Outputable@ class}
257 %************************************************************************
260 class Outputable a where
265 instance Outputable Bool where
266 ppr True = ptext SLIT("True")
267 ppr False = ptext SLIT("False")
269 instance Outputable Int where
272 instance (Outputable a) => Outputable [a] where
273 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
275 instance (Outputable a, Outputable b) => Outputable (a, b) where
276 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
278 instance Outputable a => Outputable (Maybe a) where
279 ppr Nothing = text "Nothing"
280 ppr (Just x) = text "Just" <+> ppr x
282 -- ToDo: may not be used
283 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
285 parens (sep [ppr x <> comma,
289 instance Outputable FastString where
290 ppr fs = text (unpackFS fs) -- Prints an unadorned string,
291 -- no double quotes or anything
293 pprFSAsString :: FastString -> SDoc -- The Char instance of Show prints
294 pprFSAsString fs = text (showList (unpackFS fs) "") -- strings with double quotes and escapes
296 instance Show FastString where
297 showsPrec p fs = showsPrecSDoc p (ppr fs)
301 %************************************************************************
303 \subsection{Other helper functions}
305 %************************************************************************
308 pprCols = (100 :: Int) -- could make configurable
310 printDoc :: Mode -> Handle -> Doc -> IO ()
311 printDoc mode hdl doc
312 = fullRender mode pprCols 1.5 put done doc
314 put (Chr c) next = hPutChar hdl c >> next
315 put (Str s) next = hPutStr hdl s >> next
316 put (PStr s) next = hPutFS hdl s >> next
318 done = hPutChar hdl '\n'
323 interppSP :: Outputable a => [a] -> SDoc
324 interppSP xs = hsep (map ppr xs)
326 interpp'SP :: Outputable a => [a] -> SDoc
327 interpp'SP xs = hsep (punctuate comma (map ppr xs))
329 pprQuotedList :: Outputable a => [a] -> SDoc
330 -- [x,y,z] ==> `x', `y', `z'
331 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
337 %************************************************************************
339 \subsection{Printing numbers verbally}
341 %************************************************************************
343 @speakNth@ converts an integer to a verbal index; eg 1 maps to
347 speakNth :: Int -> SDoc
349 speakNth 1 = ptext SLIT("first")
350 speakNth 2 = ptext SLIT("second")
351 speakNth 3 = ptext SLIT("third")
352 speakNth 4 = ptext SLIT("fourth")
353 speakNth 5 = ptext SLIT("fifth")
354 speakNth 6 = ptext SLIT("sixth")
355 speakNth n = hcat [ int n, text st_nd_rd_th ]
357 st_nd_rd_th | n_rem_10 == 1 = "st"
358 | n_rem_10 == 2 = "nd"
359 | n_rem_10 == 3 = "rd"
362 n_rem_10 = n `rem` 10
366 speakNTimes :: Int {- >=1 -} -> SDoc
367 speakNTimes t | t == 1 = ptext SLIT("once")
368 | t == 2 = ptext SLIT("twice")
369 | otherwise = int t <+> ptext SLIT("times")
373 %************************************************************************
375 \subsection{Error handling}
377 %************************************************************************
380 pprPanic :: String -> SDoc -> a
381 pprPanic heading pretty_msg = panic (show (doc PprDebug))
383 doc = text heading <+> pretty_msg
385 pprError :: String -> SDoc -> a
386 pprError heading pretty_msg = error (heading++ " " ++ (showSDoc pretty_msg))
388 pprTrace :: String -> SDoc -> a -> a
389 pprTrace heading pretty_msg = trace (show (doc PprDebug))
391 doc = text heading <+> pretty_msg
393 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
395 doc = text heading <+> pretty_msg
397 assertPprPanic :: String -> Int -> SDoc -> a
398 assertPprPanic file line msg
399 = panic (show (doc PprDebug))
401 doc = sep [hsep[text "ASSERT failed! file",
403 text "line", int line],
406 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
407 warnPprTrace False file line msg x = x
408 warnPprTrace True file line msg x
409 = trace (show (doc PprDebug)) x
411 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],