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
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# )
50 import GlaExts ( trace )
54 %************************************************************************
56 \subsection{The @PprStyle@ data type}
58 %************************************************************************
62 = PprUser Depth -- Pretty-print in a way that will
63 -- make sense to the ordinary user;
64 -- must be very close to Haskell
67 | PprDebug -- Standard debugging output
69 | PprInterface -- Interface generation
71 | PprCode CodeStyle -- Print code; either C or assembler
74 data CodeStyle = CStyle -- The format of labels differs for C and assembler
77 data Depth = AllTheWay
78 | PartWay Int -- 0 => stop
81 Orthogonal to the above printing styles are (possibly) some
82 command-line flags that affect printing (often carried with the
83 style). The most likely ones are variations on how much type info is
86 The following test decides whether or not we are actually generating
87 code (either C or assembly), or generating interface files.
89 %************************************************************************
91 \subsection{The @SDoc@ data type}
93 %************************************************************************
96 type SDoc = PprStyle -> Doc
98 withPprStyle :: PprStyle -> SDoc -> SDoc
99 withPprStyle sty d sty' = d sty
101 pprDeeper :: SDoc -> SDoc
102 pprDeeper d (PprUser (PartWay 0)) = Pretty.text "..."
103 pprDeeper d (PprUser (PartWay n)) = d (PprUser (PartWay (n-1)))
104 pprDeeper d other_sty = d other_sty
106 getPprStyle :: (PprStyle -> SDoc) -> SDoc
107 getPprStyle df sty = df sty sty
111 codeStyle :: PprStyle -> Bool
112 codeStyle (PprCode _) = True
115 asmStyle :: PprStyle -> Bool
116 asmStyle (PprCode AsmStyle) = True
117 asmStyle other = False
119 ifaceStyle :: PprStyle -> Bool
120 ifaceStyle PprInterface = True
121 ifaceStyle other = False
123 debugStyle :: PprStyle -> Bool
124 debugStyle PprDebug = True
125 debugStyle other = False
127 userStyle :: PprStyle -> Bool
128 userStyle (PprUser _) = True
129 userStyle other = False
133 ifNotPprForUser :: SDoc -> SDoc -- Returns empty document for User style
134 ifNotPprForUser d sty@(PprUser _) = Pretty.empty
135 ifNotPprForUser d sty = d sty
137 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
138 ifPprDebug d sty@PprDebug = d sty
139 ifPprDebug d sty = Pretty.empty
143 printSDoc :: SDoc -> PprStyle -> IO ()
144 printSDoc d sty = printDoc PageMode stdout (d sty)
146 -- I'm not sure whether the direct-IO approach of printDoc
147 -- above is better or worse than the put-big-string approach here
148 printErrs :: SDoc -> IO ()
149 printErrs doc = printDoc PageMode stderr (final_doc user_style)
151 final_doc = doc $$ text ""
152 user_style = mkUserStyle (PartWay opt_PprUserLength)
154 printDump :: SDoc -> IO ()
155 printDump doc = printDoc PageMode stderr (final_doc PprDebug)
157 final_doc = doc $$ text ""
160 -- printForC, printForAsm doe what they sound like
161 printForC :: Handle -> SDoc -> IO ()
162 printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle))
164 printForAsm :: Handle -> SDoc -> IO ()
165 printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle))
167 -- printForIface prints all on one line for interface files.
168 -- It's called repeatedly for successive lines
169 printForIface :: Handle -> SDoc -> IO ()
170 printForIface handle doc = printDoc OneLineMode handle (doc PprInterface)
173 -- showSDoc just blasts it out as a string
174 showSDoc :: SDoc -> String
175 showSDoc d = show (d (mkUserStyle AllTheWay))
177 mkUserStyle depth | opt_PprStyle_Debug
178 || opt_PprStyle_All = PprDebug
179 | otherwise = PprUser depth
183 empty sty = Pretty.empty
184 text s sty = Pretty.text s
185 char c sty = Pretty.char c
186 ptext s sty = Pretty.ptext s
187 int n sty = Pretty.int n
188 integer n sty = Pretty.integer n
189 float n sty = Pretty.float n
190 double n sty = Pretty.double n
191 rational n sty = Pretty.rational n
193 parens d sty = Pretty.parens (d sty)
194 braces d sty = Pretty.braces (d sty)
195 brackets d sty = Pretty.brackets (d sty)
196 quotes d sty = Pretty.quotes (d sty)
197 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
199 semi sty = Pretty.semi
200 comma sty = Pretty.comma
201 colon sty = Pretty.colon
202 equals sty = Pretty.equals
203 space sty = Pretty.space
204 lparen sty = Pretty.lparen
205 rparen sty = Pretty.rparen
206 lbrack sty = Pretty.lbrack
207 rbrack sty = Pretty.rbrack
208 lbrace sty = Pretty.lbrace
209 rbrace sty = Pretty.rbrace
211 nest n d sty = Pretty.nest n (d sty)
212 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 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)
217 hcat ds sty = Pretty.hcat [d sty | d <- ds]
218 hsep ds sty = Pretty.hsep [d sty | d <- ds]
219 vcat ds sty = Pretty.vcat [d sty | d <- ds]
220 sep ds sty = Pretty.sep [d sty | d <- ds]
221 cat ds sty = Pretty.cat [d sty | d <- ds]
222 fsep ds sty = Pretty.fsep [d sty | d <- ds]
223 fcat ds sty = Pretty.fcat [d sty | d <- ds]
225 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
227 punctuate :: SDoc -> [SDoc] -> [SDoc]
229 punctuate p (d:ds) = go d ds
232 go d (e:es) = (d <> p) : go e es
236 %************************************************************************
238 \subsection[Outputable-class]{The @Outputable@ class}
240 %************************************************************************
243 class Outputable a where
248 instance Outputable Bool where
249 ppr False = ptext SLIT("False")
251 instance Outputable Int where
254 instance (Outputable a) => Outputable [a] where
255 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
257 instance (Outputable a, Outputable b) => Outputable (a, b) where
259 hang (hcat [lparen, ppr x, comma]) 4 ((<>) (ppr y) rparen)
261 -- ToDo: may not be used
262 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
264 parens (sep [ (<>) (ppr x) comma,
270 %************************************************************************
272 \subsection{Other helper functions}
274 %************************************************************************
277 pprCols = (100 :: Int) -- could make configurable
279 printDoc :: Mode -> Handle -> Doc -> IO ()
280 printDoc mode hdl doc
281 = fullRender mode pprCols 1.5 put done doc
283 put (Chr c) next = hPutChar hdl c >> next
284 put (Str s) next = hPutStr hdl s >> next
285 put (PStr s) next = hPutFS hdl s >> next
287 done = hPutChar hdl '\n'
292 interppSP :: Outputable a => [a] -> SDoc
293 interppSP xs = hsep (map ppr xs)
295 interpp'SP :: Outputable a => [a] -> SDoc
296 interpp'SP xs = hsep (punctuate comma (map ppr xs))
298 pprQuotedList :: Outputable a => [a] -> SDoc
299 -- [x,y,z] ==> `x', `y', `z'
300 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
306 %************************************************************************
308 \subsection{Printing numbers verbally}
310 %************************************************************************
312 @speakNth@ converts an integer to a verbal index; eg 1 maps to
316 speakNth :: Int -> SDoc
318 speakNth 1 = ptext SLIT("first")
319 speakNth 2 = ptext SLIT("second")
320 speakNth 3 = ptext SLIT("third")
321 speakNth 4 = ptext SLIT("fourth")
322 speakNth 5 = ptext SLIT("fifth")
323 speakNth 6 = ptext SLIT("sixth")
324 speakNth n = hcat [ int n, text st_nd_rd_th ]
326 st_nd_rd_th | n_rem_10 == 1 = "st"
327 | n_rem_10 == 2 = "nd"
328 | n_rem_10 == 3 = "rd"
331 n_rem_10 = n `rem` 10
335 speakNTimes :: Int {- >=1 -} -> SDoc
336 speakNTimes t | t == 1 = ptext SLIT("once")
337 | t == 2 = ptext SLIT("twice")
338 | otherwise = int t <+> ptext SLIT("times")
341 %************************************************************************
343 \subsection[Utils-errors]{Error handling}
345 %************************************************************************
348 pprPanic heading pretty_msg = panic (show (doc PprDebug))
350 doc = text heading <+> pretty_msg
352 pprError heading pretty_msg = error (heading++ " " ++ (show pretty_msg))
354 pprTrace heading pretty_msg = trace (show (doc PprDebug))
356 doc = text heading <+> pretty_msg
358 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
360 doc = text heading <+> pretty_msg
362 assertPprPanic :: String -> Int -> SDoc -> a
363 assertPprPanic file line msg
364 = panic (show (doc PprDebug))
366 doc = sep [hsep[text "ASSERT failed! file",
368 text "line", int line],