anil.recoil.org
OCaml codecs for Python INI file handling compatible with ConfigParser
init init
+1
.gitignore
+1
.gitignore
···
1
+
_build
+28
dune-project
+28
dune-project
···
1
+
(lang dune 3.0)
2
+
(name init)
3
+
(version 0.1.0)
4
+
5
+
(generate_opam_files true)
6
+
7
+
(license ISC)
8
+
(authors "Anil Madhavapeddy <anil@recoil.org>")
9
+
(maintainers "Anil Madhavapeddy <anil@recoil.org>")
10
+
(source (github avsm/ocaml-init))
11
+
12
+
(package
13
+
(name init)
14
+
(synopsis "Declarative INI data manipulation for OCaml")
15
+
(description
16
+
"Init provides bidirectional codecs for INI files following Python's
17
+
configparser semantics. Features include multiline values, interpolation,
18
+
DEFAULT section inheritance, and layout preservation.
19
+
20
+
The core init library has no dependencies. The optional init.bytesrw
21
+
sub-library provides parsing/encoding with bytesrw. The optional init.eio
22
+
sub-library provides Eio file system integration.")
23
+
(depends
24
+
(ocaml (>= 4.14.0)))
25
+
(depopts bytesrw eio bytesrw-eio)
26
+
(conflicts
27
+
(bytesrw (< 0.1.0))
28
+
(eio (< 1.0))))
+42
init.opam
+42
init.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
version: "0.1.0"
4
+
synopsis: "Declarative INI data manipulation for OCaml"
5
+
description: """
6
+
Init provides bidirectional codecs for INI files following Python's
7
+
configparser semantics. Features include multiline values, interpolation,
8
+
DEFAULT section inheritance, and layout preservation.
9
+
10
+
The core init library has no dependencies. The optional init.bytesrw
11
+
sub-library provides parsing/encoding with bytesrw. The optional init.eio
12
+
sub-library provides Eio file system integration."""
13
+
maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
14
+
authors: ["Anil Madhavapeddy <anil@recoil.org>"]
15
+
license: "ISC"
16
+
homepage: "https://github.com/avsm/ocaml-init"
17
+
bug-reports: "https://github.com/avsm/ocaml-init/issues"
18
+
depends: [
19
+
"dune" {>= "3.0"}
20
+
"ocaml" {>= "4.14.0"}
21
+
"odoc" {with-doc}
22
+
]
23
+
depopts: ["bytesrw" "eio" "bytesrw-eio"]
24
+
conflicts: [
25
+
"bytesrw" {< "0.1.0"}
26
+
"eio" {< "1.0"}
27
+
]
28
+
build: [
29
+
["dune" "subst"] {dev}
30
+
[
31
+
"dune"
32
+
"build"
33
+
"-p"
34
+
name
35
+
"-j"
36
+
jobs
37
+
"@install"
38
+
"@runtest" {with-test}
39
+
"@doc" {with-doc}
40
+
]
41
+
]
42
+
dev-repo: "git+https://github.com/avsm/ocaml-init.git"
+4
src/bytesrw/dune
+4
src/bytesrw/dune
+739
src/bytesrw/init_bytesrw.ml
+739
src/bytesrw/init_bytesrw.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Bytesrw
7
+
8
+
(** INI parser and encoder using bytesrw.
9
+
10
+
Implements Python configparser semantics including:
11
+
- Multiline values via indentation
12
+
- Basic interpolation: %(name)s
13
+
- Extended interpolation: ${section:name}
14
+
- DEFAULT section inheritance
15
+
- Case-insensitive option lookup *)
16
+
17
+
(* ---- Configuration ---- *)
18
+
19
+
type interpolation =
20
+
| No_interpolation
21
+
| Basic_interpolation
22
+
| Extended_interpolation
23
+
24
+
type config = {
25
+
delimiters : string list;
26
+
comment_prefixes : string list;
27
+
inline_comment_prefixes : string list;
28
+
default_section : string;
29
+
interpolation : interpolation;
30
+
allow_no_value : bool;
31
+
strict : bool;
32
+
empty_lines_in_values : bool;
33
+
}
34
+
35
+
let default_config = {
36
+
delimiters = ["="; ":"];
37
+
comment_prefixes = ["#"; ";"];
38
+
inline_comment_prefixes = [];
39
+
default_section = "DEFAULT";
40
+
interpolation = Basic_interpolation;
41
+
allow_no_value = false;
42
+
strict = true;
43
+
empty_lines_in_values = true;
44
+
}
45
+
46
+
let raw_config = { default_config with interpolation = No_interpolation }
47
+
48
+
(* ---- Reading from bytesrw ---- *)
49
+
50
+
let read_all_to_string reader =
51
+
let buf = Buffer.create 4096 in
52
+
let rec loop () =
53
+
let slice = Bytes.Reader.read reader in
54
+
if Bytes.Slice.length slice = 0 then
55
+
Buffer.contents buf
56
+
else begin
57
+
Buffer.add_subbytes buf
58
+
(Bytes.Slice.bytes slice)
59
+
(Bytes.Slice.first slice)
60
+
(Bytes.Slice.length slice);
61
+
loop ()
62
+
end
63
+
in
64
+
loop ()
65
+
66
+
(* ---- Parsing State ---- *)
67
+
68
+
type parse_state = {
69
+
mutable file : string;
70
+
mutable line_num : int;
71
+
mutable byte_pos : int;
72
+
mutable line_start_byte : int;
73
+
config : config;
74
+
(* Accumulated data *)
75
+
mutable defaults : (string Init.node * Init.Repr.ini_value) list;
76
+
mutable sections : Init.Repr.ini_section list;
77
+
(* Current parse state *)
78
+
mutable cur_section : string option;
79
+
mutable cur_option : (string * Init.Meta.t) option;
80
+
mutable cur_value : string list;
81
+
mutable cur_indent : int;
82
+
mutable cur_value_meta : Init.Meta.t;
83
+
mutable pending_ws : string;
84
+
}
85
+
86
+
let make_state config file = {
87
+
file;
88
+
line_num = 1;
89
+
byte_pos = 0;
90
+
line_start_byte = 0;
91
+
config;
92
+
defaults = [];
93
+
sections = [];
94
+
cur_section = None;
95
+
cur_option = None;
96
+
cur_value = [];
97
+
cur_indent = 0;
98
+
cur_value_meta = Init.Meta.none;
99
+
pending_ws = "";
100
+
}
101
+
102
+
let current_textloc state first_byte last_byte first_line =
103
+
Init.Textloc.make
104
+
~file:state.file
105
+
~first_byte ~last_byte
106
+
~first_line
107
+
~last_line:(state.line_num, state.line_start_byte)
108
+
109
+
let current_meta state first_byte first_line =
110
+
let textloc = current_textloc state first_byte state.byte_pos first_line in
111
+
Init.Meta.make textloc
112
+
113
+
(* ---- String Utilities ---- *)
114
+
115
+
let string_starts_with ~prefix s =
116
+
let plen = String.length prefix in
117
+
let slen = String.length s in
118
+
slen >= plen && String.sub s 0 plen = prefix
119
+
120
+
let lstrip s =
121
+
let len = String.length s in
122
+
let rec find_start i =
123
+
if i >= len then len
124
+
else match s.[i] with
125
+
| ' ' | '\t' -> find_start (i + 1)
126
+
| _ -> i
127
+
in
128
+
let start = find_start 0 in
129
+
if start = 0 then s
130
+
else String.sub s start (len - start)
131
+
132
+
let rstrip s =
133
+
let rec find_end i =
134
+
if i < 0 then -1
135
+
else match s.[i] with
136
+
| ' ' | '\t' | '\r' | '\n' -> find_end (i - 1)
137
+
| _ -> i
138
+
in
139
+
let end_pos = find_end (String.length s - 1) in
140
+
if end_pos = String.length s - 1 then s
141
+
else String.sub s 0 (end_pos + 1)
142
+
143
+
let strip s = lstrip (rstrip s)
144
+
145
+
let count_indent s =
146
+
let len = String.length s in
147
+
let rec count i =
148
+
if i >= len then i
149
+
else match s.[i] with
150
+
| ' ' | '\t' -> count (i + 1)
151
+
| _ -> i
152
+
in
153
+
count 0
154
+
155
+
(* ---- Comment and Delimiter Handling ---- *)
156
+
157
+
let is_comment_line config line =
158
+
let trimmed = lstrip line in
159
+
List.exists (fun prefix -> string_starts_with ~prefix trimmed) config.comment_prefixes
160
+
161
+
let is_empty_line line =
162
+
String.length (strip line) = 0
163
+
164
+
let strip_inline_comment config value =
165
+
if config.inline_comment_prefixes = [] then value
166
+
else
167
+
(* Find inline comment with preceding whitespace *)
168
+
let len = String.length value in
169
+
let rec find_comment i =
170
+
if i >= len then value
171
+
else if value.[i] = ' ' || value.[i] = '\t' then begin
172
+
let rest = String.sub value i (len - i) in
173
+
let trimmed = lstrip rest in
174
+
if List.exists (fun p -> string_starts_with ~prefix:p trimmed) config.inline_comment_prefixes then
175
+
rstrip (String.sub value 0 i)
176
+
else
177
+
find_comment (i + 1)
178
+
end
179
+
else find_comment (i + 1)
180
+
in
181
+
find_comment 0
182
+
183
+
let find_delimiter config line =
184
+
let trimmed = lstrip line in
185
+
let len = String.length trimmed in
186
+
let rec try_delimiters delims =
187
+
match delims with
188
+
| [] -> None
189
+
| delim :: rest ->
190
+
let dlen = String.length delim in
191
+
let rec find_at i =
192
+
if i + dlen > len then try_delimiters rest
193
+
else if String.sub trimmed i dlen = delim then Some (delim, i)
194
+
else find_at (i + 1)
195
+
in
196
+
find_at 0
197
+
in
198
+
try_delimiters config.delimiters
199
+
200
+
(* ---- Section Header Parsing ---- *)
201
+
202
+
let parse_section_header line =
203
+
let trimmed = strip line in
204
+
let len = String.length trimmed in
205
+
if len >= 2 && trimmed.[0] = '[' && trimmed.[len - 1] = ']' then
206
+
Some (String.sub trimmed 1 (len - 2))
207
+
else
208
+
None
209
+
210
+
(* ---- Interpolation ---- *)
211
+
212
+
let rec basic_interpolate ~section ~defaults ~sections value max_depth =
213
+
if max_depth <= 0 then
214
+
Error (Init.Error.make (Init.Error.Interpolation {
215
+
option = ""; reason = "recursion depth exceeded" }))
216
+
else
217
+
let buf = Buffer.create (String.length value) in
218
+
let len = String.length value in
219
+
let rec scan i =
220
+
if i >= len then Ok (Buffer.contents buf)
221
+
else if i + 1 < len && value.[i] = '%' && value.[i+1] = '%' then begin
222
+
Buffer.add_char buf '%';
223
+
scan (i + 2)
224
+
end
225
+
else if value.[i] = '%' && i + 1 < len && value.[i+1] = '(' then begin
226
+
(* Find closing )s *)
227
+
let rec find_close j =
228
+
if j + 1 >= len then None
229
+
else if value.[j] = ')' && value.[j+1] = 's' then Some j
230
+
else find_close (j + 1)
231
+
in
232
+
match find_close (i + 2) with
233
+
| None ->
234
+
Buffer.add_char buf value.[i];
235
+
scan (i + 1)
236
+
| Some close_pos ->
237
+
let name = String.lowercase_ascii (String.sub value (i + 2) (close_pos - i - 2)) in
238
+
(* Look up value: current section first, then defaults *)
239
+
let lookup_result =
240
+
let find_in_opts opts =
241
+
List.find_opt (fun ((n, _), _) ->
242
+
String.lowercase_ascii n = name) opts
243
+
in
244
+
match section with
245
+
| None -> find_in_opts defaults
246
+
| Some sec ->
247
+
let sec_opts = List.find_opt (fun s ->
248
+
String.lowercase_ascii (fst s.Init.Repr.name) =
249
+
String.lowercase_ascii sec
250
+
) sections in
251
+
match sec_opts with
252
+
| Some s ->
253
+
(match find_in_opts s.Init.Repr.options with
254
+
| Some x -> Some x
255
+
| None -> find_in_opts defaults)
256
+
| None -> find_in_opts defaults
257
+
in
258
+
match lookup_result with
259
+
| None ->
260
+
Error (Init.Error.make (Init.Error.Interpolation {
261
+
option = name; reason = "option not found" }))
262
+
| Some (_, iv) ->
263
+
(* Recursively interpolate the referenced value *)
264
+
match basic_interpolate ~section ~defaults ~sections iv.Init.Repr.raw (max_depth - 1) with
265
+
| Error e -> Error e
266
+
| Ok interpolated ->
267
+
Buffer.add_string buf interpolated;
268
+
scan (close_pos + 2)
269
+
end
270
+
else begin
271
+
Buffer.add_char buf value.[i];
272
+
scan (i + 1)
273
+
end
274
+
in
275
+
scan 0
276
+
277
+
let rec extended_interpolate ~section ~defaults ~sections value max_depth =
278
+
if max_depth <= 0 then
279
+
Error (Init.Error.make (Init.Error.Interpolation {
280
+
option = ""; reason = "recursion depth exceeded" }))
281
+
else
282
+
let buf = Buffer.create (String.length value) in
283
+
let len = String.length value in
284
+
let rec scan i =
285
+
if i >= len then Ok (Buffer.contents buf)
286
+
else if i + 1 < len && value.[i] = '$' && value.[i+1] = '$' then begin
287
+
Buffer.add_char buf '$';
288
+
scan (i + 2)
289
+
end
290
+
else if value.[i] = '$' && i + 1 < len && value.[i+1] = '{' then begin
291
+
(* Find closing } *)
292
+
let rec find_close j =
293
+
if j >= len then None
294
+
else if value.[j] = '}' then Some j
295
+
else find_close (j + 1)
296
+
in
297
+
match find_close (i + 2) with
298
+
| None ->
299
+
Buffer.add_char buf value.[i];
300
+
scan (i + 1)
301
+
| Some close_pos ->
302
+
let ref_str = String.sub value (i + 2) (close_pos - i - 2) in
303
+
(* Parse section:name or just name *)
304
+
let (ref_section, name) =
305
+
match String.index_opt ref_str ':' with
306
+
| None -> (section, String.lowercase_ascii ref_str)
307
+
| Some colon_pos ->
308
+
let sec = String.sub ref_str 0 colon_pos in
309
+
let n = String.sub ref_str (colon_pos + 1) (String.length ref_str - colon_pos - 1) in
310
+
(Some sec, String.lowercase_ascii n)
311
+
in
312
+
(* Look up value *)
313
+
let lookup_result =
314
+
let find_in_opts opts =
315
+
List.find_opt (fun ((n, _), _) ->
316
+
String.lowercase_ascii n = name) opts
317
+
in
318
+
match ref_section with
319
+
| None -> find_in_opts defaults
320
+
| Some sec ->
321
+
let lc_sec = String.lowercase_ascii sec in
322
+
if lc_sec = String.lowercase_ascii "default" then
323
+
find_in_opts defaults
324
+
else
325
+
let sec_opts = List.find_opt (fun s ->
326
+
String.lowercase_ascii (fst s.Init.Repr.name) = lc_sec
327
+
) sections in
328
+
match sec_opts with
329
+
| Some s ->
330
+
(match find_in_opts s.Init.Repr.options with
331
+
| Some x -> Some x
332
+
| None -> find_in_opts defaults)
333
+
| None -> find_in_opts defaults
334
+
in
335
+
match lookup_result with
336
+
| None ->
337
+
Error (Init.Error.make (Init.Error.Interpolation {
338
+
option = name; reason = "option not found" }))
339
+
| Some (_, iv) ->
340
+
(* Recursively interpolate *)
341
+
match extended_interpolate ~section:ref_section ~defaults ~sections iv.Init.Repr.raw (max_depth - 1) with
342
+
| Error e -> Error e
343
+
| Ok interpolated ->
344
+
Buffer.add_string buf interpolated;
345
+
scan (close_pos + 1)
346
+
end
347
+
else begin
348
+
Buffer.add_char buf value.[i];
349
+
scan (i + 1)
350
+
end
351
+
in
352
+
scan 0
353
+
354
+
let interpolate config ~section ~defaults ~sections value =
355
+
match config.interpolation with
356
+
| No_interpolation -> Ok value
357
+
| Basic_interpolation -> basic_interpolate ~section ~defaults ~sections value 10
358
+
| Extended_interpolation -> extended_interpolate ~section ~defaults ~sections value 10
359
+
360
+
(* ---- Option Finalization ---- *)
361
+
362
+
let finalize_current_option state =
363
+
match state.cur_option with
364
+
| None -> ()
365
+
| Some (name, name_meta) ->
366
+
let raw_value = String.concat "\n" (List.rev state.cur_value) in
367
+
let value = strip raw_value in
368
+
let iv = {
369
+
Init.Repr.raw = value;
370
+
interpolated = value; (* Will be interpolated later *)
371
+
meta = state.cur_value_meta;
372
+
} in
373
+
let opt = ((name, name_meta), iv) in
374
+
(match state.cur_section with
375
+
| None ->
376
+
(* DEFAULT section *)
377
+
state.defaults <- opt :: state.defaults
378
+
| Some sec ->
379
+
(* Add to current section *)
380
+
match state.sections with
381
+
| [] ->
382
+
let new_sec = {
383
+
Init.Repr.name = (sec, Init.Meta.none);
384
+
options = [opt];
385
+
meta = Init.Meta.none;
386
+
} in
387
+
state.sections <- [new_sec]
388
+
| sec_data :: rest when fst sec_data.name = sec ->
389
+
state.sections <- { sec_data with options = opt :: sec_data.options } :: rest
390
+
| _ ->
391
+
let new_sec = {
392
+
Init.Repr.name = (sec, Init.Meta.none);
393
+
options = [opt];
394
+
meta = Init.Meta.none;
395
+
} in
396
+
state.sections <- new_sec :: state.sections);
397
+
state.cur_option <- None;
398
+
state.cur_value <- [];
399
+
state.cur_indent <- 0
400
+
401
+
(* ---- Line Processing ---- *)
402
+
403
+
let process_line state line =
404
+
let line_start = state.byte_pos in
405
+
let line_start_line = (state.line_num, state.line_start_byte) in
406
+
state.byte_pos <- state.byte_pos + String.length line + 1; (* +1 for newline *)
407
+
state.line_num <- state.line_num + 1;
408
+
state.line_start_byte <- state.byte_pos;
409
+
410
+
(* Check for empty line *)
411
+
if is_empty_line line then begin
412
+
if state.cur_option <> None && state.config.empty_lines_in_values then
413
+
state.cur_value <- "" :: state.cur_value
414
+
else begin
415
+
finalize_current_option state;
416
+
state.pending_ws <- state.pending_ws ^ line ^ "\n"
417
+
end;
418
+
Ok ()
419
+
end
420
+
(* Check for comment *)
421
+
else if is_comment_line state.config line then begin
422
+
if state.cur_option <> None then
423
+
(* Comment within multiline - finalize. *)
424
+
finalize_current_option state;
425
+
state.pending_ws <- state.pending_ws ^ line ^ "\n";
426
+
Ok ()
427
+
end
428
+
(* Check for section header *)
429
+
else match parse_section_header line with
430
+
| Some sec_name ->
431
+
finalize_current_option state;
432
+
let lc_sec = sec_name in (* Keep original case for section names *)
433
+
if String.lowercase_ascii sec_name = String.lowercase_ascii state.config.default_section then begin
434
+
state.cur_section <- None;
435
+
Ok ()
436
+
end
437
+
else if state.config.strict then begin
438
+
(* Check for duplicate section *)
439
+
let exists = List.exists (fun s ->
440
+
String.lowercase_ascii (fst s.Init.Repr.name) = String.lowercase_ascii sec_name
441
+
) state.sections in
442
+
if exists then
443
+
Error (Init.Error.make
444
+
~meta:(current_meta state line_start line_start_line)
445
+
(Init.Error.Duplicate_section sec_name))
446
+
else begin
447
+
let sec_meta = current_meta state line_start line_start_line in
448
+
let sec_meta = Init.Meta.with_ws_before sec_meta state.pending_ws in
449
+
state.pending_ws <- "";
450
+
let new_sec = {
451
+
Init.Repr.name = (lc_sec, sec_meta);
452
+
options = [];
453
+
meta = sec_meta;
454
+
} in
455
+
state.sections <- new_sec :: state.sections;
456
+
state.cur_section <- Some lc_sec;
457
+
Ok ()
458
+
end
459
+
end
460
+
else begin
461
+
let sec_meta = current_meta state line_start line_start_line in
462
+
let sec_meta = Init.Meta.with_ws_before sec_meta state.pending_ws in
463
+
state.pending_ws <- "";
464
+
let new_sec = {
465
+
Init.Repr.name = (lc_sec, sec_meta);
466
+
options = [];
467
+
meta = sec_meta;
468
+
} in
469
+
state.sections <- new_sec :: state.sections;
470
+
state.cur_section <- Some lc_sec;
471
+
Ok ()
472
+
end
473
+
| None ->
474
+
(* Check for continuation of multiline value *)
475
+
let indent = count_indent line in
476
+
if state.cur_option <> None && indent > state.cur_indent then begin
477
+
(* Continuation line *)
478
+
let value_part = strip line in
479
+
state.cur_value <- value_part :: state.cur_value;
480
+
Ok ()
481
+
end
482
+
else begin
483
+
(* New option or continuation *)
484
+
finalize_current_option state;
485
+
(* Try to parse as option = value *)
486
+
match find_delimiter state.config line with
487
+
| Some (delim, pos) ->
488
+
let stripped = lstrip line in
489
+
let key = String.sub stripped 0 pos in
490
+
let key = String.lowercase_ascii (rstrip key) in (* Case-fold option names *)
491
+
let value_start = pos + String.length delim in
492
+
let rest = String.sub stripped value_start (String.length stripped - value_start) in
493
+
let value = strip_inline_comment state.config (lstrip rest) in
494
+
if state.cur_section = None && state.sections = [] && state.defaults = [] then
495
+
(* No section header yet - this is DEFAULT section *)
496
+
();
497
+
let opt_meta = current_meta state line_start line_start_line in
498
+
let opt_meta = Init.Meta.with_ws_before opt_meta state.pending_ws in
499
+
state.pending_ws <- "";
500
+
state.cur_option <- Some (key, opt_meta);
501
+
state.cur_value <- [value];
502
+
state.cur_indent <- count_indent line;
503
+
state.cur_value_meta <- opt_meta;
504
+
Ok ()
505
+
| None ->
506
+
if state.config.allow_no_value then begin
507
+
(* Valueless option *)
508
+
let key = String.lowercase_ascii (strip line) in
509
+
let opt_meta = current_meta state line_start line_start_line in
510
+
let opt_meta = Init.Meta.with_ws_before opt_meta state.pending_ws in
511
+
state.pending_ws <- "";
512
+
state.cur_option <- Some (key, opt_meta);
513
+
state.cur_value <- [];
514
+
state.cur_indent <- count_indent line;
515
+
state.cur_value_meta <- opt_meta;
516
+
Ok ()
517
+
end
518
+
else
519
+
Error (Init.Error.make
520
+
~meta:(current_meta state line_start line_start_line)
521
+
(Init.Error.Parse ("no delimiter found in line: " ^ line)))
522
+
end
523
+
524
+
(* ---- Interpolation Pass ---- *)
525
+
526
+
let perform_interpolation state =
527
+
let interpolate_value ~section iv =
528
+
match interpolate state.config ~section ~defaults:state.defaults ~sections:state.sections iv.Init.Repr.raw with
529
+
| Ok interpolated -> Ok { iv with Init.Repr.interpolated = interpolated }
530
+
| Error e -> Error e
531
+
in
532
+
let interpolate_opts ~section opts =
533
+
let rec loop acc = function
534
+
| [] -> Ok (List.rev acc)
535
+
| ((name, meta), iv) :: rest ->
536
+
match interpolate_value ~section iv with
537
+
| Ok iv' -> loop (((name, meta), iv') :: acc) rest
538
+
| Error e -> Error e
539
+
in
540
+
loop [] opts
541
+
in
542
+
(* Interpolate defaults *)
543
+
match interpolate_opts ~section:None state.defaults with
544
+
| Error e -> Error e
545
+
| Ok defaults' ->
546
+
state.defaults <- defaults';
547
+
(* Interpolate sections *)
548
+
let rec loop_sections acc = function
549
+
| [] -> Ok (List.rev acc)
550
+
| sec :: rest ->
551
+
match interpolate_opts ~section:(Some (fst sec.Init.Repr.name)) sec.options with
552
+
| Ok opts' -> loop_sections ({ sec with options = opts' } :: acc) rest
553
+
| Error e -> Error e
554
+
in
555
+
match loop_sections [] state.sections with
556
+
| Error e -> Error e
557
+
| Ok sections' ->
558
+
state.sections <- sections';
559
+
Ok ()
560
+
561
+
(* ---- Line splitting ---- *)
562
+
563
+
let split_lines s =
564
+
let len = String.length s in
565
+
if len = 0 then []
566
+
else
567
+
let rec split acc start i =
568
+
if i >= len then
569
+
let last = String.sub s start (len - start) in
570
+
List.rev (if String.length last > 0 then last :: acc else acc)
571
+
else match s.[i] with
572
+
| '\n' ->
573
+
let line = String.sub s start (i - start) in
574
+
split (line :: acc) (i + 1) (i + 1)
575
+
| '\r' ->
576
+
let line = String.sub s start (i - start) in
577
+
let next = if i + 1 < len && s.[i + 1] = '\n' then i + 2 else i + 1 in
578
+
split (line :: acc) next next
579
+
| _ -> split acc start (i + 1)
580
+
in
581
+
split [] 0 0
582
+
583
+
(* ---- Main Parse Functions ---- *)
584
+
585
+
let parse_string_internal ?(config=default_config) ?(locs=false) ?(layout=false) ?(file=Init.Textloc.file_none) s =
586
+
let _ = locs in (* TODO: Use locs to control location tracking *)
587
+
let _ = layout in (* TODO: Use layout to control whitespace preservation *)
588
+
let state = make_state config file in
589
+
let lines = split_lines s in
590
+
let rec process = function
591
+
| [] ->
592
+
finalize_current_option state;
593
+
Ok ()
594
+
| line :: rest ->
595
+
match process_line state line with
596
+
| Ok () -> process rest
597
+
| Error e -> Error e
598
+
in
599
+
match process lines with
600
+
| Error e -> Error e
601
+
| Ok () ->
602
+
(* Perform interpolation *)
603
+
match perform_interpolation state with
604
+
| Error e -> Error e
605
+
| Ok () ->
606
+
let doc = {
607
+
Init.Repr.defaults = List.rev state.defaults;
608
+
sections = List.rev_map (fun (sec : Init.Repr.ini_section) ->
609
+
{ sec with options = List.rev sec.options }
610
+
) state.sections;
611
+
meta = Init.Meta.none;
612
+
} in
613
+
Ok doc
614
+
615
+
let parse_reader ?(config=default_config) ?(locs=false) ?(layout=false) ?(file=Init.Textloc.file_none) reader =
616
+
let s = read_all_to_string reader in
617
+
parse_string_internal ~config ~locs ~layout ~file s
618
+
619
+
let parse_string ?(config=default_config) ?(locs=false) ?(layout=false) ?(file=Init.Textloc.file_none) s =
620
+
parse_string_internal ~config ~locs ~layout ~file s
621
+
622
+
(* ---- Decoding ---- *)
623
+
624
+
let decode' ?(config=default_config) ?(locs=false) ?(layout=false) ?(file=Init.Textloc.file_none) codec reader =
625
+
match parse_reader ~config ~locs ~layout ~file reader with
626
+
| Error e -> Error e
627
+
| Ok doc ->
628
+
match Init.document_state codec with
629
+
| Some doc_state -> doc_state.decode doc
630
+
| None ->
631
+
(* Maybe it's a section codec - try to decode from first/only section *)
632
+
match Init.section_state codec with
633
+
| Some sec_state ->
634
+
(match doc.sections with
635
+
| [sec] -> sec_state.decode sec
636
+
| [] -> Error (Init.Error.make (Init.Error.Codec "no sections in document"))
637
+
| _ -> Error (Init.Error.make (Init.Error.Codec "multiple sections; expected single section codec")))
638
+
| None ->
639
+
Error (Init.Error.make (Init.Error.Codec "codec is neither document nor section type"))
640
+
641
+
let decode ?config ?locs ?layout ?file codec reader =
642
+
match decode' ?config ?locs ?layout ?file codec reader with
643
+
| Ok v -> Ok v
644
+
| Error e -> Error (Init.Error.to_string e)
645
+
646
+
let decode_string' ?(config=default_config) ?(locs=false) ?(layout=false) ?(file=Init.Textloc.file_none) codec s =
647
+
match parse_string ~config ~locs ~layout ~file s with
648
+
| Error e -> Error e
649
+
| Ok doc ->
650
+
match Init.document_state codec with
651
+
| Some doc_state -> doc_state.decode doc
652
+
| None ->
653
+
match Init.section_state codec with
654
+
| Some sec_state ->
655
+
(match doc.sections with
656
+
| [sec] -> sec_state.decode sec
657
+
| [] -> Error (Init.Error.make (Init.Error.Codec "no sections in document"))
658
+
| _ -> Error (Init.Error.make (Init.Error.Codec "multiple sections; expected single section codec")))
659
+
| None ->
660
+
Error (Init.Error.make (Init.Error.Codec "codec is neither document nor section type"))
661
+
662
+
let decode_string ?config ?locs ?layout ?file codec s =
663
+
match decode_string' ?config ?locs ?layout ?file codec s with
664
+
| Ok v -> Ok v
665
+
| Error e -> Error (Init.Error.to_string e)
666
+
667
+
(* ---- Encoding ---- *)
668
+
669
+
let encode_to_buffer buf codec value =
670
+
match Init.document_state codec with
671
+
| Some doc_state ->
672
+
let doc = doc_state.encode value in
673
+
(* Encode defaults *)
674
+
if doc.defaults <> [] then begin
675
+
Buffer.add_string buf "[DEFAULT]\n";
676
+
List.iter (fun ((name, _), iv) ->
677
+
Buffer.add_string buf name;
678
+
Buffer.add_string buf " = ";
679
+
Buffer.add_string buf iv.Init.Repr.raw;
680
+
Buffer.add_char buf '\n'
681
+
) doc.defaults;
682
+
Buffer.add_char buf '\n'
683
+
end;
684
+
(* Encode sections *)
685
+
List.iter (fun (sec : Init.Repr.ini_section) ->
686
+
Buffer.add_char buf '[';
687
+
Buffer.add_string buf (fst sec.name);
688
+
Buffer.add_string buf "]\n";
689
+
List.iter (fun ((name, _), iv) ->
690
+
Buffer.add_string buf name;
691
+
Buffer.add_string buf " = ";
692
+
Buffer.add_string buf iv.Init.Repr.raw;
693
+
Buffer.add_char buf '\n'
694
+
) sec.options;
695
+
Buffer.add_char buf '\n'
696
+
) doc.sections;
697
+
Ok ()
698
+
| None ->
699
+
match Init.section_state codec with
700
+
| Some sec_state ->
701
+
let sec = sec_state.encode value in
702
+
Buffer.add_char buf '[';
703
+
Buffer.add_string buf (fst sec.name);
704
+
Buffer.add_string buf "]\n";
705
+
List.iter (fun ((name, _), iv) ->
706
+
Buffer.add_string buf name;
707
+
Buffer.add_string buf " = ";
708
+
Buffer.add_string buf iv.Init.Repr.raw;
709
+
Buffer.add_char buf '\n'
710
+
) sec.options;
711
+
Ok ()
712
+
| None ->
713
+
Error (Init.Error.make (Init.Error.Codec "codec is neither document nor section type"))
714
+
715
+
let encode' ?buf:_ codec value ~eod writer =
716
+
let buffer = Buffer.create 1024 in
717
+
match encode_to_buffer buffer codec value with
718
+
| Error e -> Error e
719
+
| Ok () ->
720
+
let s = Buffer.contents buffer in
721
+
Bytes.Writer.write_string writer s;
722
+
if eod then Bytes.Writer.write_eod writer;
723
+
Ok ()
724
+
725
+
let encode ?buf codec value ~eod writer =
726
+
match encode' ?buf codec value ~eod writer with
727
+
| Ok () -> Ok ()
728
+
| Error e -> Error (Init.Error.to_string e)
729
+
730
+
let encode_string' ?buf:_ codec value =
731
+
let buffer = Buffer.create 1024 in
732
+
match encode_to_buffer buffer codec value with
733
+
| Error e -> Error e
734
+
| Ok () -> Ok (Buffer.contents buffer)
735
+
736
+
let encode_string ?buf codec value =
737
+
match encode_string' ?buf codec value with
738
+
| Ok s -> Ok s
739
+
| Error e -> Error (Init.Error.to_string e)
+121
src/bytesrw/init_bytesrw.mli
+121
src/bytesrw/init_bytesrw.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** INI parser and encoder using bytesrw.
7
+
8
+
Implements Python configparser semantics including:
9
+
- Multiline values via indentation
10
+
- Basic interpolation: [%(name)s]
11
+
- Extended interpolation: [$\{section:name\}]
12
+
- DEFAULT section inheritance
13
+
- Case-insensitive option lookup
14
+
15
+
See notes about {{!layout}layout preservation}. *)
16
+
17
+
open Bytesrw
18
+
19
+
(** {1:config Configuration} *)
20
+
21
+
type interpolation =
22
+
| No_interpolation (** RawConfigParser behavior. *)
23
+
| Basic_interpolation (** [%(name)s] syntax. *)
24
+
| Extended_interpolation (** [$\{section:name\}] syntax. *)
25
+
(** The type for interpolation modes. *)
26
+
27
+
type config = {
28
+
delimiters : string list;
29
+
(** Key-value delimiters. Default: [["="; ":"]]. *)
30
+
31
+
comment_prefixes : string list;
32
+
(** Full-line comment prefixes. Default: [["#"; ";"]]. *)
33
+
34
+
inline_comment_prefixes : string list;
35
+
(** Inline comment prefixes (require preceding whitespace).
36
+
Default: [[]] (disabled). *)
37
+
38
+
default_section : string;
39
+
(** Name of the default section. Default: ["DEFAULT"]. *)
40
+
41
+
interpolation : interpolation;
42
+
(** Interpolation mode. Default: {!Basic_interpolation}. *)
43
+
44
+
allow_no_value : bool;
45
+
(** Allow options without values. Default: [false]. *)
46
+
47
+
strict : bool;
48
+
(** Error on duplicate sections/options. Default: [true]. *)
49
+
50
+
empty_lines_in_values : bool;
51
+
(** Allow empty lines in multiline values. Default: [true]. *)
52
+
}
53
+
(** The type for parser configuration. *)
54
+
55
+
val default_config : config
56
+
(** [default_config] is the default configuration matching Python's
57
+
[configparser.ConfigParser]. *)
58
+
59
+
val raw_config : config
60
+
(** [raw_config] is configuration with no interpolation, matching
61
+
Python's [configparser.RawConfigParser]. *)
62
+
63
+
(** {1:decode Decode} *)
64
+
65
+
val decode :
66
+
?config:config -> ?locs:bool -> ?layout:bool -> ?file:Init.Textloc.fpath ->
67
+
'a Init.t -> Bytes.Reader.t -> ('a, string) result
68
+
(** [decode codec r] decodes a value from [r] according to [codec].
69
+
{ul
70
+
{- [config] is the parser configuration. Defaults to {!default_config}.}
71
+
{- If [locs] is [true] locations are preserved in metadata.
72
+
Defaults to [false].}
73
+
{- If [layout] is [true] whitespace is preserved in metadata.
74
+
Defaults to [false].}
75
+
{- [file] is the file path for error messages.
76
+
Defaults to {!Init.Textloc.file_none}.}} *)
77
+
78
+
val decode' :
79
+
?config:config -> ?locs:bool -> ?layout:bool -> ?file:Init.Textloc.fpath ->
80
+
'a Init.t -> Bytes.Reader.t -> ('a, Init.Error.t) result
81
+
(** [decode'] is like {!val-decode} but preserves the error structure. *)
82
+
83
+
val decode_string :
84
+
?config:config -> ?locs:bool -> ?layout:bool -> ?file:Init.Textloc.fpath ->
85
+
'a Init.t -> string -> ('a, string) result
86
+
(** [decode_string] is like {!val-decode} but decodes from a string. *)
87
+
88
+
val decode_string' :
89
+
?config:config -> ?locs:bool -> ?layout:bool -> ?file:Init.Textloc.fpath ->
90
+
'a Init.t -> string -> ('a, Init.Error.t) result
91
+
(** [decode_string'] is like {!val-decode'} but decodes from a string. *)
92
+
93
+
(** {1:encode Encode} *)
94
+
95
+
val encode :
96
+
?buf:Bytes.t -> 'a Init.t -> 'a -> eod:bool -> Bytes.Writer.t ->
97
+
(unit, string) result
98
+
(** [encode codec v w] encodes [v] according to [codec] on [w].
99
+
{ul
100
+
{- [buf] is an optional buffer for writing.}
101
+
{- [eod] indicates whether to write end-of-data.}} *)
102
+
103
+
val encode' :
104
+
?buf:Bytes.t -> 'a Init.t -> 'a -> eod:bool -> Bytes.Writer.t ->
105
+
(unit, Init.Error.t) result
106
+
(** [encode'] is like {!val-encode} but preserves the error structure. *)
107
+
108
+
val encode_string :
109
+
?buf:Bytes.t -> 'a Init.t -> 'a -> (string, string) result
110
+
(** [encode_string] is like {!val-encode} but writes to a string. *)
111
+
112
+
val encode_string' :
113
+
?buf:Bytes.t -> 'a Init.t -> 'a -> (string, Init.Error.t) result
114
+
(** [encode_string'] is like {!val-encode'} but writes to a string. *)
115
+
116
+
(** {1:layout Layout preservation}
117
+
118
+
When [layout:true] is passed to decode functions, whitespace and
119
+
comments are preserved in {!Init.Meta.t} values. This enables
120
+
layout-preserving round-trips where the original formatting is
121
+
maintained as much as possible. *)
+4
src/eio/dune
+4
src/eio/dune
+65
src/eio/init_eio.ml
+65
src/eio/init_eio.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Eio integration for Init INI parser.
7
+
8
+
Provides file system operations using Eio paths. *)
9
+
10
+
(* ---- Eio Exception Integration ---- *)
11
+
12
+
type Eio.Exn.err += E of Init.Error.t
13
+
14
+
let err e = Eio.Exn.create (E e)
15
+
16
+
let () = Eio.Exn.register_pp (fun fmt -> function
17
+
| E e -> Format.fprintf fmt "%a" Init.Error.pp e; true
18
+
| _ -> false)
19
+
20
+
(* ---- Path Operations ---- *)
21
+
22
+
let decode_path ?(config=Init_bytesrw.default_config) ?(locs=false) ?(layout=false)
23
+
codec path =
24
+
let file = Eio.Path.native_exn path in
25
+
Eio.Path.with_open_in path @@ fun flow ->
26
+
let reader = Bytesrw_eio.bytes_reader_of_flow flow in
27
+
Init_bytesrw.decode' ~config ~locs ~layout ~file codec reader
28
+
29
+
let decode_path_exn ?config ?locs ?layout codec path =
30
+
match decode_path ?config ?locs ?layout codec path with
31
+
| Ok v -> v
32
+
| Error e -> raise (err e)
33
+
34
+
let encode_path ?buf codec value path =
35
+
Eio.Path.with_open_out ~create:(`Or_truncate 0o644) path @@ fun flow ->
36
+
let writer = Bytesrw_eio.bytes_writer_of_flow flow in
37
+
match Init_bytesrw.encode' ?buf codec value ~eod:true writer with
38
+
| Ok () -> Ok ()
39
+
| Error e -> Error e
40
+
41
+
let encode_path_exn ?buf codec value path =
42
+
match encode_path ?buf codec value path with
43
+
| Ok () -> ()
44
+
| Error e -> raise (err e)
45
+
46
+
(* ---- Flow Operations ---- *)
47
+
48
+
let decode_flow ?(config=Init_bytesrw.default_config) ?(locs=false) ?(layout=false)
49
+
?file codec flow =
50
+
let reader = Bytesrw_eio.bytes_reader_of_flow flow in
51
+
Init_bytesrw.decode' ~config ~locs ~layout ?file codec reader
52
+
53
+
let decode_flow_exn ?config ?locs ?layout ?file codec flow =
54
+
match decode_flow ?config ?locs ?layout ?file codec flow with
55
+
| Ok v -> v
56
+
| Error e -> raise (err e)
57
+
58
+
let encode_flow ?buf codec value ~eod flow =
59
+
let writer = Bytesrw_eio.bytes_writer_of_flow flow in
60
+
Init_bytesrw.encode' ?buf codec value ~eod writer
61
+
62
+
let encode_flow_exn ?buf codec value ~eod flow =
63
+
match encode_flow ?buf codec value ~eod flow with
64
+
| Ok () -> ()
65
+
| Error e -> raise (err e)
+59
src/eio/init_eio.mli
+59
src/eio/init_eio.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Eio integration for Init INI parser.
7
+
8
+
Provides file system operations using Eio paths and flows. *)
9
+
10
+
(** {1:errors Error handling} *)
11
+
12
+
type Eio.Exn.err += E of Init.Error.t
13
+
(** Eio exception for Init errors. *)
14
+
15
+
val err : Init.Error.t -> exn
16
+
(** [err e] creates an Eio exception from [e]. *)
17
+
18
+
(** {1:paths Path operations} *)
19
+
20
+
val decode_path :
21
+
?config:Init_bytesrw.config -> ?locs:bool -> ?layout:bool ->
22
+
'a Init.t -> _ Eio.Path.t -> ('a, Init.Error.t) result
23
+
(** [decode_path codec path] reads and decodes the file at [path]. *)
24
+
25
+
val decode_path_exn :
26
+
?config:Init_bytesrw.config -> ?locs:bool -> ?layout:bool ->
27
+
'a Init.t -> _ Eio.Path.t -> 'a
28
+
(** [decode_path_exn] is like {!decode_path} but raises on error. *)
29
+
30
+
val encode_path :
31
+
?buf:bytes -> 'a Init.t -> 'a -> _ Eio.Path.t ->
32
+
(unit, Init.Error.t) result
33
+
(** [encode_path codec v path] encodes [v] and writes to [path]. *)
34
+
35
+
val encode_path_exn :
36
+
?buf:bytes -> 'a Init.t -> 'a -> _ Eio.Path.t -> unit
37
+
(** [encode_path_exn] is like {!encode_path} but raises on error. *)
38
+
39
+
(** {1:flows Flow operations} *)
40
+
41
+
val decode_flow :
42
+
?config:Init_bytesrw.config -> ?locs:bool -> ?layout:bool ->
43
+
?file:Init.Textloc.fpath -> 'a Init.t -> _ Eio.Flow.source ->
44
+
('a, Init.Error.t) result
45
+
(** [decode_flow codec flow] decodes from [flow]. *)
46
+
47
+
val decode_flow_exn :
48
+
?config:Init_bytesrw.config -> ?locs:bool -> ?layout:bool ->
49
+
?file:Init.Textloc.fpath -> 'a Init.t -> _ Eio.Flow.source -> 'a
50
+
(** [decode_flow_exn] is like {!decode_flow} but raises on error. *)
51
+
52
+
val encode_flow :
53
+
?buf:bytes -> 'a Init.t -> 'a -> eod:bool -> _ Eio.Flow.sink ->
54
+
(unit, Init.Error.t) result
55
+
(** [encode_flow codec v flow] encodes [v] to [flow]. *)
56
+
57
+
val encode_flow_exn :
58
+
?buf:bytes -> 'a Init.t -> 'a -> eod:bool -> _ Eio.Flow.sink -> unit
59
+
(** [encode_flow_exn] is like {!encode_flow} but raises on error. *)
+875
src/init.ml
+875
src/init.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Declarative INI data manipulation for OCaml.
7
+
8
+
Init provides bidirectional codecs for INI files following Python's
9
+
configparser semantics. *)
10
+
11
+
type 'a fmt = Format.formatter -> 'a -> unit
12
+
13
+
(* ---- Text Locations ---- *)
14
+
15
+
module Textloc = struct
16
+
type fpath = string
17
+
let file_none = "-"
18
+
19
+
type byte_pos = int
20
+
let byte_pos_none = -1
21
+
22
+
type line_num = int
23
+
let line_num_none = -1
24
+
25
+
type line_pos = line_num * byte_pos
26
+
let line_pos_first = (1, 0)
27
+
let line_pos_none = (line_num_none, byte_pos_none)
28
+
29
+
type t = {
30
+
file : fpath;
31
+
first_byte : byte_pos;
32
+
last_byte : byte_pos;
33
+
first_line : line_pos;
34
+
last_line : line_pos;
35
+
}
36
+
37
+
let none = {
38
+
file = file_none;
39
+
first_byte = byte_pos_none;
40
+
last_byte = byte_pos_none;
41
+
first_line = line_pos_none;
42
+
last_line = line_pos_none;
43
+
}
44
+
45
+
let make ~file ~first_byte ~last_byte ~first_line ~last_line =
46
+
{ file; first_byte; last_byte; first_line; last_line }
47
+
48
+
let file t = t.file
49
+
let set_file t file = { t with file }
50
+
let first_byte t = t.first_byte
51
+
let last_byte t = t.last_byte
52
+
let first_line t = t.first_line
53
+
let last_line t = t.last_line
54
+
55
+
let is_none t = t.first_byte < 0
56
+
let is_empty t = t.first_byte > t.last_byte
57
+
58
+
let equal t0 t1 =
59
+
String.equal t0.file t1.file &&
60
+
t0.first_byte = t1.first_byte &&
61
+
t0.last_byte = t1.last_byte
62
+
63
+
let compare t0 t1 =
64
+
let c = String.compare t0.file t1.file in
65
+
if c <> 0 then c else
66
+
let c = Int.compare t0.first_byte t1.first_byte in
67
+
if c <> 0 then c else
68
+
Int.compare t0.last_byte t1.last_byte
69
+
70
+
let set_first t ~first_byte ~first_line =
71
+
{ t with first_byte; first_line }
72
+
73
+
let set_last t ~last_byte ~last_line =
74
+
{ t with last_byte; last_line }
75
+
76
+
let to_first t =
77
+
{ t with last_byte = t.first_byte; last_line = t.first_line }
78
+
79
+
let to_last t =
80
+
{ t with first_byte = t.last_byte; first_line = t.last_line }
81
+
82
+
let before t =
83
+
{ t with last_byte = t.first_byte - 1; last_line = t.first_line }
84
+
85
+
let after t =
86
+
{ t with first_byte = t.last_byte + 1; first_line = t.last_line }
87
+
88
+
let span t0 t1 =
89
+
let first_byte, first_line, last_byte, last_line, file =
90
+
if t0.first_byte <= t1.first_byte then
91
+
if t0.last_byte >= t1.last_byte then
92
+
t0.first_byte, t0.first_line, t0.last_byte, t0.last_line, t0.file
93
+
else
94
+
t0.first_byte, t0.first_line, t1.last_byte, t1.last_line, t1.file
95
+
else
96
+
if t1.last_byte >= t0.last_byte then
97
+
t1.first_byte, t1.first_line, t1.last_byte, t1.last_line, t1.file
98
+
else
99
+
t1.first_byte, t1.first_line, t0.last_byte, t0.last_line, t0.file
100
+
in
101
+
{ file; first_byte; last_byte; first_line; last_line }
102
+
103
+
let reloc ~first ~last =
104
+
{ file = last.file;
105
+
first_byte = first.first_byte;
106
+
first_line = first.first_line;
107
+
last_byte = last.last_byte;
108
+
last_line = last.last_line }
109
+
110
+
let pp_ocaml ppf t =
111
+
let l, c = t.first_line in
112
+
let el, ec = t.last_line in
113
+
if is_none t then Format.fprintf ppf "%s" t.file
114
+
else if is_empty t then
115
+
Format.fprintf ppf "%s:%d:%d" t.file l (t.first_byte - c)
116
+
else if l = el then
117
+
Format.fprintf ppf "%s:%d:%d-%d" t.file l (t.first_byte - c) (t.last_byte - ec)
118
+
else
119
+
Format.fprintf ppf "%s:%d:%d-%d:%d" t.file l (t.first_byte - c) el (t.last_byte - ec)
120
+
121
+
let pp_gnu ppf t =
122
+
let l, c = t.first_line in
123
+
if is_none t then Format.fprintf ppf "%s" t.file
124
+
else Format.fprintf ppf "%s:%d.%d" t.file l (t.first_byte - c + 1)
125
+
126
+
let pp = pp_ocaml
127
+
128
+
let pp_dump ppf t =
129
+
Format.fprintf ppf "@[<h>{file=%S;@ first_byte=%d;@ last_byte=%d;@ \
130
+
first_line=(%d,%d);@ last_line=(%d,%d)}@]"
131
+
t.file t.first_byte t.last_byte
132
+
(fst t.first_line) (snd t.first_line)
133
+
(fst t.last_line) (snd t.last_line)
134
+
end
135
+
136
+
(* ---- Metadata ---- *)
137
+
138
+
module Meta = struct
139
+
type t = {
140
+
textloc : Textloc.t;
141
+
ws_before : string;
142
+
ws_after : string;
143
+
comment : string option; (* Associated comment *)
144
+
}
145
+
146
+
let none = {
147
+
textloc = Textloc.none;
148
+
ws_before = "";
149
+
ws_after = "";
150
+
comment = None;
151
+
}
152
+
153
+
let make ?(ws_before = "") ?(ws_after = "") ?comment textloc =
154
+
{ textloc; ws_before; ws_after; comment }
155
+
156
+
let is_none t = Textloc.is_none t.textloc
157
+
let textloc t = t.textloc
158
+
let ws_before t = t.ws_before
159
+
let ws_after t = t.ws_after
160
+
let comment t = t.comment
161
+
162
+
let with_textloc t textloc = { t with textloc }
163
+
let with_ws_before t ws_before = { t with ws_before }
164
+
let with_ws_after t ws_after = { t with ws_after }
165
+
let with_comment t comment = { t with comment }
166
+
167
+
let clear_ws t = { t with ws_before = ""; ws_after = "" }
168
+
let clear_textloc t = { t with textloc = Textloc.none }
169
+
170
+
let copy_ws src ~dst =
171
+
{ dst with ws_before = src.ws_before; ws_after = src.ws_after }
172
+
end
173
+
174
+
type 'a node = 'a * Meta.t
175
+
176
+
(* ---- Paths ---- *)
177
+
178
+
module Path = struct
179
+
type index =
180
+
| Section of string node
181
+
| Option of string node
182
+
183
+
let pp_index ppf = function
184
+
| Section (s, _) -> Format.fprintf ppf "[%s]" s
185
+
| Option (s, _) -> Format.fprintf ppf "%s" s
186
+
187
+
type t = index list (* Reversed *)
188
+
189
+
let root = []
190
+
let is_root = function [] -> true | _ -> false
191
+
192
+
let section ?(meta = Meta.none) name path = Section (name, meta) :: path
193
+
let option ?(meta = Meta.none) name path = Option (name, meta) :: path
194
+
195
+
let rev_indices t = t
196
+
197
+
let pp ppf t =
198
+
let rec loop = function
199
+
| [] -> ()
200
+
| [i] -> pp_index ppf i
201
+
| i :: rest -> loop rest; Format.fprintf ppf "/"; pp_index ppf i
202
+
in
203
+
loop (List.rev t)
204
+
end
205
+
206
+
(* ---- Errors ---- *)
207
+
208
+
module Error = struct
209
+
type kind =
210
+
| Parse of string
211
+
| Codec of string
212
+
| Missing_section of string
213
+
| Missing_option of { section : string; option : string }
214
+
| Duplicate_section of string
215
+
| Duplicate_option of { section : string; option : string }
216
+
| Type_mismatch of { expected : string; got : string }
217
+
| Interpolation of { option : string; reason : string }
218
+
| Unknown_option of string
219
+
| Unknown_section of string
220
+
221
+
type t = {
222
+
kind : kind;
223
+
meta : Meta.t;
224
+
path : Path.t;
225
+
}
226
+
227
+
let make ?(meta = Meta.none) ?(path = Path.root) kind =
228
+
{ kind; meta; path }
229
+
230
+
let kind e = e.kind
231
+
let meta e = e.meta
232
+
let path e = e.path
233
+
234
+
exception Error of t
235
+
236
+
let raise ?meta ?path kind = raise (Error (make ?meta ?path kind))
237
+
238
+
let kind_to_string = function
239
+
| Parse msg -> Printf.sprintf "parse error: %s" msg
240
+
| Codec msg -> Printf.sprintf "codec error: %s" msg
241
+
| Missing_section name -> Printf.sprintf "missing section: [%s]" name
242
+
| Missing_option { section; option } ->
243
+
Printf.sprintf "missing option '%s' in section [%s]" option section
244
+
| Duplicate_section name -> Printf.sprintf "duplicate section: [%s]" name
245
+
| Duplicate_option { section; option } ->
246
+
Printf.sprintf "duplicate option '%s' in section [%s]" option section
247
+
| Type_mismatch { expected; got } ->
248
+
Printf.sprintf "type mismatch: expected %s, got %s" expected got
249
+
| Interpolation { option; reason } ->
250
+
Printf.sprintf "interpolation error in '%s': %s" option reason
251
+
| Unknown_option name -> Printf.sprintf "unknown option: %s" name
252
+
| Unknown_section name -> Printf.sprintf "unknown section: [%s]" name
253
+
254
+
let to_string e =
255
+
let loc = if Meta.is_none e.meta then "" else
256
+
Format.asprintf "%a: " Textloc.pp (Meta.textloc e.meta)
257
+
in
258
+
let path = if Path.is_root e.path then "" else
259
+
Format.asprintf " at %a" Path.pp e.path
260
+
in
261
+
Printf.sprintf "%s%s%s" loc (kind_to_string e.kind) path
262
+
263
+
let pp ppf e = Format.pp_print_string ppf (to_string e)
264
+
end
265
+
266
+
(* ---- Codec Types ---- *)
267
+
268
+
(* Internal representation for codec implementations *)
269
+
module Repr = struct
270
+
(* A decoded INI value with metadata *)
271
+
type ini_value = {
272
+
raw : string; (* Raw string value *)
273
+
interpolated : string; (* After interpolation *)
274
+
meta : Meta.t;
275
+
}
276
+
277
+
(* A section's options *)
278
+
type ini_section = {
279
+
name : string node;
280
+
options : (string node * ini_value) list;
281
+
meta : Meta.t; (* Section header metadata *)
282
+
}
283
+
284
+
(* A full INI document *)
285
+
type ini_doc = {
286
+
defaults : (string node * ini_value) list;
287
+
sections : ini_section list;
288
+
meta : Meta.t; (* Document metadata *)
289
+
}
290
+
291
+
(* Codec error during decode/encode *)
292
+
type 'a codec_result = ('a, Error.t) result
293
+
294
+
(* Section decoder state *)
295
+
type 'dec section_state = {
296
+
decode : ini_section -> 'dec codec_result;
297
+
encode : 'dec -> ini_section;
298
+
known_options : string list;
299
+
unknown_handler : [ `Skip | `Error | `Keep ];
300
+
}
301
+
302
+
(* Document decoder state *)
303
+
type 'dec document_state = {
304
+
decode : ini_doc -> 'dec codec_result;
305
+
encode : 'dec -> ini_doc;
306
+
known_sections : string list;
307
+
unknown_handler : [ `Skip | `Error ];
308
+
}
309
+
end
310
+
311
+
(* The abstract codec type *)
312
+
type 'a t = {
313
+
kind : string;
314
+
doc : string;
315
+
(* Value-level decode/encode (for individual option values) *)
316
+
dec : Repr.ini_value -> ('a, Error.t) result;
317
+
enc : 'a -> Meta.t -> Repr.ini_value;
318
+
(* Section-level decode/encode (for Section.finish) *)
319
+
section : 'a Repr.section_state option;
320
+
(* Document-level decode/encode (for Document.finish) *)
321
+
document : 'a Repr.document_state option;
322
+
}
323
+
324
+
let kind c = c.kind
325
+
let doc c = c.doc
326
+
327
+
let with_doc ?kind:k ?doc:d c =
328
+
{ c with
329
+
kind = Option.value ~default:c.kind k;
330
+
doc = Option.value ~default:c.doc d }
331
+
332
+
let section_state c = c.section
333
+
let document_state c = c.document
334
+
335
+
(* ---- Base Codecs ---- *)
336
+
337
+
let make_value_codec ~kind ~doc ~dec ~enc = {
338
+
kind; doc; dec; enc;
339
+
section = None;
340
+
document = None;
341
+
}
342
+
343
+
let string = make_value_codec
344
+
~kind:"string"
345
+
~doc:""
346
+
~dec:(fun v -> Ok v.Repr.interpolated)
347
+
~enc:(fun s meta -> { Repr.raw = s; interpolated = s; meta })
348
+
349
+
let int = make_value_codec
350
+
~kind:"integer"
351
+
~doc:""
352
+
~dec:(fun v ->
353
+
match int_of_string_opt v.Repr.interpolated with
354
+
| Some i -> Ok i
355
+
| None -> Error (Error.make (Type_mismatch {
356
+
expected = "integer"; got = v.interpolated })))
357
+
~enc:(fun i meta ->
358
+
let s = Int.to_string i in
359
+
{ Repr.raw = s; interpolated = s; meta })
360
+
361
+
let int32 = make_value_codec
362
+
~kind:"int32"
363
+
~doc:""
364
+
~dec:(fun v ->
365
+
match Int32.of_string_opt v.Repr.interpolated with
366
+
| Some i -> Ok i
367
+
| None -> Error (Error.make (Type_mismatch {
368
+
expected = "int32"; got = v.interpolated })))
369
+
~enc:(fun i meta ->
370
+
let s = Int32.to_string i in
371
+
{ Repr.raw = s; interpolated = s; meta })
372
+
373
+
let int64 = make_value_codec
374
+
~kind:"int64"
375
+
~doc:""
376
+
~dec:(fun v ->
377
+
match Int64.of_string_opt v.Repr.interpolated with
378
+
| Some i -> Ok i
379
+
| None -> Error (Error.make (Type_mismatch {
380
+
expected = "int64"; got = v.interpolated })))
381
+
~enc:(fun i meta ->
382
+
let s = Int64.to_string i in
383
+
{ Repr.raw = s; interpolated = s; meta })
384
+
385
+
let float = make_value_codec
386
+
~kind:"float"
387
+
~doc:""
388
+
~dec:(fun v ->
389
+
match float_of_string_opt v.Repr.interpolated with
390
+
| Some f -> Ok f
391
+
| None -> Error (Error.make (Type_mismatch {
392
+
expected = "float"; got = v.interpolated })))
393
+
~enc:(fun f meta ->
394
+
let s = Float.to_string f in
395
+
{ Repr.raw = s; interpolated = s; meta })
396
+
397
+
(* Python configparser-compatible boolean parsing *)
398
+
let parse_bool s =
399
+
match String.lowercase_ascii s with
400
+
| "1" | "yes" | "true" | "on" -> Some true
401
+
| "0" | "no" | "false" | "off" -> Some false
402
+
| _ -> None
403
+
404
+
let bool = make_value_codec
405
+
~kind:"boolean"
406
+
~doc:"Accepts: 1/yes/true/on (true), 0/no/false/off (false)"
407
+
~dec:(fun v ->
408
+
match parse_bool v.Repr.interpolated with
409
+
| Some b -> Ok b
410
+
| None -> Error (Error.make (Type_mismatch {
411
+
expected = "boolean (yes/no/true/false/on/off/1/0)";
412
+
got = v.interpolated })))
413
+
~enc:(fun b meta ->
414
+
let s = if b then "true" else "false" in
415
+
{ Repr.raw = s; interpolated = s; meta })
416
+
417
+
let bool_01 = make_value_codec
418
+
~kind:"boolean (0/1)"
419
+
~doc:""
420
+
~dec:(fun v ->
421
+
match v.Repr.interpolated with
422
+
| "1" -> Ok true
423
+
| "0" -> Ok false
424
+
| s -> Error (Error.make (Type_mismatch { expected = "0 or 1"; got = s })))
425
+
~enc:(fun b meta ->
426
+
let s = if b then "1" else "0" in
427
+
{ Repr.raw = s; interpolated = s; meta })
428
+
429
+
let bool_yesno = make_value_codec
430
+
~kind:"boolean (yes/no)"
431
+
~doc:""
432
+
~dec:(fun v ->
433
+
match String.lowercase_ascii v.Repr.interpolated with
434
+
| "yes" -> Ok true
435
+
| "no" -> Ok false
436
+
| s -> Error (Error.make (Type_mismatch { expected = "yes or no"; got = s })))
437
+
~enc:(fun b meta ->
438
+
let s = if b then "yes" else "no" in
439
+
{ Repr.raw = s; interpolated = s; meta })
440
+
441
+
let bool_truefalse = make_value_codec
442
+
~kind:"boolean (true/false)"
443
+
~doc:""
444
+
~dec:(fun v ->
445
+
match String.lowercase_ascii v.Repr.interpolated with
446
+
| "true" -> Ok true
447
+
| "false" -> Ok false
448
+
| s -> Error (Error.make (Type_mismatch {
449
+
expected = "true or false"; got = s })))
450
+
~enc:(fun b meta ->
451
+
let s = if b then "true" else "false" in
452
+
{ Repr.raw = s; interpolated = s; meta })
453
+
454
+
let bool_onoff = make_value_codec
455
+
~kind:"boolean (on/off)"
456
+
~doc:""
457
+
~dec:(fun v ->
458
+
match String.lowercase_ascii v.Repr.interpolated with
459
+
| "on" -> Ok true
460
+
| "off" -> Ok false
461
+
| s -> Error (Error.make (Type_mismatch { expected = "on or off"; got = s })))
462
+
~enc:(fun b meta ->
463
+
let s = if b then "on" else "off" in
464
+
{ Repr.raw = s; interpolated = s; meta })
465
+
466
+
(* ---- Combinators ---- *)
467
+
468
+
let map ?kind:k ?doc:d ~dec ~enc c =
469
+
let kind = Option.value ~default:c.kind k in
470
+
let doc = Option.value ~default:c.doc d in
471
+
{ kind; doc;
472
+
dec = (fun v -> Result.map dec (c.dec v));
473
+
enc = (fun x meta -> c.enc (enc x) meta);
474
+
section = None;
475
+
document = None;
476
+
}
477
+
478
+
let enum ?cmp ?kind ?doc assoc =
479
+
let cmp = Option.value ~default:Stdlib.compare cmp in
480
+
let kind = Option.value ~default:"enum" kind in
481
+
let doc = Option.value ~default:"" doc in
482
+
let lc_assoc = List.map (fun (k, v) -> (String.lowercase_ascii k, v)) assoc in
483
+
let rev_assoc = List.map (fun (s, v) -> (v, s)) assoc in
484
+
make_value_codec ~kind ~doc
485
+
~dec:(fun v ->
486
+
match List.assoc_opt (String.lowercase_ascii v.Repr.interpolated) lc_assoc with
487
+
| Some x -> Ok x
488
+
| None -> Error (Error.make (Type_mismatch {
489
+
expected = kind; got = v.interpolated })))
490
+
~enc:(fun x meta ->
491
+
match List.find_opt (fun (v', _) -> cmp x v' = 0) rev_assoc with
492
+
| Some (_, s) -> { Repr.raw = s; interpolated = s; meta }
493
+
| None -> failwith "enum value not in association list")
494
+
495
+
let option ?kind ?doc c =
496
+
let kind = Option.value ~default:("optional " ^ c.kind) kind in
497
+
let doc = Option.value ~default:c.doc doc in
498
+
{ kind; doc;
499
+
dec = (fun v ->
500
+
if v.Repr.interpolated = "" then Ok None
501
+
else Result.map Option.some (c.dec v));
502
+
enc = (function
503
+
| Some x -> c.enc x
504
+
| None -> fun meta -> { Repr.raw = ""; interpolated = ""; meta });
505
+
section = None;
506
+
document = None;
507
+
}
508
+
509
+
let default def c = {
510
+
c with
511
+
dec = (fun v ->
512
+
match c.dec v with
513
+
| Ok x -> Ok x
514
+
| Error _ -> Ok def);
515
+
}
516
+
517
+
let list ?(sep = ',') c = {
518
+
kind = "list of " ^ c.kind;
519
+
doc = "";
520
+
dec = (fun v ->
521
+
if v.Repr.interpolated = "" then Ok []
522
+
else
523
+
let parts = String.split_on_char sep v.Repr.interpolated in
524
+
let parts = List.map String.trim parts in
525
+
let rec decode_all acc = function
526
+
| [] -> Ok (List.rev acc)
527
+
| part :: rest ->
528
+
let pv = { v with Repr.raw = part; interpolated = part } in
529
+
match c.dec pv with
530
+
| Ok x -> decode_all (x :: acc) rest
531
+
| Error e -> Error e
532
+
in
533
+
decode_all [] parts);
534
+
enc = (fun xs meta ->
535
+
let parts = List.map (fun x -> (c.enc x meta).Repr.interpolated) xs in
536
+
let s = String.concat (String.make 1 sep ^ " ") parts in
537
+
{ Repr.raw = s; interpolated = s; meta });
538
+
section = None;
539
+
document = None;
540
+
}
541
+
542
+
(* ---- Section Codecs ---- *)
543
+
544
+
module Section = struct
545
+
type 'a codec = 'a t
546
+
547
+
type ('o, 'dec) map = {
548
+
kind : string;
549
+
doc : string;
550
+
decode : Repr.ini_section -> 'dec Repr.codec_result;
551
+
encode : 'o -> Repr.ini_section;
552
+
known : string list;
553
+
unknown : [ `Skip | `Error | `Keep ];
554
+
}
555
+
556
+
let obj ?kind ?doc (f : 'dec) : ('o, 'dec) map =
557
+
let kind = Option.value ~default:"section" kind in
558
+
let doc = Option.value ~default:"" doc in
559
+
{
560
+
kind; doc;
561
+
decode = (fun _ -> Ok f);
562
+
encode = (fun _ -> {
563
+
Repr.name = ("", Meta.none);
564
+
options = [];
565
+
meta = Meta.none;
566
+
});
567
+
known = [];
568
+
unknown = `Skip;
569
+
}
570
+
571
+
let mem ?doc:_ ?dec_absent ?enc ?enc_omit name (c : 'a codec)
572
+
(m : ('o, 'a -> 'dec) map) : ('o, 'dec) map =
573
+
let lc_name = String.lowercase_ascii name in
574
+
{
575
+
m with
576
+
known = lc_name :: m.known;
577
+
decode = (fun sec ->
578
+
let opt = List.find_opt (fun ((n, _), _) ->
579
+
String.lowercase_ascii n = lc_name) sec.Repr.options in
580
+
let decoded = match opt with
581
+
| Some (_, v) -> c.dec v
582
+
| None ->
583
+
match dec_absent with
584
+
| Some def -> Ok def
585
+
| None -> Error (Error.make (Missing_option {
586
+
section = fst sec.name; option = name }))
587
+
in
588
+
match decoded with
589
+
| Ok a ->
590
+
(match m.decode sec with
591
+
| Ok f -> Ok (f a)
592
+
| Error e -> Error e)
593
+
| Error e -> Error e);
594
+
encode = (fun o ->
595
+
let sec = m.encode o in
596
+
match enc with
597
+
| None -> sec
598
+
| Some enc_fn ->
599
+
let v = enc_fn o in
600
+
let should_omit = match enc_omit with
601
+
| Some f -> f v
602
+
| None -> false
603
+
in
604
+
if should_omit then sec
605
+
else
606
+
let iv = c.enc v Meta.none in
607
+
{ sec with options = ((name, Meta.none), iv) :: sec.options });
608
+
}
609
+
610
+
let opt_mem ?doc ?enc name c m =
611
+
let opt_c = option c in
612
+
let enc' = Option.map (fun f o -> f o) enc in
613
+
mem ?doc ~dec_absent:None ?enc:enc' ~enc_omit:Option.is_none name opt_c m
614
+
615
+
let skip_unknown m = { m with unknown = `Skip }
616
+
let error_unknown m = { m with unknown = `Error }
617
+
618
+
let keep_unknown ?enc (m : ('o, (string * string) list -> 'dec) map)
619
+
: ('o, 'dec) map =
620
+
{
621
+
kind = m.kind;
622
+
doc = m.doc;
623
+
known = m.known;
624
+
unknown = `Keep;
625
+
decode = (fun sec ->
626
+
let unknown_opts = List.filter_map (fun ((n, _), v) ->
627
+
let lc_n = String.lowercase_ascii n in
628
+
if List.mem lc_n m.known then None
629
+
else Some (n, v.Repr.interpolated)
630
+
) sec.Repr.options in
631
+
match m.decode sec with
632
+
| Ok f -> Ok (f unknown_opts)
633
+
| Error e -> Error e);
634
+
encode = (fun o ->
635
+
let sec = m.encode o in
636
+
match enc with
637
+
| None -> sec
638
+
| Some enc_fn ->
639
+
let unknown_opts = enc_fn o in
640
+
let new_opts = List.map (fun (k, v) ->
641
+
((k, Meta.none), { Repr.raw = v; interpolated = v; meta = Meta.none })
642
+
) unknown_opts in
643
+
{ sec with options = new_opts @ sec.options });
644
+
}
645
+
646
+
let finish (m : ('o, 'o) map) : 'o codec =
647
+
let section_state : 'o Repr.section_state = {
648
+
decode = (fun sec ->
649
+
(* Check for unknown options *)
650
+
(match m.unknown with
651
+
| `Skip -> ()
652
+
| `Keep -> ()
653
+
| `Error ->
654
+
List.iter (fun ((n, _), _) ->
655
+
let lc_n = String.lowercase_ascii n in
656
+
if not (List.mem lc_n m.known) then
657
+
Error.raise (Unknown_option n)
658
+
) sec.Repr.options);
659
+
m.decode sec);
660
+
encode = (fun o ->
661
+
let sec = m.encode o in
662
+
{ sec with options = List.rev sec.options });
663
+
known_options = m.known;
664
+
unknown_handler = m.unknown;
665
+
} in
666
+
{
667
+
kind = m.kind;
668
+
doc = m.doc;
669
+
dec = (fun _ -> Error (Error.make (Codec "section codec requires section-level decode")));
670
+
enc = (fun _ _ -> { Repr.raw = ""; interpolated = ""; meta = Meta.none });
671
+
section = Some section_state;
672
+
document = None;
673
+
}
674
+
end
675
+
676
+
(* ---- Document Codecs ---- *)
677
+
678
+
module Document = struct
679
+
type 'a codec = 'a t
680
+
681
+
type ('o, 'dec) map = {
682
+
kind : string;
683
+
doc : string;
684
+
decode : Repr.ini_doc -> 'dec Repr.codec_result;
685
+
encode : 'o -> Repr.ini_doc;
686
+
known : string list;
687
+
unknown : [ `Skip | `Error ];
688
+
}
689
+
690
+
let obj ?kind ?doc (f : 'dec) : ('o, 'dec) map =
691
+
let kind = Option.value ~default:"document" kind in
692
+
let doc = Option.value ~default:"" doc in
693
+
{
694
+
kind; doc;
695
+
decode = (fun _ -> Ok f);
696
+
encode = (fun _ -> {
697
+
Repr.defaults = [];
698
+
sections = [];
699
+
meta = Meta.none;
700
+
});
701
+
known = [];
702
+
unknown = `Skip;
703
+
}
704
+
705
+
let section ?doc:_ ?enc name (sec_codec : 'a codec)
706
+
(m : ('o, 'a -> 'dec) map) : ('o, 'dec) map =
707
+
let sec_state = match sec_codec.section with
708
+
| Some s -> s
709
+
| None -> failwith "section: codec must be a section codec"
710
+
in
711
+
let lc_name = String.lowercase_ascii name in
712
+
{
713
+
m with
714
+
known = lc_name :: m.known;
715
+
decode = (fun doc ->
716
+
let sec = List.find_opt (fun s ->
717
+
String.lowercase_ascii (fst s.Repr.name) = lc_name) doc.Repr.sections in
718
+
match sec with
719
+
| None -> Error (Error.make (Missing_section name))
720
+
| Some sec ->
721
+
match sec_state.decode sec with
722
+
| Ok a ->
723
+
(match m.decode doc with
724
+
| Ok f -> Ok (f a)
725
+
| Error e -> Error e)
726
+
| Error e -> Error e);
727
+
encode = (fun o ->
728
+
let doc = m.encode o in
729
+
match enc with
730
+
| None -> doc
731
+
| Some enc_fn ->
732
+
let v = enc_fn o in
733
+
let sec = sec_state.encode v in
734
+
let sec = { sec with name = (name, Meta.none) } in
735
+
{ doc with sections = sec :: doc.sections });
736
+
}
737
+
738
+
let opt_section ?doc:_ ?enc name (sec_codec : 'a codec)
739
+
(m : ('o, 'a option -> 'dec) map) : ('o, 'dec) map =
740
+
let sec_state = match sec_codec.section with
741
+
| Some s -> s
742
+
| None -> failwith "opt_section: codec must be a section codec"
743
+
in
744
+
let lc_name = String.lowercase_ascii name in
745
+
{
746
+
m with
747
+
known = lc_name :: m.known;
748
+
decode = (fun doc ->
749
+
let sec = List.find_opt (fun s ->
750
+
String.lowercase_ascii (fst s.Repr.name) = lc_name) doc.Repr.sections in
751
+
match sec with
752
+
| None ->
753
+
(match m.decode doc with
754
+
| Ok f -> Ok (f None)
755
+
| Error e -> Error e)
756
+
| Some sec ->
757
+
match sec_state.decode sec with
758
+
| Ok a ->
759
+
(match m.decode doc with
760
+
| Ok f -> Ok (f (Some a))
761
+
| Error e -> Error e)
762
+
| Error e -> Error e);
763
+
encode = (fun o ->
764
+
let doc = m.encode o in
765
+
match enc with
766
+
| None -> doc
767
+
| Some enc_fn ->
768
+
match enc_fn o with
769
+
| None -> doc
770
+
| Some v ->
771
+
let sec = sec_state.encode v in
772
+
let sec = { sec with name = (name, Meta.none) } in
773
+
{ doc with sections = sec :: doc.sections });
774
+
}
775
+
776
+
let defaults ?doc:_ ?enc (sec_codec : 'a codec)
777
+
(m : ('o, 'a -> 'dec) map) : ('o, 'dec) map =
778
+
let sec_state = match sec_codec.section with
779
+
| Some s -> s
780
+
| None -> failwith "defaults: codec must be a section codec"
781
+
in
782
+
{
783
+
m with
784
+
known = "default" :: m.known;
785
+
decode = (fun doc ->
786
+
let fake_sec = {
787
+
Repr.name = ("DEFAULT", Meta.none);
788
+
options = doc.defaults;
789
+
meta = Meta.none;
790
+
} in
791
+
match sec_state.decode fake_sec with
792
+
| Ok a ->
793
+
(match m.decode doc with
794
+
| Ok f -> Ok (f a)
795
+
| Error e -> Error e)
796
+
| Error e -> Error e);
797
+
encode = (fun o ->
798
+
let doc = m.encode o in
799
+
match enc with
800
+
| None -> doc
801
+
| Some enc_fn ->
802
+
let v = enc_fn o in
803
+
let sec = sec_state.encode v in
804
+
{ doc with defaults = sec.options });
805
+
}
806
+
807
+
let opt_defaults ?doc:_ ?enc (sec_codec : 'a codec)
808
+
(m : ('o, 'a option -> 'dec) map) : ('o, 'dec) map =
809
+
let sec_state = match sec_codec.section with
810
+
| Some s -> s
811
+
| None -> failwith "opt_defaults: codec must be a section codec"
812
+
in
813
+
{
814
+
m with
815
+
known = "default" :: m.known;
816
+
decode = (fun doc ->
817
+
if doc.defaults = [] then
818
+
(match m.decode doc with
819
+
| Ok f -> Ok (f None)
820
+
| Error e -> Error e)
821
+
else
822
+
let fake_sec = {
823
+
Repr.name = ("DEFAULT", Meta.none);
824
+
options = doc.defaults;
825
+
meta = Meta.none;
826
+
} in
827
+
match sec_state.decode fake_sec with
828
+
| Ok a ->
829
+
(match m.decode doc with
830
+
| Ok f -> Ok (f (Some a))
831
+
| Error e -> Error e)
832
+
| Error e -> Error e);
833
+
encode = (fun o ->
834
+
let doc = m.encode o in
835
+
match enc with
836
+
| None -> doc
837
+
| Some enc_fn ->
838
+
match enc_fn o with
839
+
| None -> doc
840
+
| Some v ->
841
+
let sec = sec_state.encode v in
842
+
{ doc with defaults = sec.options });
843
+
}
844
+
845
+
let skip_unknown m = { m with unknown = `Skip }
846
+
let error_unknown m = { m with unknown = `Error }
847
+
848
+
let finish (m : ('o, 'o) map) : 'o codec =
849
+
let document_state : 'o Repr.document_state = {
850
+
decode = (fun doc ->
851
+
(* Check for unknown sections *)
852
+
(match m.unknown with
853
+
| `Skip -> ()
854
+
| `Error ->
855
+
List.iter (fun sec ->
856
+
let lc_n = String.lowercase_ascii (fst sec.Repr.name) in
857
+
if not (List.mem lc_n m.known) then
858
+
Error.raise (Unknown_section (fst sec.name))
859
+
) doc.Repr.sections);
860
+
m.decode doc);
861
+
encode = (fun o ->
862
+
let doc = m.encode o in
863
+
{ doc with sections = List.rev doc.sections });
864
+
known_sections = m.known;
865
+
unknown_handler = m.unknown;
866
+
} in
867
+
{
868
+
kind = m.kind;
869
+
doc = m.doc;
870
+
dec = (fun _ -> Error (Error.make (Codec "document codec requires document-level decode")));
871
+
enc = (fun _ _ -> { Repr.raw = ""; interpolated = ""; meta = Meta.none });
872
+
section = None;
873
+
document = Some document_state;
874
+
}
875
+
end
+519
src/init.mli
+519
src/init.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Declarative INI data manipulation for OCaml.
7
+
8
+
Init provides bidirectional codecs for INI files following Python's
9
+
configparser semantics. The core module has no dependencies.
10
+
11
+
{b Features:}
12
+
- Multiline values via indentation
13
+
- Basic interpolation: [%(name)s]
14
+
- Extended interpolation: [$\{section:name\}]
15
+
- DEFAULT section inheritance
16
+
- Case-insensitive option lookup
17
+
- Layout preservation (whitespace and comments)
18
+
19
+
{b Sub-libraries:}
20
+
- {!Init_bytesrw} for parsing/encoding with bytesrw
21
+
- {!Init_eio} for Eio file system integration *)
22
+
23
+
type 'a fmt = Format.formatter -> 'a -> unit
24
+
(** The type for formatters. *)
25
+
26
+
(** {1:textlocs Text Locations} *)
27
+
28
+
(** Text locations.
29
+
30
+
A text location identifies a text span in a given file by an inclusive
31
+
byte position range and the start position on lines. *)
32
+
module Textloc : sig
33
+
34
+
(** {1:fpath File paths} *)
35
+
36
+
type fpath = string
37
+
(** The type for file paths. *)
38
+
39
+
val file_none : fpath
40
+
(** [file_none] is ["-"]. A file path for when there is none. *)
41
+
42
+
(** {1:pos Positions} *)
43
+
44
+
type byte_pos = int
45
+
(** The type for zero-based byte positions in text. *)
46
+
47
+
val byte_pos_none : byte_pos
48
+
(** [byte_pos_none] is [-1]. A position to use when there is none. *)
49
+
50
+
type line_num = int
51
+
(** The type for one-based line numbers. *)
52
+
53
+
val line_num_none : line_num
54
+
(** [line_num_none] is [-1]. A line number to use when there is none. *)
55
+
56
+
type line_pos = line_num * byte_pos
57
+
(** The type for line positions. A one-based line number and the
58
+
byte position of the first byte of the line. *)
59
+
60
+
val line_pos_first : line_pos
61
+
(** [line_pos_first] is [(1, 0)]. *)
62
+
63
+
val line_pos_none : line_pos
64
+
(** [line_pos_none] is [(line_num_none, byte_pos_none)]. *)
65
+
66
+
(** {1:tlocs Text locations} *)
67
+
68
+
type t
69
+
(** The type for text locations. A text location identifies a text span
70
+
in a file by an inclusive byte position range and its line positions. *)
71
+
72
+
val none : t
73
+
(** [none] is a text location with no information. *)
74
+
75
+
val make :
76
+
file:fpath ->
77
+
first_byte:byte_pos -> last_byte:byte_pos ->
78
+
first_line:line_pos -> last_line:line_pos -> t
79
+
(** [make ~file ~first_byte ~last_byte ~first_line ~last_line] is a text
80
+
location with the given data. *)
81
+
82
+
val file : t -> fpath
83
+
(** [file l] is the file of [l]. *)
84
+
85
+
val set_file : t -> fpath -> t
86
+
(** [set_file l f] is [l] with [file] set to [f]. *)
87
+
88
+
val first_byte : t -> byte_pos
89
+
(** [first_byte l] is the first byte position of [l]. *)
90
+
91
+
val last_byte : t -> byte_pos
92
+
(** [last_byte l] is the last byte position of [l]. *)
93
+
94
+
val first_line : t -> line_pos
95
+
(** [first_line l] is the first line position of [l]. *)
96
+
97
+
val last_line : t -> line_pos
98
+
(** [last_line l] is the last line position of [l]. *)
99
+
100
+
val is_none : t -> bool
101
+
(** [is_none l] is [true] iff [first_byte l < 0]. *)
102
+
103
+
val is_empty : t -> bool
104
+
(** [is_empty l] is [true] iff [first_byte l > last_byte l]. *)
105
+
106
+
val equal : t -> t -> bool
107
+
(** [equal l0 l1] tests [l0] and [l1] for equality. *)
108
+
109
+
val compare : t -> t -> int
110
+
(** [compare l0 l1] is a total order on locations. *)
111
+
112
+
val set_first : t -> first_byte:byte_pos -> first_line:line_pos -> t
113
+
(** [set_first l ~first_byte ~first_line] updates the first position of [l]. *)
114
+
115
+
val set_last : t -> last_byte:byte_pos -> last_line:line_pos -> t
116
+
(** [set_last l ~last_byte ~last_line] updates the last position of [l]. *)
117
+
118
+
val to_first : t -> t
119
+
(** [to_first l] has the start of [l] as its start and end. *)
120
+
121
+
val to_last : t -> t
122
+
(** [to_last l] has the end of [l] as its start and end. *)
123
+
124
+
val before : t -> t
125
+
(** [before l] is the empty location just before [l]. *)
126
+
127
+
val after : t -> t
128
+
(** [after l] is the empty location just after [l]. *)
129
+
130
+
val span : t -> t -> t
131
+
(** [span l0 l1] is the span from the smallest position of [l0] and [l1]
132
+
to the largest position of [l0] and [l1]. *)
133
+
134
+
val reloc : first:t -> last:t -> t
135
+
(** [reloc ~first ~last] is a location that spans from [first] to [last]. *)
136
+
137
+
(** {1:fmt Formatting} *)
138
+
139
+
val pp_ocaml : t fmt
140
+
(** [pp_ocaml] formats location using OCaml syntax. *)
141
+
142
+
val pp_gnu : t fmt
143
+
(** [pp_gnu] formats location using GNU syntax. *)
144
+
145
+
val pp : t fmt
146
+
(** [pp] is {!pp_ocaml}. *)
147
+
148
+
val pp_dump : t fmt
149
+
(** [pp_dump] formats the location for debugging. *)
150
+
end
151
+
152
+
(** {1:meta Metadata} *)
153
+
154
+
(** INI element metadata.
155
+
156
+
Metadata holds text location and layout information (whitespace and
157
+
comments) for INI elements. This enables layout-preserving round-trips. *)
158
+
module Meta : sig
159
+
160
+
type t
161
+
(** The type for element metadata. *)
162
+
163
+
val none : t
164
+
(** [none] is metadata with no information. *)
165
+
166
+
val make : ?ws_before:string -> ?ws_after:string -> ?comment:string ->
167
+
Textloc.t -> t
168
+
(** [make ?ws_before ?ws_after ?comment textloc] creates metadata. *)
169
+
170
+
val is_none : t -> bool
171
+
(** [is_none m] is [true] iff [m] has no text location. *)
172
+
173
+
val textloc : t -> Textloc.t
174
+
(** [textloc m] is the text location of [m]. *)
175
+
176
+
val ws_before : t -> string
177
+
(** [ws_before m] is whitespace before the element. *)
178
+
179
+
val ws_after : t -> string
180
+
(** [ws_after m] is whitespace after the element. *)
181
+
182
+
val comment : t -> string option
183
+
(** [comment m] is the associated comment, if any. *)
184
+
185
+
val with_textloc : t -> Textloc.t -> t
186
+
(** [with_textloc m loc] is [m] with text location [loc]. *)
187
+
188
+
val with_ws_before : t -> string -> t
189
+
(** [with_ws_before m ws] is [m] with [ws_before] set to [ws]. *)
190
+
191
+
val with_ws_after : t -> string -> t
192
+
(** [with_ws_after m ws] is [m] with [ws_after] set to [ws]. *)
193
+
194
+
val with_comment : t -> string option -> t
195
+
(** [with_comment m c] is [m] with [comment] set to [c]. *)
196
+
197
+
val clear_ws : t -> t
198
+
(** [clear_ws m] clears whitespace from [m]. *)
199
+
200
+
val clear_textloc : t -> t
201
+
(** [clear_textloc m] sets textloc to {!Textloc.none}. *)
202
+
203
+
val copy_ws : t -> dst:t -> t
204
+
(** [copy_ws src ~dst] copies whitespace from [src] to [dst]. *)
205
+
end
206
+
207
+
type 'a node = 'a * Meta.t
208
+
(** The type for values with metadata. *)
209
+
210
+
(** {1:paths Paths} *)
211
+
212
+
(** INI paths.
213
+
214
+
Paths identify locations within an INI document, such as
215
+
[\[section\]/option]. *)
216
+
module Path : sig
217
+
218
+
(** {1:indices Path indices} *)
219
+
220
+
type index =
221
+
| Section of string node (** A section name. *)
222
+
| Option of string node (** An option name. *)
223
+
(** The type for path indices. *)
224
+
225
+
val pp_index : index fmt
226
+
(** [pp_index] formats an index. *)
227
+
228
+
(** {1:paths Paths} *)
229
+
230
+
type t
231
+
(** The type for paths. *)
232
+
233
+
val root : t
234
+
(** [root] is the empty path. *)
235
+
236
+
val is_root : t -> bool
237
+
(** [is_root p] is [true] iff [p] is {!root}. *)
238
+
239
+
val section : ?meta:Meta.t -> string -> t -> t
240
+
(** [section ?meta name p] appends a section index to [p]. *)
241
+
242
+
val option : ?meta:Meta.t -> string -> t -> t
243
+
(** [option ?meta name p] appends an option index to [p]. *)
244
+
245
+
val rev_indices : t -> index list
246
+
(** [rev_indices p] is the list of indices in reverse order. *)
247
+
248
+
val pp : t fmt
249
+
(** [pp] formats a path. *)
250
+
end
251
+
252
+
(** {1:errors Errors} *)
253
+
254
+
(** Error handling. *)
255
+
module Error : sig
256
+
257
+
(** {1:kinds Error kinds} *)
258
+
259
+
type kind =
260
+
| Parse of string
261
+
| Codec of string
262
+
| Missing_section of string
263
+
| Missing_option of { section : string; option : string }
264
+
| Duplicate_section of string
265
+
| Duplicate_option of { section : string; option : string }
266
+
| Type_mismatch of { expected : string; got : string }
267
+
| Interpolation of { option : string; reason : string }
268
+
| Unknown_option of string
269
+
| Unknown_section of string
270
+
(** The type for error kinds. *)
271
+
272
+
(** {1:errors Errors} *)
273
+
274
+
type t
275
+
(** The type for errors. *)
276
+
277
+
val make : ?meta:Meta.t -> ?path:Path.t -> kind -> t
278
+
(** [make ?meta ?path kind] creates an error. *)
279
+
280
+
val kind : t -> kind
281
+
(** [kind e] is the error kind. *)
282
+
283
+
val meta : t -> Meta.t
284
+
(** [meta e] is the error metadata. *)
285
+
286
+
val path : t -> Path.t
287
+
(** [path e] is the error path. *)
288
+
289
+
exception Error of t
290
+
(** Exception for errors. *)
291
+
292
+
val raise : ?meta:Meta.t -> ?path:Path.t -> kind -> 'a
293
+
(** [raise ?meta ?path kind] raises {!Error}. *)
294
+
295
+
val kind_to_string : kind -> string
296
+
(** [kind_to_string k] is a string representation of [k]. *)
297
+
298
+
val to_string : t -> string
299
+
(** [to_string e] formats the error as a string. *)
300
+
301
+
val pp : t fmt
302
+
(** [pp] formats an error. *)
303
+
end
304
+
305
+
(** {1:repr Internal Representations}
306
+
307
+
These types are exposed for use by {!Init_bytesrw}. *)
308
+
module Repr : sig
309
+
310
+
(** {1:values INI Values} *)
311
+
312
+
type ini_value = {
313
+
raw : string;
314
+
interpolated : string;
315
+
meta : Meta.t;
316
+
}
317
+
(** The type for decoded INI values. [raw] is the value before
318
+
interpolation, [interpolated] after. *)
319
+
320
+
(** {1:sections INI Sections} *)
321
+
322
+
type ini_section = {
323
+
name : string node;
324
+
options : (string node * ini_value) list;
325
+
meta : Meta.t;
326
+
}
327
+
(** The type for decoded INI sections. *)
328
+
329
+
(** {1:docs INI Documents} *)
330
+
331
+
type ini_doc = {
332
+
defaults : (string node * ini_value) list;
333
+
sections : ini_section list;
334
+
meta : Meta.t;
335
+
}
336
+
(** The type for decoded INI documents. *)
337
+
338
+
(** {1:codec_state Codec State} *)
339
+
340
+
type 'a codec_result = ('a, Error.t) result
341
+
(** The type for codec results. *)
342
+
343
+
type 'a section_state = {
344
+
decode : ini_section -> 'a codec_result;
345
+
encode : 'a -> ini_section;
346
+
known_options : string list;
347
+
unknown_handler : [ `Skip | `Error | `Keep ];
348
+
}
349
+
(** Section codec state. *)
350
+
351
+
type 'a document_state = {
352
+
decode : ini_doc -> 'a codec_result;
353
+
encode : 'a -> ini_doc;
354
+
known_sections : string list;
355
+
unknown_handler : [ `Skip | `Error ];
356
+
}
357
+
(** Document codec state. *)
358
+
end
359
+
360
+
(** {1:codecs Codecs} *)
361
+
362
+
type 'a t
363
+
(** The type for INI codecs. A value of type ['a t] describes how to
364
+
decode INI data to type ['a] and encode ['a] to INI data. *)
365
+
366
+
val kind : 'a t -> string
367
+
(** [kind c] is a description of the kind of values [c] represents. *)
368
+
369
+
val doc : 'a t -> string
370
+
(** [doc c] is the documentation for [c]. *)
371
+
372
+
val with_doc : ?kind:string -> ?doc:string -> 'a t -> 'a t
373
+
(** [with_doc ?kind ?doc c] is [c] with updated kind and doc. *)
374
+
375
+
val section_state : 'a t -> 'a Repr.section_state option
376
+
(** [section_state c] returns the section decode/encode state, if [c]
377
+
was created with {!Section.finish}. *)
378
+
379
+
val document_state : 'a t -> 'a Repr.document_state option
380
+
(** [document_state c] returns the document decode/encode state, if [c]
381
+
was created with {!Document.finish}. *)
382
+
383
+
(** {2:base_codecs Base Codecs} *)
384
+
385
+
val string : string t
386
+
(** [string] is a codec for string values. *)
387
+
388
+
val int : int t
389
+
(** [int] is a codec for integer values. *)
390
+
391
+
val int32 : int32 t
392
+
(** [int32] is a codec for 32-bit integer values. *)
393
+
394
+
val int64 : int64 t
395
+
(** [int64] is a codec for 64-bit integer values. *)
396
+
397
+
val float : float t
398
+
(** [float] is a codec for floating-point values. *)
399
+
400
+
val bool : bool t
401
+
(** [bool] is a codec for Python-compatible booleans.
402
+
Accepts (case-insensitive): [1/yes/true/on] for true,
403
+
[0/no/false/off] for false. *)
404
+
405
+
val bool_01 : bool t
406
+
(** [bool_01] is a strict codec for ["0"]/["1"] booleans. *)
407
+
408
+
val bool_yesno : bool t
409
+
(** [bool_yesno] is a codec for ["yes"]/["no"] booleans. *)
410
+
411
+
val bool_truefalse : bool t
412
+
(** [bool_truefalse] is a codec for ["true"]/["false"] booleans. *)
413
+
414
+
val bool_onoff : bool t
415
+
(** [bool_onoff] is a codec for ["on"]/["off"] booleans. *)
416
+
417
+
(** {2:combinators Combinators} *)
418
+
419
+
val map : ?kind:string -> ?doc:string ->
420
+
dec:('a -> 'b) -> enc:('b -> 'a) -> 'a t -> 'b t
421
+
(** [map ~dec ~enc c] transforms [c] using [dec] for decoding
422
+
and [enc] for encoding. *)
423
+
424
+
val enum : ?cmp:('a -> 'a -> int) -> ?kind:string -> ?doc:string ->
425
+
(string * 'a) list -> 'a t
426
+
(** [enum assoc] is a codec for enumerated values. String matching
427
+
is case-insensitive. *)
428
+
429
+
val option : ?kind:string -> ?doc:string -> 'a t -> 'a option t
430
+
(** [option c] is a codec for optional values. Empty strings decode
431
+
to [None]. *)
432
+
433
+
val default : 'a -> 'a t -> 'a t
434
+
(** [default v c] uses [v] when decoding fails. *)
435
+
436
+
val list : ?sep:char -> 'a t -> 'a list t
437
+
(** [list ?sep c] is a codec for lists of values separated by [sep]
438
+
(default: [',']). *)
439
+
440
+
(** {1:sections Section Codecs}
441
+
442
+
Build codecs for INI sections using an applicative style. *)
443
+
module Section : sig
444
+
445
+
type 'a codec = 'a t
446
+
(** Alias for codec type. *)
447
+
448
+
type ('o, 'dec) map
449
+
(** The type for section maps. ['o] is the OCaml type being built,
450
+
['dec] is the remaining constructor arguments. *)
451
+
452
+
val obj : ?kind:string -> ?doc:string -> 'dec -> ('o, 'dec) map
453
+
(** [obj f] starts building a section codec with constructor [f]. *)
454
+
455
+
val mem : ?doc:string -> ?dec_absent:'a -> ?enc:('o -> 'a) ->
456
+
?enc_omit:('a -> bool) ->
457
+
string -> 'a codec -> ('o, 'a -> 'dec) map -> ('o, 'dec) map
458
+
(** [mem name c m] adds an option [name] decoded by [c] to map [m].
459
+
@param dec_absent Default value if option is absent.
460
+
@param enc Encoder function to extract value from ['o].
461
+
@param enc_omit Predicate; if true, omit option during encoding. *)
462
+
463
+
val opt_mem : ?doc:string -> ?enc:('o -> 'a option) ->
464
+
string -> 'a codec -> ('o, 'a option -> 'dec) map -> ('o, 'dec) map
465
+
(** [opt_mem name c m] adds an optional option (decodes to [None] if absent). *)
466
+
467
+
val skip_unknown : ('o, 'dec) map -> ('o, 'dec) map
468
+
(** [skip_unknown m] ignores unknown options (default). *)
469
+
470
+
val error_unknown : ('o, 'dec) map -> ('o, 'dec) map
471
+
(** [error_unknown m] raises an error on unknown options. *)
472
+
473
+
val keep_unknown : ?enc:('o -> (string * string) list) ->
474
+
('o, (string * string) list -> 'dec) map -> ('o, 'dec) map
475
+
(** [keep_unknown m] captures unknown options as a list of (name, value) pairs. *)
476
+
477
+
val finish : ('o, 'o) map -> 'o codec
478
+
(** [finish m] completes the section codec. *)
479
+
end
480
+
481
+
(** {1:documents Document Codecs}
482
+
483
+
Build codecs for complete INI documents. *)
484
+
module Document : sig
485
+
486
+
type 'a codec = 'a t
487
+
(** Alias for codec type. *)
488
+
489
+
type ('o, 'dec) map
490
+
(** The type for document maps. *)
491
+
492
+
val obj : ?kind:string -> ?doc:string -> 'dec -> ('o, 'dec) map
493
+
(** [obj f] starts building a document codec with constructor [f]. *)
494
+
495
+
val section : ?doc:string -> ?enc:('o -> 'a) ->
496
+
string -> 'a Section.codec -> ('o, 'a -> 'dec) map -> ('o, 'dec) map
497
+
(** [section name c m] adds a required section [name] to map [m]. *)
498
+
499
+
val opt_section : ?doc:string -> ?enc:('o -> 'a option) ->
500
+
string -> 'a Section.codec -> ('o, 'a option -> 'dec) map -> ('o, 'dec) map
501
+
(** [opt_section name c m] adds an optional section [name] to map [m]. *)
502
+
503
+
val defaults : ?doc:string -> ?enc:('o -> 'a) ->
504
+
'a Section.codec -> ('o, 'a -> 'dec) map -> ('o, 'dec) map
505
+
(** [defaults c m] decodes the DEFAULT section using [c]. *)
506
+
507
+
val opt_defaults : ?doc:string -> ?enc:('o -> 'a option) ->
508
+
'a Section.codec -> ('o, 'a option -> 'dec) map -> ('o, 'dec) map
509
+
(** [opt_defaults c m] optionally decodes the DEFAULT section. *)
510
+
511
+
val skip_unknown : ('o, 'dec) map -> ('o, 'dec) map
512
+
(** [skip_unknown m] ignores unknown sections (default). *)
513
+
514
+
val error_unknown : ('o, 'dec) map -> ('o, 'dec) map
515
+
(** [error_unknown m] raises an error on unknown sections. *)
516
+
517
+
val finish : ('o, 'o) map -> 'o codec
518
+
(** [finish m] completes the document codec. *)
519
+
end
+3
test/data/cfgparser.1
+3
test/data/cfgparser.1
+537
test/data/cfgparser.2
+537
test/data/cfgparser.2
···
1
+
# This is the main Samba configuration file. You should read the
2
+
# smb.conf(5) manual page in order to understand the options listed
3
+
# here. Samba has a huge number of configurable options (perhaps too
4
+
# many!) most of which are not shown in this example
5
+
#
6
+
# Any line which starts with a ; (semi-colon) or a # (hash)
7
+
# is a comment and is ignored. In this example we will use a #
8
+
# for commentry and a ; for parts of the config file that you
9
+
# may wish to enable
10
+
#
11
+
# NOTE: Whenever you modify this file you should run the command #"testparm" # to check that you have not made any basic syntactic #errors.
12
+
#
13
+
#======================= Global Settings =====================================
14
+
[global]
15
+
16
+
# 1. Server Naming Options:
17
+
# workgroup = NT-Domain-Name or Workgroup-Name
18
+
19
+
workgroup = MDKGROUP
20
+
21
+
# netbios name is the name you will see in "Network Neighbourhood",
22
+
# but defaults to your hostname
23
+
24
+
; netbios name = <name_of_this_server>
25
+
26
+
# server string is the equivalent of the NT Description field
27
+
28
+
server string = Samba Server %v
29
+
30
+
# Message command is run by samba when a "popup" message is sent to it.
31
+
# The example below is for use with LinPopUp:
32
+
; message command = /usr/bin/linpopup "%f" "%m" %s; rm %s
33
+
34
+
# 2. Printing Options:
35
+
# CHANGES TO ENABLE PRINTING ON ALL CUPS PRINTERS IN THE NETWORK
36
+
# (as cups is now used in linux-mandrake 7.2 by default)
37
+
# if you want to automatically load your printer list rather
38
+
# than setting them up individually then you'll need this
39
+
40
+
printcap name = lpstat
41
+
load printers = yes
42
+
43
+
# It should not be necessary to spell out the print system type unless
44
+
# yours is non-standard. Currently supported print systems include:
45
+
# bsd, sysv, plp, lprng, aix, hpux, qnx, cups
46
+
47
+
printing = cups
48
+
49
+
# Samba 2.2 supports the Windows NT-style point-and-print feature. To
50
+
# use this, you need to be able to upload print drivers to the samba
51
+
# server. The printer admins (or root) may install drivers onto samba.
52
+
# Note that this feature uses the print$ share, so you will need to
53
+
# enable it below.
54
+
# This parameter works like domain admin group:
55
+
# printer admin = @<group> <user>
56
+
; printer admin = @adm
57
+
# This should work well for winbind:
58
+
; printer admin = @"Domain Admins"
59
+
60
+
# 3. Logging Options:
61
+
# this tells Samba to use a separate log file for each machine
62
+
# that connects
63
+
64
+
log file = /var/log/samba/log.%m
65
+
66
+
# Put a capping on the size of the log files (in Kb).
67
+
max log size = 50
68
+
69
+
# Set the log (verbosity) level (0 <= log level <= 10)
70
+
; log level = 3
71
+
72
+
# 4. Security and Domain Membership Options:
73
+
# This option is important for security. It allows you to restrict
74
+
# connections to machines which are on your local network. The
75
+
# following example restricts access to two C class networks and
76
+
# the "loopback" interface. For more examples of the syntax see
77
+
# the smb.conf man page. Do not enable this if (tcp/ip) name resolution #does
78
+
# not work for all the hosts in your network.
79
+
; hosts allow = 192.168.1. 192.168.2. 127.
80
+
81
+
hosts allow = 127. //note this is only my private IP address
82
+
83
+
# Uncomment this if you want a guest account, you must add this to
84
+
# /etc/passwd
85
+
# otherwise the user "nobody" is used
86
+
; guest account = pcguest
87
+
88
+
# Security mode. Most people will want user level security. See
89
+
# security_level.txt for details.
90
+
91
+
security = user
92
+
93
+
# Use password server option only with security = server or security = # domain
94
+
# When using security = domain, you should use password server = *
95
+
; password server =
96
+
; password server = *
97
+
98
+
# Password Level allows matching of _n_ characters of the password for
99
+
# all combinations of upper and lower case.
100
+
101
+
password level = 8
102
+
103
+
; username level = 8
104
+
105
+
# You may wish to use password encryption. Please read
106
+
# ENCRYPTION.txt, Win95.txt and WinNT.txt in the Samba documentation.
107
+
# Do not enable this option unless you have read those documents
108
+
# Encrypted passwords are required for any use of samba in a Windows NT #domain
109
+
# The smbpasswd file is only required by a server doing authentication, #thus members of a domain do not need one.
110
+
111
+
encrypt passwords = yes
112
+
smb passwd file = /etc/samba/smbpasswd
113
+
114
+
# The following are needed to allow password changing from Windows to
115
+
# also update the Linux system password.
116
+
# NOTE: Use these with 'encrypt passwords' and 'smb passwd file' above.
117
+
# NOTE2: You do NOT need these to allow workstations to change only
118
+
# the encrypted SMB passwords. They allow the Unix password
119
+
# to be kept in sync with the SMB password.
120
+
; unix password sync = Yes
121
+
# You either need to setup a passwd program and passwd chat, or
122
+
# enable pam password change
123
+
; pam password change = yes
124
+
; passwd program = /usr/bin/passwd %u
125
+
; passwd chat = *New*UNIX*password* %n\n *ReType*new*UNIX*password*
126
+
# %n\n
127
+
;*passwd:*all*authentication*tokens*updated*successfully*
128
+
129
+
# Unix users can map to different SMB User names
130
+
; username map = /etc/samba/smbusers
131
+
132
+
# Using the following line enables you to customize your configuration
133
+
# on a per machine basis. The %m gets replaced with the netbios name
134
+
# of the machine that is connecting
135
+
; include = /etc/samba/smb.conf.%m
136
+
137
+
# Options for using winbind. Winbind allows you to do all account and
138
+
# authentication from a Windows or samba domain controller, creating
139
+
# accounts on the fly, and maintaining a mapping of Windows RIDs to
140
+
# unix uid's
141
+
# and gid's. winbind uid and winbind gid are the only required
142
+
# parameters.
143
+
#
144
+
# winbind uid is the range of uid's winbind can use when mapping RIDs #to uid's
145
+
; winbind uid = 10000-20000
146
+
#
147
+
# winbind gid is the range of uid's winbind can use when mapping RIDs
148
+
# to gid's
149
+
; winbind gid = 10000-20000
150
+
#
151
+
# winbind separator is the character a user must use between their
152
+
# domain name and username, defaults to "\"
153
+
; winbind separator = +
154
+
#
155
+
# winbind use default domain allows you to have winbind return
156
+
# usernames in the form user instead of DOMAIN+user for the domain
157
+
# listed in the workgroup parameter.
158
+
; winbind use default domain = yes
159
+
#
160
+
# template homedir determines the home directory for winbind users,
161
+
# with %D expanding to their domain name and %U expanding to their
162
+
# username:
163
+
; template homedir = /home/%D/%U
164
+
165
+
# When using winbind, you may want to have samba create home
166
+
# directories on the fly for authenticated users. Ensure that
167
+
# /etc/pam.d/samba is using 'service=system-auth-winbind' in pam_stack
168
+
# modules, and then enable obedience of pam restrictions below:
169
+
; obey pam restrictions = yes
170
+
171
+
#
172
+
# template shell determines the shell users authenticated by winbind #get
173
+
; template shell = /bin/bash
174
+
175
+
# 5. Browser Control and Networking Options:
176
+
# Most people will find that this option gives better performance.
177
+
# See speed.txt and the manual pages for details
178
+
179
+
socket options = TCP_NODELAY SO_RCVBUF=8192 SO_SNDBUF=8192
180
+
181
+
# Configure Samba to use multiple interfaces
182
+
# If you have multiple network interfaces then you must list them
183
+
# here. See the man page for details.
184
+
; interfaces = 192.168.12.2/24 192.168.13.2/24
185
+
186
+
# Configure remote browse list synchronisation here
187
+
# request announcement to, or browse list sync from:
188
+
# a specific host or from / to a whole subnet (see below)
189
+
; remote browse sync = 192.168.3.25 192.168.5.255
190
+
# Cause this host to announce itself to local subnets here
191
+
; remote announce = 192.168.1.255 192.168.2.44
192
+
193
+
# set local master to no if you don't want Samba to become a master
194
+
# browser on your network. Otherwise the normal election rules apply
195
+
; local master = no
196
+
197
+
# OS Level determines the precedence of this server in master browser
198
+
# elections. The default value should be reasonable
199
+
; os level = 33
200
+
201
+
# Domain Master specifies Samba to be the Domain Master Browser. This
202
+
# allows Samba to collate browse lists between subnets. Don't use this
203
+
# if you already have a Windows NT domain controller doing this job
204
+
; domain master = yes
205
+
206
+
# Preferred Master causes Samba to force a local browser election on
207
+
# startup and gives it a slightly higher chance of winning the election
208
+
; preferred master = yes
209
+
210
+
# 6. Domain Control Options:
211
+
# Enable this if you want Samba to be a domain logon server for
212
+
# Windows95 workstations or Primary Domain Controller for WinNT and
213
+
# Win2k
214
+
215
+
; domain logons = yes
216
+
217
+
218
+
# if you enable domain logons then you may want a per-machine or
219
+
# per user logon script
220
+
# run a specific logon batch file per workstation (machine)
221
+
; logon script = %m.bat
222
+
# run a specific logon batch file per username
223
+
; logon script = %U.bat
224
+
225
+
# Where to store roaming profiles for WinNT and Win2k
226
+
# %L substitutes for this servers netbios name, %U is username
227
+
# You must uncomment the [Profiles] share below
228
+
; logon path = \\%L\Profiles\%U
229
+
230
+
# Where to store roaming profiles for Win9x. Be careful with this as it
231
+
# also impacts where Win2k finds it's /HOME share
232
+
; logon home = \\%L\%U\.profile
233
+
234
+
# The add user script is used by a domain member to add local user
235
+
# accounts that have been authenticated by the domain controller, or by
236
+
# the domain controller to add local machine accounts when adding
237
+
# machines to the domain.
238
+
# The script must work from the command line when replacing the macros,
239
+
# or the operation will fail. Check that groups exist if forcing a
240
+
# group.
241
+
# Script for domain controller for adding machines:
242
+
; add user script = /usr/sbin/useradd -d /dev/null -g machines –c
243
+
# 'Machine Account' -s /bin/false -M %u
244
+
# Script for domain controller with LDAP backend for adding machines
245
+
#(please
246
+
# configure in /etc/samba/smbldap_conf.pm first):
247
+
; add user script = /usr/share/samba/scripts/smbldap-useradd.pl -w –d
248
+
# /dev/null -g machines -c 'Machine Account' -s /bin/false %u
249
+
# Script for domain member for adding local accounts for authenticated
250
+
# users:
251
+
; add user script = /usr/sbin/useradd -s /bin/false %u
252
+
253
+
# Domain groups:
254
+
# domain admin group is a list of unix users or groups who are made
255
+
# members
256
+
# of the Domain Admin group
257
+
; domain admin group = root @wheel
258
+
#
259
+
# domain guest groups is a list of unix users or groups who are made
260
+
# members
261
+
# of the Domain Guests group
262
+
; domain guest group = nobody @guest
263
+
264
+
# LDAP configuration for Domain Controlling:
265
+
# The account (dn) that samba uses to access the LDAP server
266
+
# This account needs to have write access to the LDAP tree
267
+
# You will need to give samba the password for this dn, by
268
+
# running 'smbpasswd -w mypassword'
269
+
; ldap admin dn = cn=root,dc=mydomain,dc=com
270
+
; ldap ssl = start_tls
271
+
# start_tls should run on 389, but samba defaults incorrectly to 636
272
+
; ldap port = 389
273
+
; ldap suffix = dc=mydomain,dc=com
274
+
; ldap server = ldap.mydomain.com
275
+
276
+
277
+
# 7. Name Resolution Options:
278
+
# All NetBIOS names must be resolved to IP Addresses
279
+
# 'Name Resolve Order' allows the named resolution mechanism to be
280
+
# specified the default order is "host lmhosts wins bcast". "host"
281
+
# means use the unix system gethostbyname() function call that will use
282
+
# either /etc/hosts OR DNS or NIS depending on the settings of
283
+
# /etc/host.config, /etc/nsswitch.conf
284
+
# and the /etc/resolv.conf file. "host" therefore is system
285
+
# configuration dependent. This parameter is most often of use to
286
+
# prevent DNS lookups
287
+
# in order to resolve NetBIOS names to IP Addresses. Use with care!
288
+
# The example below excludes use of name resolution for machines that
289
+
# are NOT on the local network segment - OR - are not deliberately to
290
+
# be known via lmhosts or via WINS.
291
+
; name resolve order = wins lmhosts bcast
292
+
293
+
# Windows Internet Name Serving Support Section:
294
+
# WINS Support - Tells the NMBD component of Samba to enable it's WINS
295
+
# Server
296
+
; wins support = yes
297
+
298
+
# WINS Server - Tells the NMBD components of Samba to be a WINS Client
299
+
# Note: Samba can be either a WINS Server, or a WINS Client, but
300
+
# NOT both
301
+
; wins server = w.x.y.z
302
+
303
+
# WINS Proxy - Tells Samba to answer name resolution queries on
304
+
# behalf of a non WINS capable client, for this to work there must be
305
+
# at least one WINS Server on the network. The default is NO.
306
+
; wins proxy = yes
307
+
308
+
# DNS Proxy - tells Samba whether or not to try to resolve NetBIOS
309
+
# names via DNS nslookups. The built-in default for versions 1.9.17 is
310
+
# yes, this has been changed in version 1.9.18 to no.
311
+
312
+
dns proxy = no
313
+
314
+
# 8. File Naming Options:
315
+
# Case Preservation can be handy - system default is _no_
316
+
# NOTE: These can be set on a per share basis
317
+
; preserve case = no
318
+
; short preserve case = no
319
+
# Default case is normally upper case for all DOS files
320
+
; default case = lower
321
+
# Be very careful with case sensitivity - it can break things!
322
+
; case sensitive = no
323
+
324
+
# Enabling internationalization:
325
+
# you can match a Windows code page with a UNIX character set.
326
+
# Windows: 437 (US), 737 (GREEK), 850 (Latin1 - Western European),
327
+
# 852 (Eastern Eu.), 861 (Icelandic), 932 (Cyrillic - Russian),
328
+
# 936 (Japanese - Shift-JIS), 936 (Simpl. Chinese), 949 (Korean
329
+
# Hangul),
330
+
# 950 (Trad. Chin.).
331
+
# UNIX: ISO8859-1 (Western European), ISO8859-2 (Eastern Eu.),
332
+
# ISO8859-5 (Russian Cyrillic), KOI8-R (Alt-Russ. Cyril.)
333
+
# This is an example for french users:
334
+
; client code page = 850
335
+
; character set = ISO8859-1
336
+
337
+
#============================ Share Definitions ==============================
338
+
339
+
[homes]
340
+
comment = Home Directories
341
+
browseable = no
342
+
writable = yes
343
+
344
+
# You can enable VFS recycle bin on a per share basis:
345
+
# Uncomment the next 2 lines (make sure you create a
346
+
# .recycle folder in the base of the share and ensure
347
+
# all users will have write access to it. See
348
+
# examples/VFS/recycle/REAME in samba-doc for details
349
+
; vfs object = /usr/lib/samba/vfs/recycle.so
350
+
; vfs options= /etc/samba/recycle.conf
351
+
352
+
# Un-comment the following and create the netlogon directory for Domain
353
+
# Logons
354
+
; [netlogon]
355
+
; comment = Network Logon Service
356
+
; path = /var/lib/samba/netlogon
357
+
; guest ok = yes
358
+
; writable = no
359
+
360
+
#Uncomment the following 2 lines if you would like your login scripts
361
+
# to be created dynamically by ntlogon (check that you have it in the
362
+
# correct location (the default of the ntlogon rpm available in
363
+
# contribs)
364
+
365
+
;root preexec = /usr/bin/ntlogon -u %U -g %G -o %a -d /var/lib/samba/netlogon
366
+
;root postexec = rm -f /var/lib/samba/netlogon/%U.bat
367
+
368
+
# Un-comment the following to provide a specific roving profile share
369
+
# the default is to use the user's home directory
370
+
;[Profiles]
371
+
; path = /var/lib/samba/profiles
372
+
; browseable = no
373
+
; guest ok = yes
374
+
375
+
376
+
# NOTE: If you have a CUPS print system there is no need to
377
+
# specifically define each individual printer.
378
+
# You must configure the samba printers with the appropriate Windows
379
+
# drivers on your Windows clients. On the Samba server no filtering is
380
+
# done. If you wish that the server provides the driver and the clients
381
+
# send PostScript ("Generic PostScript Printer" under Windows), you
382
+
# have to swap the 'print command' line below with the commented one.
383
+
384
+
[printers]
385
+
comment = All Printers
386
+
path = /var/spool/samba
387
+
browseable = no
388
+
# to allow user 'guest account' to print.
389
+
guest ok = yes
390
+
writable = no
391
+
printable = yes
392
+
create mode = 0700
393
+
394
+
# =====================================
395
+
# print command: see above for details.
396
+
# =====================================
397
+
398
+
print command = lpr-cups -P %p -o raw %s -r
399
+
# using client side printer drivers.
400
+
; print command = lpr-cups -P %p %s
401
+
# using cups own drivers (use generic PostScript on clients).
402
+
# The following two commands are the samba defaults for printing=cups
403
+
# change them only if you need different options:
404
+
; lpq command = lpq -P %p
405
+
; lprm command = cancel %p-%j
406
+
407
+
# This share is used for Windows NT-style point-and-print support.
408
+
# To be able to install drivers, you need to be either root, or listed
409
+
# in the printer admin parameter above. Note that you also need write
410
+
# access to the directory and share definition to be able to upload the
411
+
# drivers.
412
+
# For more information on this, please see the Printing Support Section
413
+
# of /usr/share/doc/samba-/docs/Samba-HOWTO-Collection.pdf
414
+
415
+
[print$]
416
+
path = /var/lib/samba/printers
417
+
browseable = yes
418
+
read only = yes
419
+
write list = @adm root
420
+
421
+
# A useful application of samba is to make a PDF-generation service
422
+
# To streamline this, install windows postscript drivers (preferably
423
+
# colour)on the samba server, so that clients can automatically install
424
+
# them.
425
+
426
+
[pdf-generator]
427
+
path = /var/tmp
428
+
guest ok = No
429
+
printable = Yes
430
+
comment = PDF Generator (only valid users)
431
+
#print command = /usr/share/samba/scripts/print-pdf file path win_path recipient IP &
432
+
print command = /usr/share/samba/scripts/print-pdf %s ~%u \\\\\\\\%L\\\\%u %m %I &
433
+
434
+
# This one is useful for people to share files
435
+
[tmp]
436
+
comment = Temporary file space
437
+
path = /tmp
438
+
read only = no
439
+
public = yes
440
+
echo command = cat %s; rm %s
441
+
442
+
# A publicly accessible directory, but read only, except for people in
443
+
# the "staff" group
444
+
445
+
446
+
447
+
448
+
;[public]
449
+
; comment = Public Stuff
450
+
; path = /home/samba/public
451
+
; public = yes
452
+
; writable = no
453
+
; write list = @staff
454
+
# Audited directory through experimental VFS audit.so module:
455
+
# Uncomment next line.
456
+
; vfs object = /usr/lib/samba/vfs/audit.so
457
+
458
+
# Other examples.
459
+
#
460
+
# A private printer, usable only by Fred. Spool data will be placed in
461
+
# Fred's
462
+
# home directory. Note that fred must have write access to the spool
463
+
# directory,
464
+
# wherever it is.
465
+
;[fredsprn]
466
+
; comment = Fred's Printer
467
+
; valid users = fred
468
+
; path = /homes/fred
469
+
; printer = freds_printer
470
+
; public = no
471
+
; writable = no
472
+
; printable = yes
473
+
474
+
475
+
-----------------------------------------------------------
476
+
# A private directory, usable only by Fred. Note that Fred requires
477
+
# write access to the directory.
478
+
479
+
;[fredsdir]
480
+
481
+
[Agustin]
482
+
; comment = Fred's Service
483
+
comment = Agustin Private Files
484
+
; path = /usr/somewhere/private
485
+
path = /home/agustin/Documents
486
+
; valid users = fred
487
+
valid users = agustin
488
+
; public = no
489
+
; writable = yes
490
+
writable = yes
491
+
; printable = no
492
+
493
+
494
+
-----------------------------------------------------------
495
+
496
+
# a service which has a different directory for each machine that
497
+
# connects this allows you to tailor configurations to incoming
498
+
# machines. You could also use the %u option to tailor it by user name.
499
+
# The %m gets replaced with the machine name that is connecting.
500
+
;[pchome]
501
+
; comment = PC Directories
502
+
; path = /usr/pc/%m
503
+
; public = no
504
+
; writable = yes
505
+
506
+
507
+
-----------------------------------------------------------
508
+
# A publicly accessible directory, read/write to all users. Note that
509
+
# all files created in the directory by users will be owned by the
510
+
# default user, so any user with access can delete any other user's
511
+
# files. Obviously this directory must be writable by the default user.
512
+
# Another user could of course be specified, in which case all files
513
+
# would be owned by that user instead.
514
+
515
+
;[public]
516
+
; path = /usr/somewhere/else/public
517
+
; public = yes
518
+
; only guest = yes
519
+
; writable = yes
520
+
; printable = no
521
+
522
+
-----------------------------------------------------------
523
+
524
+
# The following two entries demonstrate how to share a directory so
525
+
# that two users can place files there that will be owned by the
526
+
# specific users. In this setup, the directory should be writable by
527
+
# both users and should have the sticky bit set on it to prevent abuse.
528
+
# Obviously this could be extended to as many users as required.
529
+
530
+
;[myshare]
531
+
; comment = Mary's and Fred's stuff
532
+
; path = /usr/somewhere/shared
533
+
; valid users = mary fred
534
+
; public = no
535
+
; writable = yes
536
+
; printable = no
537
+
; create mask = 0765
+69
test/data/cfgparser.3
+69
test/data/cfgparser.3
···
1
+
# INI with as many tricky parts as possible
2
+
# Most of them could not be used before 3.2
3
+
4
+
# This will be parsed with the following options
5
+
# delimiters = {'='}
6
+
# comment_prefixes = {'#'}
7
+
# allow_no_value = True
8
+
9
+
[DEFAULT]
10
+
go = %(interpolate)s
11
+
12
+
[strange]
13
+
values = that are indented # and end with hash comments
14
+
other = that do continue
15
+
in # and still have
16
+
other # comments mixed
17
+
lines # with the values
18
+
19
+
20
+
21
+
22
+
23
+
[corruption]
24
+
value = that is
25
+
26
+
27
+
actually still here
28
+
29
+
30
+
and holds all these weird newlines
31
+
32
+
33
+
# but not for the lines that are comments
34
+
nor the indentation
35
+
36
+
another value = # empty string
37
+
yet another # None!
38
+
39
+
[yeah, sections can be indented as well]
40
+
and that does not mean = anything
41
+
are they subsections = False
42
+
if you want subsections = use XML
43
+
lets use some Unicode = 片仮名
44
+
45
+
[another one!]
46
+
even if values are indented like this = seriously
47
+
yes, this still applies to = section "another one!"
48
+
this too = are there people with configurations broken as this?
49
+
beware, this is going to be a continuation
50
+
of the value for
51
+
key "this too"
52
+
even if it has a = character
53
+
this is still the continuation
54
+
your editor probably highlights it wrong
55
+
but that's life
56
+
# let's set this value so there is no error
57
+
# when getting all items for this section:
58
+
interpolate = anything will do
59
+
60
+
[no values here]
61
+
# but there's this `go` in DEFAULT
62
+
63
+
[tricky interpolation]
64
+
interpolate = do this
65
+
lets = %(go)s
66
+
67
+
[more interpolation]
68
+
interpolate = go shopping
69
+
lets = %(go)s
+373
test/test_init.ml
+373
test/test_init.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Test suite for Init INI library *)
7
+
8
+
(* ---- Test Utilities ---- *)
9
+
10
+
let check_ok msg = function
11
+
| Ok x -> x
12
+
| Error e -> Alcotest.fail (msg ^ ": " ^ e)
13
+
14
+
(* ---- Codec Tests ---- *)
15
+
16
+
(* Helper: decode a single value using a section codec wrapped in a document *)
17
+
let decode_value codec value =
18
+
let section_codec = Init.Section.(
19
+
obj (fun v -> v)
20
+
|> mem "value" codec ~enc:Fun.id
21
+
|> finish
22
+
) in
23
+
let doc_codec = Init.Document.(
24
+
obj (fun v -> v)
25
+
|> section "test" section_codec ~enc:Fun.id
26
+
|> finish
27
+
) in
28
+
let ini_str = Printf.sprintf "[test]\nvalue = %s\n" value in
29
+
Init_bytesrw.decode_string doc_codec ini_str
30
+
31
+
let test_string_codec () =
32
+
let v = decode_value Init.string "hello" in
33
+
Alcotest.(check (result string string)) "string decode"
34
+
(Ok "hello") v
35
+
36
+
let test_int_codec () =
37
+
let v = decode_value Init.int "42" in
38
+
Alcotest.(check (result int string)) "int decode"
39
+
(Ok 42) v
40
+
41
+
let test_bool_codec () =
42
+
let check_true s =
43
+
let v = decode_value Init.bool s in
44
+
Alcotest.(check (result bool string)) ("bool decode " ^ s)
45
+
(Ok true) v
46
+
in
47
+
let check_false s =
48
+
let v = decode_value Init.bool s in
49
+
Alcotest.(check (result bool string)) ("bool decode " ^ s)
50
+
(Ok false) v
51
+
in
52
+
check_true "1"; check_true "yes"; check_true "true"; check_true "on";
53
+
check_true "YES"; check_true "True"; check_true "ON";
54
+
check_false "0"; check_false "no"; check_false "false"; check_false "off";
55
+
check_false "NO"; check_false "False"; check_false "OFF"
56
+
57
+
let test_list_codec () =
58
+
let v = decode_value (Init.list Init.int) "1,2,3" in
59
+
Alcotest.(check (result (list int) string)) "list decode"
60
+
(Ok [1; 2; 3]) v
61
+
62
+
let test_option_codec () =
63
+
(* Test Some case *)
64
+
let v1 = decode_value (Init.option Init.int) "42" in
65
+
Alcotest.(check (result (option int) string)) "option decode Some"
66
+
(Ok (Some 42)) v1
67
+
68
+
let test_enum_codec () =
69
+
let color_pp fmt = function
70
+
| `Red -> Format.pp_print_string fmt "Red"
71
+
| `Green -> Format.pp_print_string fmt "Green"
72
+
| `Blue -> Format.pp_print_string fmt "Blue"
73
+
in
74
+
let v = decode_value (Init.enum ["red", `Red; "green", `Green; "blue", `Blue]) "green" in
75
+
Alcotest.(check (result (of_pp color_pp) string)) "enum decode"
76
+
(Ok `Green) v
77
+
78
+
let codec_tests = [
79
+
"string codec", `Quick, test_string_codec;
80
+
"int codec", `Quick, test_int_codec;
81
+
"bool codec", `Quick, test_bool_codec;
82
+
"list codec", `Quick, test_list_codec;
83
+
"option codec", `Quick, test_option_codec;
84
+
"enum codec", `Quick, test_enum_codec;
85
+
]
86
+
87
+
(* ---- Section Codec Tests ---- *)
88
+
89
+
type server_config = {
90
+
host : string;
91
+
port : int;
92
+
debug : bool;
93
+
}
94
+
95
+
let server_codec = Init.Section.(
96
+
obj (fun host port debug -> { host; port; debug })
97
+
|> mem "host" Init.string ~enc:(fun c -> c.host)
98
+
|> mem "port" Init.int ~enc:(fun c -> c.port)
99
+
|> mem "debug" Init.bool ~dec_absent:false ~enc:(fun c -> c.debug)
100
+
|> finish
101
+
)
102
+
103
+
let test_section_decode () =
104
+
let doc_codec = Init.Document.(
105
+
obj (fun server -> server)
106
+
|> section "server" server_codec ~enc:Fun.id
107
+
|> finish
108
+
) in
109
+
let config = check_ok "decode" @@ Init_bytesrw.decode_string doc_codec {|
110
+
[server]
111
+
host = localhost
112
+
port = 8080
113
+
|} in
114
+
Alcotest.(check string) "host" "localhost" config.host;
115
+
Alcotest.(check int) "port" 8080 config.port;
116
+
Alcotest.(check bool) "debug default" false config.debug
117
+
118
+
let test_section_decode_with_optional () =
119
+
let doc_codec = Init.Document.(
120
+
obj (fun server -> server)
121
+
|> section "server" server_codec ~enc:Fun.id
122
+
|> finish
123
+
) in
124
+
let config = check_ok "decode" @@ Init_bytesrw.decode_string doc_codec {|
125
+
[server]
126
+
host = example.com
127
+
port = 443
128
+
debug = true
129
+
|} in
130
+
Alcotest.(check string) "host" "example.com" config.host;
131
+
Alcotest.(check int) "port" 443 config.port;
132
+
Alcotest.(check bool) "debug" true config.debug
133
+
134
+
let section_tests = [
135
+
"section decode", `Quick, test_section_decode;
136
+
"section decode with optional", `Quick, test_section_decode_with_optional;
137
+
]
138
+
139
+
(* ---- Document Codec Tests ---- *)
140
+
141
+
type app_config = {
142
+
server : server_config;
143
+
}
144
+
145
+
let app_codec = Init.Document.(
146
+
obj (fun server -> { server })
147
+
|> section "server" server_codec ~enc:(fun c -> c.server)
148
+
|> finish
149
+
)
150
+
151
+
let test_document_decode () =
152
+
let config = check_ok "decode" @@ Init_bytesrw.decode_string app_codec {|
153
+
[server]
154
+
host = localhost
155
+
port = 8080
156
+
|} in
157
+
Alcotest.(check string) "host" "localhost" config.server.host;
158
+
Alcotest.(check int) "port" 8080 config.server.port
159
+
160
+
let test_document_roundtrip () =
161
+
let original = { server = { host = "example.com"; port = 443; debug = true } } in
162
+
let encoded = check_ok "encode" @@ Init_bytesrw.encode_string app_codec original in
163
+
let decoded = check_ok "decode" @@ Init_bytesrw.decode_string app_codec encoded in
164
+
Alcotest.(check string) "host roundtrip" original.server.host decoded.server.host;
165
+
Alcotest.(check int) "port roundtrip" original.server.port decoded.server.port;
166
+
Alcotest.(check bool) "debug roundtrip" original.server.debug decoded.server.debug
167
+
168
+
let document_tests = [
169
+
"document decode", `Quick, test_document_decode;
170
+
"document roundtrip", `Quick, test_document_roundtrip;
171
+
]
172
+
173
+
(* ---- Parsing Tests ---- *)
174
+
175
+
let test_simple_parse () =
176
+
let section_codec = Init.Section.(
177
+
obj (fun key -> key)
178
+
|> mem "key" Init.string ~enc:Fun.id
179
+
|> finish
180
+
) in
181
+
let doc_codec = Init.Document.(
182
+
obj (fun section -> section)
183
+
|> section "section" section_codec ~enc:Fun.id
184
+
|> finish
185
+
) in
186
+
let v = check_ok "parse" @@ Init_bytesrw.decode_string doc_codec {|
187
+
[section]
188
+
key = value
189
+
|} in
190
+
Alcotest.(check string) "simple value" "value" v
191
+
192
+
let test_multiline_value () =
193
+
let section_codec = Init.Section.(
194
+
obj (fun key -> key)
195
+
|> mem "key" Init.string ~enc:Fun.id
196
+
|> finish
197
+
) in
198
+
let doc_codec = Init.Document.(
199
+
obj (fun section -> section)
200
+
|> section "section" section_codec ~enc:Fun.id
201
+
|> finish
202
+
) in
203
+
let v = check_ok "parse" @@ Init_bytesrw.decode_string doc_codec {|
204
+
[section]
205
+
key = first line
206
+
second line
207
+
third line
208
+
|} in
209
+
Alcotest.(check string) "multiline" "first line\nsecond line\nthird line" v
210
+
211
+
let test_comments () =
212
+
let section_codec = Init.Section.(
213
+
obj (fun key -> key)
214
+
|> mem "key" Init.string ~enc:Fun.id
215
+
|> finish
216
+
) in
217
+
let doc_codec = Init.Document.(
218
+
obj (fun section -> section)
219
+
|> section "section" section_codec ~enc:Fun.id
220
+
|> finish
221
+
) in
222
+
let v = check_ok "parse" @@ Init_bytesrw.decode_string doc_codec {|
223
+
# This is a comment
224
+
[section]
225
+
; This is also a comment
226
+
key = value
227
+
|} in
228
+
Alcotest.(check string) "with comments" "value" v
229
+
230
+
let test_empty_value () =
231
+
let section_codec = Init.Section.(
232
+
obj (fun empty -> empty)
233
+
|> mem "empty" Init.string ~enc:Fun.id
234
+
|> finish
235
+
) in
236
+
let doc_codec = Init.Document.(
237
+
obj (fun section -> section)
238
+
|> section "section" section_codec ~enc:Fun.id
239
+
|> finish
240
+
) in
241
+
let v = check_ok "parse" @@ Init_bytesrw.decode_string doc_codec {|
242
+
[section]
243
+
empty =
244
+
|} in
245
+
Alcotest.(check string) "empty value" "" v
246
+
247
+
let test_colon_delimiter () =
248
+
let section_codec = Init.Section.(
249
+
obj (fun key -> key)
250
+
|> mem "key" Init.string ~enc:Fun.id
251
+
|> finish
252
+
) in
253
+
let doc_codec = Init.Document.(
254
+
obj (fun section -> section)
255
+
|> section "section" section_codec ~enc:Fun.id
256
+
|> finish
257
+
) in
258
+
let v = check_ok "parse" @@ Init_bytesrw.decode_string doc_codec {|
259
+
[section]
260
+
key : value
261
+
|} in
262
+
Alcotest.(check string) "colon delimiter" "value" v
263
+
264
+
let test_case_insensitive_options () =
265
+
let section_codec = Init.Section.(
266
+
obj (fun key -> key)
267
+
|> mem "key" Init.string ~enc:Fun.id (* lowercase lookup *)
268
+
|> finish
269
+
) in
270
+
let doc_codec = Init.Document.(
271
+
obj (fun section -> section)
272
+
|> section "section" section_codec ~enc:Fun.id
273
+
|> finish
274
+
) in
275
+
let v = check_ok "parse" @@ Init_bytesrw.decode_string doc_codec {|
276
+
[section]
277
+
KEY = value
278
+
|} in
279
+
Alcotest.(check string) "lowercase lookup" "value" v
280
+
281
+
let test_basic_interpolation () =
282
+
let section_codec = Init.Section.(
283
+
obj (fun base data -> (base, data))
284
+
|> mem "base" Init.string ~enc:fst
285
+
|> mem "data" Init.string ~enc:snd
286
+
|> finish
287
+
) in
288
+
let doc_codec = Init.Document.(
289
+
obj (fun section -> section)
290
+
|> section "section" section_codec ~enc:Fun.id
291
+
|> finish
292
+
) in
293
+
let (_, data) = check_ok "parse" @@ Init_bytesrw.decode_string doc_codec {|
294
+
[section]
295
+
base = /opt/app
296
+
data = %(base)s/data
297
+
|} in
298
+
Alcotest.(check string) "basic interpolation" "/opt/app/data" data
299
+
300
+
let test_extended_interpolation () =
301
+
let paths_codec = Init.Section.(
302
+
obj (fun base -> base)
303
+
|> mem "base" Init.string ~enc:Fun.id
304
+
|> finish
305
+
) in
306
+
let data_codec = Init.Section.(
307
+
obj (fun dir -> dir)
308
+
|> mem "dir" Init.string ~enc:Fun.id
309
+
|> finish
310
+
) in
311
+
let doc_codec = Init.Document.(
312
+
obj (fun paths data -> (paths, data))
313
+
|> section "paths" paths_codec ~enc:fst
314
+
|> section "data" data_codec ~enc:snd
315
+
|> finish
316
+
) in
317
+
let config = { Init_bytesrw.default_config with
318
+
interpolation = Init_bytesrw.Extended_interpolation } in
319
+
let (_, dir) = check_ok "parse" @@ Init_bytesrw.decode_string ~config doc_codec {|
320
+
[paths]
321
+
base = /opt/app
322
+
323
+
[data]
324
+
dir = ${paths:base}/data
325
+
|} in
326
+
Alcotest.(check string) "extended interpolation" "/opt/app/data" dir
327
+
328
+
let parsing_tests = [
329
+
"simple parse", `Quick, test_simple_parse;
330
+
"multiline value", `Quick, test_multiline_value;
331
+
"comments", `Quick, test_comments;
332
+
"empty value", `Quick, test_empty_value;
333
+
"colon delimiter", `Quick, test_colon_delimiter;
334
+
"case insensitive options", `Quick, test_case_insensitive_options;
335
+
"basic interpolation", `Quick, test_basic_interpolation;
336
+
"extended interpolation", `Quick, test_extended_interpolation;
337
+
]
338
+
339
+
(* ---- CPython Compatibility Tests ---- *)
340
+
341
+
let test_cfgparser_1 () =
342
+
let section_codec = Init.Section.(
343
+
obj (fun foo -> foo)
344
+
|> mem "foo" Init.string ~enc:Fun.id
345
+
|> skip_unknown
346
+
|> finish
347
+
) in
348
+
let doc_codec = Init.Document.(
349
+
obj (fun foobar -> foobar)
350
+
|> section "Foo Bar" section_codec ~enc:Fun.id
351
+
|> finish
352
+
) in
353
+
let v = check_ok "parse cfgparser.1" @@ Init_bytesrw.decode_string doc_codec
354
+
{|# Also used by idlelib.test_idle.test_config.
355
+
[Foo Bar]
356
+
foo=newbar
357
+
|} in
358
+
Alcotest.(check string) "foo value" "newbar" v
359
+
360
+
let cpython_tests = [
361
+
"cfgparser.1", `Quick, test_cfgparser_1;
362
+
]
363
+
364
+
(* ---- Main ---- *)
365
+
366
+
let () =
367
+
Alcotest.run "Init" [
368
+
"parsing", parsing_tests;
369
+
"codecs", codec_tests;
370
+
"sections", section_tests;
371
+
"documents", document_tests;
372
+
"cpython", cpython_tests;
373
+
]