2 % (c) The GRASP Project, Glasgow University, 1992-1996
4 \section[Outputable]{Classes for pretty-printing}
6 Defines classes for pretty-printing and forcing, both forms of
11 Outputable(..), -- Class
13 PprStyle, CodeStyle(..),
14 getPprStyle, withPprStyle, pprDeeper,
15 codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle,
16 ifPprDebug, ifNotPprForUser,
19 interppSP, interpp'SP, pprQuotedList,
22 int, integer, float, double, rational,
23 parens, brackets, braces, quotes, doubleQuotes,
24 semi, comma, colon, space, equals,
25 lparen, rparen, lbrack, rbrack, lbrace, rbrace,
26 (<>), (<+>), hcat, hsep,
31 speakNth, speakNTimes,
33 showSDoc, printSDoc, printErrs, printDump,
34 printForC, printForAsm, printForIface,
38 pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic,
39 panic, panic#, assertPanic
42 #include "HsVersions.h"
44 import IO ( Handle, hPutChar, hPutStr, stderr, stdout )
45 import CmdLineOpts ( opt_PprStyle_All, opt_PprStyle_Debug, opt_PprUserLength )
47 import qualified Pretty
48 import Pretty ( Doc, Mode(..), TextDetails(..), fullRender )
49 import Util ( panic, assertPanic, panic#, trace )
53 %************************************************************************
55 \subsection{The @PprStyle@ data type}
57 %************************************************************************
61 = PprUser Depth -- Pretty-print in a way that will
62 -- make sense to the ordinary user;
63 -- must be very close to Haskell
66 | PprDebug -- Standard debugging output
68 | PprInterface -- Interface generation
70 | PprCode CodeStyle -- Print code; either C or assembler
73 data CodeStyle = CStyle -- The format of labels differs for C and assembler
76 data Depth = AllTheWay
77 | PartWay Int -- 0 => stop
80 Orthogonal to the above printing styles are (possibly) some
81 command-line flags that affect printing (often carried with the
82 style). The most likely ones are variations on how much type info is
85 The following test decides whether or not we are actually generating
86 code (either C or assembly), or generating interface files.
88 %************************************************************************
90 \subsection{The @SDoc@ data type}
92 %************************************************************************
95 type SDoc = PprStyle -> Doc
97 withPprStyle :: PprStyle -> SDoc -> SDoc
98 withPprStyle sty d sty' = d sty
100 pprDeeper :: SDoc -> SDoc
101 pprDeeper d (PprUser (PartWay 0)) = Pretty.text "..."
102 pprDeeper d (PprUser (PartWay n)) = d (PprUser (PartWay (n-1)))
103 pprDeeper d other_sty = d other_sty
105 getPprStyle :: (PprStyle -> SDoc) -> SDoc
106 getPprStyle df sty = df sty sty
110 codeStyle :: PprStyle -> Bool
111 codeStyle (PprCode _) = True
114 asmStyle :: PprStyle -> Bool
115 asmStyle (PprCode AsmStyle) = True
116 asmStyle other = False
118 ifaceStyle :: PprStyle -> Bool
119 ifaceStyle PprInterface = True
120 ifaceStyle other = False
122 debugStyle :: PprStyle -> Bool
123 debugStyle PprDebug = True
124 debugStyle other = False
126 userStyle :: PprStyle -> Bool
127 userStyle (PprUser _) = True
128 userStyle other = False
132 ifNotPprForUser :: SDoc -> SDoc -- Returns empty document for User style
133 ifNotPprForUser d sty@(PprUser _) = Pretty.empty
134 ifNotPprForUser d sty = d sty
136 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
137 ifPprDebug d sty@PprDebug = d sty
138 ifPprDebug d sty = Pretty.empty
142 printSDoc :: SDoc -> PprStyle -> IO ()
143 printSDoc d sty = printDoc PageMode stdout (d sty)
145 -- I'm not sure whether the direct-IO approach of printDoc
146 -- above is better or worse than the put-big-string approach here
147 printErrs :: SDoc -> IO ()
148 printErrs doc = printDoc PageMode stderr (final_doc user_style)
150 final_doc = doc $$ text ""
151 user_style = mkUserStyle (PartWay opt_PprUserLength)
153 printDump :: SDoc -> IO ()
154 printDump doc = printDoc PageMode stderr (final_doc PprDebug)
156 final_doc = doc $$ text ""
159 -- printForC, printForAsm doe what they sound like
160 printForC :: Handle -> SDoc -> IO ()
161 printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle))
163 printForAsm :: Handle -> SDoc -> IO ()
164 printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle))
166 -- printForIface prints all on one line for interface files.
167 -- It's called repeatedly for successive lines
168 printForIface :: Handle -> SDoc -> IO ()
169 printForIface handle doc = printDoc OneLineMode handle (doc PprInterface)
171 pprCode :: CodeStyle -> SDoc -> SDoc
172 pprCode cs d = withPprStyle (PprCode cs) d
174 -- showSDoc just blasts it out as a string
175 showSDoc :: SDoc -> String
176 showSDoc d = show (d (mkUserStyle AllTheWay))
178 mkUserStyle depth | opt_PprStyle_Debug
179 || opt_PprStyle_All = PprDebug
180 | otherwise = PprUser depth
184 empty sty = Pretty.empty
185 text s sty = Pretty.text s
186 char c sty = Pretty.char c
187 ptext s sty = Pretty.ptext s
188 int n sty = Pretty.int n
189 integer n sty = Pretty.integer n
190 float n sty = Pretty.float n
191 double n sty = Pretty.double n
192 rational n sty = Pretty.rational n
194 parens d sty = Pretty.parens (d sty)
195 braces d sty = Pretty.braces (d sty)
196 brackets d sty = Pretty.brackets (d sty)
197 quotes d sty = Pretty.quotes (d sty)
198 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
200 semi sty = Pretty.semi
201 comma sty = Pretty.comma
202 colon sty = Pretty.colon
203 equals sty = Pretty.equals
204 space sty = Pretty.space
205 lparen sty = Pretty.lparen
206 rparen sty = Pretty.rparen
207 lbrack sty = Pretty.lbrack
208 rbrack sty = Pretty.rbrack
209 lbrace sty = Pretty.lbrace
210 rbrace sty = Pretty.rbrace
212 nest n d sty = Pretty.nest n (d sty)
213 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
214 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
215 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
216 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
218 hcat ds sty = Pretty.hcat [d sty | d <- ds]
219 hsep ds sty = Pretty.hsep [d sty | d <- ds]
220 vcat ds sty = Pretty.vcat [d sty | d <- ds]
221 sep ds sty = Pretty.sep [d sty | d <- ds]
222 cat ds sty = Pretty.cat [d sty | d <- ds]
223 fsep ds sty = Pretty.fsep [d sty | d <- ds]
224 fcat ds sty = Pretty.fcat [d sty | d <- ds]
226 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
228 punctuate :: SDoc -> [SDoc] -> [SDoc]
230 punctuate p (d:ds) = go d ds
233 go d (e:es) = (d <> p) : go e es
237 %************************************************************************
239 \subsection[Outputable-class]{The @Outputable@ class}
241 %************************************************************************
244 class Outputable a where
249 instance Outputable Bool where
250 ppr True = ptext SLIT("True")
251 ppr False = ptext SLIT("False")
253 instance Outputable Int where
256 instance (Outputable a) => Outputable [a] where
257 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
259 instance (Outputable a, Outputable b) => Outputable (a, b) where
261 hang (hcat [lparen, ppr x, comma]) 4 ((<>) (ppr y) rparen)
263 -- ToDo: may not be used
264 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
266 parens (sep [ (<>) (ppr x) comma,
272 %************************************************************************
274 \subsection{Other helper functions}
276 %************************************************************************
279 pprCols = (100 :: Int) -- could make configurable
281 printDoc :: Mode -> Handle -> Doc -> IO ()
282 printDoc mode hdl doc
283 = fullRender mode pprCols 1.5 put done doc
285 put (Chr c) next = hPutChar hdl c >> next
286 put (Str s) next = hPutStr hdl s >> next
287 put (PStr s) next = hPutFS hdl s >> next
289 done = hPutChar hdl '\n'
294 interppSP :: Outputable a => [a] -> SDoc
295 interppSP xs = hsep (map ppr xs)
297 interpp'SP :: Outputable a => [a] -> SDoc
298 interpp'SP xs = hsep (punctuate comma (map ppr xs))
300 pprQuotedList :: Outputable a => [a] -> SDoc
301 -- [x,y,z] ==> `x', `y', `z'
302 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
308 %************************************************************************
310 \subsection{Printing numbers verbally}
312 %************************************************************************
314 @speakNth@ converts an integer to a verbal index; eg 1 maps to
318 speakNth :: Int -> SDoc
320 speakNth 1 = ptext SLIT("first")
321 speakNth 2 = ptext SLIT("second")
322 speakNth 3 = ptext SLIT("third")
323 speakNth 4 = ptext SLIT("fourth")
324 speakNth 5 = ptext SLIT("fifth")
325 speakNth 6 = ptext SLIT("sixth")
326 speakNth n = hcat [ int n, text st_nd_rd_th ]
328 st_nd_rd_th | n_rem_10 == 1 = "st"
329 | n_rem_10 == 2 = "nd"
330 | n_rem_10 == 3 = "rd"
333 n_rem_10 = n `rem` 10
337 speakNTimes :: Int {- >=1 -} -> SDoc
338 speakNTimes t | t == 1 = ptext SLIT("once")
339 | t == 2 = ptext SLIT("twice")
340 | otherwise = int t <+> ptext SLIT("times")
343 %************************************************************************
345 \subsection[Utils-errors]{Error handling}
347 %************************************************************************
350 pprPanic heading pretty_msg = panic (show (doc PprDebug))
352 doc = text heading <+> pretty_msg
354 pprError heading pretty_msg = error (heading++ " " ++ (show pretty_msg))
356 pprTrace heading pretty_msg = trace (show (doc PprDebug))
358 doc = text heading <+> pretty_msg
360 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
362 doc = text heading <+> pretty_msg
364 assertPprPanic :: String -> Int -> SDoc -> a
365 assertPprPanic file line msg
366 = panic (show (doc PprDebug))
368 doc = sep [hsep[text "ASSERT failed! file",
370 text "line", int line],