(*--------------------------------------------------------------------------- Copyright (c) 2025 Anil Madhavapeddy . All rights reserved. SPDX-License-Identifier: ISC ---------------------------------------------------------------------------*) (** Declarative INI data manipulation for OCaml. Init provides bidirectional codecs for INI files following Python's configparser semantics. *) type 'a fmt = Format.formatter -> 'a -> unit (* ---- Text Locations ---- *) module Textloc = struct type fpath = string let file_none = "-" type byte_pos = int let byte_pos_none = -1 type line_num = int let line_num_none = -1 type line_pos = line_num * byte_pos let line_pos_first = (1, 0) let line_pos_none = (line_num_none, byte_pos_none) type t = { file : fpath; first_byte : byte_pos; last_byte : byte_pos; first_line : line_pos; last_line : line_pos; } let none = { file = file_none; first_byte = byte_pos_none; last_byte = byte_pos_none; first_line = line_pos_none; last_line = line_pos_none; } let make ~file ~first_byte ~last_byte ~first_line ~last_line = { file; first_byte; last_byte; first_line; last_line } let file t = t.file let set_file t file = { t with file } let first_byte t = t.first_byte let last_byte t = t.last_byte let first_line t = t.first_line let last_line t = t.last_line let is_none t = t.first_byte < 0 let is_empty t = t.first_byte > t.last_byte let equal t0 t1 = String.equal t0.file t1.file && t0.first_byte = t1.first_byte && t0.last_byte = t1.last_byte let compare t0 t1 = let c = String.compare t0.file t1.file in if c <> 0 then c else let c = Int.compare t0.first_byte t1.first_byte in if c <> 0 then c else Int.compare t0.last_byte t1.last_byte let set_first t ~first_byte ~first_line = { t with first_byte; first_line } let set_last t ~last_byte ~last_line = { t with last_byte; last_line } let to_first t = { t with last_byte = t.first_byte; last_line = t.first_line } let to_last t = { t with first_byte = t.last_byte; first_line = t.last_line } let before t = { t with last_byte = t.first_byte - 1; last_line = t.first_line } let after t = { t with first_byte = t.last_byte + 1; first_line = t.last_line } let span t0 t1 = let first_byte, first_line, last_byte, last_line, file = if t0.first_byte <= t1.first_byte then if t0.last_byte >= t1.last_byte then t0.first_byte, t0.first_line, t0.last_byte, t0.last_line, t0.file else t0.first_byte, t0.first_line, t1.last_byte, t1.last_line, t1.file else if t1.last_byte >= t0.last_byte then t1.first_byte, t1.first_line, t1.last_byte, t1.last_line, t1.file else t1.first_byte, t1.first_line, t0.last_byte, t0.last_line, t0.file in { file; first_byte; last_byte; first_line; last_line } let reloc ~first ~last = { file = last.file; first_byte = first.first_byte; first_line = first.first_line; last_byte = last.last_byte; last_line = last.last_line } let pp_ocaml ppf t = let l, c = t.first_line in let el, ec = t.last_line in if is_none t then Format.fprintf ppf "%s" t.file else if is_empty t then Format.fprintf ppf "%s:%d:%d" t.file l (t.first_byte - c) else if l = el then Format.fprintf ppf "%s:%d:%d-%d" t.file l (t.first_byte - c) (t.last_byte - ec) else Format.fprintf ppf "%s:%d:%d-%d:%d" t.file l (t.first_byte - c) el (t.last_byte - ec) let pp_gnu ppf t = let l, c = t.first_line in if is_none t then Format.fprintf ppf "%s" t.file else Format.fprintf ppf "%s:%d.%d" t.file l (t.first_byte - c + 1) let pp = pp_ocaml let pp_dump ppf t = Format.fprintf ppf "@[{file=%S;@ first_byte=%d;@ last_byte=%d;@ \ first_line=(%d,%d);@ last_line=(%d,%d)}@]" t.file t.first_byte t.last_byte (fst t.first_line) (snd t.first_line) (fst t.last_line) (snd t.last_line) end (* ---- Metadata ---- *) module Meta = struct type t = { textloc : Textloc.t; ws_before : string; ws_after : string; comment : string option; (* Associated comment *) } let none = { textloc = Textloc.none; ws_before = ""; ws_after = ""; comment = None; } let make ?(ws_before = "") ?(ws_after = "") ?comment textloc = { textloc; ws_before; ws_after; comment } let is_none t = Textloc.is_none t.textloc let textloc t = t.textloc let ws_before t = t.ws_before let ws_after t = t.ws_after let comment t = t.comment let with_textloc t textloc = { t with textloc } let with_ws_before t ws_before = { t with ws_before } let with_ws_after t ws_after = { t with ws_after } let with_comment t comment = { t with comment } let clear_ws t = { t with ws_before = ""; ws_after = "" } let clear_textloc t = { t with textloc = Textloc.none } let copy_ws src ~dst = { dst with ws_before = src.ws_before; ws_after = src.ws_after } end type 'a node = 'a * Meta.t (* ---- Paths ---- *) module Path = struct type index = | Section of string node | Option of string node let pp_index ppf = function | Section (s, _) -> Format.fprintf ppf "[%s]" s | Option (s, _) -> Format.fprintf ppf "%s" s type t = index list (* Reversed *) let root = [] let is_root = function [] -> true | _ -> false let section ?(meta = Meta.none) name path = Section (name, meta) :: path let option ?(meta = Meta.none) name path = Option (name, meta) :: path let rev_indices t = t let pp ppf t = let rec loop = function | [] -> () | [i] -> pp_index ppf i | i :: rest -> loop rest; Format.fprintf ppf "/"; pp_index ppf i in loop (List.rev t) end (* ---- Errors ---- *) module Error = struct type kind = | Parse of string | Codec of string | Missing_section of string | Missing_option of { section : string; option : string } | Duplicate_section of string | Duplicate_option of { section : string; option : string } | Type_mismatch of { expected : string; got : string } | Interpolation of { option : string; reason : string } | Unknown_option of string | Unknown_section of string type t = { kind : kind; meta : Meta.t; path : Path.t; } let make ?(meta = Meta.none) ?(path = Path.root) kind = { kind; meta; path } let kind e = e.kind let meta e = e.meta let path e = e.path exception Error of t let raise ?meta ?path kind = raise (Error (make ?meta ?path kind)) let kind_to_string = function | Parse msg -> Printf.sprintf "parse error: %s" msg | Codec msg -> Printf.sprintf "codec error: %s" msg | Missing_section name -> Printf.sprintf "missing section: [%s]" name | Missing_option { section; option } -> Printf.sprintf "missing option '%s' in section [%s]" option section | Duplicate_section name -> Printf.sprintf "duplicate section: [%s]" name | Duplicate_option { section; option } -> Printf.sprintf "duplicate option '%s' in section [%s]" option section | Type_mismatch { expected; got } -> Printf.sprintf "type mismatch: expected %s, got %s" expected got | Interpolation { option; reason } -> Printf.sprintf "interpolation error in '%s': %s" option reason | Unknown_option name -> Printf.sprintf "unknown option: %s" name | Unknown_section name -> Printf.sprintf "unknown section: [%s]" name let to_string e = let loc = if Meta.is_none e.meta then "" else Format.asprintf "%a: " Textloc.pp (Meta.textloc e.meta) in let path = if Path.is_root e.path then "" else Format.asprintf " at %a" Path.pp e.path in Printf.sprintf "%s%s%s" loc (kind_to_string e.kind) path let pp ppf e = Format.pp_print_string ppf (to_string e) end (* ---- Codec Types ---- *) (* Internal representation for codec implementations *) module Repr = struct (* A decoded INI value with metadata *) type ini_value = { raw : string; (* Raw string value *) interpolated : string; (* After interpolation *) meta : Meta.t; } (* A section's options *) type ini_section = { name : string node; options : (string node * ini_value) list; meta : Meta.t; (* Section header metadata *) } (* A full INI document *) type ini_doc = { defaults : (string node * ini_value) list; sections : ini_section list; meta : Meta.t; (* Document metadata *) } (* Codec error during decode/encode *) type 'a codec_result = ('a, Error.t) result (* Section decoder state *) type 'dec section_state = { decode : ini_section -> 'dec codec_result; encode : 'dec -> ini_section; known_options : string list; unknown_handler : [ `Skip | `Error | `Keep ]; } (* Document decoder state *) type 'dec document_state = { decode : ini_doc -> 'dec codec_result; encode : 'dec -> ini_doc; known_sections : string list; unknown_handler : [ `Skip | `Error ]; } end (* The abstract codec type *) type 'a t = { kind : string; doc : string; (* Value-level decode/encode (for individual option values) *) dec : Repr.ini_value -> ('a, Error.t) result; enc : 'a -> Meta.t -> Repr.ini_value; (* Section-level decode/encode (for Section.finish) *) section : 'a Repr.section_state option; (* Document-level decode/encode (for Document.finish) *) document : 'a Repr.document_state option; } let kind c = c.kind let doc c = c.doc let with_doc ?kind:k ?doc:d c = { c with kind = Option.value ~default:c.kind k; doc = Option.value ~default:c.doc d } let section_state c = c.section let document_state c = c.document (* ---- Base Codecs ---- *) let make_value_codec ~kind ~doc ~dec ~enc = { kind; doc; dec; enc; section = None; document = None; } let string = make_value_codec ~kind:"string" ~doc:"" ~dec:(fun v -> Ok v.Repr.interpolated) ~enc:(fun s meta -> { Repr.raw = s; interpolated = s; meta }) let int = make_value_codec ~kind:"integer" ~doc:"" ~dec:(fun v -> match int_of_string_opt v.Repr.interpolated with | Some i -> Ok i | None -> Error (Error.make (Type_mismatch { expected = "integer"; got = v.interpolated }))) ~enc:(fun i meta -> let s = Int.to_string i in { Repr.raw = s; interpolated = s; meta }) let int32 = make_value_codec ~kind:"int32" ~doc:"" ~dec:(fun v -> match Int32.of_string_opt v.Repr.interpolated with | Some i -> Ok i | None -> Error (Error.make (Type_mismatch { expected = "int32"; got = v.interpolated }))) ~enc:(fun i meta -> let s = Int32.to_string i in { Repr.raw = s; interpolated = s; meta }) let int64 = make_value_codec ~kind:"int64" ~doc:"" ~dec:(fun v -> match Int64.of_string_opt v.Repr.interpolated with | Some i -> Ok i | None -> Error (Error.make (Type_mismatch { expected = "int64"; got = v.interpolated }))) ~enc:(fun i meta -> let s = Int64.to_string i in { Repr.raw = s; interpolated = s; meta }) let float = make_value_codec ~kind:"float" ~doc:"" ~dec:(fun v -> match float_of_string_opt v.Repr.interpolated with | Some f -> Ok f | None -> Error (Error.make (Type_mismatch { expected = "float"; got = v.interpolated }))) ~enc:(fun f meta -> let s = Float.to_string f in { Repr.raw = s; interpolated = s; meta }) (* Python configparser-compatible boolean parsing *) let parse_bool s = match String.lowercase_ascii s with | "1" | "yes" | "true" | "on" -> Some true | "0" | "no" | "false" | "off" -> Some false | _ -> None let bool = make_value_codec ~kind:"boolean" ~doc:"Accepts: 1/yes/true/on (true), 0/no/false/off (false)" ~dec:(fun v -> match parse_bool v.Repr.interpolated with | Some b -> Ok b | None -> Error (Error.make (Type_mismatch { expected = "boolean (yes/no/true/false/on/off/1/0)"; got = v.interpolated }))) ~enc:(fun b meta -> let s = if b then "true" else "false" in { Repr.raw = s; interpolated = s; meta }) let bool_01 = make_value_codec ~kind:"boolean (0/1)" ~doc:"" ~dec:(fun v -> match v.Repr.interpolated with | "1" -> Ok true | "0" -> Ok false | s -> Error (Error.make (Type_mismatch { expected = "0 or 1"; got = s }))) ~enc:(fun b meta -> let s = if b then "1" else "0" in { Repr.raw = s; interpolated = s; meta }) let bool_yesno = make_value_codec ~kind:"boolean (yes/no)" ~doc:"" ~dec:(fun v -> match String.lowercase_ascii v.Repr.interpolated with | "yes" -> Ok true | "no" -> Ok false | s -> Error (Error.make (Type_mismatch { expected = "yes or no"; got = s }))) ~enc:(fun b meta -> let s = if b then "yes" else "no" in { Repr.raw = s; interpolated = s; meta }) let bool_truefalse = make_value_codec ~kind:"boolean (true/false)" ~doc:"" ~dec:(fun v -> match String.lowercase_ascii v.Repr.interpolated with | "true" -> Ok true | "false" -> Ok false | s -> Error (Error.make (Type_mismatch { expected = "true or false"; got = s }))) ~enc:(fun b meta -> let s = if b then "true" else "false" in { Repr.raw = s; interpolated = s; meta }) let bool_onoff = make_value_codec ~kind:"boolean (on/off)" ~doc:"" ~dec:(fun v -> match String.lowercase_ascii v.Repr.interpolated with | "on" -> Ok true | "off" -> Ok false | s -> Error (Error.make (Type_mismatch { expected = "on or off"; got = s }))) ~enc:(fun b meta -> let s = if b then "on" else "off" in { Repr.raw = s; interpolated = s; meta }) (* ---- Combinators ---- *) let map ?kind:k ?doc:d ~dec ~enc c = let kind = Option.value ~default:c.kind k in let doc = Option.value ~default:c.doc d in { kind; doc; dec = (fun v -> Result.map dec (c.dec v)); enc = (fun x meta -> c.enc (enc x) meta); section = None; document = None; } let enum ?cmp ?kind ?doc assoc = let cmp = Option.value ~default:Stdlib.compare cmp in let kind = Option.value ~default:"enum" kind in let doc = Option.value ~default:"" doc in let lc_assoc = List.map (fun (k, v) -> (String.lowercase_ascii k, v)) assoc in let rev_assoc = List.map (fun (s, v) -> (v, s)) assoc in make_value_codec ~kind ~doc ~dec:(fun v -> match List.assoc_opt (String.lowercase_ascii v.Repr.interpolated) lc_assoc with | Some x -> Ok x | None -> Error (Error.make (Type_mismatch { expected = kind; got = v.interpolated }))) ~enc:(fun x meta -> match List.find_opt (fun (v', _) -> cmp x v' = 0) rev_assoc with | Some (_, s) -> { Repr.raw = s; interpolated = s; meta } | None -> failwith "enum value not in association list") let option ?kind ?doc c = let kind = Option.value ~default:("optional " ^ c.kind) kind in let doc = Option.value ~default:c.doc doc in { kind; doc; dec = (fun v -> if v.Repr.interpolated = "" then Ok None else Result.map Option.some (c.dec v)); enc = (function | Some x -> c.enc x | None -> fun meta -> { Repr.raw = ""; interpolated = ""; meta }); section = None; document = None; } let default def c = { c with dec = (fun v -> Ok (Result.value ~default:def (c.dec v))); } let list ?(sep = ',') c = { kind = "list of " ^ c.kind; doc = ""; dec = (fun v -> if v.Repr.interpolated = "" then Ok [] else let parts = String.split_on_char sep v.Repr.interpolated in let parts = List.map String.trim parts in let rec decode_all acc = function | [] -> Ok (List.rev acc) | part :: rest -> let pv = { v with Repr.raw = part; interpolated = part } in match c.dec pv with | Ok x -> decode_all (x :: acc) rest | Error e -> Error e in decode_all [] parts); enc = (fun xs meta -> let parts = List.map (fun x -> (c.enc x meta).Repr.interpolated) xs in let s = String.concat (String.make 1 sep ^ " ") parts in { Repr.raw = s; interpolated = s; meta }); section = None; document = None; } (* ---- Result helpers ---- *) module Result_syntax = struct let ( let* ) = Result.bind end (* ---- Section Codecs ---- *) module Section = struct type 'a codec = 'a t type ('o, 'dec) map = { kind : string; doc : string; decode : Repr.ini_section -> 'dec Repr.codec_result; encode : 'o -> Repr.ini_section; known : string list; unknown : [ `Skip | `Error | `Keep ]; } let obj ?kind ?doc (f : 'dec) : ('o, 'dec) map = let kind = Option.value ~default:"section" kind in let doc = Option.value ~default:"" doc in { kind; doc; decode = (fun _ -> Ok f); encode = (fun _ -> { Repr.name = ("", Meta.none); options = []; meta = Meta.none; }); known = []; unknown = `Skip; } let mem ?doc:_ ?dec_absent ?enc ?enc_omit name (c : 'a codec) (m : ('o, 'a -> 'dec) map) : ('o, 'dec) map = let open Result_syntax in let lc_name = String.lowercase_ascii name in { m with known = lc_name :: m.known; decode = (fun sec -> let opt = List.find_opt (fun ((n, _), _) -> String.lowercase_ascii n = lc_name) sec.Repr.options in let decoded = match opt with | Some (_, v) -> c.dec v | None -> Option.to_result ~none:(Error.make (Missing_option { section = fst sec.name; option = name })) dec_absent in let* a = decoded in let* f = m.decode sec in Ok (f a)); encode = (fun o -> let sec = m.encode o in match enc with | None -> sec | Some enc_fn -> let v = enc_fn o in let should_omit = Option.fold ~none:false ~some:(fun f -> f v) enc_omit in if should_omit then sec else let iv = c.enc v Meta.none in { sec with options = ((name, Meta.none), iv) :: sec.options }); } let opt_mem ?doc ?enc name c m = let opt_c = option c in let enc' = Option.map (fun f o -> f o) enc in mem ?doc ~dec_absent:None ?enc:enc' ~enc_omit:Option.is_none name opt_c m let skip_unknown m = { m with unknown = `Skip } let error_unknown m = { m with unknown = `Error } let keep_unknown ?enc (m : ('o, (string * string) list -> 'dec) map) : ('o, 'dec) map = { kind = m.kind; doc = m.doc; known = m.known; unknown = `Keep; decode = (fun sec -> let unknown_opts = List.filter_map (fun ((n, _), v) -> let lc_n = String.lowercase_ascii n in if List.mem lc_n m.known then None else Some (n, v.Repr.interpolated) ) sec.Repr.options in m.decode sec |> Result.map (fun f -> f unknown_opts)); encode = (fun o -> let sec = m.encode o in match enc with | None -> sec | Some enc_fn -> let new_opts = List.map (fun (k, v) -> ((k, Meta.none), { Repr.raw = v; interpolated = v; meta = Meta.none }) ) (enc_fn o) in { sec with options = new_opts @ sec.options }); } let finish (m : ('o, 'o) map) : 'o codec = let section_state : 'o Repr.section_state = { decode = (fun sec -> (* Check for unknown options *) (match m.unknown with | `Skip -> () | `Keep -> () | `Error -> List.iter (fun ((n, _), _) -> let lc_n = String.lowercase_ascii n in if not (List.mem lc_n m.known) then Error.raise (Unknown_option n) ) sec.Repr.options); m.decode sec); encode = (fun o -> let sec = m.encode o in { sec with options = List.rev sec.options }); known_options = m.known; unknown_handler = m.unknown; } in { kind = m.kind; doc = m.doc; dec = (fun _ -> Error (Error.make (Codec "section codec requires section-level decode"))); enc = (fun _ _ -> { Repr.raw = ""; interpolated = ""; meta = Meta.none }); section = Some section_state; document = None; } end (* ---- Document Codecs ---- *) module Document = struct type 'a codec = 'a t type ('o, 'dec) map = { kind : string; doc : string; decode : Repr.ini_doc -> 'dec Repr.codec_result; encode : 'o -> Repr.ini_doc; known : string list; unknown : [ `Skip | `Error ]; } let obj ?kind ?doc (f : 'dec) : ('o, 'dec) map = let kind = Option.value ~default:"document" kind in let doc = Option.value ~default:"" doc in { kind; doc; decode = (fun _ -> Ok f); encode = (fun _ -> { Repr.defaults = []; sections = []; meta = Meta.none; }); known = []; unknown = `Skip; } let get_section_state sec_codec fn_name = match sec_codec.section with | Some s -> s | None -> failwith (fn_name ^ ": codec must be a section codec") let section ?doc:_ ?enc name (sec_codec : 'a codec) (m : ('o, 'a -> 'dec) map) : ('o, 'dec) map = let open Result_syntax in let sec_state = get_section_state sec_codec "section" in let lc_name = String.lowercase_ascii name in { m with known = lc_name :: m.known; decode = (fun doc -> let sec = List.find_opt (fun s -> String.lowercase_ascii (fst s.Repr.name) = lc_name) doc.Repr.sections in let* sec = Option.to_result ~none:(Error.make (Missing_section name)) sec in let* a = sec_state.decode sec in let* f = m.decode doc in Ok (f a)); encode = (fun o -> let doc = m.encode o in match enc with | None -> doc | Some enc_fn -> let sec = sec_state.encode (enc_fn o) in { doc with sections = { sec with name = (name, Meta.none) } :: doc.sections }); } let opt_section ?doc:_ ?enc name (sec_codec : 'a codec) (m : ('o, 'a option -> 'dec) map) : ('o, 'dec) map = let open Result_syntax in let sec_state = get_section_state sec_codec "opt_section" in let lc_name = String.lowercase_ascii name in { m with known = lc_name :: m.known; decode = (fun doc -> let sec = List.find_opt (fun s -> String.lowercase_ascii (fst s.Repr.name) = lc_name) doc.Repr.sections in let* value = match sec with | None -> Ok None | Some sec -> let* a = sec_state.decode sec in Ok (Some a) in let* f = m.decode doc in Ok (f value)); encode = (fun o -> let doc = m.encode o in match enc with | None -> doc | Some enc_fn -> match enc_fn o with | None -> doc | Some v -> let sec = sec_state.encode v in { doc with sections = { sec with name = (name, Meta.none) } :: doc.sections }); } let defaults ?doc:_ ?enc (sec_codec : 'a codec) (m : ('o, 'a -> 'dec) map) : ('o, 'dec) map = let open Result_syntax in let sec_state = get_section_state sec_codec "defaults" in { m with known = "default" :: m.known; decode = (fun doc -> let fake_sec = { Repr.name = ("DEFAULT", Meta.none); options = doc.defaults; meta = Meta.none; } in let* a = sec_state.decode fake_sec in let* f = m.decode doc in Ok (f a)); encode = (fun o -> let doc = m.encode o in match enc with | None -> doc | Some enc_fn -> let v = enc_fn o in let sec = sec_state.encode v in { doc with defaults = sec.options }); } let opt_defaults ?doc:_ ?enc (sec_codec : 'a codec) (m : ('o, 'a option -> 'dec) map) : ('o, 'dec) map = let open Result_syntax in let sec_state = get_section_state sec_codec "opt_defaults" in { m with known = "default" :: m.known; decode = (fun doc -> let* value = if doc.Repr.defaults = [] then Ok None else let fake_sec = { Repr.name = ("DEFAULT", Meta.none); options = doc.defaults; meta = Meta.none; } in let* a = sec_state.decode fake_sec in Ok (Some a) in let* f = m.decode doc in Ok (f value)); encode = (fun o -> let doc = m.encode o in match enc with | None -> doc | Some enc_fn -> match enc_fn o with | None -> doc | Some v -> let sec = sec_state.encode v in { doc with defaults = sec.options }); } let skip_unknown m = { m with unknown = `Skip } let error_unknown m = { m with unknown = `Error } let finish (m : ('o, 'o) map) : 'o codec = let document_state : 'o Repr.document_state = { decode = (fun doc -> (* Check for unknown sections *) (match m.unknown with | `Skip -> () | `Error -> List.iter (fun sec -> let lc_n = String.lowercase_ascii (fst sec.Repr.name) in if not (List.mem lc_n m.known) then Error.raise (Unknown_section (fst sec.name)) ) doc.Repr.sections); m.decode doc); encode = (fun o -> let doc = m.encode o in { doc with sections = List.rev doc.sections }); known_sections = m.known; unknown_handler = m.unknown; } in { kind = m.kind; doc = m.doc; dec = (fun _ -> Error (Error.make (Codec "document codec requires document-level decode"))); enc = (fun _ _ -> { Repr.raw = ""; interpolated = ""; meta = Meta.none }); section = None; document = Some document_state; } end