1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
|
(* Copyright Jeremy Yallop 2007.
This file is free software, distributed under the MIT license.
See the file COPYING for details.
*)
module Deriving_Show =
struct
(** Show **)
module type Show = sig
type a
val format : Format.formatter -> a -> unit
val format_list : Format.formatter -> a list -> unit
val show : a -> string
val show_list : a list -> string
end
module type SimpleFormatter =
sig
type a
val format : Format.formatter -> a -> unit
end
module ShowFormatterDefault (S : SimpleFormatter) =
struct
include S
let format_list formatter items =
let rec writeItems formatter = function
| [] -> ()
| [x] -> S.format formatter x;
| x :: xs -> Format.fprintf formatter "%a;@;%a" S.format x writeItems xs
in
Format.fprintf formatter "@[<hov 1>[%a]@]" writeItems items
end
module ShowDefaults'
(S : (sig
type a
val format : Format.formatter -> a -> unit
val format_list : Format.formatter -> a list -> unit
end)) : Show with type a = S.a =
struct
include S
let showFormatted f item =
let b = Buffer.create 16 in
let formatter = Format.formatter_of_buffer b in
Format.fprintf formatter "@[<hov 0>%a@]@?" f item;
Buffer.sub b 0 (Buffer.length b)
(* Warning: do not eta-reduce either of the following *)
let show item = showFormatted S.format item
let show_list items = showFormatted S.format_list items
end
module Defaults (S : SimpleFormatter) : Show with type a = S.a =
ShowDefaults' (ShowFormatterDefault (S))
module Show_unprintable (S : sig type a end) (*: Show with type a = S.a *) =
Defaults (struct
type a = S.a
let format formatter _ = Format.pp_print_string formatter "..."
end)
(* instance Show a => Show [a] *)
module Show_list (S : Show) : Show with type a = S.a list =
Defaults (struct
type a = S.a list
let format = S.format_list
end)
(* instance Show a => Show (a option) *)
module Show_option (S : Show) : Show with type a = S.a option =
Defaults (struct
type a = S.a option
let format formatter = function
| None -> Format.fprintf formatter "@[None@]"
| Some s -> Format.fprintf formatter "@[Some@;<1 2>(%a)@]" S.format s
end)
(* instance Show a => Show (a array) *)
module Show_array (S : Show) : Show with type a = S.a array =
Defaults (struct
type a = S.a array
let format formatter obj =
let writeItems formatter items =
let length = Array.length items in
for i = 0 to length - 2 do
Format.fprintf formatter "@[%a;@;@]" S.format (Array.get items i)
done;
if length <> 0 then
S.format formatter (Array.get items (length -1));
in
Format.fprintf formatter "@[[|%a|]@]" writeItems obj
end)
module Show_map
(O : Map.OrderedType)
(K : Show with type a = O.t)
(V : Show)
: Show with type a = V.a Map.Make(O).t =
Defaults(
struct
module M = Map.Make(O)
type a = V.a M.t
let format formatter map =
Format.pp_open_box formatter 0;
Format.pp_print_string formatter "{";
M.iter (fun key value ->
Format.pp_open_box formatter 0;
K.format formatter key;
Format.pp_print_string formatter " => ";
V.format formatter value;
Format.fprintf formatter ";@;";
Format.pp_close_box formatter ();
) map;
Format.pp_print_string formatter "}";
Format.pp_close_box formatter ();
end)
module Show_set
(O : Set.OrderedType)
(K : Show with type a = O.t)
: Show with type a = Set.Make(O).t =
Defaults(
struct
module S = Set.Make(O)
type a = S.t
let format formatter set =
Format.pp_open_box formatter 0;
Format.pp_print_string formatter "{";
S.iter (fun elt ->
Format.pp_open_box formatter 0;
K.format formatter elt;
Format.fprintf formatter ";@;";
Format.pp_close_box formatter ();
) set;
Format.pp_print_string formatter "}";
Format.pp_close_box formatter ();
end)
module Show_bool = Defaults (struct
type a = bool
let format formatter item =
match item with
| true -> Format.pp_print_string formatter "true"
| false -> Format.pp_print_string formatter "false"
end)
module Show_integer (S : sig type t val to_string : t -> string end) = Defaults (struct
type a = S.t
let format formatter item = Format.pp_print_string formatter (S.to_string item)
end)
module Show_int32 = Show_integer(Int32)
module Show_int64 = Show_integer(Int64)
module Show_nativeint = Show_integer(Nativeint)
module Show_char = Defaults (struct
type a = char
let format formatter item = Format.pp_print_string formatter ("'" ^ Char.escaped item ^ "'")
end)
module Show_int = Defaults (struct
type a = int
let format formatter item = Format.pp_print_string formatter (string_of_int item)
end)
module Show_float = Defaults(struct
type a = float
let format formatter item = Format.pp_print_string formatter (string_of_float item)
end)
module Show_string = Defaults (struct
type a = string
let format formatter item =
Format.pp_print_char formatter '"';
Format.pp_print_string formatter (String.escaped item);
Format.pp_print_char formatter '"'
end)
module Show_unit = Defaults(struct
type a = unit
let format formatter () = Format.pp_print_string formatter "()"
end)
end
include Deriving_Show
type open_flag = Pervasives.open_flag =
| Open_rdonly
| Open_wronly
| Open_append
| Open_creat
| Open_trunc
| Open_excl
| Open_binary
| Open_text
| Open_nonblock
deriving (Show)
type fpclass = Pervasives.fpclass =
| FP_normal
| FP_subnormal
| FP_zero
| FP_infinite
| FP_nan
deriving (Show)
type 'a ref = 'a Pervasives.ref = { mutable contents : 'a; }
deriving (Show)
|
