forked from
jonmsterling.com/ocaml-forester
ocaml
Legacy_xml_client, Html_client: refactoring to remove effects
Xmlns_effect still remains.
+198
-160
+37
-11
lib/frontend/Html_client.ml
+37
-11
lib/frontend/Html_client.ml
···
17
17
end
18
18
19
19
module Xmlns = Xmlns_effect.Make ()
20
-
module Loop_detection = Loop_detection_effect.Make ()
21
20
22
-
type env = {forest: State.t; scope: URI.t option; section_depth: int}
21
+
type env = {
22
+
forest: State.t;
23
+
scope: URI.t option;
24
+
section_depth: int;
25
+
loops: Loop_detection.t;
26
+
}
23
27
24
28
let hx ~env attrs children =
25
29
P.std_tag (Format.sprintf "h%i" @@ min 6 env.section_depth) attrs children
···
120
124
| Some title ->
121
125
P.HTML.header [] [hx ~env [] @@ render_content ~env title]
122
126
end;
123
-
(if Loop_detection.have_seen_uri_opt section.frontmatter.uri then
124
-
P.txt "Transclusion loop detected, rendering stopped."
125
-
else
126
-
let@ () = Loop_detection.add_seen_uri_opt section.frontmatter.uri in
127
-
P.HTML.null @@ render_content ~env section.mainmatter);
127
+
begin if
128
+
Loop_detection.have_seen_uri_opt section.frontmatter.uri env.loops
129
+
then P.txt "Transclusion loop detected, rendering stopped."
130
+
else
131
+
P.HTML.null
132
+
@@ render_content
133
+
~env:
134
+
{
135
+
env with
136
+
loops =
137
+
Loop_detection.add_seen_uri_opt section.frontmatter.uri
138
+
env.loops;
139
+
}
140
+
section.mainmatter
141
+
end;
128
142
];
129
143
]
130
144
131
145
let render_article_as_div ?(heading_level = 0) (forest : State.t)
132
146
(article : T.content T.article) : P.node =
133
147
let env =
134
-
{forest; section_depth = heading_level; scope = article.frontmatter.uri}
148
+
{
149
+
forest;
150
+
section_depth = heading_level;
151
+
scope = article.frontmatter.uri;
152
+
loops = Loop_detection.empty;
153
+
}
135
154
in
136
-
let@ () = Loop_detection.run in
137
155
let reserved = [{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}] in
138
156
let@ () = Xmlns.run ~reserved in
139
157
P.HTML.div
140
158
(List.map render_xmlns_prefix reserved)
141
159
[
142
-
(let@ () = Loop_detection.add_seen_uri_opt article.frontmatter.uri in
143
-
P.HTML.null @@ render_content ~env article.mainmatter);
160
+
P.HTML.null
161
+
@@ render_content
162
+
~env:
163
+
{
164
+
env with
165
+
loops =
166
+
Loop_detection.add_seen_uri_opt article.frontmatter.uri
167
+
env.loops;
168
+
}
169
+
article.mainmatter;
144
170
]
+136
-124
lib/frontend/Legacy_xml_client.ml
+136
-124
lib/frontend/Legacy_xml_client.ml
···
23
23
run ~reserved:X.reserved_xmlnss @@ fun () -> k X.reserved_xmlnss
24
24
end
25
25
26
-
module In_backmatter = Algaeff.Reader.Make (struct
27
-
type t = bool
28
-
end)
29
-
30
26
let local_path_components (config : Config.t) (uri : URI.t) =
31
27
let host = Option.get @@ URI.host uri in
32
28
let base_host = Option.get @@ URI.host config.url in
···
40
36
let route (forest : State.t) uri : URI.t =
41
37
match forest.={uri} with
42
38
| None -> uri
43
-
| Some tree -> (
39
+
| Some tree -> begin
44
40
match Tree.to_evaluated tree with
45
41
| Some evaluated when evaluated.route_locally ->
46
42
let path = "" :: local_path_components forest.config uri in
47
43
URI.make ~path ()
48
-
| _ -> uri)
49
-
50
-
module Scope = struct
51
-
open struct
52
-
module E = Algaeff.Reader.Make (struct
53
-
type t = URI.t option
54
-
end)
44
+
| _ -> uri
55
45
end
56
46
57
-
let read = E.read
47
+
let mainmatter_cache = Hashtbl.create 1000
58
48
59
-
let run ~(forest : State.t) ~env kont =
60
-
let@ () = E.run ~env in
61
-
let loc_opt =
62
-
let@ uri = Option.bind env in
63
-
let@ path = Option.map @~ State.source_path_of_uri uri forest in
64
-
let position =
65
-
Range.{source = `File path; offset = 0; start_of_line = 0; line_num = 0}
66
-
in
67
-
Range.make (position, position)
68
-
in
69
-
let@ () = Reporter.with_loc loc_opt in
70
-
kont ()
71
-
end
72
-
73
-
module Loop_detection = Loop_detection_effect.Make ()
49
+
type env = {
50
+
forest: State.t;
51
+
in_backmatter: bool;
52
+
uri: URI.t option;
53
+
loops: Loop_detection.t;
54
+
}
74
55
75
-
let mainmatter_cache = Hashtbl.create 1000
56
+
let range ~env =
57
+
let@ uri = Option.bind env.uri in
58
+
let@ path = Option.map @~ State.source_path_of_uri uri env.forest in
59
+
let position =
60
+
Range.{source = `File path; offset = 0; start_of_line = 0; line_num = 0}
61
+
in
62
+
Range.make (position, position)
76
63
77
64
let render_xml_qname qname =
78
65
let qname = Xmlns.normalise_qname qname in
···
80
67
| "" -> qname.uname
81
68
| _ -> Format.sprintf "%s:%s" qname.prefix qname.uname
82
69
83
-
let render_xml_attr (forest : State.t) T.{key; value} =
70
+
let render_xml_attr ~env T.{key; value} =
84
71
let str_value =
85
-
Plain_text_client.string_of_content ~forest ~router:(route forest) value
72
+
Plain_text_client.string_of_content ~forest:env.forest
73
+
~router:(route env.forest) value
86
74
in
87
75
P.string_attr (render_xml_qname key) "%s" str_value
88
76
···
100
88
X.optional_ X.numbered dict.numbered;
101
89
]
102
90
103
-
let rec render_section forest (section : T.content T.section) : P.node =
91
+
let rec render_section ~env (section : T.content T.section) : P.node =
104
92
let@ _ = Xmlns.run in
105
93
X.tree
106
94
(render_section_flags section.flags)
107
95
[
108
-
render_frontmatter forest section.frontmatter;
109
-
(let@ () = Scope.run ~forest ~env:section.frontmatter.uri in
110
-
X.mainmatter []
111
-
@@
112
-
if Loop_detection.have_seen_uri_opt section.frontmatter.uri then
113
-
[X.info [] [P.txt "Transclusion loop detected, rendering stopped."]]
114
-
else
115
-
let@ () = Loop_detection.add_seen_uri_opt section.frontmatter.uri in
116
-
render_mainmatter forest section);
96
+
render_frontmatter ~env section.frontmatter;
97
+
begin
98
+
let env = {env with uri = section.frontmatter.uri} in
99
+
X.mainmatter []
100
+
@@
101
+
if Loop_detection.have_seen_uri_opt section.frontmatter.uri env.loops
102
+
then
103
+
[X.info [] [P.txt "Transclusion loop detected, rendering stopped."]]
104
+
else
105
+
render_mainmatter
106
+
~env:
107
+
{
108
+
env with
109
+
loops =
110
+
Loop_detection.add_seen_uri_opt section.frontmatter.uri
111
+
env.loops;
112
+
}
113
+
section
114
+
end;
117
115
]
118
116
119
-
and render_mainmatter forest (section : T.content T.section) =
117
+
and render_mainmatter ~env (section : T.content T.section) =
120
118
match section.frontmatter.uri with
121
-
| None -> render_content forest section.mainmatter
122
-
| Some uri -> (
119
+
| None -> render_content ~env section.mainmatter
120
+
| Some uri -> begin
123
121
match Hashtbl.find_opt mainmatter_cache uri with
124
122
| None ->
125
-
let nodes = render_content forest section.mainmatter in
123
+
let nodes = render_content ~env section.mainmatter in
126
124
Hashtbl.add mainmatter_cache uri nodes;
127
125
nodes
128
-
| Some nodes -> nodes)
126
+
| Some nodes -> nodes
127
+
end
129
128
130
-
and render_frontmatter (forest : State.t)
131
-
(frontmatter : T.content T.frontmatter) : P.node =
129
+
and render_frontmatter ~env (frontmatter : T.content T.frontmatter) : P.node =
132
130
let result =
133
131
X.frontmatter []
134
132
[
135
-
render_attributions forest frontmatter.uri frontmatter.attributions;
136
-
render_dates forest frontmatter.dates;
137
-
X.conditional forest.dev
138
-
(X.optional (X.source_path [] "%s") frontmatter.source_path);
133
+
render_attributions ~env frontmatter.uri frontmatter.attributions;
134
+
render_dates ~env frontmatter.dates;
135
+
X.conditional env.forest.dev
136
+
@@ X.optional (X.source_path [] "%s") frontmatter.source_path;
139
137
X.optional
140
138
(fun uri -> X.uri [] "%s" @@ URI.to_string uri)
141
139
frontmatter.uri;
142
140
X.optional
143
141
(fun uri ->
144
142
X.display_uri [] "%s"
145
-
@@ URI.display_path_string ~base:forest.config.url uri)
143
+
@@ URI.display_path_string ~base:env.forest.config.url uri)
146
144
frontmatter.uri;
147
145
X.optional (X.route [] "%s")
148
-
@@ Option.map (Fun.compose URI.to_string (route forest)) frontmatter.uri;
146
+
@@ Option.map
147
+
(Fun.compose URI.to_string (route env.forest))
148
+
frontmatter.uri;
149
149
begin match frontmatter.title with
150
150
| None -> X.null []
151
151
| Some _ ->
152
152
let title =
153
-
State.get_expanded_title ?scope:(Scope.read ()) frontmatter forest
153
+
State.get_expanded_title ?scope:env.uri frontmatter env.forest
154
154
in
155
155
X.title
156
156
[
157
157
X.text_ "%s"
158
-
@@ Plain_text_client.string_of_content ~forest
159
-
~router:(route forest) title;
158
+
@@ Plain_text_client.string_of_content ~forest:env.forest
159
+
~router:(route env.forest) title;
160
160
]
161
-
@@ render_content forest title
161
+
@@ render_content ~env title
162
162
end;
163
163
begin match frontmatter.taxon with
164
164
| None -> X.null []
165
-
| Some taxon -> X.taxon [] @@ render_content forest taxon
165
+
| Some taxon -> X.taxon [] @@ render_content ~env taxon
166
166
end;
167
-
X.null @@ List.map (render_meta forest) frontmatter.metas;
167
+
X.null @@ List.map (render_meta ~env) frontmatter.metas;
168
168
]
169
169
in
170
170
result
171
171
172
-
and render_meta forest (key, body) =
173
-
X.meta [X.name "%s" key] @@ render_content forest body
172
+
and render_meta ~env (key, body) =
173
+
X.meta [X.name "%s" key] @@ render_content ~env body
174
174
175
-
and render_content (forest : State.t) (Content content : T.content) :
176
-
P.node list =
175
+
and render_content ~env (Content content : T.content) : P.node list =
177
176
match content with
178
177
| T.Text txt0 :: T.Text txt1 :: content ->
179
-
render_content forest (Content (T.Text (txt0 ^ txt1) :: content))
178
+
render_content ~env (Content (T.Text (txt0 ^ txt1) :: content))
180
179
| node :: content ->
181
-
let xs = render_content_node forest node in
182
-
let ys = render_content forest (Content content) in
180
+
let xs = render_content_node ~env node in
181
+
let ys = render_content ~env (Content content) in
183
182
xs @ ys
184
183
| [] -> []
185
184
186
-
and render_content_node (forest : State.t) (node : 'a T.content_node) :
187
-
P.node list =
185
+
and render_content_node ~env (node : 'a T.content_node) : P.node list =
188
186
match node with
189
187
| Text str -> [P.txt "%s" str]
190
188
| CDATA str -> [P.txt ~raw:true "<![CDATA[%s]]>" str]
191
189
| Uri uri ->
192
-
[P.txt "%s" (URI.display_path_string ~base:forest.config.url uri)]
193
-
| Route_of_uri uri -> [P.txt "%s" (URI.to_string (route forest uri))]
190
+
[P.txt "%s" (URI.display_path_string ~base:env.forest.config.url uri)]
191
+
| Route_of_uri uri -> [P.txt "%s" (URI.to_string (route env.forest uri))]
194
192
| Xml_elt elt ->
195
193
let prefixes_to_add, (name, attrs, content) =
196
194
let@ () = Xmlns.within_scope in
197
195
( render_xml_qname elt.name,
198
-
List.map (render_xml_attr forest) elt.attrs,
199
-
render_content forest elt.content )
196
+
List.map (render_xml_attr ~env) elt.attrs,
197
+
render_content ~env elt.content )
200
198
in
201
199
let attrs =
202
200
let xmlns_attrs = List.map render_xmlns_prefix prefixes_to_add in
203
201
attrs @ xmlns_attrs
204
202
in
205
203
[P.std_tag name attrs content]
206
-
| Transclude transclusion -> render_transclusion forest transclusion
204
+
| Transclude transclusion -> render_transclusion ~env transclusion
207
205
| Contextual_number uri ->
208
206
let custom_number =
209
-
let@ resource = Option.bind @@ forest.@{uri} in
207
+
let@ resource = Option.bind @@ env.forest.@{uri} in
210
208
match resource with
211
209
| T.Article article -> article.frontmatter.number
212
210
| _ -> None
···
218
216
[
219
217
X.uri_ "%s" @@ URI.to_string uri;
220
218
X.display_uri_ "%s"
221
-
@@ URI.display_path_string ~base:forest.config.url uri;
219
+
@@ URI.display_path_string ~base:env.forest.config.url uri;
222
220
];
223
221
]
224
222
| Some num -> [P.txt "%s" num]
225
223
end
226
-
| Link link -> render_link forest link
224
+
| Link link -> render_link ~env link
227
225
| Results_of_datalog_query q ->
228
226
let article_to_section =
229
227
T.article_to_section
···
236
234
metadata_shown = Some true;
237
235
}
238
236
in
239
-
let results = Forest.run_datalog_query forest.graphs q in
240
-
let@ article = List.map @~ Forest_util.get_sorted_articles forest results in
241
-
render_section forest @@ article_to_section article
242
-
| Section section -> [render_section forest section]
237
+
let results = Forest.run_datalog_query env.forest.graphs q in
238
+
let@ article =
239
+
List.map @~ Forest_util.get_sorted_articles env.forest results
240
+
in
241
+
render_section ~env @@ article_to_section article
242
+
| Section section -> [render_section ~env section]
243
243
| KaTeX (mode, content) ->
244
244
let display = match mode with Inline -> "inline" | Display -> "block" in
245
245
let body = Format.asprintf "%a" TeX_like.pp_content content in
246
246
[X.tex [X.display "%s" display] "<![CDATA[%s]]>" body]
247
-
| Artefact resource -> [render_artefact forest resource]
247
+
| Artefact resource -> [render_artefact ~env resource]
248
248
| Datalog_script _ -> []
249
249
250
-
and render_artefact forest (resource : T.content T.artefact) =
250
+
and render_artefact ~env (resource : T.content T.artefact) =
251
251
X.resource
252
252
[X.hash "%s" resource.hash]
253
253
[
254
-
X.resource_content [] @@ render_content forest resource.content;
254
+
X.resource_content [] @@ render_content ~env resource.content;
255
255
render_resource_sources resource.sources;
256
256
]
257
257
···
263
263
[X.type_ "%s" source.type_; X.resource_part "%s" source.part]
264
264
"<![CDATA[%s]]>" source.source
265
265
266
-
and render_transclusion (forest : State.t) (transclusion : T.transclusion) :
267
-
P.node list =
268
-
match State.get_content_of_transclusion transclusion forest with
269
-
| None -> Reporter.fatal (Resource_not_found transclusion.href)
270
-
| Some content -> render_content forest content
266
+
and render_transclusion ~env (transclusion : T.transclusion) : P.node list =
267
+
match State.get_content_of_transclusion transclusion env.forest with
268
+
| None ->
269
+
Reporter.fatal ?loc:(range ~env) (Resource_not_found transclusion.href)
270
+
| Some content -> render_content ~env content
271
271
272
-
and render_link (forest : State.t) (link : T.content T.link) : P.node list =
273
-
let article_opt = State.get_article link.href forest in
272
+
and render_link ~env (link : T.content T.link) : P.node list =
273
+
let article_opt = State.get_article link.href env.forest in
274
274
let attrs =
275
275
match article_opt with
276
276
| None ->
277
-
begin if not @@ In_backmatter.read () then
278
-
match State.suggestion_for_uri link.href forest with
277
+
begin if not env.in_backmatter then
278
+
match State.suggestion_for_uri link.href env.forest with
279
279
| Ok -> ()
280
280
| Not_found {suggestion} ->
281
-
Reporter.emit @@ Broken_link {uri = link.href; suggestion}
281
+
Reporter.emit ?loc:(range ~env)
282
+
@@ Broken_link {uri = link.href; suggestion}
282
283
end;
283
284
[
284
-
X.href "%s" @@ URI.to_string @@ route forest link.href;
285
+
X.href "%s" @@ URI.to_string @@ route env.forest link.href;
285
286
X.type_ "external";
286
287
]
287
288
| Some article ->
288
289
[
289
-
X.href "%s" @@ URI.to_string @@ route forest link.href;
290
+
X.href "%s" @@ URI.to_string @@ route env.forest link.href;
290
291
X.title_ "%s"
291
-
@@ Plain_text_client.string_of_content ~forest ~router:(route forest)
292
-
@@ State.get_expanded_title ?scope:(Scope.read ()) article.frontmatter
293
-
forest;
292
+
@@ Plain_text_client.string_of_content ~forest:env.forest
293
+
~router:(route env.forest)
294
+
@@ State.get_expanded_title ?scope:env.uri article.frontmatter
295
+
env.forest;
294
296
X.optional_ (X.uri_ "%s")
295
297
@@ Option.map URI.to_string article.frontmatter.uri;
296
298
X.optional_ (X.display_uri_ "%s")
297
299
@@ Option.map
298
-
(URI.display_path_string ~base:forest.config.url)
300
+
(URI.display_path_string ~base:env.forest.config.url)
299
301
article.frontmatter.uri;
300
302
X.type_ "local";
301
303
]
302
304
in
303
-
[X.link attrs @@ render_content forest link.content]
305
+
[X.link attrs @@ render_content ~env link.content]
304
306
305
-
and render_attributions (forest : State.t) (scope : URI.t option)
307
+
and render_attributions ~env (scope : URI.t option)
306
308
(primary_attributions : _ T.attribution list) =
307
309
X.authors []
308
-
@@ List.map (render_attribution forest)
309
-
@@ Forest_util.collect_attributions forest scope primary_attributions
310
+
@@ List.map (render_attribution ~env)
311
+
@@ Forest_util.collect_attributions env.forest scope primary_attributions
310
312
311
-
and render_attribution forest (attrib : _ T.attribution) =
313
+
and render_attribution ~env (attrib : _ T.attribution) =
312
314
let tag =
313
315
match attrib.role with Author -> X.author | Contributor -> X.contributor
314
316
in
315
-
tag [] @@ render_attribution_vertex forest attrib.vertex
317
+
tag [] @@ render_attribution_vertex ~env attrib.vertex
316
318
317
-
and render_attribution_vertex (forest : State.t) vtx =
319
+
and render_attribution_vertex ~env vtx =
318
320
match vtx with
319
321
| T.Uri_vertex href ->
320
322
let content =
321
323
T.Content
322
324
[T.Transclude {href; target = Title {empty_when_untitled = false}}]
323
325
in
324
-
render_link forest T.{href; content}
325
-
| T.Content_vertex content -> render_content forest content
326
+
render_link ~env T.{href; content}
327
+
| T.Content_vertex content -> render_content ~env content
326
328
327
-
and render_dates forest dates = X.null @@ List.map (render_date forest) dates
329
+
and render_dates ~env dates = X.null @@ List.map (render_date ~env) dates
328
330
329
-
and render_date forest (date : Human_datetime.t) =
330
-
let config = forest.config in
331
+
and render_date ~env (date : Human_datetime.t) =
332
+
let config = env.forest.config in
331
333
let href_attr =
332
334
let str =
333
335
Format.asprintf "%a" Human_datetime.pp (Human_datetime.drop_time date)
334
336
in
335
337
let uri = URI_scheme.named_uri ~base:config.url str in
336
-
match State.get_article uri forest with
338
+
match State.get_article uri env.forest with
337
339
| None -> X.null_
338
-
| Some _ -> X.href "%s" @@ URI.to_string @@ route forest uri
340
+
| Some _ -> X.href "%s" @@ URI.to_string @@ route env.forest uri
339
341
in
340
342
X.date [href_attr]
341
343
[
···
359
361
result
360
362
in
361
363
let config = forest.config in
362
-
let@ () = Loop_detection.run in
363
-
let@ () = Scope.run ~forest ~env:article.frontmatter.uri in
364
364
let@ xmlnss = Xmlns.run in
365
-
let@ () = In_backmatter.run ~env:false in
365
+
let env =
366
+
{
367
+
forest;
368
+
in_backmatter = false;
369
+
uri = article.frontmatter.uri;
370
+
loops = Loop_detection.empty;
371
+
}
372
+
in
366
373
X.tree
367
374
begin
368
375
List.map render_xmlns_prefix xmlnss
···
376
383
]
377
384
end
378
385
[
379
-
render_frontmatter forest article.frontmatter;
386
+
render_frontmatter ~env article.frontmatter;
380
387
X.mainmatter []
381
388
@@ begin
382
-
let@ () = Loop_detection.add_seen_uri_opt article.frontmatter.uri in
383
-
render_mainmatter forest @@ T.article_to_section article
389
+
render_mainmatter
390
+
~env:
391
+
{
392
+
env with
393
+
loops =
394
+
Loop_detection.add_seen_uri_opt article.frontmatter.uri
395
+
env.loops;
396
+
}
397
+
@@ T.article_to_section article
384
398
end;
385
-
(X.backmatter []
386
-
@@
387
-
let@ () = In_backmatter.run ~env:true in
388
-
render_content forest article.backmatter);
399
+
X.backmatter []
400
+
@@ render_content ~env:{env with in_backmatter = true} article.backmatter;
389
401
]
390
402
391
403
let pp_xml ~(forest : State.t) ?stylesheet fmt (article : _ T.article) =
+16
lib/frontend/Loop_detection.ml
+16
lib/frontend/Loop_detection.ml
···
1
+
(*
2
+
* SPDX-FileCopyrightText: 2024 The Forester Project Contributors
3
+
*
4
+
* SPDX-License-Identifier: GPL-3.0-or-later
5
+
*)
6
+
7
+
open Forester_core
8
+
9
+
type t = URI.Set.t
10
+
let empty = URI.Set.empty
11
+
let add_seen_uri = URI.Set.add
12
+
let add_seen_uri_opt uri_opt =
13
+
match uri_opt with Some uri -> add_seen_uri uri | None -> Fun.id
14
+
let have_seen_uri = URI.Set.mem
15
+
let have_seen_uri_opt uri_opt =
16
+
match uri_opt with Some uri -> have_seen_uri uri | None -> fun _ -> false
+8
lib/frontend/Loop_detection.mli
+8
lib/frontend/Loop_detection.mli
-25
lib/frontend/Loop_detection_effect.ml
-25
lib/frontend/Loop_detection_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 Forester_core
8
-
9
-
module Make () = struct
10
-
open Algaeff.Reader.Make (struct
11
-
type t = URI.Set.t
12
-
end)
13
-
14
-
let add_seen_uri uri = scope @@ URI.Set.add uri
15
-
16
-
let add_seen_uri_opt uri_opt kont =
17
-
match uri_opt with None -> kont () | Some uri -> add_seen_uri uri kont
18
-
19
-
let have_seen_uri uri = URI.Set.mem uri @@ read ()
20
-
21
-
let have_seen_uri_opt uri_opt =
22
-
match uri_opt with None -> false | Some uri -> have_seen_uri uri
23
-
24
-
let run k = run ~env:URI.Set.empty k
25
-
end