@@ -80,28 +80,77 @@ module Pp = struct
8080
8181 type 'a t = bool -> Format .formatter -> 'a -> unit
8282
83- let to_show f x = asprintf " %a" false ) x
83+ type pp_thunk = Format .formatter -> unit
84+
85+ let truncate_message = " ... (truncated)"
86+
87+ let truncate_length =
88+ let truncate_env = " MCTUTILS_TRUNCATE" in
89+ let ( let * ) = Option. bind in
90+ let * l = Sys. getenv_opt truncate_env in
91+ let * l = int_of_string_opt l in
92+ (* it does not make sense to truncate at less than the length of
93+ [truncate_message] *)
94+ if l > 0 then Some (max l (String. length truncate_message - 1 )) else None
95+
96+ let to_show f x =
97+ match truncate_length with
98+ | None ->
99+ let buf = Buffer. create 512 in
100+ let fmt = formatter_of_buffer buf in
101+ pp_set_margin fmt max_int;
102+ fprintf fmt " @[<h 0>%a@]@?" false ) x;
103+ let s = Buffer. contents buf in
104+ Buffer. reset buf;
105+ s
106+ | Some trlen ->
107+ (* if we overflow, we'll have the [truncate_message] at the end of the
108+ buffer, filling it until [trlen + 1]: we'll use the fact that the
109+ buffer contains more than [trlen] to indicate that it has already
110+ overflown *)
111+ let buf = Buffer. create (trlen + 1 ) in
112+ let msglen = String. length truncate_message in
113+ let out str ofs len =
114+ let blen = Buffer. length buf in
115+ (* if we didn't overflow yet... *)
116+ if blen < = trlen then
117+ if blen + len > trlen then (
118+ let fits = trlen - blen - msglen + 1 in
119+ if fits > 0 then Buffer. add_substring buf str ofs fits
120+ else Buffer. truncate buf (trlen + 1 - msglen);
121+ Buffer. add_string buf truncate_message)
122+ else Buffer. add_substring buf str ofs len
123+ in
124+ let ppf = make_formatter out ignore in
125+ pp_set_margin ppf max_int;
126+ fprintf ppf " @[<h 0>%a@]@?" false ) x;
127+ let s = Buffer. contents buf in
128+ Buffer. reset buf;
129+ s
84130
85131 let of_show f par fmt x =
86- fprintf fmt (if par then " (%s)" else " %s "
132+ fprintf fmt (if par then " @[ (%s)@] " else " @[%s@] "
87133
88134 let cst0 name fmt = pp_print_string fmt name
89135
90136 let cst1 (pp : 'a t ) name par fmt x =
91- fprintf fmt (if par then " (%s %a)" else " %s %a" true ) x
137+ let o, c = if par then (" (" " )" else (" " " " in
138+ fprintf fmt " %s@[<2>%s@ %a@]%s" true ) x c
92139
93140 let cst2 (pp1 : 'a t ) (pp2 : 'b t ) name par fmt x y =
94- fprintf fmt (if par then " (%s (%a, %a))" else " %s (%a, %a)" false ) x (pp2 false ) y
141+ let o, c = if par then (" (" " )" else (" " " " in
142+ fprintf fmt " %s@[<2>%s (@,%a,@ %a)@]%s" false ) x (pp2 false ) y c
95143
96144 let cst3 (pp1 : 'a t ) (pp2 : 'b t ) (pp3 : 'c t ) name par fmt x y z =
97- fprintf fmt
98- ( if par then " (%s ( %a, %a, %a)) " else " %s (%a, %a, %a) " )
99- name (pp1 false ) x ( pp2 false ) y (pp3 false ) z
145+ let o, c = if par then ( " ( " , " ) " ) else ( " " , " " ) in
146+ fprintf fmt " %s@[<2>%s (@, %a,@ %a,@ %a)@]%s " o name (pp1 false ) x
147+ ( pp2 false ) y (pp3 false ) z c
100148
101149 let pp_exn = of_show Printexc. to_string
102150 let pp_unit _ fmt () = pp_print_string fmt " ()"
103151 let pp_bool _ fmt b = fprintf fmt " %B"
104152 let pp_int par fmt i = fprintf fmt (if par && i < 0 then " (%d)" else " %d"
153+ let pp_int32 par fmt i = fprintf fmt (if par && i < 0l then " (%ldl)" else " %ldl"
105154 let pp_int64 par fmt i = fprintf fmt (if par && i < 0L then " (%LdL)" else " %LdL"
106155 let pp_float par fmt f = fprintf fmt (if par && f < 0.0 then " (%F)" else " %F"
107156 let pp_char _ fmt c = fprintf fmt " %C"
@@ -110,42 +159,144 @@ module Pp = struct
110159
111160 let pp_option (pp_s : 'a t ) par fmt o =
112161 match o with
113- | None -> pp_print_string fmt " None"
114- | Some s -> fprintf fmt ( if par then " ( Some %a) " else " Some %a " ) (pp_s true ) s
162+ | None -> cst0 " None" fmt
163+ | Some s -> cst1 pp_s " Some" par fmt s
115164
116165 let pp_result (pp_o : 'o t ) (pp_e : 'e t ) par fmt r =
117166 let open Result in
118167 match r with
119- | Ok o -> fprintf fmt (if par then " (Ok %a)" else " Ok %a" true ) o
120- | Error e -> fprintf fmt (if par then " (Error %a)" else " Error %a" true ) e
168+ | Ok o -> cst1 pp_o " Ok"
169+ | Error e -> cst1 pp_e " Error"
170+
171+ type pp_tuple_item = pp_thunk
172+
173+ let pp_tuple_item pp x fmt = pp false fmt x
174+
175+ let pp_tuple _ fmt items =
176+ fprintf fmt " (@["
177+ pp_print_list ~pp_sep: (fun fmt () -> fprintf fmt " ,@ " fun fmt ppf -> ppf fmt) fmt items;
178+ fprintf fmt " @])"
179+
180+ let pp_tuple2 pp1 pp2 p fmt (x1 , x2 ) =
181+ pp_tuple p fmt [ pp_tuple_item pp1 x1; pp_tuple_item pp2 x2 ]
182+
183+ let pp_tuple3 pp1 pp2 pp3 p fmt (x1 , x2 , x3 ) =
184+ pp_tuple p fmt
185+ [ pp_tuple_item pp1 x1; pp_tuple_item pp2 x2; pp_tuple_item pp3 x3 ]
186+
187+ let pp_tuple4 pp1 pp2 pp3 pp4 p fmt (x1 , x2 , x3 , x4 ) =
188+ pp_tuple p fmt
189+ [
190+ pp_tuple_item pp1 x1;
191+ pp_tuple_item pp2 x2;
192+ pp_tuple_item pp3 x3;
193+ pp_tuple_item pp4 x4;
194+ ]
195+
196+ let pp_tuple5 pp1 pp2 pp3 pp4 pp5 p fmt (x1 , x2 , x3 , x4 , x5 ) =
197+ pp_tuple p fmt
198+ [
199+ pp_tuple_item pp1 x1;
200+ pp_tuple_item pp2 x2;
201+ pp_tuple_item pp3 x3;
202+ pp_tuple_item pp4 x4;
203+ pp_tuple_item pp5 x5;
204+ ]
205+
206+ let pp_tuple6 pp1 pp2 pp3 pp4 pp5 pp6 p fmt (x1 , x2 , x3 , x4 , x5 , x6 ) =
207+ pp_tuple p fmt
208+ [
209+ pp_tuple_item pp1 x1;
210+ pp_tuple_item pp2 x2;
211+ pp_tuple_item pp3 x3;
212+ pp_tuple_item pp4 x4;
213+ pp_tuple_item pp5 x5;
214+ pp_tuple_item pp6 x6;
215+ ]
216+
217+ let pp_tuple7 pp1 pp2 pp3 pp4 pp5 pp6 pp7 p fmt (x1 , x2 , x3 , x4 , x5 , x6 , x7 ) =
218+ pp_tuple p fmt
219+ [
220+ pp_tuple_item pp1 x1;
221+ pp_tuple_item pp2 x2;
222+ pp_tuple_item pp3 x3;
223+ pp_tuple_item pp4 x4;
224+ pp_tuple_item pp5 x5;
225+ pp_tuple_item pp6 x6;
226+ pp_tuple_item pp7 x7;
227+ ]
228+
229+ let pp_tuple8 pp1 pp2 pp3 pp4 pp5 pp6 pp7 pp8 p fmt
230+ (x1 , x2 , x3 , x4 , x5 , x6 , x7 , x8 ) =
231+ pp_tuple p fmt
232+ [
233+ pp_tuple_item pp1 x1;
234+ pp_tuple_item pp2 x2;
235+ pp_tuple_item pp3 x3;
236+ pp_tuple_item pp4 x4;
237+ pp_tuple_item pp5 x5;
238+ pp_tuple_item pp6 x6;
239+ pp_tuple_item pp7 x7;
240+ pp_tuple_item pp8 x8;
241+ ]
242+
243+ let pp_tuple9 pp1 pp2 pp3 pp4 pp5 pp6 pp7 pp8 pp9 p fmt
244+ (x1 , x2 , x3 , x4 , x5 , x6 , x7 , x8 , x9 ) =
245+ pp_tuple p fmt
246+ [
247+ pp_tuple_item pp1 x1;
248+ pp_tuple_item pp2 x2;
249+ pp_tuple_item pp3 x3;
250+ pp_tuple_item pp4 x4;
251+ pp_tuple_item pp5 x5;
252+ pp_tuple_item pp6 x6;
253+ pp_tuple_item pp7 x7;
254+ pp_tuple_item pp8 x8;
255+ pp_tuple_item pp9 x9;
256+ ]
257+
258+ let pp_tuple10 pp1 pp2 pp3 pp4 pp5 pp6 pp7 pp8 pp9 pp10 p fmt
259+ (x1 , x2 , x3 , x4 , x5 , x6 , x7 , x8 , x9 , x10 ) =
260+ pp_tuple p fmt
261+ [
262+ pp_tuple_item pp1 x1;
263+ pp_tuple_item pp2 x2;
264+ pp_tuple_item pp3 x3;
265+ pp_tuple_item pp4 x4;
266+ pp_tuple_item pp5 x5;
267+ pp_tuple_item pp6 x6;
268+ pp_tuple_item pp7 x7;
269+ pp_tuple_item pp8 x8;
270+ pp_tuple_item pp9 x9;
271+ pp_tuple_item pp10 x10;
272+ ]
121273
122- let pp_pair (pp_f : 'a t ) (pp_s : 'b t ) _ fmt (x ,y ) =
123- fprintf fmt " (%a, %a)" false ) x (pp_s false ) y
274+ let pp_pair = pp_tuple2
124275
125276 let pp_list (pp_e : 'a t ) _ fmt l =
126- pp_print_string fmt " ["
277+ fprintf fmt " @[<2> ["
127278 pp_print_list ~pp_sep: (fun fmt () -> fprintf fmt " ;@ " false ) fmt l;
128- pp_print_string fmt " ]"
279+ fprintf fmt " @,]@ ]"
129280
130281 let pp_seq (pp_e : 'a t ) _ fmt s =
131- pp_print_string fmt " <"
282+ fprintf fmt " @[<2> <"
132283 pp_print_seq ~pp_sep: (fun fmt () -> fprintf fmt " ;@ " false ) fmt s;
133- pp_print_string fmt " > "
284+ fprintf fmt " @,>@] "
134285
135286 let pp_array (pp_e : 'a t ) _ fmt a =
136- pp_print_string fmt " [|"
287+ fprintf fmt " @[<2> [|"
137288 pp_print_seq ~pp_sep: (fun fmt () -> fprintf fmt " ;@ " false ) fmt (Array. to_seq a);
138- pp_print_string fmt " | ]"
289+ fprintf fmt " @,|]@ ]"
139290
140- type pp_field = Format .formatter -> unit
291+ type pp_field = pp_thunk
141292
142293 let pp_field name (pp_c : 'a t ) c fmt =
143- fprintf fmt " %s =@ %a" false ) c
294+ fprintf fmt " @[ %s =@ %a@] " false ) c
144295
145296 let pp_record _ fmt fields =
146- pp_print_string fmt " { "
297+ fprintf fmt " @[<2> { "
147298 pp_print_list ~pp_sep: (fun fmt () -> fprintf fmt " ;@ " fun fmt ppf -> ppf fmt) fmt fields;
148- fprintf fmt " @ }"
299+ fprintf fmt " @ }@] "
149300end
150301
151302module Equal = struct
0 commit comments