forked from
jonmsterling.com/ocaml-forester
ocaml
Html_client: simplify use of effects
+39
-49
+39
-49
lib/frontend/Html_client.ml
+39
-49
lib/frontend/Html_client.ml
···
17
17
end
18
18
19
19
module Xmlns = Xmlns_effect.Make ()
20
-
21
-
module Scope = Algaeff.Reader.Make (struct
22
-
type t = URI.t option
23
-
end)
24
-
25
-
module Section_depth = Algaeff.Reader.Make (struct
26
-
type t = int
27
-
end)
28
-
29
20
module Loop_detection = Loop_detection_effect.Make ()
30
21
31
-
let hx attrs children =
32
-
P.std_tag
33
-
(Format.sprintf "h%i" @@ min 6 @@ Section_depth.read ())
34
-
attrs children
22
+
type env = {forest: State.t; scope: URI.t option; section_depth: int}
35
23
36
-
let incr_section_depth k =
37
-
let i = Section_depth.read () in
38
-
Section_depth.run ~env:(i + 1) k
24
+
let hx ~env attrs children =
25
+
P.std_tag (Format.sprintf "h%i" @@ min 6 env.section_depth) attrs children
39
26
40
27
let route uri = URI.to_string uri
41
28
42
-
let get_expanded_title frontmatter forest =
43
-
let scope = Scope.read () in
44
-
State.get_expanded_title ?scope
29
+
let get_expanded_title ~env frontmatter forest =
30
+
State.get_expanded_title ?scope:env.scope
45
31
~flags:T.{empty_when_untitled = true}
46
32
frontmatter forest
47
33
···
59
45
let attr = match prefix with "" -> "xmlns" | _ -> "xmlns:" ^ prefix in
60
46
P.string_attr attr "%s" xmlns
61
47
62
-
let rec render_content (forest : State.t) (Content content : T.content) :
63
-
P.node list =
48
+
let rec render_content ~env (Content content : T.content) : P.node list =
64
49
match content with
65
50
| T.Text txt0 :: T.Text txt1 :: content ->
66
-
render_content forest (Content (T.Text (txt0 ^ txt1) :: content))
51
+
render_content ~env @@ Content (T.Text (txt0 ^ txt1) :: content)
67
52
| node :: content ->
68
-
let xs = render_content_node forest node in
69
-
let ys = render_content forest (Content content) in
53
+
let xs = render_content_node ~env node in
54
+
let ys = render_content ~env (Content content) in
70
55
xs @ ys
71
56
| [] -> []
72
57
73
-
and render_content_node (forest : State.t) (node : 'a T.content_node) :
74
-
P.node list =
75
-
let config = forest.config in
58
+
and render_content_node ~env (node : 'a T.content_node) : P.node list =
59
+
let config = env.forest.config in
76
60
match node with
77
61
| Text str -> [P.txt "%s" str]
78
62
| CDATA str -> [P.txt ~raw:true "<![CDATA[%s]]>" str]
···
81
65
let prefixes_to_add, (name, attrs, content) =
82
66
let@ () = Xmlns.within_scope in
83
67
( render_xml_qname elt.name,
84
-
List.map (render_xml_attr forest) elt.attrs,
85
-
render_content forest elt.content )
68
+
List.map (render_xml_attr env.forest) elt.attrs,
69
+
render_content ~env elt.content )
86
70
in
87
71
let attrs =
88
72
let xmlns_attrs = List.map render_xmlns_prefix prefixes_to_add in
···
92
76
| Route_of_uri uri -> [P.txt "%s" (route uri)]
93
77
| Contextual_number uri ->
94
78
let custom_number =
95
-
let@ resource = Option.bind @@ forest.@{uri} in
79
+
let@ resource = Option.bind @@ env.forest.@{uri} in
96
80
match resource with
97
81
| T.Article article -> article.frontmatter.number
98
82
| _ -> None
···
101
85
| None -> [P.txt "%s" @@ URI.relative_path_string ~base:config.url uri]
102
86
| Some num -> [P.txt "%s" num]
103
87
end
104
-
| KaTeX (_, content) -> [P.HTML.code [] @@ render_content forest content]
105
-
| Artefact artefact -> render_content forest @@ artefact.content
106
-
| Section section -> render_section forest section
107
-
| Transclude transclusion -> render_transclusion forest transclusion
108
-
| Link link -> render_link forest link
88
+
| KaTeX (_, content) -> [P.HTML.code [] @@ render_content ~env content]
89
+
| Artefact artefact -> render_content ~env @@ artefact.content
90
+
| Section section -> render_section ~env section
91
+
| Transclude transclusion -> render_transclusion ~env transclusion
92
+
| Link link -> render_link ~env link
109
93
| Results_of_datalog_query _ -> [] (* TODO: just make a list of links *)
110
94
| Datalog_script _ -> []
111
95
112
-
and render_link (forest : State.t) (link : T.content T.link) : P.node list =
96
+
and render_link ~env (link : T.content T.link) : P.node list =
113
97
[
114
98
P.HTML.a [P.HTML.href "%s" (Format.asprintf "%a" URI.pp link.href)]
115
-
@@ render_content forest link.content;
99
+
@@ render_content ~env link.content;
116
100
]
117
101
118
-
and render_transclusion (forest : State.t) (transclusion : T.transclusion) :
119
-
P.node list =
120
-
match State.get_content_of_transclusion transclusion forest with
102
+
and render_transclusion ~env (transclusion : T.transclusion) : P.node list =
103
+
match State.get_content_of_transclusion transclusion env.forest with
121
104
| None -> Reporter.fatal (Resource_not_found transclusion.href)
122
-
| Some content -> render_content forest content
105
+
| Some content -> render_content ~env content
123
106
124
-
and render_section forest (section : T.content T.section) : P.node list =
125
-
let@ () = Scope.run ~env:section.frontmatter.uri in
126
-
let@ () = incr_section_depth in
107
+
and render_section ~env (section : T.content T.section) : P.node list =
108
+
let env =
109
+
{
110
+
env with
111
+
section_depth = env.section_depth + 1;
112
+
scope = section.frontmatter.uri;
113
+
}
114
+
in
127
115
[
128
116
P.HTML.section []
129
117
[
130
118
begin match section.frontmatter.title with
131
119
| None -> P.HTML.null []
132
-
| Some title -> P.HTML.header [] [hx [] @@ render_content forest title]
120
+
| Some title ->
121
+
P.HTML.header [] [hx ~env [] @@ render_content ~env title]
133
122
end;
134
123
(if Loop_detection.have_seen_uri_opt section.frontmatter.uri then
135
124
P.txt "Transclusion loop detected, rendering stopped."
136
125
else
137
126
let@ () = Loop_detection.add_seen_uri_opt section.frontmatter.uri in
138
-
P.HTML.null @@ render_content forest section.mainmatter);
127
+
P.HTML.null @@ render_content ~env section.mainmatter);
139
128
];
140
129
]
141
130
142
131
let render_article_as_div ?(heading_level = 0) (forest : State.t)
143
132
(article : T.content T.article) : P.node =
144
-
let@ () = Section_depth.run ~env:heading_level in
145
-
let@ () = Scope.run ~env:article.frontmatter.uri in
133
+
let env =
134
+
{forest; section_depth = heading_level; scope = article.frontmatter.uri}
135
+
in
146
136
let@ () = Loop_detection.run in
147
137
let reserved = [{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}] in
148
138
let@ () = Xmlns.run ~reserved in
···
150
140
(List.map render_xmlns_prefix reserved)
151
141
[
152
142
(let@ () = Loop_detection.add_seen_uri_opt article.frontmatter.uri in
153
-
P.HTML.null @@ render_content forest article.mainmatter);
143
+
P.HTML.null @@ render_content ~env article.mainmatter);
154
144
]