Source file format.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
(*****************************************************************************)
(*                                                                           *)
(*  Copyright (C) 2026 Yves Ndiaye                                           *)
(*                                                                           *)
(* This Source Code Form is subject to the terms of the Mozilla Public       *)
(* License, v. 2.0. If a copy of the MPL was not distributed with this       *)
(* file, You can obtain one at https://mozilla.org/MPL/2.0/.                 *)
(*                                                                           *)
(*****************************************************************************)

module Node = struct
  type t =
    | Text of string
    | String of Field.String.Key.t
    | Bool of Field.Bool.Key.t
    | Int64 of Field.Int64.Key.t
    | Int of Field.Int.Key.t
    | Float of Field.Float.Key.t

  let conv = function
    | `String s ->
        String s
    | `Bool s ->
        Bool s
    | `Int64 s ->
        Int64 s
    | `Int s ->
        Int s
    | `Float s ->
        Float s

  let to_string = function
    | Text s ->
        s
    | String s ->
        Field.String.Key.to_string s
    | Bool s ->
        Field.Bool.Key.to_string s
    | Int64 s ->
        Field.Int64.Key.to_string s
    | Int s ->
        Field.Int.Key.to_string s
    | Float s ->
        Field.Float.Key.to_string s

  let to_text = function
    | Text s ->
        s
    | String _ | Bool _ | Int64 _ | Int _ | Float _ ->
        String.empty

  let equal lhs rhs =
    match (lhs, rhs) with
    | Text lhs, Text rhs ->
        String.equal lhs rhs
    | String l, String r ->
        Field.String.Key.equal l r
    | Bool l, Bool r ->
        Field.Bool.Key.equal l r
    | Int64 l, Int64 r ->
        Field.Int64.Key.equal l r
    | Int l, Int r ->
        Field.Int.Key.equal l r
    | Float l, Float r ->
        Field.Float.Key.equal l r
    | _, _ ->
        false

  let substitute m node =
    match
      List.find_map
        (fun (key, value) ->
          if equal key node then
            Some value
          else
            None
        )
        m
    with
    | None ->
        node
    | Some txt ->
        Text txt
end

type t = Node.t list

let of_string s =
  let rec flatten buffer = function
    | [] ->
        let s = Buffer.contents buffer in
        if s = String.empty then
          []
        else
          Node.Text s :: []
    | `Char c :: q ->
        let () = Buffer.add_char buffer c in
        flatten buffer q
    | `String s :: q ->
        let () = Buffer.add_string buffer s in
        flatten buffer q
    | `Field f :: q ->
        let f = Node.conv f in
        let s = Buffer.contents buffer in
        if s = String.empty then
          f :: flatten buffer q
        else
          let () = Buffer.clear buffer in
          Node.Text s :: f :: flatten buffer q
  in
  let r =
    match Angstrom.parse_string ~consume:All Parser.parser_format_string s with
    | Ok s ->
        s
    | Error _ ->
        [ `String s ]
  in
  flatten (Buffer.create 18) r

let map f s = List.map f s
let to_string s = s |> List.map Node.to_string |> String.concat String.empty
let to_text s = s |> List.map Node.to_text |> String.concat String.empty
let equal lhs rhs = List.equal Node.equal lhs rhs
let substitute m nodes = List.map (Node.substitute m) nodes
let to_list = Fun.id
let of_list = Fun.id