forked from
jonmsterling.com/ocaml-forester
ocaml
A simplified replacement for Xmlns_effect
The old version was more powerful but it was impossible to reason about.
+86
-43
+5
-2
lib/core/Types.ml
+5
-2
lib/core/Types.ml
···
39
39
expanded = None;
40
40
}
41
41
42
-
type 'content xml_attr = {key: xml_qname; value: 'content}
42
+
type 'content xml_attr = 'content Forester_xml_names.xml_attr = {
43
+
key: xml_qname;
44
+
value: 'content;
45
+
}
43
46
[@@deriving show, repr]
44
47
45
-
type 'content xml_elt = {
48
+
type 'content xml_elt = 'content Forester_xml_names.xml_elt = {
46
49
name: xml_qname;
47
50
attrs: 'content xml_attr list;
48
51
content: 'content;
+17
-18
lib/frontend/Html_client.ml
+17
-18
lib/frontend/Html_client.ml
···
16
16
module X = Xml_forester
17
17
end
18
18
19
-
module Xmlns = Xmlns_effect.Make ()
20
-
21
19
type env = {
22
20
forest: State.t;
23
21
scope: URI.t option;
24
22
section_depth: int;
25
23
loops: Loop_detection.t;
24
+
xmlns: Xmlns.t;
26
25
}
27
26
28
27
let hx ~env attrs children =
···
36
35
frontmatter forest
37
36
38
37
let render_xml_qname qname =
39
-
let qname = Xmlns.normalise_qname qname in
40
38
match qname.prefix with
41
39
| "" -> qname.uname
42
40
| _ -> Format.sprintf "%s:%s" qname.prefix qname.uname
43
41
44
-
let render_xml_attr (forest : State.t) T.{key; value} =
45
-
let str_value = Plain_text_client.string_of_content ~forest value in
42
+
let render_xml_attr ~env T.{key; value} =
43
+
let str_value =
44
+
Plain_text_client.string_of_content ~forest:env.forest value
45
+
in
46
46
P.string_attr (render_xml_qname key) "%s" str_value
47
47
48
48
let render_xmlns_prefix ({prefix; xmlns} : Forester_xml_names.xmlns_attr) =
···
66
66
| CDATA str -> [P.txt ~raw:true "<![CDATA[%s]]>" str]
67
67
| Uri uri -> [P.txt "%s" (URI.to_string uri)]
68
68
| Xml_elt elt ->
69
-
let prefixes_to_add, (name, attrs, content) =
70
-
let@ () = Xmlns.within_scope in
71
-
( render_xml_qname elt.name,
72
-
List.map (render_xml_attr env.forest) elt.attrs,
73
-
render_content ~env elt.content )
74
-
in
75
-
let attrs =
76
-
let xmlns_attrs = List.map render_xmlns_prefix prefixes_to_add in
77
-
attrs @ xmlns_attrs
78
-
in
79
-
[P.std_tag name attrs content]
69
+
let name = render_xml_qname elt.name in
70
+
let xmlns_attrs = Xmlns.xmlns_attrs_for_elt elt env.xmlns in
71
+
let env = {env with xmlns = Xmlns.extend xmlns_attrs env.xmlns} in
72
+
let content = render_content ~env elt.content in
73
+
[
74
+
P.std_tag name
75
+
(List.map render_xmlns_prefix xmlns_attrs
76
+
@ List.map (render_xml_attr ~env) elt.attrs)
77
+
content;
78
+
]
80
79
| Route_of_uri uri -> [P.txt "%s" (route uri)]
81
80
| Contextual_number uri ->
82
81
let custom_number =
···
144
143
145
144
let render_article_as_div ?(heading_level = 0) (forest : State.t)
146
145
(article : T.content T.article) : P.node =
146
+
let reserved = [{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}] in
147
147
let env =
148
148
{
149
149
forest;
150
150
section_depth = heading_level;
151
151
scope = article.frontmatter.uri;
152
152
loops = Loop_detection.empty;
153
+
xmlns = Xmlns.init ~reserved;
153
154
}
154
155
in
155
-
let reserved = [{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}] in
156
-
let@ () = Xmlns.run ~reserved in
157
156
P.HTML.div
158
157
(List.map render_xmlns_prefix reserved)
159
158
[
+13
-22
lib/frontend/Legacy_xml_client.ml
+13
-22
lib/frontend/Legacy_xml_client.ml
···
16
16
module X = Xml_forester
17
17
end
18
18
19
-
module Xmlns = struct
20
-
include Xmlns_effect.Make ()
21
-
22
-
let run (k : xmlns_attr list -> 'a) =
23
-
run ~reserved:X.reserved_xmlnss @@ fun () -> k X.reserved_xmlnss
24
-
end
25
-
26
19
let local_path_components (config : Config.t) (uri : URI.t) =
27
20
let host = Option.get @@ URI.host uri in
28
21
let base_host = Option.get @@ URI.host config.url in
···
51
44
in_backmatter: bool;
52
45
uri: URI.t option;
53
46
loops: Loop_detection.t;
47
+
xmlns: Xmlns.t;
54
48
}
55
49
56
50
let range ~env =
···
62
56
Range.make (position, position)
63
57
64
58
let render_xml_qname qname =
65
-
let qname = Xmlns.normalise_qname qname in
66
59
match qname.prefix with
67
60
| "" -> qname.uname
68
61
| _ -> Format.sprintf "%s:%s" qname.prefix qname.uname
···
89
82
]
90
83
91
84
let rec render_section ~env (section : T.content T.section) : P.node =
92
-
let@ _ = Xmlns.run in
93
85
X.tree
94
86
(render_section_flags section.flags)
95
87
[
···
190
182
[P.txt "%s" (URI.display_path_string ~base:env.forest.config.url uri)]
191
183
| Route_of_uri uri -> [P.txt "%s" (URI.to_string (route env.forest uri))]
192
184
| Xml_elt elt ->
193
-
let prefixes_to_add, (name, attrs, content) =
194
-
let@ () = Xmlns.within_scope in
195
-
( render_xml_qname elt.name,
196
-
List.map (render_xml_attr ~env) elt.attrs,
197
-
render_content ~env elt.content )
198
-
in
199
-
let attrs =
200
-
let xmlns_attrs = List.map render_xmlns_prefix prefixes_to_add in
201
-
attrs @ xmlns_attrs
202
-
in
203
-
[P.std_tag name attrs content]
185
+
let xmlns_attrs = Xmlns.xmlns_attrs_for_elt elt env.xmlns in
186
+
let env = {env with xmlns = Xmlns.extend xmlns_attrs env.xmlns} in
187
+
let content = render_content ~env elt.content in
188
+
[
189
+
P.std_tag
190
+
(render_xml_qname elt.name)
191
+
(List.map render_xmlns_prefix xmlns_attrs
192
+
@ List.map (render_xml_attr ~env) elt.attrs)
193
+
content;
194
+
]
204
195
| Transclude transclusion -> render_transclusion ~env transclusion
205
196
| Contextual_number uri ->
206
197
let custom_number =
···
361
352
result
362
353
in
363
354
let config = forest.config in
364
-
let@ xmlnss = Xmlns.run in
365
355
let env =
366
356
{
367
357
forest;
368
358
in_backmatter = false;
369
359
uri = article.frontmatter.uri;
370
360
loops = Loop_detection.empty;
361
+
xmlns = Xmlns.init ~reserved:X.reserved_xmlnss;
371
362
}
372
363
in
373
364
X.tree
374
365
begin
375
-
List.map render_xmlns_prefix xmlnss
366
+
List.map render_xmlns_prefix X.reserved_xmlnss
376
367
@ [
377
368
X.optional_ X.root
378
369
@@ begin
+1
lib/xml_names/Forester_xml_names.ml
+1
lib/xml_names/Forester_xml_names.ml
+10
lib/xml_names/Types.ml
+10
lib/xml_names/Types.ml
···
9
9
type xml_qname = {prefix: string; uname: string; xmlns: string option}
10
10
[@@deriving show, repr]
11
11
12
+
type 'content xml_attr = {key: xml_qname; value: 'content}
13
+
[@@deriving show, repr]
14
+
15
+
type 'content xml_elt = {
16
+
name: xml_qname;
17
+
attrs: 'content xml_attr list;
18
+
content: 'content;
19
+
}
20
+
[@@deriving show, repr]
21
+
12
22
let split_xml_qname str =
13
23
match String.split_on_char ':' str with
14
24
| [prefix; uname] -> (Some prefix, uname)
+33
lib/xml_names/Xmlns.ml
+33
lib/xml_names/Xmlns.ml
···
1
+
open Types
2
+
3
+
module Prefix_map = Map.Make (String)
4
+
type t = string Prefix_map.t
5
+
6
+
let init ~(reserved : xmlns_attr list) =
7
+
List.fold_left
8
+
(fun env (attr : xmlns_attr) -> Prefix_map.add attr.prefix attr.xmlns env)
9
+
Prefix_map.empty reserved
10
+
11
+
let xmlns_attr_of_qname (q : xml_qname) : xmlns_attr option =
12
+
match q.xmlns with
13
+
| None -> None
14
+
| Some xmlns -> Some {prefix = q.prefix; xmlns}
15
+
16
+
let xmlns_attr_is_new (attr : xmlns_attr) env : bool =
17
+
match Prefix_map.find_opt attr.prefix env with
18
+
| None -> true
19
+
| Some uri' -> uri' <> attr.xmlns
20
+
21
+
let extend (bindings : xmlns_attr list) env : t =
22
+
List.fold_left
23
+
(fun env (attr : xmlns_attr) -> Prefix_map.add attr.prefix attr.xmlns env)
24
+
env bindings
25
+
26
+
let xmlns_attrs_for_elt (elt : 'a xml_elt) env : xmlns_attr list =
27
+
let from_name =
28
+
match xmlns_attr_of_qname elt.name with None -> [] | Some b -> [b]
29
+
in
30
+
let from_attrs =
31
+
elt.attrs |> List.filter_map @@ fun attr -> xmlns_attr_of_qname attr.key
32
+
in
33
+
List.filter (fun attr -> xmlns_attr_is_new attr env) @@ from_name @ from_attrs
+7
lib/xml_names/Xmlns.mli
+7
lib/xml_names/Xmlns.mli