Source file Xmlns_effect.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
(*
 * SPDX-FileCopyrightText: 2024 The Forester Project Contributors
 *
 * SPDX-License-Identifier: GPL-3.0-or-later
 *)

open Types

module String_map = Map.Make(String)

module Xmlns_map = struct
  type t = {
    prefix_to_xmlns: string String_map.t;
    xmlns_to_prefixes: string list String_map.t
  }

  let empty = {
    prefix_to_xmlns = String_map.empty;
    xmlns_to_prefixes = String_map.empty
  }

  let assoc ~prefix ~xmlns env = {
    prefix_to_xmlns = String_map.add prefix xmlns env.prefix_to_xmlns;
    xmlns_to_prefixes = String_map.add_to_list xmlns prefix env.xmlns_to_prefixes
  }
end

module Make_writer (Elt : sig type t end) = struct
  type _ Effect.t += Yield : Elt.t -> unit Effect.t

  let yield x = Effect.perform (Yield x)

  let run f =
    let open Effect.Deep in
    try_with
      (fun () -> let r = f () in [], r)
      ()
      {
        effc = fun (type a) (eff : a Effect.t) ->
          match eff with
          | Yield x ->
            Option.some @@ fun (k : (a, _) continuation) ->
            let xs, r = continue k () in
            x :: xs, r
          | _ -> None
      }

  let register_printer f =
    Printexc.register_printer @@ function
      | Effect.Unhandled (Yield elt) -> f (`Yield elt)
      | _ -> None

  let () = register_printer @@ fun _ -> Some "Unhandled effect; use Make_writer.run"
end

module Make () = struct
  module E = Algaeff.State.Make(Xmlns_map)
  module Decls = Make_writer(struct type t = xmlns_attr end)

  let find_xmlns_for_prefix prefix =
    let env = E.get () in
    String_map.find_opt prefix env.prefix_to_xmlns

  let smallest_string strings =
    List.hd @@ List.sort (fun s1 s2 -> compare (String.length s1) (String.length s2)) strings

  let rec normalise_qname (qname : xml_qname) =
    let scope = E.get () in
    match qname.xmlns with
    | None ->
      begin
        match String_map.find_opt qname.prefix scope.prefix_to_xmlns with
        | None -> qname
        | Some xmlns -> {qname with xmlns = Some xmlns}
      end
    | Some xmlns ->
      begin
        match String_map.find_opt qname.prefix scope.prefix_to_xmlns,
        String_map.find_opt xmlns scope.xmlns_to_prefixes with
        | None, (None | Some []) ->
          E.modify (Xmlns_map.assoc ~prefix: qname.prefix ~xmlns);
          Decls.yield {prefix = qname.prefix; xmlns};
          qname
        | Some xmlns', Some prefixes ->
          if xmlns' = xmlns && List.mem qname.prefix prefixes then
            {qname with prefix = try smallest_string prefixes with _ -> qname.prefix}
          else
            normalise_qname {qname with prefix = qname.prefix ^ "_"}
        | None, Some prefixes ->
          {qname with prefix = try smallest_string prefixes with _ -> qname.prefix}
        | Some _, None ->
          normalise_qname {qname with prefix = qname.prefix ^ "_"}
      end

  let within_scope kont =
    let old_scope = E.get () in
    let added, r = Decls.run kont in
    E.set old_scope;
    added, r

  let run ~reserved kont =
    let init =
      let alg env ({prefix; xmlns}: xmlns_attr) =
        Xmlns_map.assoc ~prefix ~xmlns env
      in
      List.fold_left alg Xmlns_map.empty reserved
    in
    E.run ~init kont
end