1 (* Title: Pure/General/pretty.ML
3 Author: Lawrence C Paulson, Cambridge University Computer Laboratory
4 Author: Markus Wenzel, TU Munich
6 Generic pretty printing module.
9 D. C. Oppen, "Pretty Printing",
10 ACM Transactions on Programming Languages and Systems (1980), 465-483.
12 The object to be printed is given as a tree with indentation and line
13 breaking information. A "break" inserts a newline if the text until
14 the next break is too long to fit on the current line. After the newline,
15 text is indented to the level of the enclosing block. Normally, if a block
16 is broken then all enclosing blocks will also be broken. Only "inconsistent
19 The stored length of a block is used in breakdist (to treat each inner block as
23 type pprint_args = (string -> unit) * (int -> unit) * (int -> unit) *
24 (unit -> unit) * (unit -> unit);
28 val default_indent: string -> int -> string
29 val default_markup: Markup.T -> string * string
30 val add_mode: string -> (string -> int -> string) -> (Markup.T -> string * string) -> unit
32 val raw_str: string * int -> T
36 val blk: int * T list -> T
37 val unbreakable: T -> T
38 val breaks: T list -> T list
39 val fbreaks: T list -> T list
40 val block: T list -> T
41 val markup: Markup.T -> T list -> T
42 val keyword: string -> T
43 val command: string -> T
44 val strs: string list -> T
45 val chunks: T list -> T
46 val chunks2: T list -> T
47 val block_enclose: T * T -> T list -> T
50 val separate: string -> T list -> T list
51 val commas: T list -> T list
52 val enclose: string -> string -> T list -> T
53 val enum: string -> string -> string -> T list -> T
54 val list: string -> string -> T list -> T
55 val str_list: string -> string -> string list -> T
56 val big_list: string -> T list -> T
57 val indent: int -> T -> T
58 val string_of: T -> string
59 val output_buffer: T -> Buffer.T
60 val output: T -> string
61 val writeln: T -> unit
62 val str_of: T -> string
63 val pprint: T -> pprint_args -> unit
64 val setdepth: int -> unit
65 val setmargin: int -> unit
66 val setmp_margin: int -> ('a -> 'b) -> 'a -> 'b
68 val pp: (term -> T) * (typ -> T) * (sort -> T) * (class list -> T) * (arity -> T) -> pp
69 val term: pp -> term -> T
70 val typ: pp -> typ -> T
71 val sort: pp -> sort -> T
72 val classrel: pp -> class list -> T
73 val arity: pp -> arity -> T
74 val string_of_term: pp -> term -> string
75 val string_of_typ: pp -> typ -> string
76 val string_of_sort: pp -> sort -> string
77 val string_of_classrel: pp -> class list -> string
78 val string_of_arity: pp -> arity -> string
81 structure Pretty: PRETTY =
84 (** print mode operations **)
86 fun default_indent (_: string) = Symbol.spaces;
87 fun default_markup (_: Markup.T) = ("", "");
90 val default = {indent = default_indent, markup = default_markup};
91 val modes = ref (Symtab.make [("", default)]);
93 fun add_mode name indent markup =
94 change modes (Symtab.update_new (name, {indent = indent, markup = markup}));
96 the_default default (Library.get_first (Symtab.lookup (! modes)) (! print_mode));
99 fun mode_indent x y = #indent (get_mode ()) x y;
100 fun mode_markup x = #markup (get_mode ()) x;
104 (** printing items: compound phrases, strings, and breaks **)
107 Block of Markup.T * T list * int * int | (*markup, body, indentation, length*)
108 String of string * int | (*text, length*)
109 Break of bool * int; (*mandatory flag, width if not taken*)
115 val output_spaces = Output.output o Symbol.spaces;
116 val add_indent = Buffer.add o output_spaces;
117 fun set_indent wd = Buffer.empty |> add_indent wd;
119 type text = {tx: Buffer.T, ind: Buffer.T, pos: int, nl: int};
127 fun newline {tx, ind, pos, nl} : text =
128 {tx = Buffer.add (Output.output "\n") tx,
133 fun string (s, len) {tx, ind, pos: int, nl} : text =
134 {tx = Buffer.add s tx,
135 ind = Buffer.add s ind,
139 fun blanks wd = string (output_spaces wd, wd);
141 fun indentation (buf, len) {tx, ind, pos, nl} : text =
142 let val s = Buffer.content buf in
143 {tx = Buffer.add (mode_indent s len) tx,
144 ind = Buffer.add s ind,
155 fun make_margin_info m =
156 {margin = m, (*right margin, or page width*)
157 breakgain = m div 20, (*minimum added space required of a break*)
158 emergencypos = m div 2}; (*position too far to right*)
160 val margin_info = ref (make_margin_info 76);
161 fun setmargin m = margin_info := make_margin_info m;
162 fun setmp_margin m f = setmp margin_info (make_margin_info m) f;
167 (*Add the lengths of the expressions until the next Break; if no Break then
168 include "after", to account for text following this block.*)
169 fun breakdist (Block (_, _, _, len) :: es, after) = len + breakdist (es, after)
170 | breakdist (String (s, len) :: es, after) = len + breakdist (es, after)
171 | breakdist (Break _ :: es, after) = 0
172 | breakdist ([], after) = after;
174 (*Search for the next break (at this or higher levels) and force it to occur.*)
175 fun forcenext [] = []
176 | forcenext (Break (_, wd) :: es) = Break (true, 0) :: es
177 | forcenext (e :: es) = e :: forcenext es;
179 (*es is list of expressions to print;
180 blockin is the indentation of the current block;
181 after is the width of the following context until next break.*)
182 fun format ([], _, _) text = text
183 | format (e :: es, block as (blockind, blockin), after) (text as {ind, pos, nl, ...}) =
185 Block (markup, bes, indent, wd) =>
187 val {emergencypos, ...} = ! margin_info;
188 val pos' = pos + indent;
189 val pos'' = pos' mod emergencypos;
191 if pos' < emergencypos then (ind |> add_indent indent, pos')
192 else (set_indent pos'', pos'');
193 val (bg, en) = if markup = Markup.none then ("", "") else mode_markup markup;
194 val btext: text = text
196 |> format (bes, block', breakdist (es, after))
198 (*if this block was broken then force the next break*)
199 val es' = if nl < #nl btext then forcenext es else es;
200 in format (es', block, after) btext end
201 | String str => format (es, block, after) (string str text)
202 | Break (force, wd) =>
203 let val {margin, breakgain, ...} = ! margin_info in
204 (*no break if text to next break fits on this line
205 or if breaking would add only breakgain to space*)
206 format (es, block, after)
207 (if not force andalso
208 pos + wd <= Int.max (margin - breakdist (es, after), blockin + breakgain)
209 then text |> blanks wd (*just insert wd blanks*)
210 else text |> newline |> indentation block)
214 (** Exported functions to create formatting expressions **)
216 fun length (Block (_, _, _, len)) = len
217 | length (String (_, len)) = len
218 | length (Break(_, wd)) = wd;
220 val raw_str = String;
221 val str = String o Output.output_width;
223 fun brk wd = Break (false, wd);
224 val fbrk = Break (true, 2);
226 fun markup_block m (indent, es) =
229 | sum (e :: es) k = sum es (length e + k);
230 in Block (m, es, indent, sum es 0) end;
232 val blk = markup_block Markup.none;
234 fun unbreakable (Break (_, wd)) = String (output_spaces wd, wd)
235 | unbreakable (Block (m, es, indent, wd)) = Block (m, map unbreakable es, indent, wd)
236 | unbreakable (e as String _) = e;
241 fun breaks prts = Library.separate (brk 1) prts;
242 fun fbreaks prts = Library.separate fbrk prts;
244 fun block prts = blk (2, prts);
245 fun markup m prts = markup_block m (0, prts);
247 fun keyword name = markup (Markup.keyword name) [str name];
248 fun command name = markup (Markup.command name) [str name];
250 val strs = block o breaks o map str;
251 fun chunks prts = blk (0, fbreaks prts);
252 fun chunks2 prts = blk (0, flat (Library.separate [fbrk, fbrk] (map single prts)));
253 fun block_enclose (p1, p2) ps = chunks [(block o fbreaks) (p1 :: ps), p2];
255 fun quote prt = blk (1, [str "\"", prt, str "\""]);
256 fun backquote prt = blk (1, [str "`", prt, str "`"]);
258 fun separate sep prts =
259 flat (Library.separate [str sep, brk 1] (map single prts));
261 val commas = separate ",";
263 fun enclose lpar rpar prts =
264 block (str lpar :: (prts @ [str rpar]));
266 fun enum sep lpar rpar prts = enclose lpar rpar (separate sep prts);
269 fun str_list lpar rpar strs = list lpar rpar (map str strs);
271 fun big_list name prts = block (fbreaks (str name :: prts));
273 fun indent 0 prt = prt
274 | indent n prt = blk (0, [str (Symbol.spaces n), prt]);
278 (** Pretty printing with depth limitation **)
280 val depth = ref 0; (*maximum depth; 0 means no limit*)
282 fun setdepth dp = (depth := dp);
284 (*Recursively prune blocks, discarding all text exceeding depth dp*)
285 fun pruning dp (Block (m, bes, indent, wd)) =
287 then markup_block m (indent, map (pruning (dp - 1)) bes)
291 fun prune dp e = if dp > 0 then pruning dp e else e;
293 fun output_buffer e = #tx (format ([prune (! depth) e], (Buffer.empty, 0), 0) empty);
294 val output = Buffer.content o output_buffer;
295 val string_of = Output.escape o output;
296 val writeln = Output.writeln o string_of;
299 (*Create a single flat string: no line breaking*)
302 fun fmt (Block (m, prts, _, _)) =
303 let val (bg, en) = mode_markup m
304 in Buffer.add bg #> fold fmt prts #> Buffer.add en end
305 | fmt (String (s, _)) = Buffer.add s
306 | fmt (Break (false, wd)) = Buffer.add (output_spaces wd)
307 | fmt (Break (true, _)) = Buffer.add (output_spaces 1);
308 in Output.escape (Buffer.content (fmt (prune (! depth) prt) Buffer.empty)) end;
310 (*part of the interface to the ML toplevel pretty printers*)
311 fun pprint prt (put_str, begin_blk, put_brk, put_fbrk, end_blk) =
313 fun pp (Block (_, prts, ind, _)) = (begin_blk ind; pp_lst prts; end_blk ())
314 | pp (String (s, _)) = put_str s
315 | pp (Break (false, wd)) = put_brk wd
316 | pp (Break (true, _)) = put_fbrk ()
318 | pp_lst (prt :: prts) = (pp prt; pp_lst prts);
319 in pp (prune (! depth) prt) end;
323 (** abstract pretty printing context **)
326 PP of (term -> T) * (typ -> T) * (sort -> T) * (class list -> T) * (arity -> T);
330 fun pp_fun f (PP x) = f x;
332 val term = pp_fun #1;
334 val sort = pp_fun #3;
335 val classrel = pp_fun #4;
336 val arity = pp_fun #5;
338 val string_of_term = string_of oo term;
339 val string_of_typ = string_of oo typ;
340 val string_of_sort = string_of oo sort;
341 val string_of_classrel = string_of oo classrel;
342 val string_of_arity = string_of oo arity;