forked from
jonmsterling.com/ocaml-forester
ocaml
Delete Xmlns_effect
-142
-1
lib/xml_names/Forester_xml_names.ml
-1
lib/xml_names/Forester_xml_names.ml
-127
lib/xml_names/Xmlns_effect.ml
-127
lib/xml_names/Xmlns_effect.ml
···
1
-
(*
2
-
* SPDX-FileCopyrightText: 2024 The Forester Project Contributors
3
-
*
4
-
* SPDX-License-Identifier: GPL-3.0-or-later
5
-
*)
6
-
7
-
open Types
8
-
module String_map = Map.Make (String)
9
-
10
-
module Xmlns_map = struct
11
-
type t = {
12
-
prefix_to_xmlns: string String_map.t;
13
-
xmlns_to_prefixes: string list String_map.t;
14
-
}
15
-
16
-
let empty =
17
-
{prefix_to_xmlns = String_map.empty; xmlns_to_prefixes = String_map.empty}
18
-
19
-
let assoc ~prefix ~xmlns env =
20
-
{
21
-
prefix_to_xmlns = String_map.add prefix xmlns env.prefix_to_xmlns;
22
-
xmlns_to_prefixes =
23
-
String_map.add_to_list xmlns prefix env.xmlns_to_prefixes;
24
-
}
25
-
end
26
-
27
-
module Make_writer (Elt : sig
28
-
type t
29
-
end) =
30
-
struct
31
-
type _ Effect.t += Yield : Elt.t -> unit Effect.t
32
-
33
-
let yield x = Effect.perform (Yield x)
34
-
35
-
let run f =
36
-
let open Effect.Deep in
37
-
try_with
38
-
(fun () ->
39
-
let r = f () in
40
-
([], r))
41
-
()
42
-
{
43
-
effc =
44
-
(fun (type a) (eff : a Effect.t) ->
45
-
match eff with
46
-
| Yield x ->
47
-
Option.some @@ fun (k : (a, _) continuation) ->
48
-
let xs, r = continue k () in
49
-
(x :: xs, r)
50
-
| _ -> None);
51
-
}
52
-
53
-
let register_printer f =
54
-
Printexc.register_printer @@ function
55
-
| Effect.Unhandled (Yield elt) -> f (`Yield elt)
56
-
| _ -> None
57
-
58
-
let () =
59
-
register_printer @@ fun _ -> Some "Unhandled effect; use Make_writer.run"
60
-
end
61
-
62
-
module Make () = struct
63
-
module E = Algaeff.State.Make (Xmlns_map)
64
-
65
-
let () = E.register_printer (function _ -> Some "Unhandled Xmlns effect.")
66
-
67
-
module Decls = Make_writer (struct
68
-
type t = xmlns_attr
69
-
end)
70
-
71
-
let find_xmlns_for_prefix prefix =
72
-
let env = E.get () in
73
-
String_map.find_opt prefix env.prefix_to_xmlns
74
-
75
-
let smallest_string strings =
76
-
List.hd
77
-
@@ List.sort
78
-
(fun s1 s2 -> compare (String.length s1) (String.length s2))
79
-
strings
80
-
81
-
let rec normalise_qname (qname : xml_qname) =
82
-
let scope = E.get () in
83
-
match qname.xmlns with
84
-
| None -> begin
85
-
match String_map.find_opt qname.prefix scope.prefix_to_xmlns with
86
-
| None -> qname
87
-
| Some xmlns -> {qname with xmlns = Some xmlns}
88
-
end
89
-
| Some xmlns -> begin
90
-
match
91
-
( String_map.find_opt qname.prefix scope.prefix_to_xmlns,
92
-
String_map.find_opt xmlns scope.xmlns_to_prefixes )
93
-
with
94
-
| None, (None | Some []) ->
95
-
E.modify (Xmlns_map.assoc ~prefix:qname.prefix ~xmlns);
96
-
Decls.yield {prefix = qname.prefix; xmlns};
97
-
qname
98
-
| Some xmlns', Some prefixes ->
99
-
if xmlns' = xmlns && List.mem qname.prefix prefixes then
100
-
{
101
-
qname with
102
-
prefix = (try smallest_string prefixes with _ -> qname.prefix);
103
-
}
104
-
else normalise_qname {qname with prefix = qname.prefix ^ "_"}
105
-
| None, Some prefixes ->
106
-
{
107
-
qname with
108
-
prefix = (try smallest_string prefixes with _ -> qname.prefix);
109
-
}
110
-
| Some _, None -> normalise_qname {qname with prefix = qname.prefix ^ "_"}
111
-
end
112
-
113
-
let within_scope kont =
114
-
let old_scope = E.get () in
115
-
let added, r = Decls.run kont in
116
-
E.set old_scope;
117
-
(added, r)
118
-
119
-
let run ~reserved kont =
120
-
let init =
121
-
let alg env ({prefix; xmlns} : xmlns_attr) =
122
-
Xmlns_map.assoc ~prefix ~xmlns env
123
-
in
124
-
List.fold_left alg Xmlns_map.empty reserved
125
-
in
126
-
E.run ~init kont
127
-
end
-14
lib/xml_names/Xmlns_effect.mli
-14
lib/xml_names/Xmlns_effect.mli
···
1
-
(*
2
-
* SPDX-FileCopyrightText: 2024 The Forester Project Contributors
3
-
*
4
-
* SPDX-License-Identifier: GPL-3.0-or-later
5
-
*)
6
-
7
-
open Types
8
-
9
-
module Make () : sig
10
-
val normalise_qname : xml_qname -> xml_qname
11
-
val within_scope : (unit -> 'a) -> xmlns_attr list * 'a
12
-
val find_xmlns_for_prefix : string -> string option
13
-
val run : reserved:xmlns_attr list -> (unit -> 'a) -> 'a
14
-
end