Source file indexOut.ml
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
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
open IndexTypes
#if OCAML_VERSION < (5,3,0)
module Format_doc = struct
let compat = Fun.id
end
#endif
let option_iter opt f = match opt with
| Some x -> f x
| None -> ()
let rec string_index_from s i chars =
if i >= String.length s then raise Not_found
else if String.contains chars s.[i] then i
else string_index_from s (i+1) chars
module IndexFormat = struct
let list
?(paren=false) ?(left=fun _ -> ()) ?(right=fun _ -> ())
pr sep fmt lst
=
let rec aux = function
| [] -> ()
| [x] -> pr fmt x
| x::r -> pr fmt x; sep fmt (); aux r
in
match lst with
| [] -> ()
| [x] -> left fmt; pr fmt x; right fmt
| _::_::_ ->
if paren then Format.pp_print_char fmt '(';
left fmt; aux lst; right fmt;
if paren then Format.pp_print_char fmt ')'
let lines ?(escaped=false) fmt str =
let len = String.length str in
let esc = if escaped then String.escaped else fun s -> s in
let rec aux i =
if i >= len then () else
let j = try String.index_from str i '\n' with Not_found -> len in
Format.pp_print_string fmt
(esc (String.trim (String.sub str i (j - i))));
if j < len - 1 then
(Format.pp_force_newline fmt ();
aux (j+1))
in
aux 0
type coloriser =
{ f: 'a. kind ->
('a, Format.formatter, unit) format -> Format.formatter
-> 'a }
let color =
let f kind fstr fmt =
let colorcode = match kind with
| OpenType
| Type -> "\027[36m"
| Value -> "\027[1m"
| Exception -> "\027[33m"
| Field _ | Variant _ -> "\027[34m"
| Method _ -> "\027[1m"
| Module | ModuleType -> "\027[31m"
| Class | ClassType -> "\027[35m"
| Keyword -> "\027[32m"
in
Format.pp_print_as fmt 0 colorcode;
Format.kfprintf (fun fmt -> Format.pp_print_as fmt 0 "\027[m") fmt fstr
in { f }
let no_color =
let f _ fstr fmt = Format.fprintf fmt fstr in
{ f }
let name ?(colorise = no_color) fmt id =
colorise.f id.kind "%s" fmt id.name
let path ?(short = false) ?(colorise = no_color) fmt id =
List.iter
(Format.fprintf fmt "%a." (colorise.f Module "%s"))
(if short then id.path else id.orig_path);
name ~colorise fmt id
let kind ?(colorise = no_color) fmt id =
match id.kind with
| OpenType -> Format.pp_print_string fmt "opentype"
| Type -> Format.pp_print_string fmt "type"
| Value -> Format.pp_print_string fmt "val"
| Exception -> Format.pp_print_string fmt "exception"
| Field parentty ->
Format.fprintf fmt "field(%a)"
(colorise.f parentty.kind "%s") parentty.name
| Variant parentty ->
Format.fprintf fmt "constr(%a)"
(colorise.f parentty.kind "%s") parentty.name
| Method parentclass ->
Format.fprintf fmt "method(%a)"
(colorise.f parentclass.kind "%s") parentclass.name
| Module -> Format.pp_print_string fmt "module"
| ModuleType -> Format.pp_print_string fmt "modtype"
| Class -> Format.pp_print_string fmt "class"
| ClassType -> Format.pp_print_string fmt "classtype"
| Keyword -> Format.pp_print_string fmt "keyword"
let rec tydecl fmt =
let open Outcometree in
function
| Otyp_abstract -> Format.fprintf fmt "<abstract>"
| Otyp_manifest (ty,_) -> tydecl fmt ty
| Otyp_record fields ->
#if OCAML_VERSION >= (5,3,0)
let print_field fmt {olab_name; olab_mut; olab_type} =
Format.fprintf fmt "@[<2>%s%s :@ @[%a@]@];"
(match olab_mut with Mutable -> "mutable " | Immutable -> "")
olab_name
(Format_doc.compat !Oprint.out_type) olab_type
#else
let print_field fmt (name, mut, arg) =
Format.fprintf fmt "@[<2>%s%s :@ @[%a@]@];"
(if mut then "mutable " else "") name
!Oprint.out_type arg
#endif
in
Format.fprintf fmt "@[<hv 2>{%a}@]"
(list
~left:(fun fmt -> Format.pp_print_space fmt ())
~right:(fun fmt -> Format.pp_print_break fmt 1 (-2))
print_field Format.pp_print_space)
fields
| Otyp_sum [] ->
Format.pp_print_char fmt '-'
| Otyp_sum constrs ->
#if OCAML_VERSION >= (4,14,0)
let print_variant fmt {Outcometree.ocstr_name = name; ocstr_args = tyl; ocstr_return_type = ret_type_opt} =
#else
let print_variant fmt (name, tyl, ret_type_opt) =
#endif
match ret_type_opt with
| None ->
if tyl = [] then Format.pp_print_string fmt name
else
Format.fprintf fmt "@[<2>%s of@ @[%a@]@]"
name
(list (Format_doc.compat !Oprint.out_type)
(fun fmt () -> Format.fprintf fmt " *@ "))
tyl
| Some ret_type ->
if tyl = [] then
Format.fprintf fmt "@[<2>%s :@ @[%a@]@]" name
(Format_doc.compat !Oprint.out_type) ret_type
else
Format.fprintf fmt "@[<2>%s :@ @[%a -> @[%a@]@]@]"
name
(list (Format_doc.compat !Oprint.out_type)
(fun fmt () -> Format.fprintf fmt " *@ "))
tyl
(Format_doc.compat !Oprint.out_type) ret_type
in
list print_variant
~left:(fun fmt ->
Format.pp_print_if_newline fmt (); Format.fprintf fmt "| ")
(fun fmt () -> Format.fprintf fmt "@ | ")
fmt constrs
| ty ->
Format_doc.compat !Oprint.out_type fmt ty
let out_ty fmt ty =
let open Outcometree in
match ty with
| Osig_class (_,_,_,ctyp,_)
| Osig_class_type (_,_,_,ctyp,_) ->
Format_doc.compat !Oprint.out_class_type fmt ctyp
| Osig_typext ({ oext_args = [] }, _) ->
Format.pp_print_char fmt '-'
| Osig_typext ({ oext_args }, _) ->
list ~paren:true
(Format_doc.compat !Oprint.out_type)
(fun fmt () ->
Format.pp_print_char fmt ','; Format.pp_print_space fmt ())
fmt
oext_args
| Osig_modtype (_,mtyp)
| Osig_module (_,mtyp,_) ->
Format_doc.compat !Oprint.out_module_type fmt mtyp
#if OCAML_VERSION >= (4,03,0)
| Osig_type ({ otype_type },_) ->
tydecl fmt otype_type
| Osig_value {oval_type} ->
Format_doc.compat !Oprint.out_type fmt oval_type
| Osig_ellipsis ->
Format.fprintf fmt "..."
#elif OCAML_VERSION >= (4,02,0)
| Osig_type ({ otype_type },_) ->
tydecl fmt otype_type
| Osig_value (_,ty,_) ->
!Oprint.out_type fmt ty
#else
| Osig_type ((_,_,ty,_,_),_) ->
tydecl fmt ty
| Osig_value (_,ty,_) ->
!Oprint.out_type fmt ty
#endif
let ty ?(colorise = no_color) fmt id =
option_iter id.ty
(colorise.f Type "@[<hv>%a@]" fmt out_ty)
let parent_ty ?colorise ?short fmt id =
option_iter (IndexMisc.parent_type id)
(fun id ->
Format.fprintf fmt "@[<hv>%a =@ %a@]"
(path ?colorise ?short) id
(ty ?colorise) id)
let doc ?escaped ?colorise:(_ = no_color) fmt id =
option_iter (Lazy.force id.doc)
(Format.fprintf fmt "@[<h>%a@]" (lines ?escaped))
let loc ?root ?(intf=false) ?colorise:(_ = no_color) fmt id =
let loc =
if intf then Lazy.force id.loc_sig
else Lazy.force id.loc_impl
in
if loc = Location.none then
Format.fprintf fmt "@[<h><no location information>@]"
else
let pos = loc.Location.loc_start in
let fname = match root with
| Some r ->
let fname = pos.Lexing.pos_fname in
if Filename.is_relative fname then
Filename.concat r fname
else
let pfx = "/workspace_root/" in
let len = String.length pfx in
c prefix is used as an alias *)
if String.length fname > len && String.sub fname 0 len = pfx then
Filename.concat r
(String.sub fname len (String.length fname - len))
else
pos.Lexing.pos_fname
| _ -> pos.Lexing.pos_fname
in
Format.fprintf fmt "@[<h>%s:%d:%d@]"
fname pos.Lexing.pos_lnum (pos.Lexing.pos_cnum - pos.Lexing.pos_bol)
let file ?colorise:(_ = no_color) fmt id =
Format.fprintf fmt "@[<h>%s@]"
(match id.file with Cmt f | Cmi f | Cmti f -> f)
let info ?(colorise = no_color) fmt id =
let breakif n fmt = function
| None -> ()
| Some _ -> Format.pp_print_break fmt 1 n
in
Format.fprintf fmt "@[<v 2>@[<hov 2>%a@ %a%a%a@]%a%a@]@."
(path ?short:None ~colorise) id
(kind ~colorise) id
(breakif 0) id.ty
(ty ~colorise) id
(breakif 2) (Lazy.force id.doc)
(doc ?escaped:None ~colorise) id
let handle_format_char ?root chr ?colorise fmt id = match chr with
| 'n' -> name ?colorise fmt id
| 'q' -> path ~short:true ?colorise fmt id
| 'p' -> path ?colorise fmt id
| 'k' -> kind ?colorise fmt id
| 't' -> ty ?colorise fmt id
| 'd' -> doc ?colorise fmt id
| 'D' -> doc ~escaped:true ?colorise fmt id
| 'l' -> loc ?root ?colorise fmt id
| 's' -> loc ?root ~intf:true ?colorise fmt id
| 'f' -> file ?colorise fmt id
| 'i' -> info ?colorise fmt id
| 'e' -> parent_ty ?colorise fmt id
| '%' -> Format.fprintf fmt "%%"
| c -> Format.fprintf fmt "%%%c" c
let format ?root ?(separate=false) format ?colorise fmt id =
let len = String.length format in
let rec aux addsub ffmt flush i =
let j = try string_index_from format i "%\\" with Not_found -> len in
if j > i then addsub i (j - i);
if j >= len - 1 then addsub j (len - j)
else
let fmt = ffmt () in
begin match format.[j], format.[j+1] with
| '%', c -> handle_format_char ?root c ?colorise fmt id
| '\\', 'n' -> Format.pp_print_newline fmt ()
| '\\', 't' -> Format.pp_print_char fmt '\t'
| '\\', 'r' -> Format.pp_print_char fmt '\r'
| '\\', c -> Format.pp_print_char fmt c
| _ -> assert false
end;
flush fmt;
aux addsub ffmt flush (j + 2)
in
if not separate then
let addsub i len = Format.pp_print_string fmt (String.sub format i len) in
let ffmt () = fmt in
let flush _ = () in
aux addsub ffmt flush 0
else
let b = Buffer.create 200 in
let addsub = Buffer.add_substring b format in
let ffmt () = Format.formatter_of_buffer b in
let flush fmt = Format.pp_print_flush fmt () in
aux addsub ffmt flush 0;
Format.pp_print_string fmt (Buffer.contents b)
end
module Print = struct
let disable_split_lines () =
Format.pp_set_margin Format.str_formatter 1_000_000
let make (f: ?colorise: IndexFormat.coloriser -> 'a) ?(color=false) id =
let colorise =
if color then IndexFormat.color else IndexFormat.no_color
in
f ~colorise Format.str_formatter id;
Format.flush_str_formatter ()
let name = make IndexFormat.name
let path ?short = make (IndexFormat.path ?short)
let kind = make IndexFormat.kind
let ty = make IndexFormat.ty
let doc ?escaped = make (IndexFormat.doc ?escaped)
let loc ?root ?intf = make (IndexFormat.loc ?root ?intf)
let file = make IndexFormat.file
let info = make IndexFormat.info
let format ?root ?separate format =
make (IndexFormat.format ?root ?separate format)
end
module Format = IndexFormat