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, space, equals,
29 lparen, rparen, lbrack, rbrack, lbrace, rbrace,
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 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 )
56 import Util ( panic, assertPanic, panic#, trace )
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
225 nest n d sty = Pretty.nest n (d sty)
226 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
227 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
228 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
229 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
231 hcat ds sty = Pretty.hcat [d sty | d <- ds]
232 hsep ds sty = Pretty.hsep [d sty | d <- ds]
233 vcat ds sty = Pretty.vcat [d sty | d <- ds]
234 sep ds sty = Pretty.sep [d sty | d <- ds]
235 cat ds sty = Pretty.cat [d sty | d <- ds]
236 fsep ds sty = Pretty.fsep [d sty | d <- ds]
237 fcat ds sty = Pretty.fcat [d sty | d <- ds]
239 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
241 punctuate :: SDoc -> [SDoc] -> [SDoc]
243 punctuate p (d:ds) = go d ds
246 go d (e:es) = (d <> p) : go e es
250 %************************************************************************
252 \subsection[Outputable-class]{The @Outputable@ class}
254 %************************************************************************
257 class Outputable a where
262 instance Outputable Bool where
263 ppr True = ptext SLIT("True")
264 ppr False = ptext SLIT("False")
266 instance Outputable Int where
269 instance (Outputable a) => Outputable [a] where
270 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
272 instance (Outputable a, Outputable b) => Outputable (a, b) where
273 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
275 -- ToDo: may not be used
276 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
278 parens (sep [ppr x <> comma,
282 instance Outputable FastString where
283 ppr fs = text (unpackFS fs) -- Prints an unadorned string,
284 -- no double quotes or anything
286 pprFSAsString :: FastString -> SDoc -- The Char instance of Show prints
287 pprFSAsString fs = text (showList (unpackFS fs) "") -- strings with double quotes and escapes
289 instance Show FastString where
290 showsPrec p fs = showsPrecSDoc p (ppr fs)
294 %************************************************************************
296 \subsection{Other helper functions}
298 %************************************************************************
301 pprCols = (100 :: Int) -- could make configurable
303 printDoc :: Mode -> Handle -> Doc -> IO ()
304 printDoc mode hdl doc
305 = fullRender mode pprCols 1.5 put done doc
307 put (Chr c) next = hPutChar hdl c >> next
308 put (Str s) next = hPutStr hdl s >> next
309 put (PStr s) next = hPutFS hdl s >> next
311 done = hPutChar hdl '\n'
316 interppSP :: Outputable a => [a] -> SDoc
317 interppSP xs = hsep (map ppr xs)
319 interpp'SP :: Outputable a => [a] -> SDoc
320 interpp'SP xs = hsep (punctuate comma (map ppr xs))
322 pprQuotedList :: Outputable a => [a] -> SDoc
323 -- [x,y,z] ==> `x', `y', `z'
324 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
330 %************************************************************************
332 \subsection{Printing numbers verbally}
334 %************************************************************************
336 @speakNth@ converts an integer to a verbal index; eg 1 maps to
340 speakNth :: Int -> SDoc
342 speakNth 1 = ptext SLIT("first")
343 speakNth 2 = ptext SLIT("second")
344 speakNth 3 = ptext SLIT("third")
345 speakNth 4 = ptext SLIT("fourth")
346 speakNth 5 = ptext SLIT("fifth")
347 speakNth 6 = ptext SLIT("sixth")
348 speakNth n = hcat [ int n, text st_nd_rd_th ]
350 st_nd_rd_th | n_rem_10 == 1 = "st"
351 | n_rem_10 == 2 = "nd"
352 | n_rem_10 == 3 = "rd"
355 n_rem_10 = n `rem` 10
359 speakNTimes :: Int {- >=1 -} -> SDoc
360 speakNTimes t | t == 1 = ptext SLIT("once")
361 | t == 2 = ptext SLIT("twice")
362 | otherwise = int t <+> ptext SLIT("times")
365 %************************************************************************
367 \subsection[Utils-errors]{Error handling}
369 %************************************************************************
372 pprPanic heading pretty_msg = panic (show (doc PprDebug))
374 doc = text heading <+> pretty_msg
376 pprError heading pretty_msg = error (heading++ " " ++ (showSDoc pretty_msg))
378 pprTrace heading pretty_msg = trace (show (doc PprDebug))
380 doc = text heading <+> pretty_msg
382 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
384 doc = text heading <+> pretty_msg
386 assertPprPanic :: String -> Int -> SDoc -> a
387 assertPprPanic file line msg
388 = panic (show (doc PprDebug))
390 doc = sep [hsep[text "ASSERT failed! file",
392 text "line", int line],