forked from
jonmsterling.com/ocaml-forester
ocaml
Progress on Html_client
+432
-186
+3
-3
lib/frontend/Atom_client.ml
+3
-3
lib/frontend/Atom_client.ml
···
76
76
let render_dates dates = try render_dates_exn dates with _ -> A.null []
77
77
let string_of_content forest = Plain_text_client.string_of_content ~forest
78
78
79
-
let render_attribution forest (attribution : _ T.attribution) =
79
+
let render_attribution ~forest (attribution : _ T.attribution) =
80
80
let tag =
81
81
match attribution.role with
82
82
| T.Author -> A.author
···
100
100
101
101
let render_attributions (forest : State.t) uri_opt attributions : P.node =
102
102
A.null
103
-
@@ List.map (render_attribution forest)
103
+
@@ List.map (render_attribution ~forest)
104
104
@@ Forest_util.collect_attributions forest uri_opt attributions
105
105
106
106
let get_embedded_articles (forest : State.t) (article : _ T.article) =
···
142
142
end;
143
143
A.content
144
144
[A.type_ "xhtml"]
145
-
[Html_client.render_article_as_div ~heading_level:1 forest article];
145
+
[Html_client.render_article_as_div ~heading_level:1 ~forest article];
146
146
]
147
147
148
148
let render_feed (forest : State.t) ~(source_uri : URI.t) ~(feed_uri : URI.t) :
+2
lib/frontend/Forester_frontend.ml
+2
lib/frontend/Forester_frontend.ml
···
9
9
module Config_parser = Config_parser
10
10
module Forester = Forester
11
11
module DSL = DSL
12
+
module Loop_detection = Loop_detection
13
+
module Html_client = Html_client
12
14
module Htmx_client = Htmx_client
13
15
module Plain_text_client = Plain_text_client
14
16
module Legacy_xml_client = Legacy_xml_client
+272
-43
lib/frontend/Html_client.ml
+272
-43
lib/frontend/Html_client.ml
···
14
14
module T = Types
15
15
module P = Pure_html
16
16
module X = Xml_forester
17
+
module H = P.HTML
17
18
end
18
19
19
20
type env = {
···
27
28
let hx ~env attrs children =
28
29
P.std_tag (Format.sprintf "h%i" @@ min 6 env.section_depth) attrs children
29
30
31
+
let optional opt kont = match opt with None -> H.null [] | Some v -> kont v
32
+
33
+
(* test if the Home navbar be rendered*)
34
+
let is_root config uri =
35
+
match uri with
36
+
| None -> false
37
+
| Some uri -> URI.equal (Config.home_uri config) uri
38
+
39
+
let should_render_toc _article = false
40
+
30
41
let route uri = URI.to_string uri
31
42
32
-
let get_expanded_title ~env frontmatter forest =
43
+
let _get_expanded_title ~env frontmatter forest =
33
44
State.get_expanded_title ?scope:env.scope
34
45
~flags:T.{empty_when_untitled = true}
35
46
frontmatter forest
36
47
48
+
let render_date (date : Human_datetime.t) =
49
+
let year = P.txt "%i" (Human_datetime.year date) in
50
+
let month =
51
+
match Human_datetime.month date with
52
+
| None -> None
53
+
| Some i -> (
54
+
match i with
55
+
| 1 -> Some (P.txt "January")
56
+
| 2 -> Some (P.txt "February")
57
+
| 3 -> Some (P.txt "March")
58
+
| 4 -> Some (P.txt "April")
59
+
| 5 -> Some (P.txt "May")
60
+
| 6 -> Some (P.txt "June")
61
+
| 7 -> Some (P.txt "July")
62
+
| 8 -> Some (P.txt "August")
63
+
| 9 -> Some (P.txt "September")
64
+
| 10 -> Some (P.txt "October")
65
+
| 11 -> Some (P.txt "November")
66
+
| 12 -> Some (P.txt "December")
67
+
| _ -> assert false)
68
+
in
69
+
let day =
70
+
match Human_datetime.day date with
71
+
| None -> H.null []
72
+
| Some i -> P.txt "%i" i
73
+
in
74
+
H.li
75
+
[H.class_ "meta-item"]
76
+
[
77
+
H.a
78
+
[H.class_ "link local"]
79
+
[
80
+
Option.value ~default:(H.null []) month;
81
+
(if Option.is_some month then P.txt " " else H.null []);
82
+
day;
83
+
(if Option.is_some month then P.txt ", " else H.null []);
84
+
year;
85
+
];
86
+
]
87
+
37
88
let render_xml_qname qname =
38
89
match qname.prefix with
39
90
| "" -> qname.uname
···
96
147
| Results_of_datalog_query _ -> [] (* TODO: just make a list of links *)
97
148
| Datalog_script _ -> []
98
149
99
-
and render_link (forest : State.t) (link : T.content T.link) : P.node list = [
150
+
and render_link ~env (link : T.content T.link) : P.node list = [
100
151
P.HTML.a
101
152
[
102
153
P.HTML.href "%s" (URI.path_string link.href)
103
154
] @@
104
-
render_content forest link.content
155
+
render_content ~env link.content
105
156
]
106
157
107
158
and render_transclusion ~env (transclusion : T.transclusion) : P.node list =
···
109
160
| None -> Reporter.fatal (Resource_not_found transclusion.href)
110
161
| Some content -> render_content ~env content
111
162
112
-
and render_section ~env (section : T.content T.section) : P.node list =
163
+
and _render_section_for_atom_client ~env (section : T.content T.section) : P.node list =
113
164
let env =
114
165
{
115
166
env with
···
118
169
}
119
170
in
120
171
[
121
-
P.HTML.section []
172
+
H.section []
173
+
[
174
+
begin match section.frontmatter.title with
175
+
| None -> H.null []
176
+
| Some title ->
177
+
H.header [] [hx ~env [] @@ render_content ~env title]
178
+
end;
179
+
begin if
180
+
Loop_detection.have_seen_uri_opt section.frontmatter.uri env.loops
181
+
then P.txt "Transclusion loop detected, rendering stopped."
182
+
else
183
+
H.null
184
+
@@ render_content
185
+
~env:
186
+
{
187
+
env with
188
+
loops =
189
+
Loop_detection.add_seen_uri_opt section.frontmatter.uri
190
+
env.loops;
191
+
}
192
+
section.mainmatter
193
+
end;
194
+
];
195
+
]
196
+
197
+
and render_section ~env (section : T.content T.section) : P.node list =
198
+
[
199
+
H.section []
122
200
[
123
201
begin match section.frontmatter.title with
124
202
| None -> P.HTML.null []
125
203
| Some title ->
126
-
P.HTML.header [] [hx ~env [] @@ render_content ~env title]
204
+
H.header [] [hx ~env [] @@ render_content ~env title]
127
205
end;
128
206
begin if
129
207
Loop_detection.have_seen_uri_opt section.frontmatter.uri env.loops
130
208
then P.txt "Transclusion loop detected, rendering stopped."
131
209
else
132
-
P.HTML.null
210
+
H.null
133
211
@@ render_content
134
212
~env:
135
213
{
···
143
221
];
144
222
]
145
223
146
-
let render_article_as_div ?(heading_level = 0) (forest : State.t)
224
+
let render_attributions ~env (attributions : T.content T.attribution list) =
225
+
let render_attribution attribution =
226
+
match attribution with
227
+
| T.{vertex; _} -> (
228
+
match vertex with
229
+
| T.Uri_vertex href ->
230
+
let content =
231
+
T.Content
232
+
[T.Transclude {href; target = Title {empty_when_untitled = false}}]
233
+
in
234
+
H.null @@ render_link ~env T.{href; content}
235
+
| T.Content_vertex content -> H.null @@ render_content ~env content)
236
+
in
237
+
let authors, contributors =
238
+
attributions
239
+
|> List.partition_map @@ fun a ->
240
+
match T.(a.role) with T.Author -> Left a | Contributor -> Right a
241
+
in
242
+
H.li
243
+
[H.class_ "meta-item"]
244
+
[
245
+
H.address [H.class_ "author"]
246
+
@@ List.map render_attribution authors
247
+
@ begin if List.length contributors > 0 then
248
+
[P.txt "with contributions from "]
249
+
else []
250
+
end
251
+
@ List.map render_attribution contributors;
252
+
]
253
+
254
+
let render_article ~env (article : T.content T.article) : P.node
255
+
=
256
+
(* let@ () = Scope.run ~env:article.frontmatter.uri in *)
257
+
H.article []
258
+
[
259
+
H.section []
260
+
(render_content ~env:{env with loops = Loop_detection.add_seen_uri_opt article.frontmatter.uri env.loops} article.mainmatter);
261
+
]
262
+
263
+
let render_toc _article = H.ul [] []
264
+
265
+
(* Just used by the atom client *)
266
+
let render_article_as_div ?(heading_level = 0) ~(forest : State.t)
147
267
(article : T.content T.article) : P.node =
148
268
let reserved = [{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}] in
149
269
let env =
···
155
275
xmlns = Xmlns.init ~reserved;
156
276
}
157
277
in
158
-
P.HTML.div
278
+
H.div
159
279
(List.map render_xmlns_prefix reserved)
280
+
[H.null @@ render_content ~env article.mainmatter]
281
+
282
+
let get_meta (frontmatter : T.content T.frontmatter) meta =
283
+
List.find_map
284
+
(fun (m, v) -> if m = meta then Some v else None)
285
+
frontmatter.metas
286
+
287
+
let default_meta_item ~env frontmatter meta =
288
+
optional (get_meta frontmatter meta) (fun content ->
289
+
H.li [H.class_ "meta-item"] (render_content ~env content))
290
+
291
+
let render_position ~env frontmatter =
292
+
default_meta_item ~env frontmatter "position"
293
+
294
+
let render_institution ~env frontmatter =
295
+
default_meta_item ~env frontmatter "institution"
296
+
297
+
let render_venue ~env frontmatter =
298
+
default_meta_item ~env frontmatter "venue"
299
+
300
+
let render_source ~env frontmatter =
301
+
default_meta_item ~env frontmatter "source"
302
+
303
+
let render_doi ~env frontmatter =
304
+
optional (get_meta frontmatter "doi") (fun c ->
305
+
let doi = Plain_text_client.string_of_content ~forest:env.forest c in
306
+
H.li
307
+
[H.class_ "meta-item"]
308
+
[
309
+
H.a
310
+
[H.class_ "doi"; H.href "https://www.doi.org/%s" doi]
311
+
(render_content ~env c);
312
+
])
313
+
314
+
let render_orcid ~env frontmatter =
315
+
optional (get_meta frontmatter "orcid") (fun c ->
316
+
let orcid = Plain_text_client.string_of_content ~forest:env.forest c in
317
+
H.li
318
+
[H.class_ "meta-item"]
319
+
[
320
+
H.a
321
+
[H.class_ "orcid"; H.href "https://orcid.org/%s" orcid]
322
+
(render_content ~env c);
323
+
])
324
+
325
+
let render_external ~env frontmatter =
326
+
optional (get_meta frontmatter "external") (fun c ->
327
+
let link = Plain_text_client.string_of_content ~forest:env.forest c in
328
+
H.li
329
+
[H.class_ "meta-item"]
330
+
[
331
+
H.a
332
+
[H.class_ "link external"; H.href "%s" link]
333
+
(render_content ~env c);
334
+
])
335
+
336
+
let render_slides ~env frontmatter =
337
+
optional (get_meta frontmatter "slides") (fun c ->
338
+
let link = Plain_text_client.string_of_content ~forest:env.forest c in
339
+
H.li
340
+
[H.class_ "meta-item"]
341
+
[H.a [H.class_ "link external"; H.href "%s" link] [P.txt "Slides"]])
342
+
343
+
let render_video ~env frontmatter =
344
+
optional (get_meta frontmatter "video") (fun c ->
345
+
let link = Plain_text_client.string_of_content ~forest:env.forest c in
346
+
H.li
347
+
[H.class_ "meta-item"]
348
+
[H.a [H.class_ "link external"; H.href "%s" link] [P.txt "Video"]])
349
+
350
+
let render_frontmatter ~env (frontmatter : _ T.frontmatter) :
351
+
P.node =
352
+
H.header []
160
353
[
161
-
P.HTML.null
162
-
@@ render_content
163
-
~env:
164
-
{
165
-
env with
166
-
loops =
167
-
Loop_detection.add_seen_uri_opt article.frontmatter.uri
168
-
env.loops;
169
-
}
170
-
article.mainmatter;
354
+
H.h1 [] [H.span [H.class_ "taxon"] []];
355
+
H.div
356
+
[H.class_ "metadata"]
357
+
[
358
+
H.ul []
359
+
[
360
+
render_position ~env frontmatter;
361
+
render_institution ~env frontmatter;
362
+
render_venue ~env frontmatter;
363
+
render_source ~env frontmatter;
364
+
render_doi ~env frontmatter;
365
+
render_orcid ~env frontmatter;
366
+
render_external ~env frontmatter;
367
+
render_slides ~env frontmatter;
368
+
render_video ~env frontmatter;
369
+
];
370
+
];
171
371
]
172
372
173
-
let render_page (forest : State.t) (tree : _ T.article) : P.node =
174
-
let@ () = Scope.run ~env: tree.frontmatter.uri in
373
+
let render_page ~forest (tree : _ T.article) : P.node =
374
+
let reserved = [{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}] in
375
+
let env =
376
+
{
377
+
forest;
378
+
section_depth = 0;
379
+
scope = tree.frontmatter.uri;
380
+
loops = Loop_detection.empty;
381
+
xmlns = Xmlns.init ~reserved;
382
+
}
383
+
in
175
384
let ttl =
176
385
match tree.frontmatter.title with
177
-
| None -> P.HTML.null []
386
+
| None -> H.null []
178
387
| Some _ ->
179
-
let title = State.get_expanded_title ?scope: (Scope.read ()) tree.frontmatter forest in
180
-
P.HTML.title [] "%s" @@ Plain_text_client.string_of_content ~forest title
388
+
let title =
389
+
State.get_expanded_title ?scope:env.scope tree.frontmatter env.forest
390
+
in
391
+
H.title [] "%s" @@ Plain_text_client.string_of_content ~forest:env.forest title
181
392
in
182
-
let open P.HTML in
183
-
html
184
-
[]
393
+
let open H in
394
+
html []
185
395
[
186
-
head
187
-
[]
396
+
head []
188
397
[
189
398
meta [http_equiv `content_type; content "text/html"; charset "UTF-8"];
190
399
meta
191
-
[
192
-
name "viewport";
193
-
content "width=device-width, initial-scale=1.0"
194
-
];
195
-
link
196
-
[
197
-
rel "stylesheet";
198
-
href "/style.css"
199
-
];
400
+
[name "viewport"; content "width=device-width, initial-scale=1.0"];
401
+
link [rel "stylesheet"; href "/style.css"];
200
402
link [rel "stylesheet"; href "/katex.min.css"];
201
403
script [type_ "module"; src "/forester.js"] "";
202
404
ttl;
203
405
];
204
-
body
205
-
[]
406
+
body []
206
407
[
207
-
P.std_tag "ninja-keys" [placeholder "Start typing a note title or ID"][];
208
-
render_article_as_div forest tree
209
-
]
408
+
P.std_tag "ninja-keys"
409
+
[placeholder "Start typing a note title or ID"]
410
+
[];
411
+
(if is_root env.forest.config tree.frontmatter.uri then null []
412
+
else
413
+
header
414
+
[class_ "header"]
415
+
[
416
+
nav
417
+
[class_ "nav"]
418
+
[
419
+
div
420
+
[class_ "logo"]
421
+
[a [href "index.html"; title_ "home"] [P.txt "« Home"]];
422
+
];
423
+
]);
424
+
div
425
+
[id "grid-wrapper"]
426
+
[
427
+
render_article ~env tree;
428
+
(if should_render_toc article then
429
+
nav
430
+
[id "toc"]
431
+
[
432
+
div
433
+
[class_ "block"]
434
+
[h1 [] [P.txt "Table of Contents"]; render_toc article];
435
+
]
436
+
else null []);
437
+
];
438
+
];
210
439
]
+72
-121
lib/frontend/Htmx_client.ml
+72
-121
lib/frontend/Htmx_client.ml
···
5
5
*)
6
6
7
7
open Forester_prelude
8
-
open Forester_xml_names
9
8
open Forester_core
10
9
open Forester_compiler
10
+
open Forester_xml_names
11
11
12
12
open struct
13
13
module T = Types
14
+
module P = Pure_html
15
+
let render_date = Html_client.render_date
16
+
let render_attributions = Html_client.render_attributions
14
17
end
15
18
16
19
open Pure_html
···
20
23
query: (string, T.content T.vertex) Forester_core.Datalog_expr.query;
21
24
}
22
25
[@@deriving repr]
23
-
24
-
module Xmlns = Xmlns_effect.Make ()
25
26
26
27
let local_path_components (uri : URI.t) =
27
28
let host =
···
95
96
let attr = match prefix with "" -> "xmlns" | _ -> "xmlns:" ^ prefix in
96
97
string_attr attr "%s" xmlns
97
98
98
-
let render_date (date : Human_datetime.t) =
99
-
let year = txt "%i" (Human_datetime.year date) in
100
-
let month =
101
-
match Human_datetime.month date with
102
-
| None -> None
103
-
| Some i -> (
104
-
match i with
105
-
| 1 -> Some (txt "January")
106
-
| 2 -> Some (txt "February")
107
-
| 3 -> Some (txt "March")
108
-
| 4 -> Some (txt "April")
109
-
| 5 -> Some (txt "May")
110
-
| 6 -> Some (txt "June")
111
-
| 7 -> Some (txt "July")
112
-
| 8 -> Some (txt "August")
113
-
| 9 -> Some (txt "September")
114
-
| 10 -> Some (txt "October")
115
-
| 11 -> Some (txt "November")
116
-
| 12 -> Some (txt "December")
117
-
| _ -> assert false)
118
-
in
119
-
let day =
120
-
match Human_datetime.day date with None -> null [] | Some i -> txt "%i" i
121
-
in
122
-
li
123
-
[class_ "meta-item"]
124
-
[
125
-
a
126
-
[class_ "link local"]
127
-
[
128
-
Option.value ~default:(null []) month;
129
-
(if Option.is_some month then txt " " else null []);
130
-
day;
131
-
(if Option.is_some month then txt ", " else null []);
132
-
year;
133
-
];
134
-
]
135
-
136
99
(*This type is just temporary until I figure out the logic *)
137
100
type toc_config = {
138
101
suffix: string;
···
158
121
implicitly_unnumbered = false;
159
122
}
160
123
161
-
let rec render_article (forest : State.t) (article : T.content T.article) : node
124
+
let rec render_article ~(forest : State.t) (article : T.content T.article) : node
162
125
=
163
126
(* FIXME: What should reserved be here? *)
164
-
let@ () = Xmlns.run ~reserved:[] in
127
+
128
+
let reserved = [{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}] in
129
+
let env : Html_client.env =
130
+
{
131
+
forest;
132
+
section_depth = 0;
133
+
scope = article.frontmatter.uri;
134
+
loops = Loop_detection.empty;
135
+
xmlns = Xmlns.init ~reserved;
136
+
}
137
+
in
165
138
HTML.article
166
139
[id "tree-container"]
167
140
[
···
170
143
[class_ "block"]
171
144
[
172
145
details [(* TODO: check if expanded*) open_]
173
-
@@ summary [] [render_frontmatter forest article.frontmatter]
174
-
:: render_content forest article.mainmatter;
146
+
@@ summary [] [render_frontmatter ~env article.frontmatter]
147
+
:: render_content ~env article.mainmatter;
175
148
];
176
149
(match article.frontmatter.uri with
177
-
| None -> footer [] @@ render_backmatter forest article.backmatter
150
+
| None -> footer [] @@ render_backmatter ~env article.backmatter
178
151
| Some uri ->
179
-
if URI.equal (Config.home_uri forest.config) uri then null []
180
-
else footer [] @@ render_backmatter forest article.backmatter);
152
+
if URI.equal (Config.home_uri env.forest.config) uri then null []
153
+
else footer [] @@ render_backmatter ~env article.backmatter);
181
154
]
182
155
183
-
and render_section (forest : State.t) (section : T.content T.section) : node =
156
+
and render_section ~env (section : T.content T.section) : node =
184
157
match section with
185
158
| {frontmatter; mainmatter; flags} ->
186
159
let test k = function
···
205
178
details
206
179
[(if test true flags.expanded then open_ else null_)]
207
180
[
208
-
summary [] [render_frontmatter forest frontmatter];
209
-
null @@ render_content forest mainmatter;
181
+
summary [] [render_frontmatter ~env frontmatter];
182
+
null @@ render_content ~env mainmatter;
210
183
]
211
-
else null @@ render_content forest mainmatter);
184
+
else null @@ render_content ~env mainmatter);
212
185
(* render_frontmatter forest frontmatter; *)
213
186
(* null @@ render_content forest mainmatter; *)
214
187
]
215
188
216
189
(* Same as render_section, but adds the backmatter-section class *)
217
-
and render_backmatter (forest : State.t) backmatter =
218
-
let@ node = List.map @~ render_content forest backmatter in
190
+
and render_backmatter ~env backmatter =
191
+
let@ node = List.map @~ render_content ~env backmatter in
219
192
let attrs = Format.asprintf "%s backmatter-section" node.@["class"] in
220
193
node +@ class_ "%s" attrs
221
194
222
-
and render_attributions forest (attributions : T.content T.attribution list) =
223
-
let render_attribution attribution =
224
-
match attribution with
225
-
| T.{vertex; _} -> (
226
-
match vertex with
227
-
| T.Uri_vertex href ->
228
-
let content =
229
-
T.Content
230
-
[T.Transclude {href; target = Title {empty_when_untitled = false}}]
231
-
in
232
-
null @@ render_link forest T.{href; content}
233
-
| T.Content_vertex content -> null @@ render_content forest content)
234
-
in
235
-
let authors, contributors =
236
-
attributions
237
-
|> List.partition_map @@ fun a ->
238
-
match T.(a.role) with T.Author -> Left a | Contributor -> Right a
239
-
in
240
-
li
241
-
[class_ "meta-item"]
242
-
[
243
-
address [class_ "author"]
244
-
@@ List.map render_attribution authors
245
-
@ begin if List.length contributors > 0 then
246
-
[txt "with contributions from "]
247
-
else []
248
-
end
249
-
@ List.map render_attribution contributors;
250
-
]
251
-
252
-
and render_frontmatter (forest : State.t)
195
+
and render_frontmatter ~env
253
196
(frontmatter : T.content T.frontmatter) : node =
254
197
let taxon =
255
198
Option.value ~default:[]
256
199
@@
257
200
let@ c = Option.map @~ frontmatter.taxon in
258
-
render_content forest c @ [txt ". "]
201
+
render_content ~env c @ [txt ". "]
259
202
in
260
203
let title =
261
204
Option.value ~default:[]
262
205
@@
263
206
let@ c = Option.map @~ frontmatter.title in
264
-
render_content forest c
207
+
render_content ~env c
265
208
in
266
209
let uri =
267
210
match frontmatter.uri with
···
269
212
| Some uri ->
270
213
let uri_str =
271
214
(* TODO: replace with proper routing from legacy xml client *)
272
-
Format.asprintf "%a" URI.pp (route forest uri)
215
+
Format.asprintf "%a" URI.pp (route env.forest uri)
273
216
in
274
217
a [class_ "slug"; href "%s" uri_str] [txt "[%s]" uri_str]
275
218
in
···
287
230
Option.value ~default:(null []) (Option.map f (find_meta key))
288
231
in
289
232
let default_meta_item content =
290
-
li [class_ "meta-item"] (render_content forest content)
233
+
li [class_ "meta-item"] (render_content ~env content)
291
234
in
292
235
let labelled_external_link ~href ~label =
293
236
li [class_ "meta-item"] [a [class_ "link external"; href] [txt "%s" label]]
294
237
in
295
238
let to_string =
296
-
Plain_text_client.string_of_content ~forest
297
-
~router:(Legacy_xml_client.route forest)
239
+
Plain_text_client.string_of_content ~forest:env.forest
240
+
~router:(Legacy_xml_client.route env.forest)
298
241
in
299
242
let position = render_meta "position" default_meta_item in
300
243
let institution = render_meta "institution" default_meta_item in
···
340
283
ul []
341
284
@@ List.map render_date frontmatter.dates
342
285
@ [
343
-
render_attributions forest frontmatter.attributions;
286
+
render_attributions ~env frontmatter.attributions;
344
287
position;
345
288
institution;
346
289
venue;
···
372
315
[txt "transclusion: %s" (Format.asprintf "%a" URI.pp href)];
373
316
]
374
317
375
-
and render_content (forest : State.t) (Content content : T.content) : node list
318
+
and render_content ~env (Content content : T.content) : node list
376
319
=
377
-
List.concat_map (render_content_node forest) content
320
+
List.concat_map (render_content_node ~env) content
378
321
379
-
and render_content_node (forest : State.t) (node : 'a T.content_node) :
322
+
and render_content_node ~env (node : 'a T.content_node) :
380
323
node list =
381
324
match node with
382
325
| Text str -> [txt "%s" str]
383
326
| CDATA str -> [txt ~raw:true "<![CDATA[%s]]>" str]
384
327
| Xml_elt elt ->
385
-
let prefixes_to_add, (name, attrs, content) =
386
-
let@ () = Xmlns.within_scope in
387
-
( render_xml_qname elt.name,
388
-
List.map render_xml_attr elt.attrs,
389
-
render_content forest elt.content )
390
-
in
391
-
let attrs =
392
-
let xmlns_attrs = List.map render_xmlns_prefix prefixes_to_add in
393
-
attrs @ xmlns_attrs
394
-
in
395
-
[std_tag name attrs content]
328
+
let name = render_xml_qname elt.name in
329
+
let xmlns_attrs = Xmlns.xmlns_attrs_for_elt elt env.xmlns in
330
+
let env = {env with xmlns = Xmlns.extend xmlns_attrs env.xmlns} in
331
+
let content = render_content ~env elt.content in
332
+
[
333
+
P.std_tag name
334
+
(List.map render_xmlns_prefix xmlns_attrs
335
+
@ List.map render_xml_attr elt.attrs)
336
+
content;
337
+
]
396
338
| Transclude transclusion -> render_transclusion transclusion
397
339
| Contextual_number addr -> begin
398
-
match (State.get_article addr) forest with
340
+
match (State.get_article addr) env.forest with
399
341
| Some a ->
400
342
[contextual_number (T.article_to_section a) (default_toc_config ())]
401
343
| None -> []
···
409
351
(* | Some num -> num *)
410
352
(* in *)
411
353
(* [txt "%s" num] *)
412
-
| Link link -> render_link forest link
413
-
| Section section -> [render_section forest section]
354
+
| Link link -> render_link ~env link
355
+
| Section section -> [render_section ~env section]
414
356
| KaTeX (mode, content) ->
415
-
let body = Plain_text_client.string_of_content ~forest content in
357
+
let body = Plain_text_client.string_of_content ~forest:env.forest content in
416
358
(* [txt ~raw: true "%s%s%s" l body r] *)
417
359
begin match mode with
418
360
| Inline -> [span [class_ "math"] [txt ~raw:true "%s" body]]
···
435
377
| T.Artefact _ | T.Uri _ | T.Route_of_uri _ -> [txt "todo"]
436
378
437
379
(* TODO: links need to be flattened in order to produce valid HTML. *)
438
-
and render_link (forest : State.t) (link : T.content T.link) : node list =
380
+
and render_link ~env (link : T.content T.link) : node list =
439
381
let attrs =
440
-
match State.get_article link.href forest with
382
+
match State.get_article link.href env.forest with
441
383
| None ->
442
384
(* TODO: rendering of hrefs is suboptimal... *)
443
385
[href "%s" (Format.asprintf "%a" URI.pp link.href)]
···
447
389
[
448
390
title_ "%s" @@ Option.value ~default:""
449
391
@@ Option.map
450
-
(Plain_text_client.string_of_content ~forest
451
-
~router:(Legacy_xml_client.route forest))
392
+
(Plain_text_client.string_of_content ~forest:env.forest
393
+
~router:(Legacy_xml_client.route env.forest))
452
394
article.frontmatter.title;
453
395
href "/trees%s" (Format.asprintf "%s" (URI.path_string link.href));
454
396
Hx.target "#tree-container";
···
457
399
| None -> [HTML.null_]
458
400
end
459
401
in
460
-
[span [class_ "link local"] [a attrs (render_content forest link.content)]]
402
+
[span [class_ "link local"] [a attrs (render_content ~env link.content)]]
461
403
462
404
and contextual_number (_tree : T.content T.section) (cfg : toc_config) =
463
405
let should_number =
···
496
438
(*TODO: Implement.*)
497
439
contextual_number _tree cfg
498
440
499
-
and _render_toc_item (forest : State.t) (item : T.content T.section) =
441
+
and _render_toc_item ~(env: Html_client.env) (item : T.content T.section) =
500
442
let to_str =
501
-
Plain_text_client.string_of_content ~forest
502
-
~router:(Legacy_xml_client.route forest)
443
+
Plain_text_client.string_of_content ~forest:env.forest
444
+
~router:(Legacy_xml_client.route env.forest)
503
445
in
504
446
null
505
447
[
···
522
464
[_tree_taxon_with_number item (default_toc_config ())];
523
465
(* null @@ render_content forest item.mainmatter; *)
524
466
];
525
-
ul [] (render_content forest item.mainmatter);
467
+
ul [] (render_content ~env item.mainmatter);
526
468
]
527
469
528
470
and render_toc_mainmatter content =
···
552
494
];
553
495
]
554
496
555
-
let render_query_result (forest : State.t) (vs : Vertex_set.t) =
497
+
let render_query_result ~forest (vs : Vertex_set.t) =
556
498
let module C = Types.Comparators (struct
557
499
let string_of_content =
558
500
Plain_text_client.string_of_content ~forest ~router:(route forest)
559
501
end) in
502
+
let env : Html_client.env =
503
+
{
504
+
forest;
505
+
section_depth = 0;
506
+
scope = None;
507
+
loops = Loop_detection.empty;
508
+
xmlns = Xmlns.init ~reserved: [{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}];
509
+
}
510
+
in
560
511
let make_section =
561
512
T.article_to_section
562
513
~flags:
···
574
525
|> Seq.filter_map (State.get_article @~ forest)
575
526
|> List.of_seq
576
527
|> List.sort C.compare_article
577
-
|> List.map (Fun.compose (render_section forest) make_section)
528
+
|> List.map (Fun.compose (render_section ~env) make_section)
578
529
in
579
530
if List.length nodes = 0 then None
580
531
else Some (div [class_ "tree-content"] nodes)
+53
-10
lib/frontend/Htmx_client.mli
+53
-10
lib/frontend/Htmx_client.mli
···
8
8
open Forester_compiler
9
9
module T := Types
10
10
11
-
type query = {
12
-
query: (string, T.content T.vertex) Forester_core.Datalog_expr.query;
13
-
}
11
+
(* type query = { *)
12
+
(* query : (string, T.content T.vertex) Forester_core.Datalog_expr.query; *)
13
+
(* } *)
14
+
(* val query_t : query Repr.ty *)
15
+
(* val local_path_components : Forester_core.URI.t -> string list *)
16
+
(* val route : *)
17
+
(* State.t -> Forester_core.URI.t -> Forester_core.URI.t *)
18
+
(* val title_flags_to_http_header : *)
19
+
(* T.title_flags -> [> `Assoc of (string * [> `String of string ]) list ] *)
20
+
(* val section_flags_to_http_header : *)
21
+
(* T.section_flags -> [> `Assoc of (string * [> `String of string ]) list ] *)
22
+
(* val content_target_to_http_header : *)
23
+
(* T.content_target -> [> `Assoc of (string * [> `String of string ]) list ] *)
24
+
(* val render_xml_qname : Forester_xml_names.xml_qname -> string *)
25
+
(* val render_xml_attr : T.content T.xml_attr -> Pure_html.attr *)
26
+
(* val render_xmlns_prefix : Forester_xml_names.xmlns_attr -> Pure_html.attr *)
27
+
(* type toc_config = { *)
28
+
(* suffix : string; *)
29
+
(* taxon : string; *)
30
+
(* number : string; *)
31
+
(* fallback_number : string; *)
32
+
(* in_backmatter : bool; *)
33
+
(* is_root : bool; *)
34
+
(* implicitly_unnumbered : bool; *)
35
+
(* } *)
36
+
(* val default_toc_config : *)
37
+
(* ?suffix:string -> *)
38
+
(* ?taxon:string -> *)
39
+
(* ?number:string -> *)
40
+
(* ?fallback_number:string -> ?in_backmatter:bool -> unit -> toc_config *)
41
+
val render_article :
42
+
forest:State.t-> T.content T.article -> Pure_html.node
43
+
(* val render_section : *)
44
+
(* env:Html_client.env -> T.content T.section -> Pure_html.node *)
45
+
(* val render_backmatter : *)
46
+
(* env:Html_client.env -> T.content -> Pure_html.node list *)
47
+
(* val render_frontmatter : *)
48
+
(* env:Html_client.env -> T.content T.frontmatter -> Pure_html.node *)
49
+
(* val render_transclusion : T.transclusion -> Pure_html.node list *)
50
+
val render_content : env:Html_client.env -> T.content -> Pure_html.node list
51
+
(* val render_content_node : *)
52
+
(* env:Html_client.env -> T.content T.content_node -> Pure_html.node list *)
53
+
(* val render_link : *)
54
+
(* env:Html_client.env -> T.content T.link -> Pure_html.node list *)
55
+
(* val contextual_number : T.content T.section -> toc_config -> Pure_html.node *)
56
+
(* val _tree_taxon_with_number : *)
57
+
(* T.content T.section -> toc_config -> Pure_html.node *)
58
+
(* val _render_toc_item : *)
59
+
(* env:Html_client.env -> T.content T.section -> Pure_html.node *)
60
+
val render_toc_mainmatter : T.content -> Pure_html.node
61
+
(* val render_toc : T.content T.section -> Pure_html.node *)
62
+
val render_query_result :
63
+
forest:State.t -> Forester_core.Vertex_set.t -> Pure_html.node option
14
64
15
-
val query_t : query Repr.t
16
-
val route : State.t -> URI.t -> URI.t
17
-
val render_article : State.t -> T.content T.article -> Pure_html.node
18
-
val render_content : State.t -> T.content -> Pure_html.node list
19
-
val render_frontmatter : State.t -> T.content T.frontmatter -> Pure_html.node
20
-
val render_query_result : State.t -> Vertex_set.t -> Pure_html.node option
21
-
val render_toc : T.content T.section -> Pure_html.node
+26
-6
lib/server/Server.ml
+26
-6
lib/server/Server.ml
···
8
8
open Forester_core
9
9
open Forester_compiler
10
10
open Forester_frontend
11
+
open Forester_xml_names
11
12
12
13
open struct
13
14
module T = Types
···
107
108
Cohttp_eio.Server.respond_string ~status:`Not_found ~body:"" ()
108
109
| Some content ->
109
110
let response =
110
-
Pure_html.to_string @@ Htmx_client.render_article forest content
111
+
Pure_html.to_string @@ Htmx_client.render_article ~forest content
111
112
in
112
113
Cohttp_eio.Server.respond_string ~status:`OK ~body:response ()
113
114
end
···
117
118
Cohttp_eio.Server.respond_string ~status:`Not_found ~body:"" ()
118
119
| Some content ->
119
120
(* TODO: Remove any sort of HTML generation from the handler. *)
121
+
let env : Html_client.env =
122
+
{
123
+
forest;
124
+
section_depth = 0;
125
+
scope = Some href;
126
+
loops = Loop_detection.empty;
127
+
xmlns = Xmlns.init ~reserved: [{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}];
128
+
}
129
+
in
120
130
let response =
121
131
Pure_html.(
122
132
to_string
123
-
@@ HTML.span [] (Htmx_client.render_content forest content))
133
+
@@ HTML.span [] (Htmx_client.render_content ~env content))
124
134
in
125
135
Cohttp_eio.Server.respond_string ~status:`OK ~body:response ())
126
136
end
···
129
139
| Some article ->
130
140
let content =
131
141
Pure_html.to_string
132
-
@@ Index.v ~c:(Htmx_client.render_article forest article) ()
142
+
@@ Index.v ~c:(Htmx_client.render_article ~forest article) ()
133
143
in
134
144
let headers = Http.Header.of_list [("Content-Type", "text/html")] in
135
145
Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body:content ()
···
162
172
| Some _ -> assert false
163
173
in
164
174
let response =
165
-
Search_menu.results forest (List.map snd search_results)
175
+
176
+
let env : Html_client.env =
177
+
{
178
+
forest;
179
+
section_depth = 0;
180
+
scope = None;
181
+
loops = Loop_detection.empty;
182
+
xmlns = Xmlns.init ~reserved: [{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}];
183
+
}
184
+
in
185
+
Search_menu.results ~env (List.map snd search_results)
166
186
in
167
187
Cohttp_eio.Server.respond_string ~status:`OK ~body:response ()
168
188
else
···
176
196
| None -> Cohttp_eio.Server.respond_string ~status:`OK ~body:"" ()
177
197
| Some home_tree ->
178
198
let content =
179
-
Pure_html.to_string @@ Htmx_client.render_article forest home_tree
199
+
Pure_html.to_string @@ Htmx_client.render_article ~forest home_tree
180
200
in
181
201
let headers = Http.Header.of_list [("Content-Type", "text/html")] in
182
202
Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body:content ()
···
194
214
begin match None with
195
215
(* FIXME :*)
196
216
(* | `Vertex_set(vs : Vertex_set.t) -> Htmx_client.render_query_result forest vs *)
197
-
| Some (`Vertex_set vs) -> Htmx_client.render_query_result forest vs
217
+
| Some (`Vertex_set vs) -> Htmx_client.render_query_result ~forest vs
198
218
| _ -> None
199
219
end
200
220
| Error (`Msg str) ->