forked from
jonmsterling.com/ocaml-forester
ocaml
The Big topiary=>ocamlformat switch
Topiary has been getting less and less reliable at properly formatting,
and simultaneously it appears that ocamlformat has become much more
reliable than it was when I last evaluated it.
For this reason, I have decided to switch formatters for Forester.
+5810
-5706
-14
.nova/Tasks/Format File.json
-14
.nova/Tasks/Format File.json
-8
.nova/Tasks/Format Repo.json
-8
.nova/Tasks/Format Repo.json
+10
.ocamlformat
+10
.ocamlformat
+7
-5
README.md
+7
-5
README.md
···
28
28
<~jonsterling/forester-devel@lists.sr.ht>. General discussion can be mailed to
29
29
<~jonsterling/forester-discuss@lists.sr.ht>.
30
30
31
-
When you prepare patches, please try to match the surrounding coding style to
32
-
the best of your ability (and do not use `ocamlformat`); patches will not be
33
-
rejected on grounds of poor formatting but they may be reformatted before being
34
-
applied. If you install [Topiary](https://topiary.tweag.io), you can format the
35
-
entire project using `./format.sh`.
31
+
When you prepare patches, please be sure that all code is formatted as follows:
32
+
33
+
dune build @fmt
34
+
dune promote
35
+
36
+
Patches will not be rejected on grounds of poor formatting but they may be
37
+
reformatted before being applied.
36
38
37
39
[Join us on IRC](irc://irc.libera.chat/#forester)
38
40
-6
REUSE.toml
-6
REUSE.toml
···
11
11
SPDX-License-Identifier = "GPL-3.0-or-later"
12
12
13
13
[[annotations]]
14
-
path = ["topiary/*"]
15
-
precedence = "override"
16
-
SPDX-FileCopyrightText = "2024 Tweag I/O Limited"
17
-
SPDX-License-Identifier = "MIT"
18
-
19
-
[[annotations]]
20
14
path = [".envrc", ".nova/**/*", ".vscode/**/*", "flake.lock", "flake.nix"]
21
15
precedence = "override"
22
16
SPDX-FileCopyrightText = "2024 The Forester Project Contributors"
+32
-49
bin/forester/App.ml
+32
-49
bin/forester/App.ml
···
7
7
open Brr
8
8
9
9
let htmx = Jv.get Jv.global "htmx"
10
-
11
10
let ajax o = Jv.call o "ajax"
12
11
let on_load o = Jv.call o "onLoad"
13
-
14
12
let katex = Jv.get Jv.global "katex"
15
13
16
14
type _katex_config = {
···
26
24
maxExpand: Jv.t;
27
25
strict: Jv.t;
28
26
trust: Jv.t; (* Boolean or function*)
29
-
globalGroup: Jv.t
27
+
globalGroup: Jv.t;
30
28
}
31
29
32
-
let trust_config =
33
-
Jv.obj
34
-
[|
35
-
"trust",
36
-
Jv.of_bool true
37
-
|]
38
-
30
+
let trust_config = Jv.obj [|("trust", Jv.of_bool true)|]
39
31
let render o = Jv.call o "render"
40
32
41
33
let () =
42
-
ignore @@
43
-
on_load
44
-
htmx
45
-
[|
46
-
let f = fun root ->
47
-
El.fold_find_by_selector
48
-
~root
49
-
(fun elt _ ->
50
-
ignore @@
51
-
render
52
-
katex
53
-
[|
54
-
Jv.get (El.to_jv elt) "textContent";
55
-
El.to_jv elt;
56
-
trust_config;
57
-
|]
58
-
)
59
-
(Jstr.v ".math")
60
-
()
61
-
in
62
-
Jv.repr f
63
-
|]
34
+
ignore
35
+
@@ on_load htmx
36
+
[|
37
+
(let f =
38
+
fun root ->
39
+
El.fold_find_by_selector ~root
40
+
(fun elt _ ->
41
+
ignore
42
+
@@ render katex
43
+
[|
44
+
Jv.get (El.to_jv elt) "textContent";
45
+
El.to_jv elt;
46
+
trust_config;
47
+
|])
48
+
(Jstr.v ".math") ()
49
+
in
50
+
Jv.repr f);
51
+
|]
64
52
65
53
(* let () = ignore @@ Jv.call htmx "logAll" [||] *)
66
54
67
55
let () =
68
-
ignore @@
69
-
Ev.listen
70
-
Ev.keydown
71
-
(fun e ->
72
-
let ev = Ev.as_type e in
73
-
Ev.(
74
-
if Keyboard.ctrl_key ev && Keyboard.key ev = Jstr.v "k" then
75
-
begin
76
-
Console.log ["hello"];
77
-
prevent_default e;
78
-
ignore @@
79
-
ajax
80
-
htmx
56
+
ignore
57
+
@@ Ev.listen Ev.keydown
58
+
(fun e ->
59
+
let ev = Ev.as_type e in
60
+
Ev.(
61
+
if Keyboard.ctrl_key ev && Keyboard.key ev = Jstr.v "k" then begin
62
+
Console.log ["hello"];
63
+
prevent_default e;
64
+
ignore
65
+
@@ ajax htmx
81
66
[|
82
67
Jv.of_string "GET";
83
68
Jv.of_string "/searchmenu";
84
69
Jv.of_string "#modal-container";
85
70
|]
86
-
end
87
-
)
88
-
)
89
-
(Document.as_target G.document)
71
+
end))
72
+
(Document.as_target G.document)
+118
-118
bin/forester/main.ml
+118
-118
bin/forester/main.ml
···
9
9
open Forester_frontend
10
10
open Forester_compiler
11
11
open Cmdliner
12
-
13
12
module EP = Eio.Path
14
13
15
14
let setup_logs style_renderer level =
···
20
19
21
20
let verbosity =
22
21
let env = Cmd.Env.info "PART_LOGS" in
23
-
Logs_cli.level ~env ~docs: Manpage.s_common_options ()
22
+
Logs_cli.level ~env ~docs:Manpage.s_common_options ()
24
23
25
24
let renderer =
26
25
let env = Cmd.Env.info "PART_FMT" in
27
-
Fmt_cli.style_renderer ~docs: Manpage.s_common_options ~env ()
26
+
Fmt_cli.style_renderer ~docs:Manpage.s_common_options ~env ()
28
27
29
28
let arg_logs = Term.(const setup_logs $ renderer $ verbosity)
30
29
···
43
42
let forest = Driver.batch_run ~env ~dev ~config in
44
43
forest.diagnostics
45
44
|> URI.Tbl.iter (fun _ d -> List.iter Reporter.Tty.display d);
46
-
begin
47
-
if not no_theme then
48
-
let@ () = Reporter.trace "when copying theme directory" in
49
-
Forester.copy_contents_of_dir ~env ~forest @@ Eio_util.path_of_dir ~env "theme"
45
+
begin if not no_theme then
46
+
let@ () = Reporter.trace "when copying theme directory" in
47
+
Forester.copy_contents_of_dir ~env ~forest
48
+
@@ Eio_util.path_of_dir ~env "theme"
50
49
end;
51
50
Forester.render_forest ~dev ~forest;
52
51
Logs.app (fun m -> m "Success!")
···
54
53
let new_tree ~env config_filename dest_dir prefix template random =
55
54
let@ () = Reporter.silence in
56
55
let config = Config_parser.parse_forest_config_file config_filename in
57
-
let forest = Driver.batch_run ~env ~dev: true ~config in
56
+
let forest = Driver.batch_run ~env ~dev:true ~config in
58
57
let mode = if random then `Random else `Sequential in
59
-
let new_tree = Forester.create_tree ~env ~dest_dir ~prefix ~template ~mode ~forest in
58
+
let new_tree =
59
+
Forester.create_tree ~env ~dest_dir ~prefix ~template ~mode ~forest
60
+
in
60
61
Format.printf "%s" new_tree
61
62
62
63
let complete ~env config_filename title =
63
64
let@ () = Reporter.silence in
64
65
let config = Config_parser.parse_forest_config_file config_filename in
65
-
let forest = Driver.batch_run ~env ~dev: true ~config in
66
+
let forest = Driver.batch_run ~env ~dev:true ~config in
66
67
let@ uri, title = List.iter @~ Forester.complete ~forest title in
67
68
Format.printf "%s, %s\n" uri title
68
69
69
70
let query_all ~env config_filename =
70
71
let@ () = Reporter.silence in
71
72
let config = Config_parser.parse_forest_config_file config_filename in
72
-
let forest = Driver.batch_run ~env ~config ~dev: true in
73
-
Format.printf "%s" (Forester.json_manifest ~dev: true ~forest)
73
+
let forest = Driver.batch_run ~env ~config ~dev:true in
74
+
Format.printf "%s" (Forester.json_manifest ~dev:true ~forest)
74
75
75
76
let default_config_str =
76
77
{|[forest]
···
91
92
|}
92
93
93
94
let init ~env dir =
94
-
let default_theme_url = "https://git.sr.ht/~jonsterling/forester-base-theme" in
95
+
let default_theme_url =
96
+
"https://git.sr.ht/~jonsterling/forester-base-theme"
97
+
in
95
98
let theme_version = "5.0" in
96
99
let cwd =
97
100
match dir with
98
101
| None -> Eio.Stdenv.cwd env
99
102
| Some d ->
100
-
begin
101
-
try
102
-
EP.mkdir ~perm: 0o755 EP.(Eio.Stdenv.cwd env / d)
103
-
with
104
-
| _ ->
105
-
Reporter.emit Initialization_warning ~extra_remarks: [Asai.Diagnostic.loctextf "Directory `%s` already exists" d]
103
+
begin try EP.mkdir ~perm:0o755 EP.(Eio.Stdenv.cwd env / d)
104
+
with _ ->
105
+
Reporter.emit Initialization_warning
106
+
~extra_remarks:
107
+
[Asai.Diagnostic.loctextf "Directory `%s` already exists" d]
106
108
end;
107
-
EP.((Eio.Stdenv.cwd env) / d)
109
+
EP.(Eio.Stdenv.cwd env / d)
108
110
in
109
-
begin
110
-
try
111
-
let proc_mgr = Eio.Stdenv.process_mgr env in
112
-
let@ cmd =
113
-
List.iter @~
114
-
[
115
-
["git"; "init"; "--quiet"];
116
-
["git"; "branch"; "-m"; "main"];
117
-
["git"; "submodule"; "add"; default_theme_url; "theme"];
118
-
["git"; "-C"; "theme"; "checkout"; theme_version];
119
-
]
120
-
in
121
-
Eio.Process.run ~cwd proc_mgr cmd
122
-
with
123
-
| exn ->
124
-
Reporter.fatal
125
-
Configuration_error
126
-
~extra_remarks: [
127
-
Asai.Diagnostic.loctextf
128
-
{|
111
+
begin try
112
+
let proc_mgr = Eio.Stdenv.process_mgr env in
113
+
let@ cmd =
114
+
List.iter
115
+
@~ [
116
+
["git"; "init"; "--quiet"];
117
+
["git"; "branch"; "-m"; "main"];
118
+
["git"; "submodule"; "add"; default_theme_url; "theme"];
119
+
["git"; "-C"; "theme"; "checkout"; theme_version];
120
+
]
121
+
in
122
+
Eio.Process.run ~cwd proc_mgr cmd
123
+
with exn ->
124
+
Reporter.fatal Configuration_error
125
+
~extra_remarks:
126
+
[
127
+
Asai.Diagnostic.loctextf
128
+
{|
129
129
Failed to set up theme: %a. To perform this step manually, run the commands
130
130
131
131
git init
132
132
git submodule add %s
133
133
git -C theme checkout %s
134
134
|}
135
-
Eio.Exn.pp
136
-
exn
137
-
default_theme_url
138
-
theme_version
139
-
]
135
+
Eio.Exn.pp exn default_theme_url theme_version;
136
+
]
140
137
end;
141
138
["trees"; "assets"] |> List.iter (Eio_util.try_create_dir ~cwd);
142
-
Eio_util.try_create_file ~cwd ~content: default_config_str "forest.toml";
143
-
Eio_util.try_create_file ~cwd ~content: "output/" ".gitignore";
144
-
Eio_util.try_create_file ~cwd ~content: "" "assets/.gitkeep";
145
-
Eio_util.try_create_file ~cwd ~content: index_tree_str "trees/index.tree";
146
-
Reporter.emit Log ~extra_remarks: [Asai.Diagnostic.loctextf "%s" "Initialized forest, try editing `trees/index.tree` and running `forester build`. Afterwards, you can open `output/index.html` in your browser to view your forest."]
139
+
Eio_util.try_create_file ~cwd ~content:default_config_str "forest.toml";
140
+
Eio_util.try_create_file ~cwd ~content:"output/" ".gitignore";
141
+
Eio_util.try_create_file ~cwd ~content:"" "assets/.gitkeep";
142
+
Eio_util.try_create_file ~cwd ~content:index_tree_str "trees/index.tree";
143
+
Reporter.emit Log
144
+
~extra_remarks:
145
+
[
146
+
Asai.Diagnostic.loctextf "%s"
147
+
"Initialized forest, try editing `trees/index.tree` and running \
148
+
`forester build`. Afterwards, you can open `output/index.html` in \
149
+
your browser to view your forest.";
150
+
]
147
151
148
152
let arg_config =
149
153
let doc = "A TOML file like $(i,forest.toml)" in
150
-
Arg.(value & pos 0 file "forest.toml" & info [] ~docv: "FOREST" ~doc)
154
+
Arg.(value & pos 0 file "forest.toml" & info [] ~docv:"FOREST" ~doc)
151
155
152
156
let build_cmd ~env =
153
157
let arg_dev =
154
-
let doc = "Run forester in development mode; this will attach source file locations to the generated json." in
158
+
let doc =
159
+
"Run forester in development mode; this will attach source file \
160
+
locations to the generated json."
161
+
in
155
162
Arg.value @@ Arg.flag @@ Arg.info ["dev"] ~doc
156
163
in
157
164
let arg_no_theme =
···
159
166
Arg.value @@ Arg.flag @@ Arg.info ["no-theme"] ~doc
160
167
in
161
168
let doc = "Build the forest" in
162
-
let man = [
163
-
`S Manpage.s_description;
164
-
`P "The $(tname) command builds a hypertext $(b,forest) from trees stored in each $(i,INPUT_DIR) or any of its subdirectories; tree files are expected to be of the form $(i,addr.tree) where $(i,addr) is the address of the tree. Note that the physical location of a tree is not taken into account, and two trees with the same address are not permitted.";
165
-
]
169
+
let man =
170
+
[
171
+
`S Manpage.s_description;
172
+
`P
173
+
"The $(tname) command builds a hypertext $(b,forest) from trees stored \
174
+
in each $(i,INPUT_DIR) or any of its subdirectories; tree files are \
175
+
expected to be of the form $(i,addr.tree) where $(i,addr) is the \
176
+
address of the tree. Note that the physical location of a tree is not \
177
+
taken into account, and two trees with the same address are not \
178
+
permitted.";
179
+
]
166
180
in
167
181
let info = Cmd.info "build" ~version ~doc ~man in
168
-
Cmd.v
169
-
info
170
-
Term.(
171
-
const (build ~env)
172
-
$ arg_logs
173
-
$ arg_config
174
-
$ arg_dev
175
-
$ arg_no_theme
176
-
)
182
+
Cmd.v info
183
+
Term.(const (build ~env) $ arg_logs $ arg_config $ arg_dev $ arg_no_theme)
177
184
178
185
let new_tree_cmd ~env =
179
186
let arg_prefix =
180
187
let doc = "The namespace prefix for the created tree." in
181
-
Arg.value @@
182
-
Arg.opt (Arg.some Arg.string) None @@
183
-
Arg.info ["prefix"] ~docv: "XXX" ~doc
188
+
Arg.value
189
+
@@ Arg.opt (Arg.some Arg.string) None
190
+
@@ Arg.info ["prefix"] ~docv:"XXX" ~doc
184
191
in
185
192
let arg_template =
186
193
let doc = "The tree to use as a template" in
187
-
Arg.value @@
188
-
Arg.opt (Arg.some Arg.string) None @@
189
-
Arg.info ["template"] ~docv: "XXX" ~doc
194
+
Arg.value
195
+
@@ Arg.opt (Arg.some Arg.string) None
196
+
@@ Arg.info ["template"] ~docv:"XXX" ~doc
190
197
in
191
-
let arg_dest_dir
192
-
: string option Term.t
193
-
=
198
+
let arg_dest_dir : string option Term.t =
194
199
let doc = "The directory in which to deposit created tree." in
195
-
Arg.value @@
196
-
Arg.opt (Arg.some Arg.dir) None @@
197
-
Arg.info ["dest"] ~docv: "DEST" ~doc
200
+
Arg.value
201
+
@@ Arg.opt (Arg.some Arg.dir) None
202
+
@@ Arg.info ["dest"] ~docv:"DEST" ~doc
198
203
in
199
204
let arg_random =
200
-
let doc = "True if the new tree should have id assigned randomly rather than sequentially" in
205
+
let doc =
206
+
"True if the new tree should have id assigned randomly rather than \
207
+
sequentially"
208
+
in
201
209
Arg.value @@ Arg.flag @@ Arg.info ["random"] ~doc
202
210
in
203
211
let doc = "Create a new tree." in
204
212
let info = Cmd.info "new" ~version ~doc in
205
-
Cmd.v
206
-
info
213
+
Cmd.v info
207
214
Term.(
208
215
const (new_tree ~env)
209
-
$ arg_config
210
-
$ arg_dest_dir
211
-
$ arg_prefix
212
-
$ arg_template
213
-
$ arg_random
214
-
)
216
+
$ arg_config $ arg_dest_dir $ arg_prefix $ arg_template $ arg_random)
215
217
216
218
let complete_cmd ~env =
217
219
let arg_title =
218
220
let doc = "The tree title prefix to complete." in
219
-
Arg.value @@
220
-
Arg.opt Arg.string "" @@
221
-
Arg.info ["title"] ~docv: "title" ~doc
221
+
Arg.value @@ Arg.opt Arg.string "" @@ Arg.info ["title"] ~docv:"title" ~doc
222
222
in
223
223
let doc = "Complete a tree title." in
224
224
let info = Cmd.info "complete" ~version ~doc in
···
237
237
let init_cmd ~env =
238
238
let arg_dir =
239
239
let doc = "The directory in which to initialize the forest" in
240
-
Arg.value @@ Arg.opt (Arg.some Arg.string) None @@ Arg.info ["dir"] ~docv: "DIR" ~doc
240
+
Arg.value
241
+
@@ Arg.opt (Arg.some Arg.string) None
242
+
@@ Arg.info ["dir"] ~docv:"DIR" ~doc
241
243
in
242
244
let doc = "Initialize a new forest" in
243
-
let man = [
244
-
`S Manpage.s_description;
245
-
`P "The $(tname) command initializes a $(b,forest) in the current directory. This involves initialising a git repository, setting up a git submodule for the theme, creating an assets and trees directory, as well as a config file."
246
-
]
245
+
let man =
246
+
[
247
+
`S Manpage.s_description;
248
+
`P
249
+
"The $(tname) command initializes a $(b,forest) in the current \
250
+
directory. This involves initialising a git repository, setting up a \
251
+
git submodule for the theme, creating an assets and trees directory, \
252
+
as well as a config file.";
253
+
]
247
254
in
248
255
let info = Cmd.info "init" ~version ~doc ~man in
249
256
Cmd.v info Term.(const (init ~env) $ arg_dir)
250
257
251
258
let lsp ~env _ config =
252
259
let config = Config_parser.parse_forest_config_file config in
253
-
Forester_lsp.start
254
-
~env
255
-
~config
260
+
Forester_lsp.start ~env ~config
256
261
257
262
let lsp_cmd ~env =
258
-
let man = [
259
-
`S Manpage.s_description;
260
-
`P "The $(tname) command starts the forester language server.";
261
-
]
263
+
let man =
264
+
[
265
+
`S Manpage.s_description;
266
+
`P "The $(tname) command starts the forester language server.";
267
+
]
262
268
in
263
269
let doc = "Start the LSP" in
264
270
let info = Cmd.info "lsp" ~version ~doc ~man in
265
-
Cmd.v
266
-
info
267
-
Term.(
268
-
const (lsp ~env)
269
-
$ arg_logs
270
-
$ arg_config
271
-
)
271
+
Cmd.v info Term.(const (lsp ~env) $ arg_logs $ arg_config)
272
272
273
273
let cmd ~env =
274
274
let doc = "a tool for tending mathematical forests" in
275
-
let man = [
276
-
`S Manpage.s_bugs;
277
-
`P "Email bug reports to <~jonsterling/forester-discuss@lists.sr.ht>.";
278
-
`S Manpage.s_authors;
279
-
`P "Jonathan Sterling"
280
-
]
275
+
let man =
276
+
[
277
+
`S Manpage.s_bugs;
278
+
`P "Email bug reports to <~jonsterling/forester-discuss@lists.sr.ht>.";
279
+
`S Manpage.s_authors;
280
+
`P "Jonathan Sterling";
281
+
]
281
282
in
282
283
let info = Cmd.info "forester" ~version ~doc ~man in
283
-
Cmd.group
284
-
info
284
+
Cmd.group info
285
285
[
286
286
build_cmd ~env;
287
287
new_tree_cmd ~env;
288
288
complete_cmd ~env;
289
289
init_cmd ~env;
290
290
query_cmd ~env;
291
-
lsp_cmd ~env
291
+
lsp_cmd ~env;
292
292
]
293
293
294
294
let () =
···
297
297
Logs.set_reporter (Logs_fmt.reporter ());
298
298
let@ env = Eio_main.run in
299
299
let@ () = Forester_core.Reporter.easy_run in
300
-
exit @@ Cmd.eval ~catch: false @@ cmd ~env
300
+
exit @@ Cmd.eval ~catch:false @@ cmd ~env
+2
-2
docs/dune
+2
-2
docs/dune
+2
-1
dune
+2
-1
dune
-2
flake.nix
-2
flake.nix
···
101
101
legacyPackages = scopes.scope';
102
102
packages.default = scopesStatic.main;
103
103
devShells.default = pkgs.mkShell {
104
-
TOPIARY_LANGUAGE_DIR = "topiary";
105
104
inputsFrom = [ scopes.main ];
106
105
107
106
buildInputs =
···
109
108
devPackages
110
109
++ [
111
110
tex
112
-
topiary
113
111
reuse
114
112
watchexec
115
113
];
-10
format.sh
-10
format.sh
+8
-9
lib/compiler/Action.ml
+8
-9
lib/compiler/Action.ml
···
6
6
7
7
open Forester_core
8
8
9
-
type exit =
10
-
Fail | Finished
11
-
[@@deriving show]
9
+
type exit = Fail | Finished [@@deriving show]
12
10
13
11
type t =
14
12
| Quit of exit
···
20
18
| Parse_all
21
19
| Expand_all
22
20
| Eval_all
23
-
| Load_tree of (Eio.Fs.dir_ty Eio.Path.t [@printer Eio.Path.pp])
24
-
| Parse of (Lsp.Uri.t [@printer fun fmt uri -> fprintf fmt "%s" (Lsp.Uri.to_string uri)])
21
+
| Load_tree of (Eio.Fs.dir_ty Eio.Path.t[@printer Eio.Path.pp])
22
+
| Parse of
23
+
(Lsp.Uri.t
24
+
[@printer fun fmt uri -> fprintf fmt "%s" (Lsp.Uri.to_string uri)])
25
25
| Expand of URI.t
26
26
| Eval of URI.t
27
27
| Query of (string, Vertex.t) Datalog_expr.query
28
-
| Query_results of (Vertex_set.t [@opaque])
29
-
| Report_errors of ((Reporter.Message.t Asai.Diagnostic.t [@opaque]) list * t)
28
+
| Query_results of (Vertex_set.t[@opaque])
29
+
| Report_errors of ((Reporter.Message.t Asai.Diagnostic.t[@opaque]) list * t)
30
30
| Run_jobs of Job.job Range.located list
31
31
[@@deriving show]
32
32
33
33
let report ~next_action ~errors =
34
-
if List.length errors > 0 then
35
-
Report_errors (errors, next_action)
34
+
if List.length errors > 0 then Report_errors (errors, next_action)
36
35
else next_action
+11
-12
lib/compiler/Asset_router.ml
+11
-12
lib/compiler/Asset_router.ml
···
9
9
let router : (string, URI.t) Hashtbl.t = Hashtbl.create 100
10
10
11
11
let normalize ?loc source_path =
12
-
try
13
-
Unix.realpath source_path
14
-
with
15
-
| Unix.Unix_error (e, _, m) ->
16
-
Reporter.fatal
17
-
?loc
18
-
(Asset_not_found (Format.asprintf "%s: %s" (Unix.error_message e) m))
12
+
try Unix.realpath source_path
13
+
with Unix.Unix_error (e, _, m) ->
14
+
Reporter.fatal ?loc
15
+
(Asset_not_found (Format.asprintf "%s: %s" (Unix.error_message e) m))
19
16
20
17
let install ~(config : Config.t) ~source_path ~content =
21
18
let normalized = normalize source_path in
22
19
match Hashtbl.find_opt router normalized with
23
20
| Some uri -> uri
24
21
| None ->
25
-
let hash = Result.get_ok @@ Multihash_digestif.of_cstruct `Sha3_256 (Cstruct.of_string content) in
26
-
let cid = Cid.v ~version: `Cidv1 ~codec: `Raw ~base: `Base32 ~hash in
22
+
let hash =
23
+
Result.get_ok
24
+
@@ Multihash_digestif.of_cstruct `Sha3_256 (Cstruct.of_string content)
25
+
in
26
+
let cid = Cid.v ~version:`Cidv1 ~codec:`Raw ~base:`Base32 ~hash in
27
27
let cid_str = Cid.to_string cid in
28
28
let ext = Filename.extension normalized in
29
-
let uri = URI_scheme.named_uri ~base: config.url (cid_str ^ ext) in
29
+
let uri = URI_scheme.named_uri ~base:config.url (cid_str ^ ext) in
30
30
Hashtbl.add router normalized uri;
31
31
uri
32
32
···
34
34
let normalized = normalize ?loc source_path in
35
35
match Hashtbl.find_opt router normalized with
36
36
| Some uri -> uri
37
-
| None ->
38
-
Reporter.fatal ?loc (Asset_has_no_content_address normalized)
37
+
| None -> Reporter.fatal ?loc (Asset_has_no_content_address normalized)
+8
-8
lib/compiler/Build_latex.ml
+8
-8
lib/compiler/Build_latex.ml
···
17
17
let svg_path = Eio.Path.(resources_dir cwd / name) in
18
18
let perm = 0o755 in
19
19
Eio_util.ensure_context_of_path ~perm svg_path;
20
-
try
21
-
Eio.Path.load svg_path
22
-
with
23
-
| Eio.Io (Eio.Fs.E (Eio.Fs.Not_found _), _) ->
24
-
Reporter.emit Log ~extra_remarks: [Asai.Diagnostic.loctextf "Building %s" (Eio.Path.native_exn svg_path)];
25
-
let svg_code = LaTeX_pipeline.latex_to_svg ~env ?loc source in
26
-
Eio.Path.save ~create: (`Or_truncate perm) svg_path svg_code;
27
-
svg_code
20
+
try Eio.Path.load svg_path
21
+
with Eio.Io (Eio.Fs.E (Eio.Fs.Not_found _), _) ->
22
+
Reporter.emit Log
23
+
~extra_remarks:
24
+
[Asai.Diagnostic.loctextf "Building %s" (Eio.Path.native_exn svg_path)];
25
+
let svg_code = LaTeX_pipeline.latex_to_svg ~env ?loc source in
26
+
Eio.Path.save ~create:(`Or_truncate perm) svg_path svg_code;
27
+
svg_code
+1
-5
lib/compiler/Build_latex.mli
+1
-5
lib/compiler/Build_latex.mli
+55
-64
lib/compiler/Cache.ml
+55
-64
lib/compiler/Cache.ml
···
6
6
7
7
open Forester_prelude
8
8
open Forester_core
9
-
open struct module T = Types end
9
+
10
+
open struct
11
+
module T = Types
12
+
end
10
13
11
14
(*Inspired by
12
-
https://rustc-dev-guide.rust-lang.org/queries/incremental-compilation-in-detail.html
15
+
https://rustc-dev-guide.rust-lang.org/queries/incremental-compilation-in-detail.html
13
16
*)
14
17
15
18
module Item = struct
16
19
type color = Red | Green | Unknown
20
+
type meta = {timestamp: float option; color: color}
17
21
18
-
type meta = {
19
-
timestamp: float option;
20
-
color: color;
21
-
}
22
-
23
-
type t = (* Key *)
24
-
| Tree of URI.t
25
-
| Path of Trie.path
26
-
| Asset of string
22
+
type t =
23
+
(* Key *)
24
+
| Tree of URI.t
25
+
| Path of Trie.path
26
+
| Asset of string
27
27
28
28
(* TODO: Hand-roll these for performance? *)
29
29
let compare = compare
30
30
let hash = Hashtbl.hash
31
-
let equal = (=)
31
+
let equal = ( = )
32
32
33
-
let check_timestamp
34
-
= fun path timestamp ->
33
+
let check_timestamp =
34
+
fun path timestamp ->
35
35
match timestamp with
36
36
| Some timestamp ->
37
-
let last_modified = Eio.Path.(stat ~follow: true @@ path).mtime in
38
-
if last_modified > timestamp then
39
-
Red
40
-
else Green
37
+
let last_modified = Eio.Path.(stat ~follow:true @@ path).mtime in
38
+
if last_modified > timestamp then Red else Green
41
39
| _ -> Red
42
40
end
43
41
44
42
(* The core datastructure here is a {graph; hashtbl}
45
43
We shadow many functions from both datastructures.
46
-
*)
44
+
*)
47
45
48
-
module Dependency_tbl = Hashtbl.Make(Item)
46
+
module Dependency_tbl = Hashtbl.Make (Item)
49
47
50
48
module Dependecy_graph : sig
51
-
type t
52
-
type vertex = Item.t
53
-
val add_vertex : t -> vertex -> t
49
+
type t
50
+
type vertex = Item.t
54
51
55
-
val create : ?size: int -> unit -> t
56
-
val pred : t -> vertex -> vertex list
57
-
val empty : unit -> t
58
-
end
59
-
= struct
60
-
module G = Graph.Imperative.Digraph.ConcreteBidirectional(Item)
52
+
val add_vertex : t -> vertex -> t
53
+
val create : ?size:int -> unit -> t
54
+
val pred : t -> vertex -> vertex list
55
+
val empty : unit -> t
56
+
end = struct
57
+
module G = Graph.Imperative.Digraph.ConcreteBidirectional (Item)
58
+
61
59
type t = G.t
62
60
type vertex = Item.t
61
+
63
62
let create = G.create
64
63
let pred = G.pred
65
-
let add_vertex g v = G.add_vertex g v; g
66
-
let empty = G.create ?size: None
64
+
65
+
let add_vertex g v =
66
+
G.add_vertex g v;
67
+
g
68
+
69
+
let empty = G.create ?size:None
67
70
end
68
71
69
72
type t = {
···
72
75
db: Datalog_engine.db;
73
76
}
74
77
75
-
let empty = {
76
-
tbl = Dependency_tbl.create 1000;
77
-
graph = Dependecy_graph.create ();
78
-
db = Datalog_engine.db_create ();
79
-
}
78
+
let empty =
79
+
{
80
+
tbl = Dependency_tbl.create 1000;
81
+
graph = Dependecy_graph.create ();
82
+
db = Datalog_engine.db_create ();
83
+
}
80
84
81
85
let find_opt t uri = Dependency_tbl.find_opt t.tbl uri
82
86
···
86
90
87
91
let pred t v = Dependecy_graph.pred t.graph v
88
92
89
-
let get_changed_paths ~(config : Config.t) (cache : t) (dirs : Eio.Fs.dir_ty Eio.Path.t List.t) : Eio.Fs.dir_ty Eio.Path.t Seq.t =
93
+
let get_changed_paths ~(config : Config.t) (cache : t)
94
+
(dirs : Eio.Fs.dir_ty Eio.Path.t List.t) : Eio.Fs.dir_ty Eio.Path.t Seq.t =
90
95
let@ path = Seq.filter_map @~ Dir_scanner.scan_directories dirs in
91
96
let path_str = Eio.Path.native_exn path in
92
-
let uri = URI_scheme.path_to_uri ~base: config.url path_str in
93
-
let last_modified = Eio.Path.(stat ~follow: true path).mtime in
97
+
let uri = URI_scheme.path_to_uri ~base:config.url path_str in
98
+
let last_modified = Eio.Path.(stat ~follow:true path).mtime in
94
99
(* "flipped" bind, by default returns the current path. IDK, I am being lazy. *)
95
-
let (let*) o f = match o with None -> Some path | Some v -> f v in
100
+
let ( let* ) o f = match o with None -> Some path | Some v -> f v in
96
101
let* {timestamp; _} = Dependency_tbl.find_opt cache.tbl (Tree uri) in
97
102
let* last_seen = timestamp in
98
-
if last_modified > last_seen then
99
-
Some path
100
-
else
101
-
None
103
+
if last_modified > last_seen then Some path else None
102
104
103
105
let rec try_mark_green t node =
104
106
let exception Done of bool in
···
106
108
let@ v = List.filter_map @~ pred t node in
107
109
match Dependency_tbl.find_opt t.tbl v with
108
110
| None -> None
109
-
| Some c ->
110
-
Some (v, c)
111
+
| Some c -> Some (v, c)
111
112
in
112
113
let result =
113
114
try
···
117
118
| Red -> raise (Done false)
118
119
| Green -> true && acc
119
120
| Unknown ->
120
-
if try_mark_green t dep then true && acc
121
-
else raise (Done false)
122
-
)
123
-
dependencies
124
-
true
125
-
with
126
-
| Done b -> b
121
+
if try_mark_green t dep then true && acc else raise (Done false))
122
+
dependencies true
123
+
with Done b -> b
127
124
in
128
125
if result then
129
-
Dependency_tbl.replace
130
-
t.tbl
131
-
node
132
-
{
133
-
color = Green;
134
-
timestamp = Some (Unix.time ())
135
-
}
136
-
else
137
-
assert false;
126
+
Dependency_tbl.replace t.tbl node
127
+
{color = Green; timestamp = Some (Unix.time ())}
128
+
else assert false;
138
129
result
139
130
140
131
let marshal filename (v : t) =
141
132
let oc = open_out_bin filename in
142
133
Fun.protect
143
-
~finally: (fun () -> close_out oc)
134
+
~finally:(fun () -> close_out oc)
144
135
(fun () -> Marshal.to_channel oc v [])
145
136
146
137
let unmarshal filename : t =
147
138
let ic = open_in_bin filename in
148
139
Fun.protect
149
-
~finally: (fun () -> close_in ic)
140
+
~finally:(fun () -> close_in ic)
150
141
(fun () -> Marshal.from_channel ic)
+13
-16
lib/compiler/Dir_scanner.ml
+13
-16
lib/compiler/Dir_scanner.ml
···
6
6
7
7
open Forester_prelude
8
8
open Forester_core
9
-
10
9
module EP = Eio.Path
11
-
module S = Algaeff.Sequencer.Make(struct type t = Eio.Fs.dir_ty EP.t end)
10
+
11
+
module S = Algaeff.Sequencer.Make (struct
12
+
type t = Eio.Fs.dir_ty EP.t
13
+
end)
12
14
13
15
let rec process_file condition fp =
14
-
if EP.is_directory fp then
15
-
process_dir condition fp
16
-
else if condition fp then
17
-
S.yield fp
16
+
if EP.is_directory fp then process_dir condition fp
17
+
else if condition fp then S.yield fp
18
18
19
19
and process_dir condition dir =
20
20
assert (not @@ Filename.is_relative @@ EP.native_exn dir);
21
21
try
22
22
let@ fp = List.iter @~ EP.read_dir dir in
23
23
process_file condition EP.(dir / fp)
24
-
with
25
-
| Eio.Io (Eio.Fs.E (Permission_denied _), _) -> ()
24
+
with Eio.Io (Eio.Fs.E (Permission_denied _), _) -> ()
26
25
27
26
let is_tree fp =
28
27
match EP.split fp with
29
28
| None -> false
30
29
| Some (_, basename) ->
31
-
Filename.extension basename = ".tree" && not @@ String.starts_with ~prefix: "." basename
30
+
Filename.extension basename = ".tree"
31
+
&& (not @@ String.starts_with ~prefix:"." basename)
32
32
33
33
let is_not_hidden fp =
34
34
match EP.split fp with
35
35
| None -> false
36
-
| Some (_, basename) ->
37
-
not @@ String.starts_with ~prefix: "." basename
36
+
| Some (_, basename) -> not @@ String.starts_with ~prefix:"." basename
38
37
39
38
let matching_basename str fp =
40
39
match EP.split fp with
41
40
| None -> false
42
-
| Some (_, basename) ->
43
-
is_tree fp
44
-
&& Filename.chop_extension basename = str
41
+
| Some (_, basename) -> is_tree fp && Filename.chop_extension basename = str
45
42
46
43
let scan_directories dirs =
47
44
let@ () = S.run in
···
68
65
if Filename.is_relative native then raise (Is_relative native);
69
66
Some first_match
70
67
with
71
-
| Is_relative _ -> assert false
72
-
| Failure _ -> None
68
+
| Is_relative _ -> assert false
69
+
| Failure _ -> None
+8
-3
lib/compiler/Dir_scanner.mli
+8
-3
lib/compiler/Dir_scanner.mli
···
6
6
7
7
open Forester_core
8
8
9
-
val scan_directories : Eio.Fs.dir_ty Eio.Path.t list -> Eio.Fs.dir_ty Eio.Path.t Seq.t
10
-
val scan_asset_directories : Eio.Fs.dir_ty Eio.Path.t list -> Eio.Fs.dir_ty Eio.Path.t Seq.t
11
-
val find_tree : Eio.Fs.dir_ty Eio.Path.t list -> URI.t -> Eio.Fs.dir_ty Eio.Path.t option
9
+
val scan_directories :
10
+
Eio.Fs.dir_ty Eio.Path.t list -> Eio.Fs.dir_ty Eio.Path.t Seq.t
11
+
12
+
val scan_asset_directories :
13
+
Eio.Fs.dir_ty Eio.Path.t list -> Eio.Fs.dir_ty Eio.Path.t Seq.t
14
+
15
+
val find_tree :
16
+
Eio.Fs.dir_ty Eio.Path.t list -> URI.t -> Eio.Fs.dir_ty Eio.Path.t option
+101
-119
lib/compiler/Driver.ml
+101
-119
lib/compiler/Driver.ml
···
8
8
open Forester_prelude
9
9
open State.Syntax
10
10
11
-
open struct module T = Types end
11
+
open struct
12
+
module T = Types
13
+
end
12
14
13
15
let update (action : Action.t) (forest : State.t) =
14
16
let open Action in
15
17
let forest = State.update_history forest action in
16
18
match action with
17
-
| Quit e ->
18
-
begin
19
-
match e with
20
-
| Fail -> exit 1
21
-
| Finished -> exit 0
22
-
end
19
+
| Quit e -> begin match e with Fail -> exit 1 | Finished -> exit 0 end
23
20
| Query q ->
24
21
let@ () = Reporter.trace "when running query" in
25
22
let r = Forest.run_datalog_query forest.graphs q in
26
-
Query_results r, forest
27
-
| Query_results _ -> Done, forest
28
-
| Report_errors (_, next_action) -> next_action, forest
23
+
(Query_results r, forest)
24
+
| Query_results _ -> (Done, forest)
25
+
| Report_errors (_, next_action) -> (next_action, forest)
29
26
| Load_all_configured_dirs ->
30
27
let@ () = Reporter.trace "when loading files from disk" in
31
-
let tree_dirs = Eio_util.paths_of_dirs ~env: forest.env forest.config.trees in
28
+
let tree_dirs =
29
+
Eio_util.paths_of_dirs ~env:forest.env forest.config.trees
30
+
in
32
31
List.iter (fun path -> assert (Eio.Path.is_directory path)) tree_dirs;
33
32
let docs = Phases.load tree_dirs in
34
33
Seq.iter
35
34
(fun doc ->
36
35
let lsp_uri = Lsp.Text_document.documentUri doc in
37
-
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url lsp_uri in
36
+
let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url lsp_uri in
38
37
URI.Tbl.replace forest.resolver uri (Lsp.Uri.to_path lsp_uri);
39
-
forest.={uri} <- Document doc
40
-
)
38
+
forest.={uri} <- Document doc)
41
39
docs;
42
40
Logs.debug (fun m -> m "loaded %d trees" (Seq.length docs));
43
-
Parse_all, forest
41
+
(Parse_all, forest)
44
42
| Parse_all ->
45
43
let@ () = Reporter.trace "when parsing trees" in
46
44
let errors, succeeded = Phases.parse forest in
···
48
46
(fun (code : Tree.code) ->
49
47
let@ uri = Option.iter @~ Tree.(identity_to_uri code.identity) in
50
48
forest.={uri} <- Parsed code;
51
-
forest.?{uri} <- []
52
-
)
49
+
forest.?{uri} <- [])
53
50
succeeded;
54
-
if (List.length errors = 0) then
55
-
assert (
56
-
Seq.for_all
57
-
Tree.is_parsed
58
-
(URI.Tbl.to_seq_values forest.index)
59
-
);
51
+
if List.length errors = 0 then
52
+
assert (Seq.for_all Tree.is_parsed (URI.Tbl.to_seq_values forest.index));
60
53
List.iter
61
54
(fun diag ->
62
55
let@ uri =
63
-
Option.iter @~ Option.map (URI_scheme.lsp_uri_to_uri ~base: forest.config.url) (Reporter.guess_uri diag)
56
+
Option.iter
57
+
@~ Option.map
58
+
(URI_scheme.lsp_uri_to_uri ~base:forest.config.url)
59
+
(Reporter.guess_uri diag)
64
60
in
65
-
forest.?{uri} <- [diag]
66
-
)
61
+
forest.?{uri} <- [diag])
67
62
errors;
68
-
Action.report ~errors ~next_action: Build_import_graph, forest
63
+
(Action.report ~errors ~next_action:Build_import_graph, forest)
69
64
| Build_import_graph ->
70
65
let@ () = Reporter.trace "when building import graph" in
71
66
let errors, import_graph = Phases.build_import_graph forest in
72
-
Logs.debug (fun m -> m "import graph has %d vertices" (Forest_graph.nb_vertex import_graph));
73
-
Action.report ~errors ~next_action: Expand_all, {forest with import_graph}
67
+
Logs.debug (fun m ->
68
+
m "import graph has %d vertices" (Forest_graph.nb_vertex import_graph));
69
+
(Action.report ~errors ~next_action:Expand_all, {forest with import_graph})
74
70
| Expand_all ->
75
71
let@ () = Reporter.tracef "when expanding trees" in
76
72
Logs.debug (fun m -> m "expanding trees");
77
73
let errors = Phases.expand_all forest in
78
-
Action.report ~errors ~next_action: Eval_all, forest
74
+
(Action.report ~errors ~next_action:Eval_all, forest)
79
75
| Expand uri ->
80
76
let@ () = Reporter.tracef "when expanding %a" URI.pp uri in
81
-
begin
82
-
match Option.bind forest.={uri} Tree.to_code with
83
-
| None ->
84
-
Action.report ~errors: [Reporter.diagnostic (Resource_not_found uri)] ~next_action: Done, forest
85
-
| Some code ->
86
-
let result, errors = Phases.expand forest code in
87
-
forest.={uri} <- Expanded result;
88
-
Action.report ~errors ~next_action: (Eval uri), forest
77
+
begin match Option.bind forest.={uri} Tree.to_code with
78
+
| None ->
79
+
( Action.report
80
+
~errors:[Reporter.diagnostic (Resource_not_found uri)]
81
+
~next_action:Done,
82
+
forest )
83
+
| Some code ->
84
+
let result, errors = Phases.expand forest code in
85
+
forest.={uri} <- Expanded result;
86
+
(Action.report ~errors ~next_action:(Eval uri), forest)
89
87
end
90
88
| Eval_all ->
91
89
let@ () = Reporter.tracef "when evaluating" in
92
90
Logs.debug (fun m -> m "evaluating");
93
91
let result = Phases.eval forest in
94
92
let jobs, errors =
95
-
result
96
-
|> List.of_seq
97
-
|> List.map
98
-
(fun (Eval.{articles; jobs}, diagnostics) ->
99
-
begin
100
-
let@ article = List.iter @~ articles in
101
-
State.plant_resource (T.Article article) forest
102
-
end;
103
-
jobs, diagnostics
104
-
)
105
-
|> List.split |> fun (j, e) -> List.concat j, List.concat e
93
+
result |> List.of_seq
94
+
|> List.map (fun (Eval.{articles; jobs}, diagnostics) ->
95
+
begin
96
+
let@ article = List.iter @~ articles in
97
+
State.plant_resource (T.Article article) forest
98
+
end;
99
+
(jobs, diagnostics))
100
+
|> List.split
101
+
|> fun (j, e) -> (List.concat j, List.concat e)
106
102
in
107
-
Logs.debug (fun m -> m "got %d resources " (Seq.length (State.get_all_resources forest)));
108
-
Action.report ~errors ~next_action: (Run_jobs jobs), forest
103
+
Logs.debug (fun m ->
104
+
m "got %d resources " (Seq.length (State.get_all_resources forest)));
105
+
(Action.report ~errors ~next_action:(Run_jobs jobs), forest)
109
106
| Eval uri ->
110
107
let@ () = Reporter.tracef "when evaluating %a" URI.pp uri in
111
108
let result, _err = Phases.eval_only uri forest in
112
-
Done, result
109
+
(Done, result)
113
110
| Plant_assets ->
114
111
let@ () = Reporter.tracef "when planting assets" in
115
-
(* TODO: We really only need to plant the assets that are referred to (look for calls to Asset_router.uri_of_asset).*)
112
+
(* TODO: We really only need to plant the assets that are referred to (look
113
+
for calls to Asset_router.uri_of_asset).*)
116
114
let paths =
117
115
Dir_scanner.scan_asset_directories
118
-
(Eio_util.paths_of_dirs ~env: forest.env forest.config.assets)
116
+
(Eio_util.paths_of_dirs ~env:forest.env forest.config.assets)
119
117
in
120
118
Logs.debug (fun m -> m "planting %i assets" (Seq.length paths));
121
119
let module EP = Eio.Path in
122
120
begin
123
-
let@ path = Eio.Fiber.List.iter ~max_fibers: 20 @~ List.of_seq paths in
121
+
let@ path = Eio.Fiber.List.iter ~max_fibers:20 @~ List.of_seq paths in
124
122
let@ () = Reporter.easy_run in
125
123
let content = EP.load path in
126
124
let source_path = EP.native_exn path in
127
-
let uri = Asset_router.install ~config: forest.config ~source_path ~content in
125
+
let uri =
126
+
Asset_router.install ~config:forest.config ~source_path ~content
127
+
in
128
128
Logs.debug (fun m -> m "Installed %s at %a" source_path URI.pp uri);
129
129
State.plant_resource (T.Asset {uri; content}) forest
130
130
end;
131
-
Done, forest
131
+
(Done, forest)
132
132
| Plant_foreign ->
133
133
let@ () = Reporter.tracef "when planting foreign forest" in
134
134
Logs.debug (fun m -> m "Planting foreign forests");
135
135
let result, err = Phases.implant_foreign forest in
136
-
Report_errors (err, Done), result
136
+
(Report_errors (err, Done), result)
137
137
| Run_jobs jobs ->
138
138
Phases.run_jobs forest jobs;
139
-
Done, forest
139
+
(Done, forest)
140
140
| Load_tree path ->
141
141
let@ () = Reporter.tracef "when loading %a" Eio.Path.pp path in
142
142
let doc = Imports.load_tree path in
143
143
Logs.debug (fun m -> m "%s" (Lsp.Text_document.text doc));
144
144
let lsp_uri = Lsp.Text_document.documentUri doc in
145
-
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url lsp_uri in
145
+
let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url lsp_uri in
146
146
forest.={uri} <- Document doc;
147
-
Parse lsp_uri, forest
147
+
(Parse lsp_uri, forest)
148
148
| Parse uri ->
149
149
let@ () = Reporter.tracef "when parsing %s" (Lsp.Uri.to_string uri) in
150
150
Logs.debug (fun m -> m "Reparsing");
151
-
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url uri in
152
-
begin
153
-
match Option.bind forest.={uri} Tree.to_doc with
154
-
| Some doc ->
155
-
begin
156
-
match Parse.parse_document ~config: forest.config doc with
157
-
| Ok code ->
158
-
forest.={uri} <- Parsed code;
159
-
forest.?{uri} <- [];
160
-
Imports.fixup code forest;
161
-
Expand uri, forest
162
-
| Error diagnostic ->
163
-
forest.?{uri} <- [diagnostic];
164
-
(Report_errors ([diagnostic], Done)), forest
165
-
end
166
-
| None ->
167
-
match Imports.resolve_uri_to_code forest uri with
168
-
| None -> Reporter.fatal (Resource_not_found uri)
169
-
| Some code ->
170
-
Imports.fixup code forest;
171
-
forest.={uri} <- Parsed code;
172
-
Expand uri, forest
151
+
let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url uri in
152
+
begin match Option.bind forest.={uri} Tree.to_doc with
153
+
| Some doc -> begin
154
+
match Parse.parse_document ~config:forest.config doc with
155
+
| Ok code ->
156
+
forest.={uri} <- Parsed code;
157
+
forest.?{uri} <- [];
158
+
Imports.fixup code forest;
159
+
(Expand uri, forest)
160
+
| Error diagnostic ->
161
+
forest.?{uri} <- [diagnostic];
162
+
(Report_errors ([diagnostic], Done), forest)
173
163
end
174
-
| Done ->
175
-
Done, forest
164
+
| None -> (
165
+
match Imports.resolve_uri_to_code forest uri with
166
+
| None -> Reporter.fatal (Resource_not_found uri)
167
+
| Some code ->
168
+
Imports.fixup code forest;
169
+
forest.={uri} <- Parsed code;
170
+
(Expand uri, forest))
171
+
end
172
+
| Done -> (Done, forest)
176
173
177
174
let run_until_done a s : State.t =
178
175
let fatal d =
···
187
184
| Quit Fail -> exit 1
188
185
| Quit Finished -> exit 0
189
186
| Done -> new_state
190
-
| _ ->
191
-
go new_action new_state
187
+
| _ -> go new_action new_state
192
188
in
193
189
go a s
194
190
···
197
193
198
194
let any_fatal =
199
195
List.fold_left
200
-
Asai.Diagnostic.(
201
-
fun acc x ->
202
-
acc
203
-
|| x.severity = Error
204
-
|| x.severity = Bug
205
-
)
196
+
Asai.Diagnostic.(fun acc x -> acc || x.severity = Error || x.severity = Bug)
206
197
false
207
198
208
199
let batch_run ~env ~(config : Config.t) ~dev =
209
200
let init =
210
-
State.make ~env ~config ~dev ()
211
-
|> plant_assets
212
-
|> implant_foreign
201
+
State.make ~env ~config ~dev () |> plant_assets |> implant_foreign
213
202
in
214
203
let rec go action state =
215
204
let new_action, new_state = update action state in
···
221
210
assert (List.length errors > 0);
222
211
Logs.debug (fun m -> m "got %d errors" (List.length errors));
223
212
List.iter Reporter.Tty.display errors;
224
-
if any_fatal errors then
225
-
go (Quit Fail) new_state
213
+
if any_fatal errors then go (Quit Fail) new_state
226
214
else go new_action new_state
227
-
| _ ->
228
-
go new_action new_state
215
+
| _ -> go new_action new_state
229
216
in
230
217
go Load_all_configured_dirs init
231
218
232
219
let language_server ~env ~config =
233
-
let init = State.make ~env ~config ~dev: true () in
220
+
let init = State.make ~env ~config ~dev:true () in
234
221
let rec go action state =
235
222
let new_action, new_state = update action state in
236
223
match action with
237
224
| Quit Fail -> exit 1
238
225
| Quit Finished -> exit 0
239
226
| Done -> new_state
240
-
| _ ->
241
-
go new_action new_state
227
+
| _ -> go new_action new_state
242
228
in
243
229
let _, state = update Plant_assets init in
244
230
(* TODO: this ought to implant the foreign trees as well *)
···
251
237
match update action state with
252
238
| new_action, new_state ->
253
239
if action = Done then new_state
254
-
else
255
-
begin
256
-
go new_action new_state
257
-
end
240
+
else begin
241
+
go new_action new_state
242
+
end
258
243
in
259
244
let forest = go a s in
260
-
forest, List.rev !history
245
+
(forest, List.rev !history)
261
246
262
247
let collect_emitted_errors a s =
263
248
let errors = ref [] in
264
249
let rec go action state =
265
250
match update action state with
266
-
| new_action, new_state ->
251
+
| new_action, new_state -> (
267
252
match action with
268
253
| Done -> new_state
269
-
| Report_errors (errs, _) ->
270
-
begin
271
-
errors := errs @ !errors;
272
-
go new_action new_state
273
-
end
274
-
| _ ->
254
+
| Report_errors (errs, _) -> begin
255
+
errors := errs @ !errors;
275
256
go new_action new_state
257
+
end
258
+
| _ -> go new_action new_state)
276
259
in
277
260
let forest = go a s in
278
-
forest, List.rev !errors
261
+
(forest, List.rev !errors)
279
262
280
-
let rec force
281
-
: Action.t list -> State.t -> State.t
282
-
= fun msgs state ->
263
+
let rec force : Action.t list -> State.t -> State.t =
264
+
fun msgs state ->
283
265
match msgs with
284
266
| [] -> state
285
267
| msg :: remaining ->
+54
-59
lib/compiler/Eio_util.ml
+54
-59
lib/compiler/Eio_util.ml
···
10
10
11
11
let path_of_dir ~env dir =
12
12
try
13
-
let path = Path.(Eio.Stdenv.fs env / (Unix.realpath dir)) in
13
+
let path = Path.(Eio.Stdenv.fs env / Unix.realpath dir) in
14
14
assert (Path.is_directory path);
15
15
path
16
16
with
17
-
| Unix.Unix_error (e, _, m) ->
18
-
Reporter.fatal
19
-
IO_error
20
-
~extra_remarks: [
21
-
Asai.Diagnostic.loctextf "%s: %s" (Unix.error_message e) m
22
-
]
23
-
| Assert_failure (_, _, _) ->
24
-
Reporter.fatal
25
-
Configuration_error
26
-
~extra_remarks: [Asai.Diagnostic.loctextf "%s is not a directory" dir]
17
+
| Unix.Unix_error (e, _, m) ->
18
+
Reporter.fatal IO_error
19
+
~extra_remarks:
20
+
[Asai.Diagnostic.loctextf "%s: %s" (Unix.error_message e) m]
21
+
| Assert_failure (_, _, _) ->
22
+
Reporter.fatal Configuration_error
23
+
~extra_remarks:[Asai.Diagnostic.loctextf "%s is not a directory" dir]
27
24
28
25
let path_of_file ~env file =
29
26
try
30
-
let path = Path.(Eio.Stdenv.fs env / (Unix.realpath file)) in
27
+
let path = Path.(Eio.Stdenv.fs env / Unix.realpath file) in
31
28
assert (Path.is_file path);
32
29
path
33
-
with
34
-
| Unix.Unix_error (e, _, m) ->
35
-
Reporter.fatal Configuration_error ~extra_remarks: [Asai.Diagnostic.loctextf "%s: %s" (Unix.error_message e) m]
30
+
with Unix.Unix_error (e, _, m) ->
31
+
Reporter.fatal Configuration_error
32
+
~extra_remarks:
33
+
[Asai.Diagnostic.loctextf "%s: %s" (Unix.error_message e) m]
36
34
37
-
let paths_of_dirs ~env =
38
-
List.map (path_of_dir ~env)
39
-
40
-
let paths_of_files ~env =
41
-
List.map (path_of_file ~env)
35
+
let paths_of_dirs ~env = List.map (path_of_dir ~env)
36
+
let paths_of_files ~env = List.map (path_of_file ~env)
42
37
43
38
module NullSink : Flow.Pi.SINK with type t = unit = struct
44
39
type t = unit
40
+
45
41
let single_write _ _ = 0
46
-
let copy _ ~src: _ = ()
42
+
let copy _ ~src:_ = ()
47
43
end
48
44
49
45
let null_sink () : Flow.sink_ty Resource.t =
···
52
48
53
49
let ensure_context_of_path ~perm (path : _ Path.t) =
54
50
let@ path', _ = Option.iter @~ Path.split path in
55
-
Path.mkdirs ~exists_ok: true ~perm path'
51
+
Path.mkdirs ~exists_ok:true ~perm path'
56
52
57
53
let ensure_remove_file path =
58
-
try
59
-
Eio.Path.unlink path
60
-
with
61
-
| Eio.Exn.Io (Eio.Fs.E (Eio.Fs.Not_found _), _) -> ()
54
+
try Eio.Path.unlink path
55
+
with Eio.Exn.Io (Eio.Fs.E (Eio.Fs.Not_found _), _) -> ()
62
56
63
57
let with_open_tmp_dir ~env kont =
64
58
let dir_name = string_of_int @@ Oo.id (object end) in
65
59
let cwd = Eio.Stdenv.cwd env in
66
60
let tmp = "_tmp" in
67
61
let tmp_path = Eio.Path.(cwd / tmp / dir_name) in
68
-
Path.mkdirs ~exists_ok: true ~perm: 0o755 tmp_path;
62
+
Path.mkdirs ~exists_ok:true ~perm:0o755 tmp_path;
69
63
let@ p = Eio.Path.with_open_dir tmp_path in
70
64
let result = kont p in
71
-
Path.rmtree ~missing_ok: true tmp_path;
65
+
Path.rmtree ~missing_ok:true tmp_path;
72
66
result
73
67
74
68
let run_process ?(quiet = false) ~env ~cwd cmd =
···
77
71
let errbuf = Buffer.create 100 in
78
72
let errsink = Eio.Flow.buffer_sink errbuf in
79
73
let outsink = Eio.Flow.buffer_sink outbuf in
80
-
if not quiet then
81
-
Eio.traceln "Running %s" (String.concat " " cmd);
82
-
try
83
-
Eio.Process.run ~cwd ~stdout: outsink ~stderr: errsink mgr cmd
84
-
with
85
-
| exn ->
86
-
Eio.traceln "Error: %s" (Buffer.contents errbuf);
87
-
Eio.traceln "Output: %s" (Buffer.contents outbuf);
88
-
raise exn
74
+
if not quiet then Eio.traceln "Running %s" (String.concat " " cmd);
75
+
try Eio.Process.run ~cwd ~stdout:outsink ~stderr:errsink mgr cmd
76
+
with exn ->
77
+
Eio.traceln "Error: %s" (Buffer.contents errbuf);
78
+
Eio.traceln "Output: %s" (Buffer.contents outbuf);
79
+
raise exn
89
80
90
81
let file_exists path =
91
82
try
92
83
let@ _ = Eio.Path.with_open_in path in
93
84
true
94
-
with
95
-
| Eio.Io (Eio.Fs.E (Eio.Fs.Not_found _), _) -> false
85
+
with Eio.Io (Eio.Fs.E (Eio.Fs.Not_found _), _) -> false
96
86
97
87
let try_create_dir ~cwd dname =
98
-
let (/) = Path.(/) in
88
+
let ( / ) = Path.( / ) in
99
89
if Eio.Path.is_directory (cwd / dname) then
100
-
Reporter.emit
101
-
Initialization_warning
102
-
~extra_remarks: [Asai.Diagnostic.loctextf "`%s` already exists" dname]
90
+
Reporter.emit Initialization_warning
91
+
~extra_remarks:[Asai.Diagnostic.loctextf "`%s` already exists" dname]
103
92
else
104
-
try
105
-
Eio.Path.mkdir ~perm: 0o755 (cwd / dname)
106
-
with
107
-
| exn ->
108
-
Forester_core.Reporter.emit Initialization_warning ~extra_remarks: [Asai.Diagnostic.loctextf "Failed to create directory `%s`: %a" dname Eio.Exn.pp exn]
93
+
try Eio.Path.mkdir ~perm:0o755 (cwd / dname)
94
+
with exn ->
95
+
Forester_core.Reporter.emit Initialization_warning
96
+
~extra_remarks:
97
+
[
98
+
Asai.Diagnostic.loctextf "Failed to create directory `%s`: %a" dname
99
+
Eio.Exn.pp exn;
100
+
]
109
101
110
102
let try_create_file ~cwd ?(content = "") fname =
111
-
let (/) = Path.(/) in
103
+
let ( / ) = Path.( / ) in
112
104
if Eio.Path.is_file (cwd / fname) then
113
-
Forester_core.Reporter.emit Initialization_warning ~extra_remarks: [Asai.Diagnostic.loctextf "`%s` already exists" fname]
105
+
Forester_core.Reporter.emit Initialization_warning
106
+
~extra_remarks:[Asai.Diagnostic.loctextf "`%s` already exists" fname]
114
107
else
115
-
try
116
-
Eio.Path.save ~create: (`Exclusive 0o644) (cwd / fname) content
117
-
with
118
-
| exn ->
119
-
Forester_core.Reporter.emit Initialization_warning ~extra_remarks: [Asai.Diagnostic.loctextf "Failed to create file `%s`: %a" fname Eio.Exn.pp exn]
108
+
try Eio.Path.save ~create:(`Exclusive 0o644) (cwd / fname) content
109
+
with exn ->
110
+
Forester_core.Reporter.emit Initialization_warning
111
+
~extra_remarks:
112
+
[
113
+
Asai.Diagnostic.loctextf "Failed to create file `%s`: %a" fname
114
+
Eio.Exn.pp exn;
115
+
]
120
116
121
117
(* TODO: test this! *)
122
118
let copy_to_dir ~env ~cwd ~source ~dest_dir =
123
119
let path = Path.(cwd / dest_dir) in
124
-
Path.mkdirs ~exists_ok: true ~perm: 0o755 path;
120
+
Path.mkdirs ~exists_ok:true ~perm:0o755 path;
125
121
if Sys.unix then
126
-
run_process ~quiet: true ~env ~cwd ["cp"; "-R"; source; dest_dir]
127
-
else
128
-
run_process ~quiet: true ~env ~cwd ["xcopy"; source; dest_dir ^ "/"]
122
+
run_process ~quiet:true ~env ~cwd ["cp"; "-R"; source; dest_dir]
123
+
else run_process ~quiet:true ~env ~cwd ["xcopy"; source; dest_dir ^ "/"]
+16
-25
lib/compiler/Eio_util.mli
+16
-25
lib/compiler/Eio_util.mli
···
9
9
(* val ( / ) : ([> Fs.dir_ty ] as 'a) Path.t -> string -> 'a Path.t *)
10
10
11
11
val path_of_dir :
12
-
env: < fs: ([> Fs.dir_ty] as 'a) Path.t; .. > ->
13
-
string ->
14
-
'a Path.t
12
+
env:< fs : ([> Fs.dir_ty] as 'a) Path.t ; .. > -> string -> 'a Path.t
15
13
16
14
val paths_of_dirs :
17
-
env: < fs: ([> Fs.dir_ty] as 'a) Path.t; .. > ->
15
+
env:< fs : ([> Fs.dir_ty] as 'a) Path.t ; .. > ->
18
16
string list ->
19
17
'a Path.t list
20
18
21
19
val path_of_file :
22
-
env: < fs: ([> Fs.dir_ty] as 'a) Path.t; .. > ->
23
-
string ->
24
-
'a Path.t
20
+
env:< fs : ([> Fs.dir_ty] as 'a) Path.t ; .. > -> string -> 'a Path.t
25
21
26
22
val paths_of_files :
27
-
env: < fs: ([> Fs.dir_ty] as 'a) Path.t; .. > ->
23
+
env:< fs : ([> Fs.dir_ty] as 'a) Path.t ; .. > ->
28
24
string list ->
29
25
'a Path.t list
30
26
31
27
val null_sink : unit -> Flow.sink_ty Resource.t
32
28
33
29
val ensure_context_of_path :
34
-
perm: File.Unix_perm.t -> [> Fs.dir_ty] Path.t -> unit
30
+
perm:File.Unix_perm.t -> [> Fs.dir_ty] Path.t -> unit
35
31
36
32
val ensure_remove_file : [> Fs.dir_ty] Path.t -> unit
37
33
38
34
val with_open_tmp_dir :
39
-
env: < cwd: [> Fs.dir_ty] Path.t; .. > ->
40
-
([< `Close | `Dir>`Dir] Path.t -> 'a) ->
35
+
env:< cwd : [> Fs.dir_ty] Path.t ; .. > ->
36
+
([< `Close | `Dir > `Dir] Path.t -> 'a) ->
41
37
'a
42
38
43
39
val run_process :
44
-
?quiet: bool ->
45
-
env:
46
-
< process_mgr: [> [> `Generic] Process.mgr_ty] Process.mgr;
47
-
.. > ->
48
-
cwd: [> Fs.dir_ty] Path.t ->
40
+
?quiet:bool ->
41
+
env:< process_mgr : [> [> `Generic] Process.mgr_ty] Process.mgr ; .. > ->
42
+
cwd:[> Fs.dir_ty] Path.t ->
49
43
string list ->
50
44
unit
51
45
52
46
val file_exists : [> Fs.dir_ty] Path.t -> bool
53
-
54
-
val try_create_dir : cwd: [> Fs.dir_ty] Path.t -> string -> unit
47
+
val try_create_dir : cwd:[> Fs.dir_ty] Path.t -> string -> unit
55
48
56
49
val try_create_file :
57
-
cwd: [> Fs.dir_ty] Path.t -> ?content: string -> string -> unit
50
+
cwd:[> Fs.dir_ty] Path.t -> ?content:string -> string -> unit
58
51
59
52
val copy_to_dir :
60
-
env:
61
-
< process_mgr: [> [> `Generic] Process.mgr_ty] Process.mgr;
62
-
.. > ->
63
-
cwd: [> Fs.dir_ty] Path.t ->
64
-
source: string ->
65
-
dest_dir: string ->
53
+
env:< process_mgr : [> [> `Generic] Process.mgr_ty] Process.mgr ; .. > ->
54
+
cwd:[> Fs.dir_ty] Path.t ->
55
+
source:string ->
56
+
dest_dir:string ->
66
57
unit
+351
-276
lib/compiler/Eval.ml
+351
-276
lib/compiler/Eval.ml
···
11
11
module T = Types
12
12
module String_map = Value.String_map
13
13
module Symbol_map = Value.Symbol_map
14
+
14
15
type located = Value.t Range.located
15
16
end
16
17
17
18
let extract_content (node : located) =
18
19
match node.value with
19
20
| Value.Content content -> content
20
-
| v -> Reporter.fatal ?loc: node.loc (Type_error {expected = [Content]; got = Some v})
21
+
| v ->
22
+
Reporter.fatal ?loc:node.loc
23
+
(Type_error {expected = [Content]; got = Some v})
21
24
22
25
let extract_text_loc (node : located) : string Range.located =
23
26
let content = extract_content node in
···
29
32
in
30
33
match loop Emp (T.extract_content content) with
31
34
| Some txt -> {value = String.trim txt; loc = node.loc}
32
-
| None -> Reporter.fatal ?loc: node.loc (Type_error {expected = [Text]; got = None})
35
+
| None ->
36
+
Reporter.fatal ?loc:node.loc (Type_error {expected = [Text]; got = None})
33
37
34
38
let extract_text (node : located) : string = (extract_text_loc node).value
35
39
36
40
let extract_obj_ptr (x : located) =
37
41
match x.value with
38
42
| Obj sym -> sym
39
-
(* TODO: Rephrase, should be something like "this is a thing of type foo, cannot access method bar"*)
40
-
| other -> Reporter.fatal ?loc: x.loc (Type_error {expected = [Obj]; got = Some other})
43
+
(* TODO: Rephrase, should be something like "this is a thing of type foo,
44
+
cannot access method bar"*)
45
+
| other ->
46
+
Reporter.fatal ?loc:x.loc (Type_error {expected = [Obj]; got = Some other})
41
47
42
48
let extract_sym (x : located) =
43
49
match x.value with
44
50
| Sym sym -> sym
45
-
| other -> Reporter.fatal ?loc: x.loc (Type_error {expected = [Sym]; got = Some other})
51
+
| other ->
52
+
Reporter.fatal ?loc:x.loc (Type_error {expected = [Sym]; got = Some other})
46
53
47
54
let extract_bool (x : located) =
48
55
match x.value with
49
56
| Content (T.Content [Text "true"]) -> true
50
57
| Content (T.Content [Text "false"]) -> false
51
-
| other -> Reporter.fatal ?loc: x.loc (Type_error {expected = [Bool]; got = Some other})
58
+
| other ->
59
+
Reporter.fatal ?loc:x.loc (Type_error {expected = [Bool]; got = Some other})
52
60
53
61
let default_backmatter ~(uri : URI.t) : T.content =
54
62
let vtx = T.Uri_vertex uri in
55
63
let make_section title query =
56
64
let section =
57
-
let frontmatter = T.default_frontmatter ~title: (T.Content [T.Text title]) () in
65
+
let frontmatter =
66
+
T.default_frontmatter ~title:(T.Content [T.Text title]) ()
67
+
in
58
68
let mainmatter = T.Content [T.Results_of_datalog_query query] in
59
-
let flags = {T.default_section_flags with hidden_when_empty = Some true} in
69
+
let flags =
70
+
{T.default_section_flags with hidden_when_empty = Some true}
71
+
in
60
72
T.{frontmatter; mainmatter; flags}
61
73
in
62
74
T.Section section
···
67
79
make_section "Context" @@ Builtin_queries.context_datalog vtx;
68
80
make_section "Backlinks" @@ Builtin_queries.backlinks_datalog vtx;
69
81
make_section "Related" @@ Builtin_queries.related_datalog vtx;
70
-
make_section "Contributions" @@ Builtin_queries.contributions_datalog vtx
82
+
make_section "Contributions" @@ Builtin_queries.contributions_datalog vtx;
71
83
]
72
84
73
-
type result = {articles: T.content T.article list; jobs: Job.job Range.located list} [@@deriving show]
85
+
type result = {
86
+
articles: T.content T.article list;
87
+
jobs: Job.job Range.located list;
88
+
}
89
+
[@@deriving show]
74
90
75
91
module Tape = Tape_effect.Make ()
76
-
module Lex_env = Algaeff.Reader.Make(struct type t = Value.t String_map.t end)
77
-
module Dyn_env = Algaeff.Reader.Make(struct type t = Value.t Symbol_map.t end)
78
-
module Config_env = Algaeff.Reader.Make(struct type t = Config.t end)
79
-
module Heap = Algaeff.State.Make(struct type t = Value.obj Symbol_map.t end)
80
-
module Emitted_trees = Algaeff.State.Make(struct type t = T.content T.article list end)
81
-
module Jobs = Algaeff.State.Make(struct type t = Job.job Range.located list end)
82
-
module Frontmatter = Algaeff.State.Make(struct type t = T.content T.frontmatter end)
83
-
module Mode_env = Algaeff.Reader.Make(struct type t = eval_mode end)
92
+
93
+
module Lex_env = Algaeff.Reader.Make (struct
94
+
type t = Value.t String_map.t
95
+
end)
96
+
97
+
module Dyn_env = Algaeff.Reader.Make (struct
98
+
type t = Value.t Symbol_map.t
99
+
end)
100
+
101
+
module Config_env = Algaeff.Reader.Make (struct
102
+
type t = Config.t
103
+
end)
104
+
105
+
module Heap = Algaeff.State.Make (struct
106
+
type t = Value.obj Symbol_map.t
107
+
end)
108
+
109
+
module Emitted_trees = Algaeff.State.Make (struct
110
+
type t = T.content T.article list
111
+
end)
112
+
113
+
module Jobs = Algaeff.State.Make (struct
114
+
type t = Job.job Range.located list
115
+
end)
116
+
117
+
module Frontmatter = Algaeff.State.Make (struct
118
+
type t = T.content T.frontmatter
119
+
end)
120
+
121
+
module Mode_env = Algaeff.Reader.Make (struct
122
+
type t = eval_mode
123
+
end)
84
124
85
125
let get_current_uri ~loc =
86
126
match (Frontmatter.get ()).uri with
87
127
| Some uri -> uri
88
-
| None -> Reporter.fatal ?loc Internal_error ~extra_remarks: [Asai.Diagnostic.loctext "No uri for tree"]
128
+
| None ->
129
+
Reporter.fatal ?loc Internal_error
130
+
~extra_remarks:[Asai.Diagnostic.loctext "No uri for tree"]
89
131
90
132
let get_transclusion_flags ~loc =
91
133
let dynenv = Dyn_env.read () in
···
96
138
let module S = Expand.Builtins.Transclude in
97
139
let open Option_util in
98
140
let flags = T.default_section_flags in
99
-
{flags with
141
+
{
142
+
flags with
100
143
expanded = override (get_bool S.expanded_sym) flags.expanded;
101
144
header_shown = override (get_bool S.show_heading_sym) flags.header_shown;
102
145
included_in_toc = override (get_bool S.toc_sym) flags.included_in_toc;
103
146
numbered = override (get_bool S.numbered_sym) flags.numbered;
104
-
metadata_shown = override (get_bool S.show_metadata_sym) flags.metadata_shown;
147
+
metadata_shown =
148
+
override (get_bool S.show_metadata_sym) flags.metadata_shown;
105
149
}
106
150
107
-
let resolve_uri ~loc: _ str =
151
+
let resolve_uri ~loc:_ str =
108
152
match URI.of_string_exn str with
109
-
| uri ->
110
-
(* If the URI is just a single component without anything else, we should treat it as a link to a local tree. *)
111
-
match URI.scheme uri, URI.host uri, URI.path_components uri with
153
+
| uri -> (
154
+
(* If the URI is just a single component without anything else, we should
155
+
treat it as a link to a local tree. *)
156
+
match (URI.scheme uri, URI.host uri, URI.path_components uri) with
112
157
| None, None, ([] | [_]) ->
113
158
let config = Config_env.read () in
114
-
let uri = URI_scheme.named_uri ~base: config.url str in
159
+
let uri = URI_scheme.named_uri ~base:config.url str in
115
160
Result.ok uri
116
161
| _ -> Ok uri
117
-
| exception _ -> Error "Invalid URI"
162
+
| exception _ -> Error "Invalid URI")
118
163
119
164
let extract_uri (node : located) =
120
165
let text = extract_text node in
121
-
resolve_uri ~loc: node.loc text
166
+
resolve_uri ~loc:node.loc text
122
167
123
168
let extract_dx_term (node : located) =
124
169
match node.value with
125
170
| Dx_var name -> Datalog_expr.Var name
126
171
| Dx_const vtx -> Datalog_expr.Const vtx
127
172
(* | other -> Reporter.fatalf Type_error "Expected datalog term" *)
128
-
| other -> Reporter.fatal ?loc: node.loc (Type_error {expected = [Datalog_term]; got = Some other})
173
+
| other ->
174
+
Reporter.fatal ?loc:node.loc
175
+
(Type_error {expected = [Datalog_term]; got = Some other})
129
176
130
177
let extract_dx_prop (node : located) =
131
178
match node.value with
132
179
| Dx_prop prop -> prop
133
180
(* | _ -> Reporter.fatalf Type_error "Expected datalog proposition" *)
134
-
| other -> Reporter.fatal ?loc: node.loc (Type_error {expected = [Dx_prop]; got = Some other})
181
+
| other ->
182
+
Reporter.fatal ?loc:node.loc
183
+
(Type_error {expected = [Dx_prop]; got = Some other})
135
184
136
185
let extract_dx_sequent (node : located) =
137
186
match node.value with
138
187
| Dx_sequent sequent -> sequent
139
-
| other -> Reporter.fatal ?loc: node.loc (Type_error {expected = [Dx_sequent]; got = Some other})
188
+
| other ->
189
+
Reporter.fatal ?loc:node.loc
190
+
(Type_error {expected = [Dx_sequent]; got = Some other})
140
191
141
192
let extract_vertex ~type_ (node : located) =
142
193
match type_ with
143
-
| `Content ->
144
-
Ok (T.Content_vertex (extract_content node))
194
+
| `Content -> Ok (T.Content_vertex (extract_content node))
145
195
| `Uri ->
146
196
let@ uri = Result.map @~ extract_uri node in
147
197
T.Uri_vertex uri
···
155
205
| None -> Value.Content (T.Content [])
156
206
| Some node -> eval_node node
157
207
158
-
and eval_tape tape =
159
-
Tape.run ~tape process_tape
160
-
161
-
and eval_pop_arg ~loc =
162
-
Tape.pop_arg ~loc
163
-
|> Range.map eval_tape
164
-
165
-
and pop_content_arg ~loc =
166
-
eval_pop_arg ~loc
167
-
|> extract_content
168
-
169
-
and pop_text_arg ~loc =
170
-
eval_pop_arg ~loc
171
-
|> extract_text
172
-
173
-
and pop_text_arg_loc ~loc =
174
-
eval_pop_arg ~loc
175
-
|> extract_text_loc
208
+
and eval_tape tape = Tape.run ~tape process_tape
209
+
and eval_pop_arg ~loc = Tape.pop_arg ~loc |> Range.map eval_tape
210
+
and pop_content_arg ~loc = eval_pop_arg ~loc |> extract_content
211
+
and pop_text_arg ~loc = eval_pop_arg ~loc |> extract_text
212
+
and pop_text_arg_loc ~loc = eval_pop_arg ~loc |> extract_text_loc
176
213
177
214
and eval_node node : Value.t =
178
215
let loc = node.loc in
179
216
match node.value with
180
-
| Var x ->
181
-
eval_var ~loc x
182
-
| Text str ->
183
-
emit_content_node ~loc @@ T.Text str
217
+
| Var x -> eval_var ~loc x
218
+
| Text str -> emit_content_node ~loc @@ T.Text str
184
219
| Prim p ->
185
-
let content = pop_content_arg ~loc |> T.extract_content |> T.trim_whitespace in
220
+
let content =
221
+
pop_content_arg ~loc |> T.extract_content |> T.trim_whitespace
222
+
in
186
223
emit_content_node ~loc @@ T.prim p @@ T.Content content
187
224
| Fun (xs, body) ->
188
225
let env = Lex_env.read () in
189
-
focus_clo ?loc env (List.map (fun (info, x) -> info, Some x) xs) body
190
-
| Ref ->
191
-
begin
192
-
match eval_pop_arg ~loc |> extract_uri with
193
-
| Ok href ->
194
-
let content =
195
-
T.Content
196
-
[
197
-
T.Transclude {href; target = T.Taxon};
198
-
T.Text " ";
199
-
T.Contextual_number href
200
-
]
201
-
in
202
-
emit_content_node ~loc @@ Link {href; content}
203
-
| Error _ ->
204
-
Reporter.fatal
205
-
?loc
206
-
(Type_error {got = None; expected = [URI]})
207
-
~extra_remarks: [Asai.Diagnostic.loctextf "Expected valid URI in ref"]
208
-
end
226
+
focus_clo ?loc env (List.map (fun (info, x) -> (info, Some x)) xs) body
227
+
| Ref -> begin
228
+
match eval_pop_arg ~loc |> extract_uri with
229
+
| Ok href ->
230
+
let content =
231
+
T.Content
232
+
[
233
+
T.Transclude {href; target = T.Taxon};
234
+
T.Text " ";
235
+
T.Contextual_number href;
236
+
]
237
+
in
238
+
emit_content_node ~loc @@ Link {href; content}
239
+
| Error _ ->
240
+
Reporter.fatal ?loc
241
+
(Type_error {got = None; expected = [URI]})
242
+
~extra_remarks:[Asai.Diagnostic.loctextf "Expected valid URI in ref"]
243
+
end
209
244
| Link {title; dest} ->
210
245
let dest = {node with value = dest} |> Range.map eval_tape in
211
246
let href =
212
247
match extract_uri dest with
213
248
| Ok uri -> uri
214
249
| Error error ->
215
-
Reporter.fatal
216
-
?loc
250
+
Reporter.fatal ?loc
217
251
(Type_error {expected = [URI]; got = None})
218
-
~extra_remarks: [Asai.Diagnostic.loctext error]
219
-
(* "Expected valid URI in link") *)
252
+
~extra_remarks:[Asai.Diagnostic.loctext error]
253
+
(* "Expected valid URI in link") *)
220
254
in
221
255
let content =
222
256
match title with
223
-
| None -> T.Content [T.Transclude {href; target = T.Title {empty_when_untitled = false}}]
257
+
| None ->
258
+
T.Content
259
+
[T.Transclude {href; target = T.Title {empty_when_untitled = false}}]
224
260
| Some title -> {node with value = eval_tape title} |> extract_content
225
261
in
226
262
emit_content_node ~loc @@ Link {href; content}
227
263
| Math (mode, body) ->
228
264
let content =
229
-
let@ () = Mode_env.run ~env: TeX_mode in
265
+
let@ () = Mode_env.run ~env:TeX_mode in
230
266
{node with value = eval_tape body} |> extract_content
231
267
in
232
268
emit_content_node ~loc @@ KaTeX (mode, content)
···
234
270
let rec process : _ list -> _ T.xml_attr list = function
235
271
| [] -> []
236
272
| (key, v) :: attrs ->
237
-
{T.key; value = extract_content {node with value = eval_tape v}} :: process attrs
273
+
{T.key; value = extract_content {node with value = eval_tape v}}
274
+
:: process attrs
238
275
in
239
-
let name = T.{prefix = name.prefix; uname = name.uname; xmlns = name.xmlns} in
276
+
let name =
277
+
T.{prefix = name.prefix; uname = name.uname; xmlns = name.xmlns}
278
+
in
240
279
let content = {node with value = eval_tape body} |> extract_content in
241
280
emit_content_node ~loc @@ T.Xml_elt {name; attrs = process attrs; content}
242
281
| TeX_cs cs ->
243
282
emit_content_node ~loc @@ T.Text (Format.asprintf "%a" pp_tex_cs cs)
244
283
| Unresolved_ident (visible, path) ->
245
284
let tex_cs_opt =
246
-
match path with
247
-
| [name] -> TeX_cs.parse name
248
-
| _ -> None
285
+
match path with [name] -> TeX_cs.parse name | _ -> None
249
286
in
250
-
begin
251
-
match Mode_env.read (), tex_cs_opt with
252
-
| TeX_mode, Some (cs, rest) ->
253
-
emit_content_node ~loc @@ T.Text (Format.asprintf "%a%s" pp_tex_cs cs rest)
254
-
| _, _ ->
255
-
let extra_remarks = Suggestions.create_suggestions ~visible path in
256
-
Reporter.emit ?loc ~extra_remarks (Unresolved_identifier (visible, path));
257
-
emit_content_node ~loc @@ T.Text (Format.asprintf "\\%a" Resolver.Scope.pp_path path)
287
+
begin match (Mode_env.read (), tex_cs_opt) with
288
+
| TeX_mode, Some (cs, rest) ->
289
+
emit_content_node ~loc
290
+
@@ T.Text (Format.asprintf "%a%s" pp_tex_cs cs rest)
291
+
| _, _ ->
292
+
let extra_remarks = Suggestions.create_suggestions ~visible path in
293
+
Reporter.emit ?loc ~extra_remarks (Unresolved_identifier (visible, path));
294
+
emit_content_node ~loc
295
+
@@ T.Text (Format.asprintf "\\%a" Resolver.Scope.pp_path path)
258
296
end
259
297
| Transclude ->
260
298
let flags = get_transclusion_flags ~loc in
···
263
301
match extract_uri href_arg with
264
302
| Ok uri -> uri
265
303
| Error _ ->
266
-
Reporter.fatal ?loc (Type_error {got = None; expected = [URI]}) ~extra_remarks: [Asai.Diagnostic.loctext "Expected valid URI in transclusion"]
304
+
Reporter.fatal ?loc
305
+
(Type_error {got = None; expected = [URI]})
306
+
~extra_remarks:
307
+
[Asai.Diagnostic.loctext "Expected valid URI in transclusion"]
267
308
in
268
309
emit_content_node ~loc @@ T.Transclude {href; target = Full flags}
269
310
| Subtree (addr_opt, nodes) ->
···
271
312
let config = Config_env.read () in
272
313
let uri =
273
314
match addr_opt with
274
-
| Some addr -> Some (URI_scheme.named_uri ~base: config.url addr)
315
+
| Some addr -> Some (URI_scheme.named_uri ~base:config.url addr)
275
316
| None -> None
276
317
in
277
318
let subtree = eval_tree_inner ?uri nodes in
278
319
let frontmatter = Frontmatter.get () in
279
-
let subtree = {subtree with frontmatter = {subtree.frontmatter with uri; designated_parent = frontmatter.uri}} in
280
-
begin
281
-
match uri with
282
-
| Some uri ->
283
-
Emitted_trees.modify @@ List.cons subtree;
284
-
let transclusion = T.{href = uri; target = Full flags} in
285
-
emit_content_node ~loc @@ Transclude transclusion
286
-
| None ->
287
-
emit_content_node ~loc @@ T.Section (T.article_to_section ~flags subtree)
320
+
let subtree =
321
+
{
322
+
subtree with
323
+
frontmatter =
324
+
{subtree.frontmatter with uri; designated_parent = frontmatter.uri};
325
+
}
326
+
in
327
+
begin match uri with
328
+
| Some uri ->
329
+
Emitted_trees.modify @@ List.cons subtree;
330
+
let transclusion = T.{href = uri; target = Full flags} in
331
+
emit_content_node ~loc @@ Transclude transclusion
332
+
| None ->
333
+
emit_content_node ~loc @@ T.Section (T.article_to_section ~flags subtree)
288
334
end
289
335
| Results_of_query ->
290
336
let arg = eval_pop_arg ~loc in
291
-
begin
292
-
match arg.value with
293
-
| Value.Dx_query query ->
294
-
emit_content_node ~loc @@ Results_of_datalog_query query
295
-
| other -> Reporter.fatal ?loc: arg.loc (Type_error {expected = [Dx_query]; got = Some other})
337
+
begin match arg.value with
338
+
| Value.Dx_query query ->
339
+
emit_content_node ~loc @@ Results_of_datalog_query query
340
+
| other ->
341
+
Reporter.fatal ?loc:arg.loc
342
+
(Type_error {expected = [Dx_query]; got = Some other})
296
343
end
297
344
| Syndicate_query_as_json_blob ->
298
345
let name = pop_text_arg ~loc in
299
346
let config = Config_env.read () in
300
-
let blob_uri = URI_scheme.named_uri ~base: config.url @@ name ^ ".json" in
347
+
let blob_uri = URI_scheme.named_uri ~base:config.url @@ name ^ ".json" in
301
348
let query_arg = eval_pop_arg ~loc in
302
-
begin
303
-
match query_arg.value with
304
-
| Dx_query query ->
305
-
let job = Job.Syndicate (Json_blob {blob_uri; query}) in
306
-
Jobs.modify @@ List.cons @@ Range.locate_opt loc job;
307
-
process_tape ()
308
-
| other -> Reporter.fatal ?loc: query_arg.loc (Type_error {expected = [Dx_query]; got = Some other})
349
+
begin match query_arg.value with
350
+
| Dx_query query ->
351
+
let job = Job.Syndicate (Json_blob {blob_uri; query}) in
352
+
Jobs.modify @@ List.cons @@ Range.locate_opt loc job;
353
+
process_tape ()
354
+
| other ->
355
+
Reporter.fatal ?loc:query_arg.loc
356
+
(Type_error {expected = [Dx_query]; got = Some other})
309
357
end
310
358
| Syndicate_current_tree_as_atom_feed ->
311
-
let source_uri = get_current_uri ~loc: node.loc in
359
+
let source_uri = get_current_uri ~loc:node.loc in
312
360
let feed_uri =
313
-
let components = URI.append_path_component (URI.path_components source_uri) "atom.xml" in
361
+
let components =
362
+
URI.append_path_component (URI.path_components source_uri) "atom.xml"
363
+
in
314
364
URI.with_path_components components source_uri
315
365
in
316
366
let job = Job.Syndicate (Atom_feed {source_uri; feed_uri}) in
···
319
369
| Embed_tex ->
320
370
let config = Config_env.read () in
321
371
let preamble, body =
322
-
let@ () = Mode_env.run ~env: TeX_mode in
372
+
let@ () = Mode_env.run ~env:TeX_mode in
323
373
let preamble = pop_content_arg ~loc |> TeX_like.string_of_content in
324
374
let body = pop_content_arg ~loc |> TeX_like.string_of_content in
325
-
preamble, body
375
+
(preamble, body)
326
376
in
327
377
let source = LaTeX_template.to_string ~preamble ~body in
328
378
let hash = Digest.to_hex @@ Digest.string source in
329
379
let job = Job.{hash; source} in
330
-
let uri = Job.uri_for_latex_to_svg_job ~base: config.url job in
380
+
let uri = Job.uri_for_latex_to_svg_job ~base:config.url job in
331
381
let content =
332
382
T.Content
333
383
[
334
384
T.Xml_elt
335
385
{
336
386
content = T.Content [];
337
-
name = {uname = "img"; prefix = "html"; xmlns = Some "http://www.w3.org/1999/xhtml"};
338
-
attrs = [
387
+
name =
339
388
{
340
-
key = {uname = "src"; prefix = ""; xmlns = None};
341
-
value = T.Content [T.Route_of_uri uri]
342
-
}
343
-
]
344
-
}
389
+
uname = "img";
390
+
prefix = "html";
391
+
xmlns = Some "http://www.w3.org/1999/xhtml";
392
+
};
393
+
attrs =
394
+
[
395
+
{
396
+
key = {uname = "src"; prefix = ""; xmlns = None};
397
+
value = T.Content [T.Route_of_uri uri];
398
+
};
399
+
];
400
+
};
345
401
]
346
402
in
347
-
let sources = [
348
-
T.{type_ = "latex"; part = "preamble"; source = preamble};
349
-
T.{type_ = "latex"; part = "body"; source = body}
350
-
]
403
+
let sources =
404
+
[
405
+
T.{type_ = "latex"; part = "preamble"; source = preamble};
406
+
T.{type_ = "latex"; part = "body"; source = body};
407
+
]
351
408
in
352
409
let artefact = T.{hash; content; sources} in
353
410
Jobs.modify (List.cons (Range.locate_opt loc (Job.LaTeX_to_svg job)));
354
411
emit_content_node ~loc @@ T.Artefact artefact
355
412
| Route_asset ->
356
413
let Range.{value = source_path; loc = path_loc} = pop_text_arg_loc ~loc in
357
-
let uri = Asset_router.uri_of_asset ?loc: path_loc ~source_path () in
414
+
let uri = Asset_router.uri_of_asset ?loc:path_loc ~source_path () in
358
415
emit_content_nodes ~loc @@ [T.Route_of_uri uri]
359
416
| Object {self; methods} ->
360
417
let table =
···
366
423
in
367
424
let sym = Symbol.named ["obj"] in
368
425
Heap.modify @@ Symbol_map.add sym Value.{prototype = None; methods = table};
369
-
focus ?loc: node.loc @@ Value.Obj sym
426
+
focus ?loc:node.loc @@ Value.Obj sym
370
427
| Patch {obj; self; super; methods} ->
371
-
let obj_ptr = {node with value = obj} |> Range.map eval_tape |> extract_obj_ptr in
428
+
let obj_ptr =
429
+
{node with value = obj} |> Range.map eval_tape |> extract_obj_ptr
430
+
in
372
431
let table =
373
432
let env = Lex_env.read () in
374
433
let add (name, body) =
375
-
Value.Method_table.add
376
-
name
377
-
Value.{body; self; super; env}
434
+
Value.Method_table.add name Value.{body; self; super; env}
378
435
in
379
436
List.fold_right add methods Value.Method_table.empty
380
437
in
381
438
let sym = Symbol.named ["obj"] in
382
-
Heap.modify @@ Symbol_map.add sym Value.{prototype = Some obj_ptr; methods = table};
383
-
focus ?loc: node.loc @@ Value.Obj sym
439
+
Heap.modify
440
+
@@ Symbol_map.add sym Value.{prototype = Some obj_ptr; methods = table};
441
+
focus ?loc:node.loc @@ Value.Obj sym
384
442
| Group (d, body) ->
385
443
let l, r = delim_to_strings d in
386
444
let content =
387
445
let body = extract_content {node with value = eval_tape body} in
388
-
T.Content (T.Text l :: T.extract_content body @ [T.Text r])
446
+
T.Content ((T.Text l :: T.extract_content body) @ [T.Text r])
389
447
in
390
-
focus ?loc: node.loc @@ Value.Content (T.compress_content content)
448
+
focus ?loc:node.loc @@ Value.Content (T.compress_content content)
391
449
| Call (obj, method_name) ->
392
-
let sym = {node with value = obj} |> Range.map eval_tape |> extract_obj_ptr in
450
+
let sym =
451
+
{node with value = obj} |> Range.map eval_tape |> extract_obj_ptr
452
+
in
393
453
let rec call_method (obj : Value.obj) =
394
454
let proto_val = obj.prototype |> Option.map @@ fun ptr -> Value.Obj ptr in
395
455
match Value.Method_table.find_opt method_name obj.methods with
···
402
462
in
403
463
match proto_val with
404
464
| None -> env
405
-
| Some proto_val ->
465
+
| Some proto_val -> (
406
466
match mthd.super with
407
467
| None -> env
408
-
| Some super -> String_map.add super proto_val env
468
+
| Some super -> String_map.add super proto_val env)
409
469
in
410
470
let@ () = Lex_env.run ~env in
411
471
eval_tape mthd.body
412
-
| None ->
472
+
| None -> (
413
473
match obj.prototype with
414
-
| Some proto ->
415
-
call_method @@ Symbol_map.find proto @@ Heap.get ()
474
+
| Some proto -> call_method @@ Symbol_map.find proto @@ Heap.get ()
416
475
| None ->
417
-
Reporter.fatal
418
-
?loc: node.loc
419
-
(Unbound_method (method_name, obj))
476
+
Reporter.fatal ?loc:node.loc (Unbound_method (method_name, obj)))
420
477
in
421
478
let result = call_method @@ Symbol_map.find sym @@ Heap.get () in
422
-
focus ?loc: node.loc result
479
+
focus ?loc:node.loc result
423
480
| Put (k, v, body) ->
424
481
let k = {node with value = k} |> Range.map eval_tape |> extract_sym in
425
482
let body =
426
483
let@ () = Dyn_env.scope (Symbol_map.add k (eval_tape v)) in
427
484
eval_tape body
428
485
in
429
-
focus ?loc: node.loc body
486
+
focus ?loc:node.loc body
430
487
| Default (k, v, body) ->
431
488
let k = {node with value = k} |> Range.map eval_tape |> extract_sym in
432
489
let body =
433
-
let upd flenv = if Symbol_map.mem k flenv then flenv else Symbol_map.add k (eval_tape v) flenv in
490
+
let upd flenv =
491
+
if Symbol_map.mem k flenv then flenv
492
+
else Symbol_map.add k (eval_tape v) flenv
493
+
in
434
494
let@ () = Dyn_env.scope upd in
435
495
eval_tape body
436
496
in
437
-
focus ?loc: node.loc body
497
+
focus ?loc:node.loc body
438
498
| Get k ->
439
499
let k = {node with value = k} |> Range.map eval_tape |> extract_sym in
440
500
let env = Dyn_env.read () in
441
-
begin
442
-
match Symbol_map.find_opt k env with
443
-
| None ->
444
-
Reporter.fatal
445
-
?loc: node.loc
446
-
(Unbound_fluid_symbol k)
447
-
| Some v -> focus ?loc: node.loc v
501
+
begin match Symbol_map.find_opt k env with
502
+
| None -> Reporter.fatal ?loc:node.loc (Unbound_fluid_symbol k)
503
+
| Some v -> focus ?loc:node.loc v
448
504
end
449
-
| Verbatim str ->
450
-
emit_content_node ~loc @@ CDATA str
505
+
| Verbatim str -> emit_content_node ~loc @@ CDATA str
451
506
| Title ->
452
507
let title = pop_content_arg ~loc in
453
508
Frontmatter.modify (fun fm -> {fm with title = Some title});
···
457
512
let parent =
458
513
match extract_uri parent_arg with
459
514
| Ok uri -> uri
460
-
| Error _ -> Reporter.fatal ?loc Invalid_URI ~extra_remarks: [Asai.Diagnostic.loctext "Expected valid URI in parent declaration"]
515
+
| Error _ ->
516
+
Reporter.fatal ?loc Invalid_URI
517
+
~extra_remarks:
518
+
[Asai.Diagnostic.loctext "Expected valid URI in parent declaration"]
461
519
in
462
520
Frontmatter.modify (fun fm -> {fm with designated_parent = Some parent});
463
521
process_tape ()
464
522
| Meta ->
465
523
let k = pop_text_arg ~loc in
466
524
let v = pop_content_arg ~loc in
467
-
Frontmatter.modify (fun fm -> {fm with metas = fm.metas @ [k, v]});
525
+
Frontmatter.modify (fun fm -> {fm with metas = fm.metas @ [(k, v)]});
468
526
process_tape ()
469
527
| Attribution (role, type_) ->
470
528
let arg = eval_pop_arg ~loc in
···
477
535
| Author -> "\\author/literal"
478
536
| Contributor -> "\\contributor/literal"
479
537
in
480
-
Reporter.emit
481
-
?loc
482
-
Type_warning
483
-
~extra_remarks: [Asai.Diagnostic.loctextf "Expected valid URI in attribution. Use `%s` instead if you intend an unlinked attribution." corrected_attribution_code];
538
+
Reporter.emit ?loc Type_warning
539
+
~extra_remarks:
540
+
[
541
+
Asai.Diagnostic.loctextf
542
+
"Expected valid URI in attribution. Use `%s` instead if you \
543
+
intend an unlinked attribution."
544
+
corrected_attribution_code;
545
+
];
484
546
T.Content_vertex (extract_content arg)
485
547
in
486
548
let attribution = T.{role; vertex} in
487
-
Frontmatter.modify (fun fm -> {fm with attributions = fm.attributions @ [attribution]});
549
+
Frontmatter.modify (fun fm ->
550
+
{fm with attributions = fm.attributions @ [attribution]});
488
551
process_tape ()
489
552
| Tag type_ ->
490
553
let arg = eval_pop_arg ~loc in
···
493
556
| Ok vtx -> vtx
494
557
| Error _ ->
495
558
let corrected = "\\tag/content" in
496
-
Reporter.emit ?loc Type_warning ~extra_remarks: [Asai.Diagnostic.loctextf "Expected valid URI in tag. Use `%s` instead if you intend an unlinked attribution." corrected];
559
+
Reporter.emit ?loc Type_warning
560
+
~extra_remarks:
561
+
[
562
+
Asai.Diagnostic.loctextf
563
+
"Expected valid URI in tag. Use `%s` instead if you intend an \
564
+
unlinked attribution."
565
+
corrected;
566
+
];
497
567
T.Content_vertex (extract_content arg)
498
568
in
499
569
Frontmatter.modify (fun fm -> {fm with tags = fm.tags @ [vertex]});
500
570
process_tape ()
501
571
| Date ->
502
572
let date_str = pop_text_arg ~loc in
503
-
begin
504
-
match Human_datetime.parse_string date_str with
505
-
| None ->
506
-
Reporter.fatal ?loc: node.loc Parse_error ~extra_remarks: [Asai.Diagnostic.loctextf "Invalid date string `%s`" date_str]
507
-
| Some date ->
508
-
Frontmatter.modify (fun fm -> {fm with dates = fm.dates @ [date]});
509
-
process_tape ()
573
+
begin match Human_datetime.parse_string date_str with
574
+
| None ->
575
+
Reporter.fatal ?loc:node.loc Parse_error
576
+
~extra_remarks:
577
+
[Asai.Diagnostic.loctextf "Invalid date string `%s`" date_str]
578
+
| Some date ->
579
+
Frontmatter.modify (fun fm -> {fm with dates = fm.dates @ [date]});
580
+
process_tape ()
510
581
end
511
582
| Number ->
512
583
let num = pop_text_arg ~loc in
···
516
587
let taxon = Some (pop_content_arg ~loc) in
517
588
Frontmatter.modify (fun fm -> {fm with taxon});
518
589
process_tape ()
519
-
| Sym sym ->
520
-
focus ?loc: node.loc @@ Value.Sym sym
590
+
| Sym sym -> focus ?loc:node.loc @@ Value.Sym sym
521
591
| Dx_prop (rel, args) ->
522
592
let rel = {node with value = eval_tape rel} |> extract_text in
523
593
let args =
524
594
let@ arg = List.map @~ args in
525
595
{node with value = eval_tape arg} |> extract_dx_term
526
596
in
527
-
focus ?loc: node.loc @@ Dx_prop {rel; args}
597
+
focus ?loc:node.loc @@ Dx_prop {rel; args}
528
598
| Dx_sequent (conclusion, premises) ->
529
-
let conclusion = {node with value = eval_tape conclusion} |> extract_dx_prop in
599
+
let conclusion =
600
+
{node with value = eval_tape conclusion} |> extract_dx_prop
601
+
in
530
602
let premises =
531
603
let@ premise = List.map @~ premises in
532
604
{node with value = eval_tape premise} |> extract_dx_prop
533
605
in
534
-
focus ?loc: node.loc @@ Dx_sequent {conclusion; premises}
606
+
focus ?loc:node.loc @@ Dx_sequent {conclusion; premises}
535
607
| Dx_query (var, positives, negatives) ->
536
608
let positives =
537
609
let@ premise = List.map @~ positives in
···
541
613
let@ premise = List.map @~ negatives in
542
614
{node with value = eval_tape premise} |> extract_dx_prop
543
615
in
544
-
focus ?loc: node.loc @@ Dx_query {var; positives; negatives}
545
-
| Dx_var name ->
546
-
focus ?loc: node.loc @@ Dx_var name
616
+
focus ?loc:node.loc @@ Dx_query {var; positives; negatives}
617
+
| Dx_var name -> focus ?loc:node.loc @@ Dx_var name
547
618
| Dx_const (type_, arg) ->
548
619
let arg = {node with value = eval_tape arg} in
549
620
let const =
550
621
match type_ with
551
622
| `Content -> T.Content_vertex (extract_content arg)
552
-
| `Uri ->
553
-
begin
554
-
match extract_uri arg with
555
-
| Ok uri -> T.Uri_vertex uri
556
-
| Error _ ->
557
-
Reporter.fatal ?loc: node.loc Invalid_URI ~extra_remarks: [Asai.Diagnostic.loctext "Expected valid URI in datalog constant expression."]
558
-
end
623
+
| `Uri -> begin
624
+
match extract_uri arg with
625
+
| Ok uri -> T.Uri_vertex uri
626
+
| Error _ ->
627
+
Reporter.fatal ?loc:node.loc Invalid_URI
628
+
~extra_remarks:
629
+
[
630
+
Asai.Diagnostic.loctext
631
+
"Expected valid URI in datalog constant expression.";
632
+
]
633
+
end
559
634
in
560
-
focus ?loc: node.loc @@ Dx_const const
635
+
focus ?loc:node.loc @@ Dx_const const
561
636
| Dx_execute ->
562
-
let script = eval_pop_arg ~loc: node.loc |> extract_dx_sequent in
563
-
emit_content_node ~loc: node.loc @@ T.Datalog_script [script]
637
+
let script = eval_pop_arg ~loc:node.loc |> extract_dx_sequent in
638
+
emit_content_node ~loc:node.loc @@ T.Datalog_script [script]
564
639
| Current_tree ->
565
-
emit_content_node ~loc: node.loc @@ T.Uri (get_current_uri ~loc: node.loc)
640
+
emit_content_node ~loc:node.loc @@ T.Uri (get_current_uri ~loc:node.loc)
566
641
567
642
and eval_var ~loc (x : string) =
568
643
let env = Lex_env.read () in
569
644
match String_map.find_opt x env with
570
645
| Some v -> focus ?loc v
571
-
| None ->
572
-
Reporter.fatal
573
-
?loc
574
-
(Unbound_variable x)
646
+
| None -> Reporter.fatal ?loc (Unbound_variable x)
575
647
576
648
and focus ?loc = function
577
-
| Clo (rho, xs, body) ->
578
-
focus_clo ?loc rho xs body
579
-
| Content content ->
580
-
begin
581
-
match process_tape () with
582
-
| Content content' -> Value.Content (T.concat_compressed_content content content')
583
-
| value -> value
584
-
end
585
-
| Sym _ | Obj _ | Dx_prop _ | Dx_sequent _ | Dx_query _ | Dx_var _ | Dx_const _ as v ->
586
-
begin
587
-
match process_tape () with
588
-
| Content content when T.strip_whitespace content = T.Content [] -> v
589
-
| v' ->
590
-
Reporter.fatal
591
-
?loc
592
-
(Type_error {expected = []; got = None})
593
-
~extra_remarks: [Asai.Diagnostic.loctextf "Expected solitary node but got %a / %a" Value.pp v Value.pp v']
594
-
end
649
+
| Clo (rho, xs, body) -> focus_clo ?loc rho xs body
650
+
| Content content -> begin
651
+
match process_tape () with
652
+
| Content content' ->
653
+
Value.Content (T.concat_compressed_content content content')
654
+
| value -> value
655
+
end
656
+
| ( Sym _ | Obj _ | Dx_prop _ | Dx_sequent _ | Dx_query _ | Dx_var _
657
+
| Dx_const _ ) as v -> begin
658
+
match process_tape () with
659
+
| Content content when T.strip_whitespace content = T.Content [] -> v
660
+
| v' ->
661
+
Reporter.fatal ?loc
662
+
(Type_error {expected = []; got = None})
663
+
~extra_remarks:
664
+
[
665
+
Asai.Diagnostic.loctextf "Expected solitary node but got %a / %a"
666
+
Value.pp v Value.pp v';
667
+
]
668
+
end
595
669
596
670
and focus_clo ?loc rho (xs : string option binding list) body =
597
671
match xs with
598
672
| [] ->
599
-
focus ?loc @@
600
-
let@ () = Lex_env.run ~env: rho in
601
-
eval_tape body
602
-
| (info, y) :: ys ->
673
+
focus ?loc
674
+
@@
675
+
let@ () = Lex_env.run ~env:rho in
676
+
eval_tape body
677
+
| (info, y) :: ys -> (
603
678
match Tape.pop_arg_opt () with
604
679
| Some arg ->
605
680
let yval =
···
607
682
| Strict -> eval_tape arg.value
608
683
| Lazy -> Clo (Lex_env.read (), [(Strict, None)], arg.value)
609
684
in
610
-
let rhoy = match y with Some y -> String_map.add y yval rho | None -> rho in
685
+
let rhoy =
686
+
match y with Some y -> String_map.add y yval rho | None -> rho
687
+
in
611
688
focus_clo ?loc rhoy ys body
612
-
| None ->
613
-
begin
614
-
match process_tape () with
615
-
| Content nodes when T.strip_whitespace nodes = T.Content [] -> Clo (rho, xs, body)
616
-
| _ -> Reporter.fatal ?loc Missing_argument ~extra_remarks: [Asai.Diagnostic.loctextf "Expected %i additional arguments" (List.length xs)]
617
-
end
689
+
| None -> begin
690
+
match process_tape () with
691
+
| Content nodes when T.strip_whitespace nodes = T.Content [] ->
692
+
Clo (rho, xs, body)
693
+
| _ ->
694
+
Reporter.fatal ?loc Missing_argument
695
+
~extra_remarks:
696
+
[
697
+
Asai.Diagnostic.loctextf "Expected %i additional arguments"
698
+
(List.length xs);
699
+
]
700
+
end)
618
701
619
702
and emit_content_nodes ~loc content =
620
703
focus ?loc @@ Content (T.Content (T.compress_nodes content))
621
704
622
-
and emit_content_node ~loc content =
623
-
emit_content_nodes ~loc [content]
705
+
and emit_content_node ~loc content = emit_content_nodes ~loc [content]
624
706
625
707
and eval_tree_inner ?(uri : URI.t option) (syn : Syn.t) : T.content T.article =
626
708
let attribution_is_author attr =
627
-
match T.(attr.role) with
628
-
| T.Author -> true
629
-
| _ -> false
709
+
match T.(attr.role) with T.Author -> true | _ -> false
630
710
in
631
711
let outer_frontmatter = Frontmatter.get () in
632
-
let attributions = List.filter attribution_is_author outer_frontmatter.attributions in
712
+
let attributions =
713
+
List.filter attribution_is_author outer_frontmatter.attributions
714
+
in
633
715
let frontmatter =
634
-
T.default_frontmatter
635
-
?uri
636
-
~attributions
637
-
?source_path: outer_frontmatter.source_path
638
-
~dates: outer_frontmatter.dates
716
+
T.default_frontmatter ?uri ~attributions
717
+
?source_path:outer_frontmatter.source_path ~dates:outer_frontmatter.dates
639
718
()
640
719
in
641
-
let@ () = Frontmatter.run ~init: frontmatter in
720
+
let@ () = Frontmatter.run ~init:frontmatter in
642
721
let mainmatter = {value = eval_tape syn; loc = None} |> extract_content in
643
722
let frontmatter = Frontmatter.get () in
644
-
let backmatter = match uri with Some uri -> default_backmatter ~uri | None -> Content [] in
645
-
T.{frontmatter; mainmatter; backmatter = backmatter}
723
+
let backmatter =
724
+
match uri with Some uri -> default_backmatter ~uri | None -> Content []
725
+
in
726
+
T.{frontmatter; mainmatter; backmatter}
646
727
647
-
let empty_result = {
648
-
articles = [];
649
-
jobs = []
650
-
}
728
+
let empty_result = {articles = []; jobs = []}
651
729
652
-
let eval_tree
653
-
~(config : Config.t)
654
-
~(uri : URI.t)
655
-
~(source_path : string option)
656
-
(tree : Syn.t)
657
-
: result * Reporter.diagnostic list
658
-
=
730
+
let eval_tree ~(config : Config.t) ~(uri : URI.t) ~(source_path : string option)
731
+
(tree : Syn.t) : result * Reporter.diagnostic list =
659
732
let diagnostics = ref [] in
660
733
let push d = diagnostics := d :: !diagnostics in
661
734
let res =
662
735
Reporter.run
663
-
~fatal: (fun d -> push d; empty_result)
664
-
~emit: push
665
-
@@ fun () ->
666
-
let fm = T.default_frontmatter ~uri ?source_path () in
667
-
let@ () = Mode_env.run ~env: Text_mode in
668
-
let@ () = Frontmatter.run ~init: fm in
669
-
let@ () = Emitted_trees.run ~init: [] in
670
-
let@ () = Jobs.run ~init: [] in
671
-
let@ () = Heap.run ~init: Symbol_map.empty in
672
-
let@ () = Lex_env.run ~env: String_map.empty in
673
-
let@ () = Dyn_env.run ~env: Symbol_map.empty in
674
-
let@ () = Config_env.run ~env: config in
675
-
let main = eval_tree_inner ~uri tree in
676
-
let side = Emitted_trees.get () in
677
-
let jobs = Jobs.get () in
678
-
{articles = main :: side; jobs}
736
+
~fatal:(fun d ->
737
+
push d;
738
+
empty_result)
739
+
~emit:push
740
+
@@ fun () ->
741
+
let fm = T.default_frontmatter ~uri ?source_path () in
742
+
let@ () = Mode_env.run ~env:Text_mode in
743
+
let@ () = Frontmatter.run ~init:fm in
744
+
let@ () = Emitted_trees.run ~init:[] in
745
+
let@ () = Jobs.run ~init:[] in
746
+
let@ () = Heap.run ~init:Symbol_map.empty in
747
+
let@ () = Lex_env.run ~env:String_map.empty in
748
+
let@ () = Dyn_env.run ~env:Symbol_map.empty in
749
+
let@ () = Config_env.run ~env:config in
750
+
let main = eval_tree_inner ~uri tree in
751
+
let side = Emitted_trees.get () in
752
+
let jobs = Jobs.get () in
753
+
{articles = main :: side; jobs}
679
754
in
680
-
res, !diagnostics
755
+
(res, !diagnostics)
+4
-4
lib/compiler/Eval.mli
+4
-4
lib/compiler/Eval.mli
···
9
9
10
10
type result = {
11
11
articles: T.content T.article list;
12
-
jobs: Job.job Range.located list
12
+
jobs: Job.job Range.located list;
13
13
}
14
14
[@@deriving show]
15
15
16
16
val eval_tree :
17
-
config: Config.t ->
18
-
uri: URI.t ->
19
-
source_path: string option ->
17
+
config:Config.t ->
18
+
uri:URI.t ->
19
+
source_path:string option ->
20
20
Syn.t ->
21
21
result * Reporter.diagnostic list
+866
-175
lib/compiler/Expand.ml
+866
-175
lib/compiler/Expand.ml
···
7
7
open Forester_prelude
8
8
open Forester_core
9
9
open State.Syntax
10
-
11
10
module Unit_map = URI.Map
12
11
13
12
open struct
···
29
28
| {value = Hash_ident x; loc} :: rest ->
30
29
let base = [Range.{value = Syn.Call (base, x); loc}] in
31
30
expand_method_calls base rest
32
-
| rest -> base, rest
31
+
| rest -> (base, rest)
33
32
34
33
type 'a Effect.t += Entered_range : Range.t option -> unit Effect.t
35
34
···
38
37
39
38
let rec expand_eff ~(forest : State.t) : Code.t -> Syn.t = function
40
39
| [] -> []
41
-
| node :: rest ->
40
+
| node :: rest -> begin
42
41
entered_range node.loc;
43
42
match node.value with
44
43
| Hash_ident x ->
45
44
{node with value = Text ("#" ^ x)} :: expand_eff ~forest rest
46
-
| Text x ->
47
-
{node with value = Text x} :: expand_eff ~forest rest
48
-
| Verbatim x ->
49
-
{node with value = Verbatim x} :: expand_eff ~forest rest
45
+
| Text x -> {node with value = Text x} :: expand_eff ~forest rest
46
+
| Verbatim x -> {node with value = Verbatim x} :: expand_eff ~forest rest
50
47
| Namespace (path, body) ->
51
48
let result =
52
49
let@ () = Sc.section path in
···
54
51
in
55
52
result @ expand_eff ~forest rest
56
53
| Open path ->
57
-
Sc.modify_visible @@
58
-
R.Lang.union
59
-
[
60
-
R.Lang.all;
61
-
R.Lang.renaming path []
62
-
];
54
+
Sc.modify_visible @@ R.Lang.union [R.Lang.all; R.Lang.renaming path []];
63
55
expand_eff ~forest rest
64
-
| Group (Squares, x) ->
65
-
begin
66
-
match x with
67
-
| [{value = Group (Squares, y); loc = yloc}] ->
56
+
| Group (Squares, x) -> begin
57
+
match x with
58
+
| [{value = Group (Squares, y); loc = yloc}] ->
59
+
entered_range yloc;
60
+
let y = expand_eff ~forest y in
61
+
{node with value = Link {dest = y; title = None}}
62
+
:: expand_eff ~forest rest
63
+
| _ ->
64
+
let x = expand_eff ~forest x in
65
+
begin match rest with
66
+
| {value = Group (Parens, y); loc = yloc} :: rest ->
68
67
entered_range yloc;
69
68
let y = expand_eff ~forest y in
70
-
{node with value = Link {dest = y; title = None}} :: expand_eff ~forest rest
71
-
| _ ->
72
-
let x = expand_eff ~forest x in
73
-
begin
74
-
match rest with
75
-
| {value = Group (Parens, y); loc = yloc} :: rest ->
76
-
entered_range yloc;
77
-
let y = expand_eff ~forest y in
78
-
(* TODO: merge the ranges *)
79
-
{node with value = Link {dest = y; title = Some x}} :: expand_eff ~forest rest
80
-
| _ -> {node with value = Group (Squares, x)} :: expand_eff ~forest rest
81
-
end
82
-
end
69
+
(* TODO: merge the ranges *)
70
+
{node with value = Link {dest = y; title = Some x}}
71
+
:: expand_eff ~forest rest
72
+
| _ -> {node with value = Group (Squares, x)} :: expand_eff ~forest rest
73
+
end
74
+
end
83
75
| Group (d, x) ->
84
76
let x = expand_eff ~forest x in
85
77
{node with value = Group (d, x)} :: expand_eff ~forest rest
···
99
91
let qname = expand_xml_ident node.loc (prefix, uname) in
100
92
let attrs, rest = get_xml_attrs ~forest [] rest in
101
93
let arg_opt, rest = get_arg_opt ~forest rest in
102
-
{node with value = Xml_tag (qname, attrs, Option.value ~default: [] arg_opt)} :: expand_eff ~forest rest
94
+
{
95
+
node with
96
+
value = Xml_tag (qname, attrs, Option.value ~default:[] arg_opt);
97
+
}
98
+
:: expand_eff ~forest rest
103
99
| Scope body ->
104
100
let body =
105
101
let@ () = Sc.section [] in
···
108
104
body @ expand_eff ~forest rest
109
105
| Alloc x ->
110
106
let symbol = Symbol.named x in
111
-
Sc.include_singleton x (Term [Range.locate_opt node.loc (Syn.Sym symbol)], node.loc);
107
+
Sc.include_singleton x
108
+
(Term [Range.locate_opt node.loc (Syn.Sym symbol)], node.loc);
112
109
expand_eff ~forest rest
113
110
| Put (k, v) ->
114
111
let k = expand_ident node.loc k in
115
112
let v = expand_eff ~forest v in
116
-
(* TODO: merge locations! the resulting location is narrowed to the 'put' node, and therefore breaks the nesting of locations. That could lead to trouble in the future. *)
113
+
(* TODO: merge locations! the resulting location is narrowed to the 'put'
114
+
node, and therefore breaks the nesting of locations. That could lead to
115
+
trouble in the future. *)
117
116
[{node with value = Put (k, v, expand_eff ~forest rest)}]
118
117
| Default (k, v) ->
119
118
let k = expand_ident node.loc k in
120
119
let v = expand_eff ~forest v in
121
-
(* TODO: merge locations! the resulting location is narrowed to the 'put' node, and therefore breaks the nesting of locations. That could lead to trouble in the future. *)
120
+
(* TODO: merge locations! the resulting location is narrowed to the 'put'
121
+
node, and therefore breaks the nesting of locations. That could lead to
122
+
trouble in the future. *)
122
123
[{node with value = Default (k, v, expand_eff ~forest rest)}]
123
124
| Get k ->
124
125
let k = expand_ident node.loc k in
125
126
{node with value = Get k} :: expand_eff ~forest rest
126
-
| Dx_var name ->
127
-
{node with value = Dx_var name} :: expand_eff ~forest rest
127
+
| Dx_var name -> {node with value = Dx_var name} :: expand_eff ~forest rest
128
128
| Dx_const_content x ->
129
129
let x = expand_eff ~forest x in
130
130
{node with value = Dx_const (`Content, x)} :: expand_eff ~forest rest
···
164
164
let@ () = Sc.section [] in
165
165
begin
166
166
let@ self = Option.iter @~ self in
167
-
let var = Range.{value = Syn.Var self; loc = node.loc} in (* TODO: correct the location *)
168
-
Sc.import_singleton [self] (Term [var], node.loc) (* TODO: correct the location*)
167
+
let var = Range.{value = Syn.Var self; loc = node.loc} in
168
+
(* TODO: correct the location *)
169
+
Sc.import_singleton [self] (Term [var], node.loc)
170
+
(* TODO: correct the location*)
169
171
end;
170
172
List.map (expand_method ~forest) methods
171
173
in
···
190
192
let obj = expand_eff ~forest obj in
191
193
{node with value = Call (obj, meth)} :: expand_eff ~forest rest
192
194
| Import (vis, dep) ->
193
-
let dep_uri = URI_scheme.named_uri ~base: forest.config.url dep in
194
-
begin
195
-
match forest./{dep_uri} with
196
-
| None ->
197
-
Reporter.emit ?loc: node.loc (Import_not_found dep_uri)
198
-
| Some tree ->
199
-
begin
200
-
match vis with
201
-
| Public -> Sc.include_subtree [] tree
202
-
| Private -> Sc.import_subtree [] tree
203
-
end
195
+
let dep_uri = URI_scheme.named_uri ~base:forest.config.url dep in
196
+
begin match forest./{dep_uri} with
197
+
| None -> Reporter.emit ?loc:node.loc (Import_not_found dep_uri)
198
+
| Some tree -> begin
199
+
match vis with
200
+
| Public -> Sc.include_subtree [] tree
201
+
| Private -> Sc.import_subtree [] tree
202
+
end
204
203
end;
205
204
expand_eff ~forest rest
206
205
| Comment _ | Error _ ->
207
206
ignore @@ assert false;
208
207
expand_eff ~forest rest
208
+
end
209
209
210
210
and get_xml_attrs ~forest acc = function
211
-
| {value = Group (Squares, [{value = Text key; loc = loc1}]); _} :: {value = Group (Braces, value); loc = loc2} :: rest ->
211
+
| {value = Group (Squares, [{value = Text key; loc = loc1}]); _}
212
+
:: {value = Group (Braces, value); loc = loc2}
213
+
:: rest ->
212
214
entered_range loc1;
213
215
entered_range loc2;
214
-
let qname = expand_xml_ident loc1 @@ Forester_xml_names.split_xml_qname key in
216
+
let qname =
217
+
expand_xml_ident loc1 @@ Forester_xml_names.split_xml_qname key
218
+
in
215
219
let value = expand_eff ~forest value in
216
-
get_xml_attrs ~forest (acc @ [qname, value]) rest
217
-
| rest -> acc, rest
220
+
get_xml_attrs ~forest (acc @ [(qname, value)]) rest
221
+
| rest -> (acc, rest)
218
222
219
223
and get_arg_opt ~forest : Code.t -> _ = function
220
224
| {value = Group (Braces, arg); loc} :: rest ->
221
225
entered_range loc;
222
-
Some (expand_eff ~forest arg), rest
223
-
| rest -> None, rest
226
+
(Some (expand_eff ~forest arg), rest)
227
+
| rest -> (None, rest)
224
228
225
229
and expand_ident loc path =
226
230
match Sc.resolve path with
···
232
236
List.map relocate x
233
237
| Some (Xmlns {xmlns; prefix}, _) ->
234
238
let visible = Sc.get_visible () in
235
-
Reporter.fatal
236
-
?loc
237
-
~extra_remarks: [
238
-
Asai.Diagnostic.loctextf
239
-
"path %a resolved to xmlns:%s=\"%s\" instead of term"
240
-
Sc.pp_path
241
-
path
242
-
xmlns
243
-
prefix
244
-
]
245
-
(Unresolved_identifier (visible, path)) (* TODO: This should be perhaps a different error *)
239
+
Reporter.fatal ?loc
240
+
~extra_remarks:
241
+
[
242
+
Asai.Diagnostic.loctextf
243
+
"path %a resolved to xmlns:%s=\"%s\" instead of term" Sc.pp_path
244
+
path xmlns prefix;
245
+
]
246
+
(Unresolved_identifier (visible, path))
247
+
(* TODO: This should be perhaps a different error *)
246
248
247
249
and expand_xml_ident loc (prefix, uname) : Types.xml_qname =
248
250
match prefix with
249
251
| None -> {xmlns = None; prefix = ""; uname}
250
-
| Some prefix ->
252
+
| Some prefix -> (
251
253
match Sc.resolve ["xmlns"; prefix] with
252
-
| Some (Xmlns {xmlns; prefix}, _) ->
253
-
{xmlns = Some xmlns; prefix = prefix; uname}
254
+
| Some (Xmlns {xmlns; prefix}, _) -> {xmlns = Some xmlns; prefix; uname}
254
255
| _ ->
255
-
Reporter.fatal
256
-
?loc
257
-
(Unresolved_xmlns prefix)
258
-
~extra_remarks: [
259
-
Asai.Diagnostic.loctextf
260
-
"expected path `%s` to resolve to xmlns"
261
-
prefix;
262
-
Asai.Diagnostic.loctextf "You may fix this by defining an XML namespace:@. \\xmlns:%s{...}" prefix;
263
-
]
256
+
Reporter.fatal ?loc (Unresolved_xmlns prefix)
257
+
~extra_remarks:
258
+
[
259
+
Asai.Diagnostic.loctextf "expected path `%s` to resolve to xmlns"
260
+
prefix;
261
+
Asai.Diagnostic.loctextf
262
+
"You may fix this by defining an XML namespace:@. \
263
+
\\xmlns:%s{...}"
264
+
prefix;
265
+
])
264
266
265
-
and expand_method ~forest (key, body) =
266
-
key, expand_eff ~forest body
267
+
and expand_method ~forest (key, body) = (key, expand_eff ~forest body)
267
268
268
269
and expand_lambda ~forest loc (xs, body) =
269
270
let@ () = Sc.section [] in
···
271
272
let@ strategy, x = List.map @~ xs in
272
273
let var = Range.locate_opt None @@ Syn.Var x in
273
274
Sc.import_singleton [x] (Term [var], loc);
274
-
strategy, x
275
+
(strategy, x)
275
276
in
276
277
Range.{value = Syn.Fun (xs, expand_eff ~forest body); loc}
277
278
278
279
let ignore_entered_range f x =
279
280
let open Effect.Deep in
280
-
try_with
281
-
f
282
-
x
281
+
try_with f x
283
282
{
284
-
effc = fun (type a) (eff : a Effect.t) ->
285
-
match eff with
286
-
| Entered_range _ ->
287
-
Option.some @@ fun (k : (a, _) continuation) ->
288
-
continue k ()
289
-
| _ -> None
283
+
effc =
284
+
(fun (type a) (eff : a Effect.t) ->
285
+
match eff with
286
+
| Entered_range _ ->
287
+
Option.some @@ fun (k : (a, _) continuation) -> continue k ()
288
+
| _ -> None);
290
289
}
291
290
292
291
let expand ~forest (xs : Code.t) : Syn.t =
···
294
293
295
294
(* Feel free to extend this *)
296
295
let tex_builtin_words =
297
-
List.to_seq ["left"; "right"; "big"; "bigr"; "Big"; "Bigr"; "bigg"; "biggr"; "Bigg"; "Biggr"; "bigl"; "Bigl"; "biggl"; "Biggl"; "mathrlap"; "mathllap"; "mathclap"; "rlap"; "llap"; "ulap"; "dlap"; "infty"; "infinity"; "lbrace"; "rbrace"; "llbracket"; "rrbracket"; "lvert"; "lVert"; "rvert"; "rVert"; "vert"; "Vert"; "setminus"; "backslash"; "smallsetminus"; "sslash"; "lfloor"; "lceil"; "lmoustache"; "lang"; "langle"; "llangle"; "rfloor"; "rceil"; "rmoustache"; "rang"; "rangle"; "rrangle"; "uparrow"; "downarrow"; "updownarrow"; "prime"; "alpha"; "beta"; "gamma"; "delta"; "zeta"; "eta"; "theta"; "iota"; "kappa"; "lambda"; "mu"; "nu"; "xi"; "pi"; "rho"; "sigma"; "tau"; "upsilon"; "chi"; "psi"; "omega"; "backepsilon"; "varkappa"; "varpi"; "varrho"; "varsigma"; "vartheta"; "varepsilon"; "phi"; "varphi"; "arccos"; "arcsin"; "arctan"; "arg"; "cos"; "cosh"; "cot"; "coth"; "csc"; "deg"; "dim"; "exp"; "hom"; "ker"; "lg"; "ln"; "log"; "sec"; "sin"; "sinh"; "tan"; "tanh"; "det"; "gcd"; "inf"; "lim"; "liminf"; "limsup"; "max"; "min"; "Pr"; "sup"; "omicron"; "epsilon"; "cdot"; "Alpha"; "Beta"; "Delta"; "Gamma"; "digamma"; "Lambda"; "Pi"; "Phi"; "Psi"; "Sigma"; "Theta"; "Xi"; "Zeta"; "Eta"; "Iota"; "Kappa"; "Mu"; "Nu"; "Rho"; "Tau"; "mho"; "Omega"; "Upsilon"; "Upsi"; "iff"; "Longleftrightarrow"; "Leftrightarrow"; "impliedby"; "Leftarrow"; "implies"; "Rightarrow"; "hookleftarrow"; "embedsin"; "hookrightarrow"; "longleftarrow"; "longrightarrow"; "leftarrow"; "to"; "rightarrow"; "leftrightarrow"; "mapsto"; "map"; "nearrow"; "nearr"; "nwarrow"; "nwarr"; "searrow"; "searr"; "swarrow"; "swarr"; "neArrow"; "neArr"; "nwArrow"; "nwArr"; "seArrow"; "seArr"; "swArrow"; "swArr"; "darr"; "Downarrow"; "uparr"; "Uparrow"; "downuparrow"; "duparr"; "updarr"; "Updownarrow"; "leftsquigarrow"; "rightsquigarrow"; "dashleftarrow"; "dashrightarrow"; "curvearrowbotright"; "righttoleftarrow"; "lefttorightarrow"; "leftrightsquigarrow"; "upuparrows"; "rightleftarrows"; "rightrightarrows"; "curvearrowleft"; "curvearrowright"; "downdownarrows"; "leftarrowtail"; "rightarrowtail"; "leftleftarrows"; "leftrightarrows"; "Lleftarrow"; "Rrightarrow"; "looparrowleft"; "looparrowright"; "Lsh"; "Rsh"; "circlearrowleft"; "circlearrowright"; "twoheadleftarrow"; "twoheadrightarrow"; "nLeftarrow"; "nleftarrow"; "nLeftrightarrow"; "nleftrightarrow"; "nRightarrow"; "nrightarrow"; "rightharpoonup"; "rightharpoondown"; "leftharpoonup"; "leftharpoondown"; "downharpoonleft"; "downharpoonright"; "leftrightharpoons"; "rightleftharpoons"; "upharpoonleft"; "upharpoonright"; "xrightarrow"; "xleftarrow"; "xleftrightarrow"; "xLeftarrow"; "xRightarrow"; "xLeftrightarrow"; "xleftrightharpoons"; "xrightleftharpoons"; "xhookleftarrow"; "xhookrightarrow"; "xmapsto"; "dots"; "ldots"; "cdots"; "ddots"; "udots"; "vdots"; "colon"; "cup"; "union"; "bigcup"; "Union"; "⋃"; "cap"; "intersection"; "bigcap"; "Intersection"; "in"; "coloneqq"; "Coloneqq"; "coloneq"; "Coloneq"; "eqqcolon"; "Eqqcolon"; "eqcolon"; "Eqcolon"; "colonapprox"; "Colonapprox"; "colonsim"; "Colonsim"; "dblcolon"; "ast"; "Cap"; "Cup"; "circledast"; "circledcirc"; "curlyvee"; "curlywedge"; "divideontimes"; "dotplus"; "leftthreetimes"; "rightthreetimes"; "veebar"; "gt"; "lt"; "approxeq"; "backsim"; "backsimeq"; "barwedge"; "doublebarwedge"; "subset"; "subseteq"; "subseteqq"; "subsetneq"; "subsetneqq"; "varsubsetneq"; "varsubsetneqq"; "prec"; "parallel"; "nparallel"; "shortparallel"; "nshortparallel"; "perp"; "eqslantgtr"; "eqslantless"; "gg"; "ggg"; "geq"; "geqq"; "geqslant"; "gneq"; "gneqq"; "gnapprox"; "gnsim"; "gtrapprox"; "ge"; "le"; "leq"; "leqq"; "leqslant"; "lessapprox"; "lessdot"; "lesseqgtr"; "lesseqqgtr"; "lessgtr"; "lneq"; "lneqq"; "lnsim"; "lvertneqq"; "gtrsim"; "gtrdot"; "gtreqless"; "gtreqqless"; "gtrless"; "gvertneqq"; "lesssim"; "lnapprox"; "nsubset"; "nsubseteq"; "nsubseteqq"; "notin"; "ni"; "notni"; "nmid"; "nshortmid"; "preceq"; "npreceq"; "ll"; "ngeq"; "ngeqq"; "ngeqslant"; "nleq"; "nleqq"; "nleqslant"; "nless"; "supset"; "supseteq"; "supseteqq"; "supsetneq"; "supsetneqq"; "varsupsetneq"; "varsupsetneqq"; "approx"; "asymp"; "bowtie"; "dashv"; "Vdash"; "vDash"; "VDash"; "vdash"; "Vvdash"; "models"; "sim"; "simeq"; "nsim"; "smile"; "triangle"; "triangledown"; "triangleleft"; "cong"; "succ"; "nsucc"; "ngtr"; "nsupset"; "nsupseteq"; "propto"; "equiv"; "nequiv"; "frown"; "triangleright"; "ncong"; "succeq"; "succapprox"; "succnapprox"; "succcurlyeq"; "succsim"; "succnsim"; "nsucceq"; "nvDash"; "nvdash"; "nVDash"; "amalg"; "pm"; "mp"; "bigcirc"; "wr"; "odot"; "uplus"; "clubsuit"; "spadesuit"; "Diamond"; "diamond"; "sqcup"; "sqcap"; "sqsubset"; "sqsubseteq"; "sqsupset"; "sqsupseteq"; "Subset"; "Supset"; "ltimes"; "div"; "rtimes"; "bot"; "therefore"; "thickapprox"; "thicksim"; "varpropto"; "varnothing"; "flat"; "vee"; "because"; "between"; "Bumpeq"; "bumpeq"; "circeq"; "curlyeqprec"; "curlyeqsucc"; "doteq"; "doteqdot"; "eqcirc"; "fallingdotseq"; "multimap"; "pitchfork"; "precapprox"; "precnapprox"; "preccurlyeq"; "precsim"; "precnsim"; "risingdotseq"; "sharp"; "bullet"; "nexists"; "dagger"; "ddagger"; "not"; "top"; "natural"; "angle"; "measuredangle"; "backprime"; "bigstar"; "blacklozenge"; "lozenge"; "blacksquare"; "blacktriangle"; "blacktriangleleft"; "blacktriangleright"; "blacktriangledown"; "ntriangleleft"; "ntriangleright"; "ntrianglelefteq"; "ntrianglerighteq"; "trianglelefteq"; "trianglerighteq"; "triangleq"; "vartriangleleft"; "vartriangleright"; "forall"; "bigtriangleup"; "bigtriangledown"; "nprec"; "aleph"; "beth"; "eth"; "ell"; "hbar"; "Im"; "imath"; "jmath"; "wp"; "Re"; "Perp"; "Vbar"; "boxdot"; "Box"; "square"; "emptyset"; "empty"; "exists"; "circ"; "rhd"; "lhd"; "lll"; "unrhd"; "unlhd"; "Del"; "nabla"; "sphericalangle"; "heartsuit"; "diamondsuit"; "partial"; "qed"; "mod"; "pmod"; "bottom"; "neg"; "neq"; "ne"; "shortmid"; "mid"; "int"; "integral"; "iint"; "doubleintegral"; "iiint"; "tripleintegral"; "iiiint"; "quadrupleintegral"; "oint"; "conint"; "contourintegral"; "times"; "star"; "circleddash"; "odash"; "intercal"; "smallfrown"; "smallsmile"; "boxminus"; "minusb"; "boxplus"; "plusb"; "boxtimes"; "timesb"; "sum"; "prod"; "product"; "coprod"; "coproduct"; "otimes"; "Otimes"; "bigotimes"; "ominus"; "oslash"; "oplus"; "Oplus"; "bigoplus"; "bigodot"; "bigsqcup"; "bigsqcap"; "biginterleave"; "biguplus"; "wedge"; "Wedge"; "bigwedge"; "Vee"; "bigvee"; "invamp"; "parr"; "frac"; "tfrac"; "binom"; "tbinom"; "tensor"; "multiscripts"; "overbrace"; "underbrace"; "underline"; "bar"; "overline"; "closure"; "widebar"; "vec"; "widevec"; "overrightarrow"; "overleftarrow"; "overleftrightarrow"; "underrightarrow"; "underleftarrow"; "underleftrightarrow"; "dot"; "ddot"; "dddot"; "ddddot"; "tilde"; "widetilde"; "check"; "widecheck"; "hat"; "widehat"; "underset"; "stackrel"; "overset"; "over"; "atop"; "underoverset"; "sqrt"; "root"; "space"; "text"; "statusline"; "tooltip"; "toggle"; "begintoggle"; "endtoggle"; "mathraisebox"; "fghilight"; "fghighlight"; "bghilight"; "bghighlight"; "color"; "bgcolor"; "displaystyle"; "textstyle"; "textsize"; "scriptsize"; "scriptscriptsize"; "mathit"; "mathsf"; "mathtt"; "boldsymbol"; "mathbf"; "mathrm"; "mathbb"; "mathfrak"; "mathfr"; "slash"; "boxed"; "mathcal"; "mathscr"; "begin"; "end"; "substack"; "array"; "arrayopts"; "colalign"; "collayout"; "rowalign"; "align"; "equalrows"; "equalcols"; "rowlines"; "collines"; "frame"; "padding"; "rowopts"; "cellopts"; "rowspan"; "colspan"; "thinspace"; "medspace"; "thickspace"; "quad"; "qquad"; "negspace"; "negthinspace"; "negmedspace"; "negthickspace"; "phantom"; "operatorname"; "mathop"; "mathbin"; "mathrel"; "includegraphics"; "lparen"; "rparen"; "land"; "lor"; "middle"; "mathpunct"; "mathord"]
296
+
List.to_seq
297
+
[
298
+
"left";
299
+
"right";
300
+
"big";
301
+
"bigr";
302
+
"Big";
303
+
"Bigr";
304
+
"bigg";
305
+
"biggr";
306
+
"Bigg";
307
+
"Biggr";
308
+
"bigl";
309
+
"Bigl";
310
+
"biggl";
311
+
"Biggl";
312
+
"mathrlap";
313
+
"mathllap";
314
+
"mathclap";
315
+
"rlap";
316
+
"llap";
317
+
"ulap";
318
+
"dlap";
319
+
"infty";
320
+
"infinity";
321
+
"lbrace";
322
+
"rbrace";
323
+
"llbracket";
324
+
"rrbracket";
325
+
"lvert";
326
+
"lVert";
327
+
"rvert";
328
+
"rVert";
329
+
"vert";
330
+
"Vert";
331
+
"setminus";
332
+
"backslash";
333
+
"smallsetminus";
334
+
"sslash";
335
+
"lfloor";
336
+
"lceil";
337
+
"lmoustache";
338
+
"lang";
339
+
"langle";
340
+
"llangle";
341
+
"rfloor";
342
+
"rceil";
343
+
"rmoustache";
344
+
"rang";
345
+
"rangle";
346
+
"rrangle";
347
+
"uparrow";
348
+
"downarrow";
349
+
"updownarrow";
350
+
"prime";
351
+
"alpha";
352
+
"beta";
353
+
"gamma";
354
+
"delta";
355
+
"zeta";
356
+
"eta";
357
+
"theta";
358
+
"iota";
359
+
"kappa";
360
+
"lambda";
361
+
"mu";
362
+
"nu";
363
+
"xi";
364
+
"pi";
365
+
"rho";
366
+
"sigma";
367
+
"tau";
368
+
"upsilon";
369
+
"chi";
370
+
"psi";
371
+
"omega";
372
+
"backepsilon";
373
+
"varkappa";
374
+
"varpi";
375
+
"varrho";
376
+
"varsigma";
377
+
"vartheta";
378
+
"varepsilon";
379
+
"phi";
380
+
"varphi";
381
+
"arccos";
382
+
"arcsin";
383
+
"arctan";
384
+
"arg";
385
+
"cos";
386
+
"cosh";
387
+
"cot";
388
+
"coth";
389
+
"csc";
390
+
"deg";
391
+
"dim";
392
+
"exp";
393
+
"hom";
394
+
"ker";
395
+
"lg";
396
+
"ln";
397
+
"log";
398
+
"sec";
399
+
"sin";
400
+
"sinh";
401
+
"tan";
402
+
"tanh";
403
+
"det";
404
+
"gcd";
405
+
"inf";
406
+
"lim";
407
+
"liminf";
408
+
"limsup";
409
+
"max";
410
+
"min";
411
+
"Pr";
412
+
"sup";
413
+
"omicron";
414
+
"epsilon";
415
+
"cdot";
416
+
"Alpha";
417
+
"Beta";
418
+
"Delta";
419
+
"Gamma";
420
+
"digamma";
421
+
"Lambda";
422
+
"Pi";
423
+
"Phi";
424
+
"Psi";
425
+
"Sigma";
426
+
"Theta";
427
+
"Xi";
428
+
"Zeta";
429
+
"Eta";
430
+
"Iota";
431
+
"Kappa";
432
+
"Mu";
433
+
"Nu";
434
+
"Rho";
435
+
"Tau";
436
+
"mho";
437
+
"Omega";
438
+
"Upsilon";
439
+
"Upsi";
440
+
"iff";
441
+
"Longleftrightarrow";
442
+
"Leftrightarrow";
443
+
"impliedby";
444
+
"Leftarrow";
445
+
"implies";
446
+
"Rightarrow";
447
+
"hookleftarrow";
448
+
"embedsin";
449
+
"hookrightarrow";
450
+
"longleftarrow";
451
+
"longrightarrow";
452
+
"leftarrow";
453
+
"to";
454
+
"rightarrow";
455
+
"leftrightarrow";
456
+
"mapsto";
457
+
"map";
458
+
"nearrow";
459
+
"nearr";
460
+
"nwarrow";
461
+
"nwarr";
462
+
"searrow";
463
+
"searr";
464
+
"swarrow";
465
+
"swarr";
466
+
"neArrow";
467
+
"neArr";
468
+
"nwArrow";
469
+
"nwArr";
470
+
"seArrow";
471
+
"seArr";
472
+
"swArrow";
473
+
"swArr";
474
+
"darr";
475
+
"Downarrow";
476
+
"uparr";
477
+
"Uparrow";
478
+
"downuparrow";
479
+
"duparr";
480
+
"updarr";
481
+
"Updownarrow";
482
+
"leftsquigarrow";
483
+
"rightsquigarrow";
484
+
"dashleftarrow";
485
+
"dashrightarrow";
486
+
"curvearrowbotright";
487
+
"righttoleftarrow";
488
+
"lefttorightarrow";
489
+
"leftrightsquigarrow";
490
+
"upuparrows";
491
+
"rightleftarrows";
492
+
"rightrightarrows";
493
+
"curvearrowleft";
494
+
"curvearrowright";
495
+
"downdownarrows";
496
+
"leftarrowtail";
497
+
"rightarrowtail";
498
+
"leftleftarrows";
499
+
"leftrightarrows";
500
+
"Lleftarrow";
501
+
"Rrightarrow";
502
+
"looparrowleft";
503
+
"looparrowright";
504
+
"Lsh";
505
+
"Rsh";
506
+
"circlearrowleft";
507
+
"circlearrowright";
508
+
"twoheadleftarrow";
509
+
"twoheadrightarrow";
510
+
"nLeftarrow";
511
+
"nleftarrow";
512
+
"nLeftrightarrow";
513
+
"nleftrightarrow";
514
+
"nRightarrow";
515
+
"nrightarrow";
516
+
"rightharpoonup";
517
+
"rightharpoondown";
518
+
"leftharpoonup";
519
+
"leftharpoondown";
520
+
"downharpoonleft";
521
+
"downharpoonright";
522
+
"leftrightharpoons";
523
+
"rightleftharpoons";
524
+
"upharpoonleft";
525
+
"upharpoonright";
526
+
"xrightarrow";
527
+
"xleftarrow";
528
+
"xleftrightarrow";
529
+
"xLeftarrow";
530
+
"xRightarrow";
531
+
"xLeftrightarrow";
532
+
"xleftrightharpoons";
533
+
"xrightleftharpoons";
534
+
"xhookleftarrow";
535
+
"xhookrightarrow";
536
+
"xmapsto";
537
+
"dots";
538
+
"ldots";
539
+
"cdots";
540
+
"ddots";
541
+
"udots";
542
+
"vdots";
543
+
"colon";
544
+
"cup";
545
+
"union";
546
+
"bigcup";
547
+
"Union";
548
+
"⋃";
549
+
"cap";
550
+
"intersection";
551
+
"bigcap";
552
+
"Intersection";
553
+
"in";
554
+
"coloneqq";
555
+
"Coloneqq";
556
+
"coloneq";
557
+
"Coloneq";
558
+
"eqqcolon";
559
+
"Eqqcolon";
560
+
"eqcolon";
561
+
"Eqcolon";
562
+
"colonapprox";
563
+
"Colonapprox";
564
+
"colonsim";
565
+
"Colonsim";
566
+
"dblcolon";
567
+
"ast";
568
+
"Cap";
569
+
"Cup";
570
+
"circledast";
571
+
"circledcirc";
572
+
"curlyvee";
573
+
"curlywedge";
574
+
"divideontimes";
575
+
"dotplus";
576
+
"leftthreetimes";
577
+
"rightthreetimes";
578
+
"veebar";
579
+
"gt";
580
+
"lt";
581
+
"approxeq";
582
+
"backsim";
583
+
"backsimeq";
584
+
"barwedge";
585
+
"doublebarwedge";
586
+
"subset";
587
+
"subseteq";
588
+
"subseteqq";
589
+
"subsetneq";
590
+
"subsetneqq";
591
+
"varsubsetneq";
592
+
"varsubsetneqq";
593
+
"prec";
594
+
"parallel";
595
+
"nparallel";
596
+
"shortparallel";
597
+
"nshortparallel";
598
+
"perp";
599
+
"eqslantgtr";
600
+
"eqslantless";
601
+
"gg";
602
+
"ggg";
603
+
"geq";
604
+
"geqq";
605
+
"geqslant";
606
+
"gneq";
607
+
"gneqq";
608
+
"gnapprox";
609
+
"gnsim";
610
+
"gtrapprox";
611
+
"ge";
612
+
"le";
613
+
"leq";
614
+
"leqq";
615
+
"leqslant";
616
+
"lessapprox";
617
+
"lessdot";
618
+
"lesseqgtr";
619
+
"lesseqqgtr";
620
+
"lessgtr";
621
+
"lneq";
622
+
"lneqq";
623
+
"lnsim";
624
+
"lvertneqq";
625
+
"gtrsim";
626
+
"gtrdot";
627
+
"gtreqless";
628
+
"gtreqqless";
629
+
"gtrless";
630
+
"gvertneqq";
631
+
"lesssim";
632
+
"lnapprox";
633
+
"nsubset";
634
+
"nsubseteq";
635
+
"nsubseteqq";
636
+
"notin";
637
+
"ni";
638
+
"notni";
639
+
"nmid";
640
+
"nshortmid";
641
+
"preceq";
642
+
"npreceq";
643
+
"ll";
644
+
"ngeq";
645
+
"ngeqq";
646
+
"ngeqslant";
647
+
"nleq";
648
+
"nleqq";
649
+
"nleqslant";
650
+
"nless";
651
+
"supset";
652
+
"supseteq";
653
+
"supseteqq";
654
+
"supsetneq";
655
+
"supsetneqq";
656
+
"varsupsetneq";
657
+
"varsupsetneqq";
658
+
"approx";
659
+
"asymp";
660
+
"bowtie";
661
+
"dashv";
662
+
"Vdash";
663
+
"vDash";
664
+
"VDash";
665
+
"vdash";
666
+
"Vvdash";
667
+
"models";
668
+
"sim";
669
+
"simeq";
670
+
"nsim";
671
+
"smile";
672
+
"triangle";
673
+
"triangledown";
674
+
"triangleleft";
675
+
"cong";
676
+
"succ";
677
+
"nsucc";
678
+
"ngtr";
679
+
"nsupset";
680
+
"nsupseteq";
681
+
"propto";
682
+
"equiv";
683
+
"nequiv";
684
+
"frown";
685
+
"triangleright";
686
+
"ncong";
687
+
"succeq";
688
+
"succapprox";
689
+
"succnapprox";
690
+
"succcurlyeq";
691
+
"succsim";
692
+
"succnsim";
693
+
"nsucceq";
694
+
"nvDash";
695
+
"nvdash";
696
+
"nVDash";
697
+
"amalg";
698
+
"pm";
699
+
"mp";
700
+
"bigcirc";
701
+
"wr";
702
+
"odot";
703
+
"uplus";
704
+
"clubsuit";
705
+
"spadesuit";
706
+
"Diamond";
707
+
"diamond";
708
+
"sqcup";
709
+
"sqcap";
710
+
"sqsubset";
711
+
"sqsubseteq";
712
+
"sqsupset";
713
+
"sqsupseteq";
714
+
"Subset";
715
+
"Supset";
716
+
"ltimes";
717
+
"div";
718
+
"rtimes";
719
+
"bot";
720
+
"therefore";
721
+
"thickapprox";
722
+
"thicksim";
723
+
"varpropto";
724
+
"varnothing";
725
+
"flat";
726
+
"vee";
727
+
"because";
728
+
"between";
729
+
"Bumpeq";
730
+
"bumpeq";
731
+
"circeq";
732
+
"curlyeqprec";
733
+
"curlyeqsucc";
734
+
"doteq";
735
+
"doteqdot";
736
+
"eqcirc";
737
+
"fallingdotseq";
738
+
"multimap";
739
+
"pitchfork";
740
+
"precapprox";
741
+
"precnapprox";
742
+
"preccurlyeq";
743
+
"precsim";
744
+
"precnsim";
745
+
"risingdotseq";
746
+
"sharp";
747
+
"bullet";
748
+
"nexists";
749
+
"dagger";
750
+
"ddagger";
751
+
"not";
752
+
"top";
753
+
"natural";
754
+
"angle";
755
+
"measuredangle";
756
+
"backprime";
757
+
"bigstar";
758
+
"blacklozenge";
759
+
"lozenge";
760
+
"blacksquare";
761
+
"blacktriangle";
762
+
"blacktriangleleft";
763
+
"blacktriangleright";
764
+
"blacktriangledown";
765
+
"ntriangleleft";
766
+
"ntriangleright";
767
+
"ntrianglelefteq";
768
+
"ntrianglerighteq";
769
+
"trianglelefteq";
770
+
"trianglerighteq";
771
+
"triangleq";
772
+
"vartriangleleft";
773
+
"vartriangleright";
774
+
"forall";
775
+
"bigtriangleup";
776
+
"bigtriangledown";
777
+
"nprec";
778
+
"aleph";
779
+
"beth";
780
+
"eth";
781
+
"ell";
782
+
"hbar";
783
+
"Im";
784
+
"imath";
785
+
"jmath";
786
+
"wp";
787
+
"Re";
788
+
"Perp";
789
+
"Vbar";
790
+
"boxdot";
791
+
"Box";
792
+
"square";
793
+
"emptyset";
794
+
"empty";
795
+
"exists";
796
+
"circ";
797
+
"rhd";
798
+
"lhd";
799
+
"lll";
800
+
"unrhd";
801
+
"unlhd";
802
+
"Del";
803
+
"nabla";
804
+
"sphericalangle";
805
+
"heartsuit";
806
+
"diamondsuit";
807
+
"partial";
808
+
"qed";
809
+
"mod";
810
+
"pmod";
811
+
"bottom";
812
+
"neg";
813
+
"neq";
814
+
"ne";
815
+
"shortmid";
816
+
"mid";
817
+
"int";
818
+
"integral";
819
+
"iint";
820
+
"doubleintegral";
821
+
"iiint";
822
+
"tripleintegral";
823
+
"iiiint";
824
+
"quadrupleintegral";
825
+
"oint";
826
+
"conint";
827
+
"contourintegral";
828
+
"times";
829
+
"star";
830
+
"circleddash";
831
+
"odash";
832
+
"intercal";
833
+
"smallfrown";
834
+
"smallsmile";
835
+
"boxminus";
836
+
"minusb";
837
+
"boxplus";
838
+
"plusb";
839
+
"boxtimes";
840
+
"timesb";
841
+
"sum";
842
+
"prod";
843
+
"product";
844
+
"coprod";
845
+
"coproduct";
846
+
"otimes";
847
+
"Otimes";
848
+
"bigotimes";
849
+
"ominus";
850
+
"oslash";
851
+
"oplus";
852
+
"Oplus";
853
+
"bigoplus";
854
+
"bigodot";
855
+
"bigsqcup";
856
+
"bigsqcap";
857
+
"biginterleave";
858
+
"biguplus";
859
+
"wedge";
860
+
"Wedge";
861
+
"bigwedge";
862
+
"Vee";
863
+
"bigvee";
864
+
"invamp";
865
+
"parr";
866
+
"frac";
867
+
"tfrac";
868
+
"binom";
869
+
"tbinom";
870
+
"tensor";
871
+
"multiscripts";
872
+
"overbrace";
873
+
"underbrace";
874
+
"underline";
875
+
"bar";
876
+
"overline";
877
+
"closure";
878
+
"widebar";
879
+
"vec";
880
+
"widevec";
881
+
"overrightarrow";
882
+
"overleftarrow";
883
+
"overleftrightarrow";
884
+
"underrightarrow";
885
+
"underleftarrow";
886
+
"underleftrightarrow";
887
+
"dot";
888
+
"ddot";
889
+
"dddot";
890
+
"ddddot";
891
+
"tilde";
892
+
"widetilde";
893
+
"check";
894
+
"widecheck";
895
+
"hat";
896
+
"widehat";
897
+
"underset";
898
+
"stackrel";
899
+
"overset";
900
+
"over";
901
+
"atop";
902
+
"underoverset";
903
+
"sqrt";
904
+
"root";
905
+
"space";
906
+
"text";
907
+
"statusline";
908
+
"tooltip";
909
+
"toggle";
910
+
"begintoggle";
911
+
"endtoggle";
912
+
"mathraisebox";
913
+
"fghilight";
914
+
"fghighlight";
915
+
"bghilight";
916
+
"bghighlight";
917
+
"color";
918
+
"bgcolor";
919
+
"displaystyle";
920
+
"textstyle";
921
+
"textsize";
922
+
"scriptsize";
923
+
"scriptscriptsize";
924
+
"mathit";
925
+
"mathsf";
926
+
"mathtt";
927
+
"boldsymbol";
928
+
"mathbf";
929
+
"mathrm";
930
+
"mathbb";
931
+
"mathfrak";
932
+
"mathfr";
933
+
"slash";
934
+
"boxed";
935
+
"mathcal";
936
+
"mathscr";
937
+
"begin";
938
+
"end";
939
+
"substack";
940
+
"array";
941
+
"arrayopts";
942
+
"colalign";
943
+
"collayout";
944
+
"rowalign";
945
+
"align";
946
+
"equalrows";
947
+
"equalcols";
948
+
"rowlines";
949
+
"collines";
950
+
"frame";
951
+
"padding";
952
+
"rowopts";
953
+
"cellopts";
954
+
"rowspan";
955
+
"colspan";
956
+
"thinspace";
957
+
"medspace";
958
+
"thickspace";
959
+
"quad";
960
+
"qquad";
961
+
"negspace";
962
+
"negthinspace";
963
+
"negmedspace";
964
+
"negthickspace";
965
+
"phantom";
966
+
"operatorname";
967
+
"mathop";
968
+
"mathbin";
969
+
"mathrel";
970
+
"includegraphics";
971
+
"lparen";
972
+
"rparen";
973
+
"land";
974
+
"lor";
975
+
"middle";
976
+
"mathpunct";
977
+
"mathord";
978
+
]
298
979
|> Seq.map @@ fun word ->
299
-
let path = [word] in
300
-
let node = Syn.TeX_cs (TeX_cs.Word word) in
301
-
path, (Syn.Term [Range.locate_opt None node], None)
980
+
let path = [word] in
981
+
let node = Syn.TeX_cs (TeX_cs.Word word) in
982
+
(path, (Syn.Term [Range.locate_opt None node], None))
302
983
303
984
(* Feel free to extend this *)
304
985
let tex_builtin_symbols =
305
986
List.to_seq ['_'; ','; ';']
306
987
|> Seq.map @@ fun c ->
307
-
let path = [String_util.implode [c]] in
308
-
let node = Syn.TeX_cs (TeX_cs.Symbol c) in
309
-
path, (Syn.Term [Range.locate_opt None node], None)
988
+
let path = [String_util.implode [c]] in
989
+
let node = Syn.TeX_cs (TeX_cs.Symbol c) in
990
+
(path, (Syn.Term [Range.locate_opt None node], None))
310
991
311
992
let builtin_xml_namespaces =
312
993
List.to_seq
313
994
[
314
-
"html", "http://www.w3.org/1999/xhtml";
315
-
"mml", "http://www.w3.org/1998/Math/MathML"
995
+
("html", "http://www.w3.org/1999/xhtml");
996
+
("mml", "http://www.w3.org/1998/Math/MathML");
316
997
]
317
998
|> Seq.map @@ fun (prefix, xmlns) ->
318
-
["xmlns"; prefix], (Syn.Xmlns {prefix; xmlns}, None)
999
+
(["xmlns"; prefix], (Syn.Xmlns {prefix; xmlns}, None))
319
1000
320
1001
let builtins =
321
-
Seq.concat @@
322
-
List.to_seq
323
-
[
324
-
builtin_xml_namespaces;
325
-
tex_builtin_words;
326
-
tex_builtin_symbols;
327
-
begin
328
-
let open Builtins.Transclude in
329
-
List.to_seq [expanded_sym; show_heading_sym; toc_sym; numbered_sym; show_metadata_sym]
330
-
|> Seq.map @@ fun sym ->
331
-
Symbol.name sym, (Syn.Term [Range.locate_opt None (Syn.Sym sym)], None)
332
-
end;
333
-
begin
334
-
List.to_seq
335
-
[
336
-
["p"], Syn.Prim `P;
337
-
["em"], Syn.Prim `Em;
338
-
["strong"], Syn.Prim `Strong;
339
-
["li"], Syn.Prim `Li;
340
-
["ol"], Syn.Prim `Ol;
341
-
["ul"], Syn.Prim `Ul;
342
-
["code"], Syn.Prim `Code;
343
-
["blockquote"], Syn.Prim `Blockquote;
344
-
["pre"], Syn.Prim `Pre;
345
-
["figure"], Syn.Prim `Figure;
346
-
["figcaption"], Syn.Prim `Figcaption;
347
-
["transclude"], Syn.Transclude;
348
-
["tex"], Syn.Embed_tex;
349
-
["ref"], Syn.Ref;
350
-
["title"], Syn.Title;
351
-
["taxon"], Syn.Taxon;
352
-
["date"], Syn.Date;
353
-
["meta"], Syn.Meta;
354
-
["author"], Syn.Attribution (Author, `Uri);
355
-
["author"; "literal"], Syn.Attribution (Author, `Content);
356
-
["contributor"], Syn.Attribution (Contributor, `Uri);
357
-
["contributor"; "literal"], Syn.Attribution (Contributor, `Content);
358
-
["parent"], Syn.Parent;
359
-
["number"], Syn.Number;
360
-
["tag"], Syn.Tag `Content;
361
-
["query"], Syn.Results_of_query;
362
-
["rel"; "has-tag"], Syn.Text Builtin_relation.has_tag;
363
-
["rel"; "has-taxon"], Syn.Text Builtin_relation.has_taxon;
364
-
["rel"; "has-author"], Syn.Text Builtin_relation.has_author;
365
-
["rel"; "has-direct-contributor"], Syn.Text Builtin_relation.has_direct_contributor;
366
-
["rel"; "transcludes"], Syn.Text Builtin_relation.transcludes;
367
-
["rel"; "transcludes"; "transitive-closure"], Syn.Text Builtin_relation.transcludes_tc;
368
-
["rel"; "transcludes"; "reflexive-transitive-closure"], Syn.Text Builtin_relation.transcludes_rtc;
369
-
["rel"; "links-to"], Syn.Text Builtin_relation.links_to;
370
-
["rel"; "is-reference"], Syn.Text Builtin_relation.is_reference;
371
-
["rel"; "is-person"], Syn.Text Builtin_relation.is_person;
372
-
["rel"; "is-node"], Syn.Text Builtin_relation.is_node;
373
-
["rel"; "is-article"], Syn.Text Builtin_relation.is_article;
374
-
["rel"; "is-asset"], Syn.Text Builtin_relation.is_asset;
375
-
["rel"; "in-host"], Syn.Text Builtin_relation.in_host;
376
-
["execute"], Syn.Dx_execute;
377
-
["route-asset"], Syn.Route_asset;
378
-
["syndicate-query-as-json-blob"], Syn.Syndicate_query_as_json_blob;
379
-
["syndicate-current-tree-as-atom-feed"], Syn.Syndicate_current_tree_as_atom_feed;
380
-
["current-tree"], Syn.Current_tree;
381
-
]
382
-
|> Seq.map @@ fun (path, node) ->
383
-
path, (Syn.Term [Range.locate_opt None node], None)
384
-
end
385
-
]
1002
+
Seq.concat
1003
+
@@ List.to_seq
1004
+
[
1005
+
builtin_xml_namespaces;
1006
+
tex_builtin_words;
1007
+
tex_builtin_symbols;
1008
+
begin
1009
+
let open Builtins.Transclude in
1010
+
List.to_seq
1011
+
[
1012
+
expanded_sym;
1013
+
show_heading_sym;
1014
+
toc_sym;
1015
+
numbered_sym;
1016
+
show_metadata_sym;
1017
+
]
1018
+
|> Seq.map @@ fun sym ->
1019
+
( Symbol.name sym,
1020
+
(Syn.Term [Range.locate_opt None (Syn.Sym sym)], None) )
1021
+
end;
1022
+
begin
1023
+
List.to_seq
1024
+
[
1025
+
(["p"], Syn.Prim `P);
1026
+
(["em"], Syn.Prim `Em);
1027
+
(["strong"], Syn.Prim `Strong);
1028
+
(["li"], Syn.Prim `Li);
1029
+
(["ol"], Syn.Prim `Ol);
1030
+
(["ul"], Syn.Prim `Ul);
1031
+
(["code"], Syn.Prim `Code);
1032
+
(["blockquote"], Syn.Prim `Blockquote);
1033
+
(["pre"], Syn.Prim `Pre);
1034
+
(["figure"], Syn.Prim `Figure);
1035
+
(["figcaption"], Syn.Prim `Figcaption);
1036
+
(["transclude"], Syn.Transclude);
1037
+
(["tex"], Syn.Embed_tex);
1038
+
(["ref"], Syn.Ref);
1039
+
(["title"], Syn.Title);
1040
+
(["taxon"], Syn.Taxon);
1041
+
(["date"], Syn.Date);
1042
+
(["meta"], Syn.Meta);
1043
+
(["author"], Syn.Attribution (Author, `Uri));
1044
+
(["author"; "literal"], Syn.Attribution (Author, `Content));
1045
+
(["contributor"], Syn.Attribution (Contributor, `Uri));
1046
+
( ["contributor"; "literal"],
1047
+
Syn.Attribution (Contributor, `Content) );
1048
+
(["parent"], Syn.Parent);
1049
+
(["number"], Syn.Number);
1050
+
(["tag"], Syn.Tag `Content);
1051
+
(["query"], Syn.Results_of_query);
1052
+
(["rel"; "has-tag"], Syn.Text Builtin_relation.has_tag);
1053
+
(["rel"; "has-taxon"], Syn.Text Builtin_relation.has_taxon);
1054
+
(["rel"; "has-author"], Syn.Text Builtin_relation.has_author);
1055
+
( ["rel"; "has-direct-contributor"],
1056
+
Syn.Text Builtin_relation.has_direct_contributor );
1057
+
(["rel"; "transcludes"], Syn.Text Builtin_relation.transcludes);
1058
+
( ["rel"; "transcludes"; "transitive-closure"],
1059
+
Syn.Text Builtin_relation.transcludes_tc );
1060
+
( ["rel"; "transcludes"; "reflexive-transitive-closure"],
1061
+
Syn.Text Builtin_relation.transcludes_rtc );
1062
+
(["rel"; "links-to"], Syn.Text Builtin_relation.links_to);
1063
+
(["rel"; "is-reference"], Syn.Text Builtin_relation.is_reference);
1064
+
(["rel"; "is-person"], Syn.Text Builtin_relation.is_person);
1065
+
(["rel"; "is-node"], Syn.Text Builtin_relation.is_node);
1066
+
(["rel"; "is-article"], Syn.Text Builtin_relation.is_article);
1067
+
(["rel"; "is-asset"], Syn.Text Builtin_relation.is_asset);
1068
+
(["rel"; "in-host"], Syn.Text Builtin_relation.in_host);
1069
+
(["execute"], Syn.Dx_execute);
1070
+
(["route-asset"], Syn.Route_asset);
1071
+
( ["syndicate-query-as-json-blob"],
1072
+
Syn.Syndicate_query_as_json_blob );
1073
+
( ["syndicate-current-tree-as-atom-feed"],
1074
+
Syn.Syndicate_current_tree_as_atom_feed );
1075
+
(["current-tree"], Syn.Current_tree);
1076
+
]
1077
+
|> Seq.map @@ fun (path, node) ->
1078
+
(path, (Syn.Term [Range.locate_opt None node], None))
1079
+
end;
1080
+
]
386
1081
387
1082
let initial_visible_trie : (Syn.resolver_data, Range.t option) Trie.t =
388
1083
Yuujinchou.Trie.of_seq builtins
···
401
1096
let exports = Sc.get_export () in
402
1097
Tree.{nodes; identity = code.identity; code; units = exports}
403
1098
404
-
let expand_tree ~(forest : State.t) (code : Tree.code) : Tree.syn * Reporter.Message.t Asai.Diagnostic.t list =
1099
+
let expand_tree ~(forest : State.t) (code : Tree.code) :
1100
+
Tree.syn * Reporter.Message.t Asai.Diagnostic.t list =
405
1101
let diagnostics = ref [] in
406
1102
let emit d = diagnostics := d :: !diagnostics in
407
1103
let fatal d =
408
1104
emit d;
409
-
Tree.{
410
-
nodes = [];
411
-
identity = code.identity;
412
-
code = code;
413
-
units = Trie.empty;
414
-
},
415
-
!diagnostics
1105
+
( Tree.{nodes = []; identity = code.identity; code; units = Trie.empty},
1106
+
!diagnostics )
416
1107
in
417
1108
Reporter.run ~emit ~fatal @@ fun () ->
418
-
Sc.run ~init_visible: initial_visible_trie @@ fun () ->
1109
+
Sc.run ~init_visible:initial_visible_trie @@ fun () ->
419
1110
let expanded_tree = ignore_entered_range (expand_tree_inner ~forest) code in
420
-
expanded_tree, !diagnostics
1111
+
(expanded_tree, !diagnostics)
+10
-8
lib/compiler/Expand.mli
+10
-8
lib/compiler/Expand.mli
···
5
5
*)
6
6
7
7
open Forester_core
8
-
9
8
module Unit_map = URI.Map
10
9
11
10
val initial_visible_trie : (Syn.resolver_data, Range.t option) Trie.t
12
11
13
-
module Builtins :
14
-
sig
15
-
module Transclude :
16
-
sig
12
+
module Builtins : sig
13
+
module Transclude : sig
17
14
val expanded_sym : Symbol.t
18
15
val show_heading_sym : Symbol.t
19
16
val show_metadata_sym : Symbol.t
···
22
19
end
23
20
end
24
21
25
-
val expand : forest: State.t -> Code.t -> Syn.t
26
-
val expand_tree : forest: State.t -> Tree.code -> Tree.syn * Reporter.Message.t Asai.Diagnostic.t list
22
+
val expand : forest:State.t -> Code.t -> Syn.t
23
+
24
+
val expand_tree :
25
+
forest:State.t ->
26
+
Tree.code ->
27
+
Tree.syn * Reporter.Message.t Asai.Diagnostic.t list
27
28
28
29
type 'a Effect.t += Entered_range : Range.t option -> unit Effect.t
29
-
val expand_eff : forest: State.t -> Code.t -> Syn.t
30
+
31
+
val expand_eff : forest:State.t -> Code.t -> Syn.t
+33
-26
lib/compiler/Forest.ml
+33
-26
lib/compiler/Forest.ml
···
25
25
(* TODO: Why is this not run at the top level? *)
26
26
(* let () = execute_datalog_script Builtin_relation.axioms *)
27
27
28
-
let run_datalog_query (graphs : env) (q : (string, Vertex.t) Dx.query) : Vertex_set.t =
28
+
let run_datalog_query (graphs : env) (q : (string, Vertex.t) Dx.query) :
29
+
Vertex_set.t =
29
30
let@ () = Reporter.trace "when running query" in
30
31
(* TODO: See above *)
31
32
let () = execute_datalog_script graphs Builtin_relation.axioms in
···
50
51
in
51
52
execute_datalog_script graphs [{conclusion; premises}]
52
53
53
-
let rec analyse_content_node graphs (scope : URI.t) (node : 'a T.content_node) : unit =
54
+
let rec analyse_content_node graphs (scope : URI.t) (node : 'a T.content_node) :
55
+
unit =
54
56
match node with
55
-
| Text _ | CDATA _ | Route_of_uri _ | Uri _ | Results_of_datalog_query _ | Contextual_number _ -> ()
56
-
| Transclude transclusion ->
57
-
analyse_transclusion graphs scope transclusion
57
+
| Text _ | CDATA _ | Route_of_uri _ | Uri _ | Results_of_datalog_query _
58
+
| Contextual_number _ ->
59
+
()
60
+
| Transclude transclusion -> analyse_transclusion graphs scope transclusion
58
61
| Xml_elt elt ->
59
62
begin
60
63
let@ attr = List.iter @~ elt.attrs in
61
64
analyse_content graphs scope attr.value
62
65
end;
63
66
analyse_content graphs scope elt.content
64
-
| Section section ->
65
-
analyse_section graphs scope section
67
+
| Section section -> analyse_section graphs scope section
66
68
| Link link ->
67
-
add_edge graphs Builtin_relation.links_to ~source: (Uri_vertex scope) ~target: (Uri_vertex link.href);
69
+
add_edge graphs Builtin_relation.links_to ~source:(Uri_vertex scope)
70
+
~target:(Uri_vertex link.href);
68
71
analyse_content graphs scope link.content
69
-
| KaTeX (_, content) ->
70
-
analyse_content graphs scope content
71
-
| Artefact artefact ->
72
-
analyse_artefact graphs scope artefact
73
-
| Datalog_script script ->
74
-
execute_datalog_script graphs script
72
+
| KaTeX (_, content) -> analyse_content graphs scope content
73
+
| Artefact artefact -> analyse_artefact graphs scope artefact
74
+
| Datalog_script script -> execute_datalog_script graphs script
75
75
76
76
and analyse_artefact graphs scope artefact =
77
77
analyse_content graphs scope artefact.content
78
78
79
-
and analyse_transclusion graphs (scope : URI.t) (transclusion : T.transclusion) : unit =
79
+
and analyse_transclusion graphs (scope : URI.t) (transclusion : T.transclusion)
80
+
: unit =
80
81
match transclusion.target with
81
82
| Full _ | Mainmatter ->
82
-
add_edge graphs Builtin_relation.transcludes ~source: (Uri_vertex scope) ~target: (Uri_vertex transclusion.href)
83
+
add_edge graphs Builtin_relation.transcludes ~source:(Uri_vertex scope)
84
+
~target:(Uri_vertex transclusion.href)
83
85
| Title _ | Taxon -> ()
84
86
85
-
and analyse_content (graphs : env) (scope : URI.t) (content : T.content) : unit =
87
+
and analyse_content (graphs : env) (scope : URI.t) (content : T.content) : unit
88
+
=
86
89
T.extract_content content |> List.iter @@ analyse_content_node graphs scope
87
90
88
91
and analyse_attribution graphs (scope : URI.t) (attr : _ T.attribution) =
···
91
94
| Author -> Builtin_relation.has_author
92
95
| Contributor -> Builtin_relation.has_direct_contributor
93
96
in
94
-
add_edge graphs rel ~source: (Uri_vertex scope) ~target: attr.vertex;
97
+
add_edge graphs rel ~source:(Uri_vertex scope) ~target:attr.vertex;
95
98
analyse_vertex graphs scope attr.vertex
96
99
97
100
and analyse_vertex graphs scope vtx =
···
101
104
102
105
and analyse_tag graphs (scope : URI.t) (tag : _ T.vertex) =
103
106
analyse_vertex graphs scope tag;
104
-
add_edge graphs Builtin_relation.has_tag ~source: (Uri_vertex scope) ~target: tag
107
+
add_edge graphs Builtin_relation.has_tag ~source:(Uri_vertex scope)
108
+
~target:tag
105
109
106
110
and analyse_taxon graphs (scope : URI.t) (taxon_opt : T.content option) =
107
111
let@ taxon = Option.iter @~ taxon_opt in
108
112
analyse_content graphs scope taxon;
109
-
add_edge graphs Builtin_relation.has_taxon ~source: (Uri_vertex scope) ~target: (Content_vertex taxon)
113
+
add_edge graphs Builtin_relation.has_taxon ~source:(Uri_vertex scope)
114
+
~target:(Content_vertex taxon)
110
115
111
116
and analyse_attributions graphs (scope : URI.t) =
112
117
List.iter @@ analyse_attribution graphs scope
113
118
114
-
and analyse_tags graphs (scope : URI.t) =
115
-
List.iter @@ analyse_tag graphs scope
119
+
and analyse_tags graphs (scope : URI.t) = List.iter @@ analyse_tag graphs scope
116
120
117
-
and analyse_frontmatter graphs (scope : URI.t) (fm : T.content T.frontmatter) : unit =
121
+
and analyse_frontmatter graphs (scope : URI.t) (fm : T.content T.frontmatter) :
122
+
unit =
118
123
Option.iter (analyse_content graphs scope) fm.title;
119
124
analyse_taxon graphs scope fm.taxon;
120
125
analyse_attributions graphs scope fm.attributions;
···
127
132
and analyse_meta graphs (scope : URI.t) (_, content) : unit =
128
133
analyse_content graphs scope content
129
134
130
-
and analyse_section graphs (scope : URI.t) (section : T.content T.section) : unit =
135
+
and analyse_section graphs (scope : URI.t) (section : T.content T.section) :
136
+
unit =
131
137
begin
132
138
let@ target = Option.iter @~ section.frontmatter.uri in
133
-
add_edge graphs Builtin_relation.transcludes ~source: (Uri_vertex scope) ~target: (Uri_vertex target)
139
+
add_edge graphs Builtin_relation.transcludes ~source:(Uri_vertex scope)
140
+
~target:(Uri_vertex target)
134
141
end;
135
-
let scope = Option.value ~default: scope section.frontmatter.uri in
142
+
let scope = Option.value ~default:scope section.frontmatter.uri in
136
143
analyse_frontmatter graphs scope section.frontmatter;
137
144
analyse_content graphs scope section.mainmatter
138
145
+18
-7
lib/compiler/Forest.mli
+18
-7
lib/compiler/Forest.mli
···
5
5
*)
6
6
7
7
open Forester_core
8
-
9
8
include module type of URI.Tbl
10
9
11
10
(**/**)
11
+
12
12
module T := Types
13
13
module Dx := Datalog_expr
14
14
15
-
val execute_datalog_script : (module Forest_graphs.S) -> (string, Vertex.t) Dx.sequent list -> unit
15
+
val execute_datalog_script :
16
+
(module Forest_graphs.S) -> (string, Vertex.t) Dx.sequent list -> unit
17
+
16
18
(**/**)
17
19
18
20
val analyse_resource : (module Forest_graphs.S) -> T.content T.resource -> unit
19
-
(** [analyse_resource graphs resource] traverses {{!Forester_core.Types.resource}[resource]}, recording facts about it in {{!Forester_core.Forest_graphs.S}[graphs]}.
21
+
(** [analyse_resource graphs resource] traverses
22
+
{{!Forester_core.Types.resource}[resource]}, recording facts about it in
23
+
{{!Forester_core.Forest_graphs.S}[graphs]}.
20
24
21
-
- When encountering a {{!Forester_core.Types.Link}[Link]}, it adds an edge to the {{!Forester_core.Builtin_relation.links_to}[links_to]} relation in {{!Forester_core.Forest_graphs.S}[graphs]}.
25
+
- When encountering a {{!Forester_core.Types.Link}[Link]}, it adds an edge
26
+
to the {{!Forester_core.Builtin_relation.links_to}[links_to]} relation in
27
+
{{!Forester_core.Forest_graphs.S}[graphs]}.
22
28
23
-
- When encountering a {{!Forester_core.Types.Transclude}[Transclude]}, it adds an edge to the {{!Forester_core.Builtin_relation.transcludes}[transcludes]} relation in {{!Forester_core.Forest_graphs.S}[graphs]}.
29
+
- When encountering a {{!Forester_core.Types.Transclude}[Transclude]}, it
30
+
adds an edge to the
31
+
{{!Forester_core.Builtin_relation.transcludes}[transcludes]} relation in
32
+
{{!Forester_core.Forest_graphs.S}[graphs]}.
24
33
25
-
- When encountering a {{!Forester_core.Types.Datalog_script}[Datalog_script script]}, it runs the script and records the results in {{!Forester_core.Forest_graphs.S}[graphs]}.
26
-
*)
34
+
- When encountering a
35
+
{{!Forester_core.Types.Datalog_script}[Datalog_script script]}, it runs
36
+
the script and records the results in
37
+
{{!Forester_core.Forest_graphs.S}[graphs]}. *)
27
38
28
39
val run_datalog_query :
29
40
(module Forest_graphs.S) ->
+17
-10
lib/compiler/Forester_compiler.ml
+17
-10
lib/compiler/Forester_compiler.ml
···
6
6
7
7
(** The forester compiler*)
8
8
9
-
(** {1 Base types }*)
9
+
(** {1 Base types}*)
10
10
11
11
module Xml_forester = Xml_forester
12
12
(** Definition of the forester XML schema. This is the compilation target.*)
···
15
15
16
16
(** {2 Parsing}
17
17
18
-
The lexer and parser are implemented with {{: https://ocaml.org/manual/5.3/lexyacc.html} ocamllex} and {{: https://gallium.inria.fr/~fpottier/menhir/} menhir}*)
18
+
The lexer and parser are implemented with
19
+
{{:https://ocaml.org/manual/5.3/lexyacc.html} ocamllex} and
20
+
{{:https://gallium.inria.fr/~fpottier/menhir/} menhir}*)
19
21
20
22
module Parse = Parse
21
23
22
24
module Imports = Imports
23
-
(** Create {{!Forester_core.Forest_graph.t}import and dependency graphs}.
24
-
*)
25
+
(** Create {{!Forester_core.Forest_graph.t}import and dependency graphs}. *)
25
26
26
27
module Expand = Expand
27
-
(** Transform {!Code.tree}s into {!Syn.tree}s by {{!Forester_core.Forest_graph.topo_fold}folding} over the {{!Forester_core.Forest_graph}import graph.}*)
28
+
(** Transform {!Code.tree}s into {!Syn.tree}s by
29
+
{{!Forester_core.Forest_graph.topo_fold}folding} over the
30
+
{{!Forester_core.Forest_graph}import graph.}*)
28
31
29
32
module Eval = Eval
30
33
(** Transform {!Syn.tree}s into {{!Forester_core.Types.article}[articles]}.*)
31
34
32
35
(** {1 High-level architecture}
33
36
34
-
The compiler needs to support both batch-style and incremental compilation. To this end, we define a {{!State.t}state type} and {{!Phases}transition functions} that act on this state.
37
+
The compiler needs to support both batch-style and incremental compilation.
38
+
To this end, we define a {{!State.t}state type} and
39
+
{{!Phases}transition functions} that act on this state.
35
40
36
-
In the future, we want to record more knowledge in {{!field:State.graphs}[graphs]} of the {{!State.t}state} and derive the information we need for the language server via the query system.
37
-
38
-
*)
41
+
In the future, we want to record more knowledge in
42
+
{{!field:State.graphs}[graphs]} of the {{!State.t}state} and derive the
43
+
information we need for the language server via the query system. *)
39
44
40
45
module Forest = Forest
41
46
(** Augmented hash table used throughout compilation phases.*)
···
45
50
module Phases = Phases
46
51
module Driver = Driver
47
52
module Asset_router = Asset_router
48
-
49
53
module URI_util = URI_util
50
54
51
55
(** {1 IO}*)
···
55
59
module Build_latex = Build_latex
56
60
module LaTeX_pipeline = LaTeX_pipeline
57
61
module LaTeX_template = LaTeX_template
62
+
58
63
module Job = Job
59
64
(** Definition of LaTeX jobs*)
60
65
61
66
(**/**)
67
+
62
68
module Eio_util = Eio_util
63
69
module Export_for_test = Export_for_test
64
70
module Cache = Cache
65
71
module Dir_scanner = Dir_scanner
72
+
66
73
(**/**)
+77
-63
lib/compiler/Imports.ml
+77
-63
lib/compiler/Imports.ml
···
6
6
7
7
open Forester_core
8
8
open Forester_prelude
9
-
open struct module T = Types end
9
+
10
+
open struct
11
+
module T = Types
12
+
end
10
13
11
14
type analysis_env = {
12
15
follow: bool;
···
19
22
let path_str = Eio.Path.native_exn path in
20
23
assert (not @@ Filename.is_relative path_str);
21
24
let uri = Lsp.Uri.of_path path_str in
22
-
Lsp.Text_document.make
23
-
~position_encoding: `UTF8
24
-
{
25
-
textDocument = {
26
-
languageId = "forester";
27
-
text = content;
28
-
uri;
29
-
version = 1
30
-
}
31
-
}
25
+
Lsp.Text_document.make ~position_encoding:`UTF8
26
+
{textDocument = {languageId = "forester"; text = content; uri; version = 1}}
32
27
33
28
(* Only add edge if both vertices are already present*)
34
29
let add_edge g v w =
···
36
31
assert (Forest_graph.mem_vertex g v);
37
32
assert (Forest_graph.mem_vertex g w);
38
33
Forest_graph.add_edge g v w
39
-
with
40
-
| exn -> Reporter.fatal Internal_error ~extra_remarks: [Asai.Diagnostic.loctextf "%a" Eio.Exn.pp exn]
34
+
with exn ->
35
+
Reporter.fatal Internal_error
36
+
~extra_remarks:[Asai.Diagnostic.loctextf "%a" Eio.Exn.pp exn]
41
37
42
-
module Analysis_env = Algaeff.Reader.Make(struct type t = analysis_env end)
38
+
module Analysis_env = Algaeff.Reader.Make (struct
39
+
type t = analysis_env
40
+
end)
43
41
44
-
let resolve_uri_to_code
45
-
(forest : State.t)
46
-
(uri : URI.t)
47
-
: Tree.code option
48
-
=
49
-
let dirs = Eio_util.paths_of_dirs ~env: forest.env forest.config.trees in
42
+
let resolve_uri_to_code (forest : State.t) (uri : URI.t) : Tree.code option =
43
+
let dirs = Eio_util.paths_of_dirs ~env:forest.env forest.config.trees in
50
44
match Forest.find_opt forest.index uri with
51
45
| Some tree -> Tree.to_code tree
52
-
| None ->
46
+
| None -> (
53
47
match URI.Tbl.find_opt forest.resolver uri with
54
48
| Some path ->
55
49
let doc = load_tree Eio.Path.(forest.env#fs / path) in
56
-
Result.to_option @@
57
-
Parse.parse_document ~config: forest.config doc
58
-
| None ->
50
+
Result.to_option @@ Parse.parse_document ~config:forest.config doc
51
+
| None -> (
59
52
match Dir_scanner.find_tree dirs uri with
60
53
| Some path ->
61
54
let native = Eio.Path.native_exn path in
62
55
URI.Tbl.add forest.resolver uri native;
63
56
let doc = load_tree path in
64
-
Result.to_option @@
65
-
Parse.parse_document ~config: forest.config doc
66
-
| None ->
67
-
Reporter.fatal (Resource_not_found uri)
57
+
Result.to_option @@ Parse.parse_document ~config:forest.config doc
58
+
| None -> Reporter.fatal (Resource_not_found uri)))
68
59
69
60
let rec analyse_tree (tree : Tree.code) =
70
61
let env = Analysis_env.read () in
71
62
let@ root = Option.iter @~ identity_to_uri tree.identity in
72
63
let code = tree.nodes in
73
64
Forest_graph.add_vertex env.graph (T.Uri_vertex root);
74
-
analyse_code ~root code;
65
+
analyse_code ~root code
75
66
76
-
and analyse_code ~root (code : Code.t) =
77
-
List.iter (analyse_node ~root) code
67
+
and analyse_code ~root (code : Code.t) = List.iter (analyse_node ~root) code
78
68
79
69
and analyse_node ~root (node : Code.node Asai.Range.located) =
80
70
let env = Analysis_env.read () in
81
71
let config = env.forest.config in
82
72
match node.value with
83
73
| Import (_, dep) ->
84
-
let dep_uri = URI_scheme.named_uri ~base: config.url dep in
74
+
let dep_uri = URI_scheme.named_uri ~base:config.url dep in
85
75
let dependency = T.Uri_vertex dep_uri in
86
76
let target = T.Uri_vertex root in
87
77
Forest_graph.add_vertex env.graph dependency;
88
78
(* add_vertex env.forest env.graph tar; *)
89
79
add_edge env.graph dependency target;
90
-
if env.follow then
91
-
begin
92
-
match resolve_uri_to_code env.forest dep_uri with
93
-
| None -> Reporter.fatal ?loc: node.loc (Resource_not_found dep_uri)
94
-
| Some code ->
95
-
analyse_tree code;
96
-
assert false
97
-
end
80
+
if env.follow then begin
81
+
match resolve_uri_to_code env.forest dep_uri with
82
+
| None -> Reporter.fatal ?loc:node.loc (Resource_not_found dep_uri)
83
+
| Some code ->
84
+
analyse_tree code;
85
+
assert false
86
+
end
98
87
| Subtree (addr, nodes) ->
99
88
let identity =
100
89
match addr with
101
90
| None -> Anonymous
102
-
| Some string ->
103
-
URI (URI_scheme.named_uri ~base: config.url string)
91
+
| Some string -> URI (URI_scheme.named_uri ~base:config.url string)
104
92
in
105
93
analyse_tree
106
-
{identity; origin = Subtree {parent = URI root}; nodes; timestamp = None;}
107
-
| Scope code | Namespace (_, code) | Group (_, code) | Math (_, code) | Let (_, _, code) | Fun (_, code) | Def (_, _, code) ->
94
+
{identity; origin = Subtree {parent = URI root}; nodes; timestamp = None}
95
+
| Scope code
96
+
| Namespace (_, code)
97
+
| Group (_, code)
98
+
| Math (_, code)
99
+
| Let (_, _, code)
100
+
| Fun (_, code)
101
+
| Def (_, _, code) ->
108
102
analyse_code ~root code
109
103
| Object {methods; _} | Patch {methods; _} ->
110
104
let@ _, code = List.iter @~ methods in
···
118
112
| Dx_query (_, positives, negatives) ->
119
113
List.iter (analyse_code ~root) positives;
120
114
List.iter (analyse_code ~root) negatives
121
-
| Text _ | Hash_ident _ | Xml_ident (_, _) | Verbatim _ | Ident _ | Open _ | Put (_, _) | Default (_, _) | Get _ | Decl_xmlns (_, _) | Call (_, _) | Alloc _ | Dx_var _ | Dx_const_content _ | Dx_const_uri _ | Comment _ | Error _ -> ()
115
+
| Text _ | Hash_ident _
116
+
| Xml_ident (_, _)
117
+
| Verbatim _ | Ident _ | Open _
118
+
| Put (_, _)
119
+
| Default (_, _)
120
+
| Get _
121
+
| Decl_xmlns (_, _)
122
+
| Call (_, _)
123
+
| Alloc _ | Dx_var _ | Dx_const_content _ | Dx_const_uri _ | Comment _
124
+
| Error _ ->
125
+
()
122
126
123
127
let dependencies tree forest =
124
128
let env = {forest; follow = true; graph = Forest_graph.create ()} in
···
127
131
env.graph
128
132
129
133
let fixup (tree : Tree.code) (forest : State.t) =
130
-
let@ () = Reporter.tracef "when updating imports for %a" pp_identity tree.identity in
134
+
let@ () =
135
+
Reporter.tracef "when updating imports for %a" pp_identity tree.identity
136
+
in
131
137
Logs.debug (fun m -> m "updating imports for %a" pp_identity tree.identity);
132
138
let graph = forest.import_graph in
133
139
match tree.identity with
134
140
| Anonymous -> assert false
135
141
| URI uri ->
136
142
let this_vertex = T.Uri_vertex uri in
137
-
let old_deps = Vertex_set.of_list @@ Forest_graph.immediate_dependencies graph this_vertex in
143
+
let old_deps =
144
+
Vertex_set.of_list
145
+
@@ Forest_graph.immediate_dependencies graph this_vertex
146
+
in
138
147
let new_deps =
139
-
let env = {forest; follow = false; graph;} in
148
+
let env = {forest; follow = false; graph} in
140
149
let@ () = Analysis_env.run ~env in
141
150
begin
142
151
analyse_tree tree;
143
-
Vertex_set.of_list @@ Forest_graph.immediate_dependencies env.graph this_vertex
144
-
end;
152
+
Vertex_set.of_list
153
+
@@ Forest_graph.immediate_dependencies env.graph this_vertex
154
+
end
145
155
in
146
156
let unchanged_deps = Vertex_set.inter new_deps old_deps in
147
157
let added_deps = Vertex_set.diff new_deps unchanged_deps in
148
158
let removed_deps = Vertex_set.diff old_deps unchanged_deps in
149
-
Logs.debug (fun m -> m "added %d dependencies" (Vertex_set.cardinal added_deps));
150
-
Logs.debug (fun m -> m "removed %d dependencies" (Vertex_set.cardinal removed_deps));
151
-
Vertex_set.iter (fun v -> Forest_graph.remove_edge graph v this_vertex) removed_deps;
152
-
Vertex_set.iter (fun v -> Forest_graph.add_edge graph v this_vertex) added_deps
159
+
Logs.debug (fun m ->
160
+
m "added %d dependencies" (Vertex_set.cardinal added_deps));
161
+
Logs.debug (fun m ->
162
+
m "removed %d dependencies" (Vertex_set.cardinal removed_deps));
163
+
Vertex_set.iter
164
+
(fun v -> Forest_graph.remove_edge graph v this_vertex)
165
+
removed_deps;
166
+
Vertex_set.iter
167
+
(fun v -> Forest_graph.add_edge graph v this_vertex)
168
+
added_deps
153
169
154
-
let _minimal_dependency_graph
155
-
: addr: URI.t -> Forest_graph.t
156
-
= fun ~addr ->
170
+
let _minimal_dependency_graph : addr:URI.t -> Forest_graph.t =
171
+
fun ~addr ->
157
172
let dep_graph = Forest_graph.create () in
158
173
let rec f v =
159
174
Forest_graph.iter_succ
160
-
(fun w -> Forest_graph.add_edge dep_graph v w; f w)
161
-
dep_graph
162
-
v
175
+
(fun w ->
176
+
Forest_graph.add_edge dep_graph v w;
177
+
f w)
178
+
dep_graph v
163
179
in
164
180
f (T.Uri_vertex addr);
165
181
dep_graph
···
167
183
let build forest =
168
184
let env = {forest; follow = false; graph = Forest_graph.create ()} in
169
185
let@ () = Analysis_env.run ~env in
170
-
env.forest
171
-
|> State.get_all_code
172
-
|> Seq.iter analyse_tree;
186
+
env.forest |> State.get_all_code |> Seq.iter analyse_tree;
173
187
env.graph
+1
-5
lib/compiler/Imports.mli
+1
-5
lib/compiler/Imports.mli
···
6
6
7
7
open Forester_core
8
8
9
-
type analysis_env = {
10
-
follow: bool;
11
-
forest: State.t;
12
-
graph: Forest_graph.t;
13
-
}
9
+
type analysis_env = {follow: bool; forest: State.t; graph: Forest_graph.t}
14
10
15
11
val load_tree : Eio.Fs.dir_ty Eio.Path.t -> Lsp.Text_document.t
16
12
val build : State.t -> Forest_graph.t
+2
-8
lib/compiler/Job.ml
+2
-8
lib/compiler/Job.ml
···
7
7
open Forester_core
8
8
open Types
9
9
10
-
type latex_to_svg_job = {
11
-
hash: string;
12
-
source: string;
13
-
}
14
-
[@@deriving show]
10
+
type latex_to_svg_job = {hash: string; source: string} [@@deriving show]
15
11
16
12
let uri_for_latex_to_svg_job ~(base : URI.t) (job : latex_to_svg_job) =
17
13
URI_scheme.named_uri ~base @@ job.hash ^ ".svg"
18
14
19
-
type job =
20
-
| LaTeX_to_svg of latex_to_svg_job
21
-
| Syndicate of content syndication
15
+
type job = LaTeX_to_svg of latex_to_svg_job | Syndicate of content syndication
22
16
[@@deriving show]
+35
-30
lib/compiler/LaTeX_pipeline.ml
+35
-30
lib/compiler/LaTeX_pipeline.ml
···
6
6
7
7
open Forester_prelude
8
8
open Forester_core
9
-
10
9
module EP = Eio.Path
11
10
12
11
type env = Eio_unix.Stdenv.base
13
12
14
13
let indent_string string =
15
-
string
16
-
|> String.split_on_char '\n'
14
+
string |> String.split_on_char '\n'
17
15
|> List.map (Format.sprintf "\t%s")
18
16
|> String.concat "\n"
19
17
20
-
(* TODO: When error occurs on stderr, there is nothing informative in the diagnostic*)
18
+
(* TODO: When error occurs on stderr, there is nothing informative in the
19
+
diagnostic*)
21
20
let pipe_latex_dvi ~env ~tex_source ?loc kont =
22
21
let mgr = Eio.Stdenv.process_mgr env in
23
22
let@ tmp = Eio_util.with_open_tmp_dir ~env in
24
23
let tex_fn = "job.tex" in
25
24
begin
26
-
let@ tex_sink = EP.with_open_out ~create: (`Or_truncate 0o644) EP.(tmp / tex_fn) in
25
+
let@ tex_sink =
26
+
EP.with_open_out ~create:(`Or_truncate 0o644) EP.(tmp / tex_fn)
27
+
in
27
28
Eio.Flow.copy tex_source tex_sink
28
29
end;
29
30
begin
···
31
32
let stdout = Eio.Flow.buffer_sink out_buf in
32
33
let stderr = Eio_util.null_sink () in
33
34
let cmd = ["latex"; "-halt-on-error"; "-interaction=nonstopmode"; tex_fn] in
34
-
try
35
-
Eio.Process.run ~cwd: tmp ~stdout ~stderr mgr cmd
36
-
with
37
-
| _ ->
38
-
let formatted_output = Buffer.contents out_buf |> indent_string in
39
-
Reporter.fatal
40
-
External_error
41
-
~extra_remarks: [
42
-
Asai.Diagnostic.loctextf
43
-
?loc
44
-
"Encountered fatal LaTeX error: @.@.%s@.@. while running `%s` in directory `%s`."
45
-
formatted_output
46
-
(String.concat " " cmd)
47
-
(Eio.Path.native_exn tmp)
35
+
try Eio.Process.run ~cwd:tmp ~stdout ~stderr mgr cmd
36
+
with _ ->
37
+
let formatted_output = Buffer.contents out_buf |> indent_string in
38
+
Reporter.fatal External_error
39
+
~extra_remarks:
40
+
[
41
+
Asai.Diagnostic.loctextf ?loc
42
+
"Encountered fatal LaTeX error: @.@.%s@.@. while running `%s` in \
43
+
directory `%s`."
44
+
formatted_output (String.concat " " cmd) (Eio.Path.native_exn tmp);
48
45
]
49
46
end;
50
47
EP.with_open_in EP.(tmp / "job.dvi") kont
···
54
51
let mgr = Eio.Stdenv.process_mgr env in
55
52
let err_buf = Buffer.create 1000 in
56
53
let stderr = Eio.Flow.buffer_sink err_buf in
57
-
let cmd = ["dvisvgm"; "--exact"; "--clipjoin"; "--font-format=woff"; "--bbox=papersize"; "--zoom=1.5"; "--stdin"; "--stdout"] in
58
-
try
59
-
Eio.Process.run ~cwd ~stdin: dvi_source ~stdout: svg_sink ~stderr mgr cmd
60
-
with
61
-
| _ ->
62
-
Reporter.fatal
63
-
External_error
64
-
~extra_remarks: [
65
-
Asai.Diagnostic.loctextf
66
-
?loc
54
+
let cmd =
55
+
[
56
+
"dvisvgm";
57
+
"--exact";
58
+
"--clipjoin";
59
+
"--font-format=woff";
60
+
"--bbox=papersize";
61
+
"--zoom=1.5";
62
+
"--stdin";
63
+
"--stdout";
64
+
]
65
+
in
66
+
try Eio.Process.run ~cwd ~stdin:dvi_source ~stdout:svg_sink ~stderr mgr cmd
67
+
with _ ->
68
+
Reporter.fatal External_error
69
+
~extra_remarks:
70
+
[
71
+
Asai.Diagnostic.loctextf ?loc
67
72
"Encountered fatal error running `dvisvgm`: %s"
68
-
(Buffer.contents err_buf)
73
+
(Buffer.contents err_buf);
69
74
]
70
75
71
76
let pipe_latex_svg ~env ?loc ~tex_source ~svg_sink () =
+1
-1
lib/compiler/LaTeX_pipeline.mli
+1
-1
lib/compiler/LaTeX_pipeline.mli
+2
-2
lib/compiler/LaTeX_template.mli
+2
-2
lib/compiler/LaTeX_template.mli
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
val pp : Format.formatter -> preamble: string -> body: string -> unit
8
-
val to_string : preamble: string -> body: string -> string
7
+
val pp : Format.formatter -> preamble:string -> body:string -> unit
8
+
val to_string : preamble:string -> body:string -> string
+8
-9
lib/compiler/Parse.ml
+8
-9
lib/compiler/Parse.ml
···
6
6
7
7
open Forester_prelude
8
8
open Forester_core
9
-
10
9
include Forester_parser.Parse
11
10
12
11
let parse_channel filename ch =
···
23
22
lexbuf.lex_curr_p <- {lexbuf.lex_curr_p with pos_fname = path};
24
23
parse lexbuf
25
24
|> Result.map (fun nodes ->
26
-
Tree.{
27
-
nodes;
28
-
origin = Physical doc;
29
-
identity = URI (URI_scheme.path_to_uri ~base: config.url path);
30
-
timestamp = Some (Unix.time ());
31
-
}
32
-
)
25
+
Tree.
26
+
{
27
+
nodes;
28
+
origin = Physical doc;
29
+
identity = URI (URI_scheme.path_to_uri ~base:config.url path);
30
+
timestamp = Some (Unix.time ());
31
+
})
33
32
34
33
let parse_file filename =
35
34
let@ () = Reporter.tracef "when parsing file `%s`" filename in
36
35
let ch = open_in filename in
37
-
Fun.protect ~finally: (fun _ -> close_in ch) @@ fun _ ->
36
+
Fun.protect ~finally:(fun _ -> close_in ch) @@ fun _ ->
38
37
parse_channel filename ch
+2
-3
lib/compiler/Parse.mli
+2
-3
lib/compiler/Parse.mli
···
8
8
include module type of Forester_parser.Parse
9
9
10
10
val parse_document :
11
-
config: Config.t ->
11
+
config:Config.t ->
12
12
Lsp.Text_document.t ->
13
13
(Forester_core.Tree.code, Forester_core.Reporter.diagnostic) result
14
14
15
15
val parse_file :
16
-
string ->
17
-
(Forester_core.Code.t, Forester_core.Reporter.diagnostic) result
16
+
string -> (Forester_core.Code.t, Forester_core.Reporter.diagnostic) result
+76
-72
lib/compiler/Phases.ml
+76
-72
lib/compiler/Phases.ml
···
8
8
open Forester_prelude
9
9
open Forester_core
10
10
11
-
open struct module T = Types end
11
+
open struct
12
+
module T = Types
13
+
end
12
14
13
15
open State.Syntax
14
16
15
17
let load (tree_dirs : Eio.Fs.dir_ty Eio.Path.t list) =
16
-
Logs.debug (fun m -> m "loading trees from %i directories" (List.length tree_dirs));
17
-
Dir_scanner.scan_directories tree_dirs
18
-
|> Seq.map Imports.load_tree
18
+
Logs.debug (fun m ->
19
+
m "loading trees from %i directories" (List.length tree_dirs));
20
+
Dir_scanner.scan_directories tree_dirs |> Seq.map Imports.load_tree
19
21
20
22
let parse (forest : State.t) =
21
23
let trees = forest.index |> URI.Tbl.to_seq_values |> List.of_seq in
22
24
let results =
23
25
let@ tree = List.filter_map @~ trees in
24
26
match tree with
25
-
| Document doc -> Some (Parse.parse_document ~config: forest.config doc)
26
-
| Parsed _
27
-
| Expanded _
28
-
| Resource _ ->
29
-
None
27
+
| Document doc -> Some (Parse.parse_document ~config:forest.config doc)
28
+
| Parsed _ | Expanded _ | Resource _ -> None
30
29
in
31
30
let@ result = List.partition_map @~ results in
32
-
match result with
33
-
| Ok t -> Right t
34
-
| Error d -> Left d
31
+
match result with Ok t -> Right t | Error d -> Left d
35
32
36
33
let reparse (doc : Lsp.Text_document.t) (forest : State.t) =
37
34
Logs.debug (fun m -> m "reparsing");
38
-
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url @@ Lsp.Text_document.documentUri doc in
39
-
begin
40
-
match Parse.parse_document ~config: forest.config doc with
41
-
| Ok code ->
42
-
forest.={uri} <- Parsed code;
43
-
Imports.fixup code forest
44
-
| Error d ->
45
-
forest.?{uri} <- [d]
35
+
let uri =
36
+
URI_scheme.lsp_uri_to_uri ~base:forest.config.url
37
+
@@ Lsp.Text_document.documentUri doc
38
+
in
39
+
begin match Parse.parse_document ~config:forest.config doc with
40
+
| Ok code ->
41
+
forest.={uri} <- Parsed code;
42
+
Imports.fixup code forest
43
+
| Error d -> forest.?{uri} <- [d]
46
44
end;
47
45
forest
48
46
···
51
49
let errors = ref [] in
52
50
let push d = errors := d :: !errors in
53
51
let new_graph =
54
-
Reporter.run
55
-
~emit: push
56
-
~fatal: (fun d ->
52
+
Reporter.run ~emit:push ~fatal:(fun d ->
57
53
push d;
58
54
Reporter.Tty.display d;
59
-
forest.import_graph
60
-
)
61
-
@@ fun () ->
62
-
Imports.build forest
55
+
forest.import_graph)
56
+
@@ fun () -> Imports.build forest
63
57
in
64
-
!errors, new_graph
58
+
(!errors, new_graph)
65
59
66
-
let expand (forest : State.t) =
67
-
Expand.expand_tree ~forest
60
+
let expand (forest : State.t) = Expand.expand_tree ~forest
68
61
69
62
let expand_all (forest : State.t) =
70
63
let diagnostics = ref [] in
71
64
let task vertex =
72
65
match vertex with
73
66
| T.Content_vertex _ -> assert false
74
-
| T.Uri_vertex uri ->
67
+
| T.Uri_vertex uri -> (
75
68
match forest.={uri} with
76
-
| None ->
77
-
()
78
-
| Some tree ->
69
+
| None -> ()
70
+
| Some tree -> (
79
71
match Tree.to_code tree with
80
72
| Some tree ->
81
73
let expanded, errors = Expand.expand_tree ~forest tree in
···
84
76
forest.?{uri} <- errors
85
77
| None ->
86
78
Logs.debug (fun m -> m "expanding: no source code for %a" URI.pp uri);
87
-
assert false;
79
+
assert false))
88
80
in
89
81
Forest_graph.topo_iter task forest.import_graph;
90
82
!diagnostics
91
83
92
84
let run_jobs (forest : State.t) jobs =
93
85
Logs.debug (fun m -> m "Running %d jobs" (List.length jobs));
94
-
(* All resources induced by LaTeX jobs must be planted prior to publication export. *)
86
+
(* All resources induced by LaTeX jobs must be planted prior to publication
87
+
export. *)
95
88
let resources_to_plant =
96
-
let@ Range.{value; loc} = Eio.Fiber.List.map ~max_fibers: 20 @~ jobs in
89
+
let@ Range.{value; loc} = Eio.Fiber.List.map ~max_fibers:20 @~ jobs in
97
90
let@ () = Reporter.easy_run in
98
91
match value with
99
92
| Job.LaTeX_to_svg job ->
100
-
let svg = Build_latex.latex_to_svg ~env: forest.env ?loc job.source in
101
-
let uri = Job.uri_for_latex_to_svg_job ~base: forest.config.url job in
93
+
let svg = Build_latex.latex_to_svg ~env:forest.env ?loc job.source in
94
+
let uri = Job.uri_for_latex_to_svg_job ~base:forest.config.url job in
102
95
T.Asset {uri; content = svg}
103
-
| Job.Syndicate syndication ->
104
-
T.Syndication syndication
96
+
| Job.Syndicate syndication -> T.Syndication syndication
105
97
in
106
98
begin
107
-
(* It is probably not save to plant the articles in parallel, so this is done sequentially! *)
99
+
(* It is probably not save to plant the articles in parallel, so this is
100
+
done sequentially! *)
108
101
let@ resource = List.iter @~ resources_to_plant in
109
102
State.plant_resource resource forest
110
103
end
···
116
109
|> Seq.map (fun tree ->
117
110
let tree = Option.get @@ Tree.to_syn tree in
118
111
match identity_to_uri tree.identity with
119
-
| None -> Reporter.fatal Internal_error ~extra_remarks: [Asai.Diagnostic.loctext "can't evaluate a tree with no URI"]
112
+
| None ->
113
+
Reporter.fatal Internal_error
114
+
~extra_remarks:
115
+
[Asai.Diagnostic.loctext "can't evaluate a tree with no URI"]
120
116
| Some uri ->
121
117
let source_path =
122
-
if forest.dev then
123
-
URI.Tbl.find_opt forest.resolver uri
124
-
else None
118
+
if forest.dev then URI.Tbl.find_opt forest.resolver uri else None
125
119
in
126
-
Eval.eval_tree
127
-
~config: forest.config
128
-
~source_path
129
-
~uri
130
-
tree.nodes
131
-
)
120
+
Eval.eval_tree ~config:forest.config ~source_path ~uri tree.nodes)
132
121
in
133
122
result
134
123
···
139
128
| Some (Parsed _) | Some (Resource _) -> assert false
140
129
| Some (Expanded expanded) ->
141
130
let source_path =
142
-
if forest.dev then
143
-
URI.Tbl.find_opt forest.resolver uri
144
-
else None
131
+
if forest.dev then URI.Tbl.find_opt forest.resolver uri else None
145
132
in
146
133
(* NOTE: Not running jobs. *)
147
134
let Eval.{articles; jobs = _}, diagnostics =
148
-
Eval.eval_tree
149
-
~config: forest.config
150
-
~source_path
151
-
~uri
152
-
expanded.nodes
135
+
Eval.eval_tree ~config:forest.config ~source_path ~uri expanded.nodes
153
136
in
154
137
begin
155
138
let@ article = List.iter @~ articles in
156
139
State.plant_resource (Article article) forest
157
140
end;
158
-
forest, diagnostics
141
+
(forest, diagnostics)
159
142
160
143
let check_status _uri (forest : State.t) =
161
-
match forest with
162
-
| {dependency_cache = _; _} ->
163
-
forest, None
144
+
match forest with {dependency_cache = _; _} -> (forest, None)
164
145
165
146
let implant_foreign (state : State.t) : State.t * _ =
166
147
begin
167
-
Logs.debug (fun m -> m "implanting %i foreign forests" (List.length state.config.foreign));
148
+
Logs.debug (fun m ->
149
+
m "implanting %i foreign forests" (List.length state.config.foreign));
168
150
let module EP = Eio.Path in
169
151
let@ foreign = List.iter @~ state.config.foreign in
170
-
let path = Eio_util.path_of_file ~env: state.env foreign.path in
152
+
let path = Eio_util.path_of_file ~env:state.env foreign.path in
171
153
let path_str = EP.native_exn path in
172
-
Reporter.log Format.pp_print_string (Format.sprintf "Implant foreign forest from `%s'" path_str);
173
-
let blob = try EP.load path with _ -> Reporter.fatal IO_error ~extra_remarks: [Asai.Diagnostic.loctextf "Could not read foreign forest blob at `%s`" path_str] in
154
+
Reporter.log Format.pp_print_string
155
+
(Format.sprintf "Implant foreign forest from `%s'" path_str);
156
+
let blob =
157
+
try EP.load path
158
+
with _ ->
159
+
Reporter.fatal IO_error
160
+
~extra_remarks:
161
+
[
162
+
Asai.Diagnostic.loctextf
163
+
"Could not read foreign forest blob at `%s`" path_str;
164
+
]
165
+
in
174
166
match Repr.of_json_string (T.forest_t T.content_t) blob with
175
167
| Ok foreign_forest ->
176
168
let@ r = List.iter @~ foreign_forest in
177
-
State.plant_resource ~route_locally: foreign.route_locally ~include_in_manifest: foreign.include_in_manifest r state
169
+
State.plant_resource ~route_locally:foreign.route_locally
170
+
~include_in_manifest:foreign.include_in_manifest r state
178
171
| Error (`Msg err) ->
179
-
Reporter.fatal Parse_error ~extra_remarks: [Asai.Diagnostic.loctextf "Could not parse foreign forest blob: %s" err]
172
+
Reporter.fatal Parse_error
173
+
~extra_remarks:
174
+
[
175
+
Asai.Diagnostic.loctextf "Could not parse foreign forest blob: %s"
176
+
err;
177
+
]
180
178
| exception exn ->
181
-
Reporter.fatal Parse_error ~extra_remarks: [Asai.Diagnostic.loctextf "Encountered unknown error while decoding foreign forest blob: %s" (Printexc.to_string exn)]
179
+
Reporter.fatal Parse_error
180
+
~extra_remarks:
181
+
[
182
+
Asai.Diagnostic.loctextf
183
+
"Encountered unknown error while decoding foreign forest blob: %s"
184
+
(Printexc.to_string exn);
185
+
]
182
186
end;
183
-
state, []
187
+
(state, [])
+143
-157
lib/compiler/State.ml
+143
-157
lib/compiler/State.ml
···
6
6
7
7
open Forester_prelude
8
8
open Forester_core
9
-
10
9
open Tree
11
10
open Forester_core
12
-
open struct module T = Types end
11
+
12
+
open struct
13
+
module T = Types
14
+
end
15
+
13
16
type resource = T.content T.resource
14
17
15
18
type t = {
···
26
29
usages: (Tree.exports, URI.t Asai.Range.located) Hashtbl.t;
27
30
history: Action.t list;
28
31
hosts: (string, unit) Hashtbl.t;
29
-
suggestions: URI.t URI.Tbl.t
32
+
suggestions: URI.t URI.Tbl.t;
30
33
}
31
34
32
-
let make
33
-
~(env : Eio_unix.Stdenv.base)
34
-
~(config : Config.t)
35
-
~(dev : bool)
36
-
?(graphs = (module Forest_graphs.Make (): Forest_graphs.S))
37
-
?(import_graph = Forest_graph.create ~size: 1000 ())
38
-
?(resolver = URI.Tbl.create 1000)
39
-
?(index = URI.Tbl.create 1000)
40
-
?(diagnostics = URI.Tbl.create 1000)
41
-
?(usages = Hashtbl.create 1000)
42
-
?(search_index = Forester_search.Index.create [])
43
-
?(dependency_cache = Cache.empty)
44
-
?(hosts = Hashtbl.create 10)
45
-
?(suggestions = URI.Tbl.create 1000)
46
-
()
47
-
= {env; dev; config; index; diagnostics; resolver; import_graph; graphs; search_index; dependency_cache; usages; hosts; suggestions; history = []}
35
+
let make ~(env : Eio_unix.Stdenv.base) ~(config : Config.t) ~(dev : bool)
36
+
?(graphs = (module Forest_graphs.Make () : Forest_graphs.S))
37
+
?(import_graph = Forest_graph.create ~size:1000 ())
38
+
?(resolver = URI.Tbl.create 1000) ?(index = URI.Tbl.create 1000)
39
+
?(diagnostics = URI.Tbl.create 1000) ?(usages = Hashtbl.create 1000)
40
+
?(search_index = Forester_search.Index.create [])
41
+
?(dependency_cache = Cache.empty) ?(hosts = Hashtbl.create 10)
42
+
?(suggestions = URI.Tbl.create 1000) () =
43
+
{
44
+
env;
45
+
dev;
46
+
config;
47
+
index;
48
+
diagnostics;
49
+
resolver;
50
+
import_graph;
51
+
graphs;
52
+
search_index;
53
+
dependency_cache;
54
+
usages;
55
+
hosts;
56
+
suggestions;
57
+
history = [];
58
+
}
48
59
49
60
module Syntax = struct
50
-
let (.={}) state uri =
51
-
URI.Tbl.find_opt state.index uri
61
+
let ( .={} ) state uri = URI.Tbl.find_opt state.index uri
52
62
53
-
let (.={} <-) state uri tree =
63
+
let ( .={}<- ) state uri tree =
54
64
match state.={uri} with
55
-
| None ->
56
-
URI.Tbl.replace state.index uri tree
65
+
| None -> URI.Tbl.replace state.index uri tree
57
66
| Some existing ->
58
67
let o1 = Tree.origin tree in
59
68
let o2 = Tree.origin existing in
60
-
if o1 <> o2 then
61
-
begin
62
-
Reporter.emit (Duplicate_tree (o1, o2));
63
-
URI.Tbl.replace state.index uri tree
64
-
end
65
-
else
69
+
if o1 <> o2 then begin
70
+
Reporter.emit (Duplicate_tree (o1, o2));
66
71
URI.Tbl.replace state.index uri tree
72
+
end
73
+
else URI.Tbl.replace state.index uri tree
67
74
(* URI.Tbl.replace state.index uri item *)
68
75
69
76
(* / for units*)
70
-
let (./{}) state uri =
71
-
Option.bind
72
-
(URI.Tbl.find_opt state.index uri)
73
-
Tree.get_units
77
+
let ( ./{} ) state uri =
78
+
Option.bind (URI.Tbl.find_opt state.index uri) Tree.get_units
74
79
75
80
(* updating units*)
76
-
let (./{} <-) state uri units =
81
+
let ( ./{}<- ) state uri units =
77
82
let@ () = Reporter.tracef "when updating units for %a" URI.pp uri in
78
83
match URI.Tbl.find_opt state.index uri with
79
-
| None -> Reporter.fatal Internal_error ~extra_remarks: [Asai.Diagnostic.loctextf "Updating units: %a not found" URI.pp uri]
80
-
| Some (Document _)
81
-
| Some (Parsed _) ->
82
-
Reporter.fatal Internal_error ~extra_remarks: [Asai.Diagnostic.loctextf "%a has not been expanded yet" URI.pp uri]
84
+
| None ->
85
+
Reporter.fatal Internal_error
86
+
~extra_remarks:
87
+
[Asai.Diagnostic.loctextf "Updating units: %a not found" URI.pp uri]
88
+
| Some (Document _) | Some (Parsed _) ->
89
+
Reporter.fatal Internal_error
90
+
~extra_remarks:
91
+
[Asai.Diagnostic.loctextf "%a has not been expanded yet" URI.pp uri]
83
92
| Some (Expanded expanded) ->
84
-
URI.Tbl.replace
85
-
state.index
86
-
uri
87
-
(Expanded {expanded with units})
93
+
URI.Tbl.replace state.index uri (Expanded {expanded with units})
88
94
| Some (Resource _) -> ()
89
95
90
96
(* ? for diagnostics*)
91
-
let (.?{}) state uri =
92
-
Option.value ~default: [] (URI.Tbl.find_opt state.diagnostics uri)
97
+
let ( .?{} ) state uri =
98
+
Option.value ~default:[] (URI.Tbl.find_opt state.diagnostics uri)
93
99
94
-
let (.?{} <-) state uri diagnostics = URI.Tbl.add state.diagnostics uri diagnostics
100
+
let ( .?{}<- ) state uri diagnostics =
101
+
URI.Tbl.add state.diagnostics uri diagnostics
95
102
96
103
(* @ for article/resource *)
97
-
let (.@{}) state uri =
104
+
let ( .@{} ) state uri =
98
105
match URI.Tbl.find_opt state.index uri with
99
106
| Some (Document _) -> None
100
-
| Some (Parsed _)
101
-
| Some (Expanded (_))
102
-
| None ->
103
-
None
107
+
| Some (Parsed _) | Some (Expanded _) | None -> None
104
108
| Some (Resource res) -> Some res.resource
105
109
end
106
110
107
111
open Syntax
108
112
109
-
let update_history forest action = {forest with history = action :: forest.history}
113
+
let update_history forest action =
114
+
{forest with history = action :: forest.history}
110
115
111
116
let find_opt state uri = URI.Tbl.find_opt state.index uri
112
117
let to_seq state = URI.Tbl.to_seq state.index
113
118
114
119
let get_all_unparsed state =
115
-
state.index
116
-
|> URI.Tbl.to_seq_values
117
-
|> Seq.filter is_unparsed
120
+
state.index |> URI.Tbl.to_seq_values |> Seq.filter is_unparsed
118
121
119
122
let get_all_code state =
120
-
state.index
121
-
|> URI.Tbl.to_seq_values
122
-
|> Seq.filter_map to_code
123
+
state.index |> URI.Tbl.to_seq_values |> Seq.filter_map to_code
123
124
124
125
let get_all_unexpanded state =
125
-
state.index
126
-
|> URI.Tbl.to_seq_values
127
-
|> Seq.filter is_unexpanded
126
+
state.index |> URI.Tbl.to_seq_values |> Seq.filter is_unexpanded
128
127
129
128
let get_all_expanded state =
130
-
state.index
131
-
|> URI.Tbl.to_seq_values
132
-
|> Seq.filter_map to_syn
129
+
state.index |> URI.Tbl.to_seq_values |> Seq.filter_map to_syn
133
130
134
131
let get_all_unevaluated state =
135
-
state.index
136
-
|> URI.Tbl.to_seq_values
137
-
|> Seq.filter is_unevaluated
132
+
state.index |> URI.Tbl.to_seq_values |> Seq.filter is_unevaluated
138
133
139
-
let get_all_articles : t -> T.content T.article Seq.t = fun state ->
140
-
state.index
141
-
|> URI.Tbl.to_seq_values
142
-
|> Seq.filter_map to_article
134
+
let get_all_articles : t -> T.content T.article Seq.t =
135
+
fun state -> state.index |> URI.Tbl.to_seq_values |> Seq.filter_map to_article
143
136
144
-
let get_all_evaluated : t -> evaluated Seq.t = fun state ->
145
-
state.index
146
-
|> URI.Tbl.to_seq_values
147
-
|> Seq.filter_map to_evaluated
137
+
let get_all_evaluated : t -> evaluated Seq.t =
138
+
fun state ->
139
+
state.index |> URI.Tbl.to_seq_values |> Seq.filter_map to_evaluated
148
140
149
-
let get_all_resources : t -> T.content T.resource Seq.t = fun state ->
150
-
state.index
151
-
|> URI.Tbl.to_seq_values
152
-
|> Seq.filter_map to_resource
141
+
let get_all_resources : t -> T.content T.resource Seq.t =
142
+
fun state -> state.index |> URI.Tbl.to_seq_values |> Seq.filter_map to_resource
153
143
154
144
let get_resource state uri =
155
-
match state.={uri} with
156
-
| None -> None
157
-
| Some tree -> to_resource tree
145
+
match state.={uri} with None -> None | Some tree -> to_resource tree
158
146
159
147
let get_code state uri =
160
-
match state.={uri} with
161
-
| None -> None
162
-
| Some tree -> to_code tree
148
+
match state.={uri} with None -> None | Some tree -> to_code tree
163
149
164
-
let get_article : URI.t -> t -> T.content T.article option = fun uri forest ->
150
+
let get_article : URI.t -> t -> T.content T.article option =
151
+
fun uri forest ->
165
152
match URI.Tbl.find_opt forest.index uri with
166
-
| None
167
-
| Some (Document _)
168
-
| Some (Parsed _)
169
-
| Some (Expanded _) ->
170
-
None
171
-
| Some (Resource {resource; _}) ->
172
-
match resource with
173
-
| T.Article a -> Some a
174
-
| _ -> None
153
+
| None | Some (Document _) | Some (Parsed _) | Some (Expanded _) -> None
154
+
| Some (Resource {resource; _}) -> (
155
+
match resource with T.Article a -> Some a | _ -> None)
175
156
176
157
let section_symbol = "§"
177
158
178
-
let rec get_expanded_title ?scope ?(flags = T.{empty_when_untitled = false}) (frontmatter : _ T.frontmatter) forest =
159
+
let rec get_expanded_title ?scope ?(flags = T.{empty_when_untitled = false})
160
+
(frontmatter : _ T.frontmatter) forest =
179
161
let short_title =
180
162
match frontmatter.title with
181
163
| Some content -> content
182
-
| None when not flags.empty_when_untitled ->
183
-
begin
184
-
match frontmatter.uri with
185
-
| Some uri -> T.Content [T.Uri uri]
186
-
| _ -> T.Content [T.Text "Untitled"]
187
-
end
164
+
| None when not flags.empty_when_untitled -> begin
165
+
match frontmatter.uri with
166
+
| Some uri -> T.Content [T.Uri uri]
167
+
| _ -> T.Content [T.Text "Untitled"]
168
+
end
188
169
| _ -> T.Content []
189
170
in
190
-
Option.value ~default: short_title @@
191
-
match frontmatter.designated_parent with
192
-
| Some parent_uri when not (Option.equal URI.equal scope frontmatter.designated_parent) ->
193
-
let@ parent = Option.map @~ get_article parent_uri forest in
194
-
let parent_title = get_expanded_title parent.frontmatter forest in
195
-
let parent_link = T.Link {href = parent_uri; content = parent_title} in
196
-
let chevron = T.Text " › " in
197
-
T.map_content (fun xs -> parent_link :: chevron :: xs) short_title
198
-
| _ -> None
171
+
Option.value ~default:short_title
172
+
@@
173
+
match frontmatter.designated_parent with
174
+
| Some parent_uri
175
+
when not (Option.equal URI.equal scope frontmatter.designated_parent) ->
176
+
let@ parent = Option.map @~ get_article parent_uri forest in
177
+
let parent_title = get_expanded_title parent.frontmatter forest in
178
+
let parent_link = T.Link {href = parent_uri; content = parent_title} in
179
+
let chevron = T.Text " › " in
180
+
T.map_content (fun xs -> parent_link :: chevron :: xs) short_title
181
+
| _ -> None
199
182
200
183
let get_content_of_transclusion (transclusion : T.transclusion) forest =
201
184
match transclusion.target with
···
206
189
let@ article = Option.map @~ get_article transclusion.href forest in
207
190
article.mainmatter
208
191
| Title flags ->
209
-
Option.some @@
210
-
begin
211
-
match get_article transclusion.href forest with
212
-
| None -> T.Content [T.Uri transclusion.href]
213
-
| Some article -> get_expanded_title ~flags article.frontmatter forest
214
-
end
192
+
Option.some
193
+
@@ begin match get_article transclusion.href forest with
194
+
| None -> T.Content [T.Uri transclusion.href]
195
+
| Some article -> get_expanded_title ~flags article.frontmatter forest
196
+
end
215
197
| Taxon ->
216
198
let@ article = Option.map @~ get_article transclusion.href forest in
217
199
let default = T.Content [T.Text section_symbol] in
···
220
202
let get_title_or_content_of_vertex ?(not_found = fun _ -> None) vertex forest =
221
203
match vertex with
222
204
| T.Content_vertex content -> Some content
223
-
| T.Uri_vertex uri ->
224
-
begin
225
-
match get_article uri forest with
226
-
| Some article -> article.frontmatter.title
227
-
| None -> not_found uri
228
-
end
205
+
| T.Uri_vertex uri -> begin
206
+
match get_article uri forest with
207
+
| Some article -> article.frontmatter.title
208
+
| None -> not_found uri
209
+
end
229
210
230
-
(* A list of mistakes that a user might make when typing a given URI.
231
-
For example, they might type "https://www.forester-notes.com/005P" instead of "https://www.forester-notes.com/005P/".
232
-
*)
211
+
(* A list of mistakes that a user might make when typing a given URI. For
212
+
example, they might type "https://www.forester-notes.com/005P" instead of
213
+
"https://www.forester-notes.com/005P/".
214
+
*)
233
215
let wrong_variants_for_uri uri =
234
216
let components = URI.path_components uri in
235
217
match List.rev components with
···
237
219
[
238
220
URI.with_path_components (List.rev rest) uri;
239
221
URI.with_path_components (components @ ["index.html"]) uri;
240
-
URI.with_path_components (components @ ["index.xml"]) uri
222
+
URI.with_path_components (components @ ["index.xml"]) uri;
241
223
]
242
224
| _ -> []
243
225
244
-
type uri_suggestion =
245
-
| Ok
246
-
| Not_found of {suggestion: URI.t option}
226
+
type uri_suggestion = Ok | Not_found of {suggestion: URI.t option}
247
227
248
228
let suggestion_for_uri uri forest =
249
229
match URI.host uri with
250
230
| None -> Ok
251
-
| Some host ->
231
+
| Some host -> (
252
232
match Hashtbl.find_opt forest.hosts host with
253
233
| None -> Ok
254
-
| Some() ->
234
+
| Some () -> (
255
235
match URI.Tbl.find_opt forest.index uri with
256
236
| Some _ -> Ok
257
237
| None -> Not_found {suggestion = URI.Tbl.find_opt forest.suggestions uri}
238
+
))
258
239
259
-
let plant_resource ?(route_locally = true) ?(include_in_manifest = true) resource forest =
240
+
let plant_resource ?(route_locally = true) ?(include_in_manifest = true)
241
+
resource forest =
260
242
let module Graphs = (val forest.graphs) in
261
243
Forest.analyse_resource forest.graphs resource;
262
244
let@ uri = Option.iter @~ T.uri_for_resource resource in
263
-
let uri = URI.canonicalise uri in (* Seems dodgy if this isn't already canonical! *)
245
+
let uri = URI.canonicalise uri in
246
+
(* Seems dodgy if this isn't already canonical! *)
264
247
Graphs.register_uri uri;
265
248
begin
266
249
let@ host = Option.iter @~ URI.host uri in
···
272
255
end;
273
256
match forest.={uri} with
274
257
| None ->
275
-
forest.={uri} <- Resource {resource; expanded = None; route_locally; include_in_manifest}
258
+
forest.={uri} <-
259
+
Resource {resource; expanded = None; route_locally; include_in_manifest}
276
260
| Some (Tree.Expanded syn) ->
277
-
forest.={uri} <- Resource {resource; expanded = Some syn; route_locally; include_in_manifest}
261
+
forest.={uri} <-
262
+
Resource
263
+
{resource; expanded = Some syn; route_locally; include_in_manifest}
278
264
| _ ->
279
-
forest.={uri} <- Resource {resource; expanded = None; route_locally; include_in_manifest}
265
+
forest.={uri} <-
266
+
Resource {resource; expanded = None; route_locally; include_in_manifest}
280
267
281
-
let serialize_graphs
282
-
: (module Forest_graphs.S) -> 'a
283
-
= fun s ->
268
+
let serialize_graphs : (module Forest_graphs.S) -> 'a =
269
+
fun s ->
284
270
let module Graphs = (val s) in
285
271
Graphs.dl_db
286
272
···
288
274
| {import_graph; _} ->
289
275
(* let dl_db = serialize_graphs graphs in *)
290
276
let open Cache in
291
-
let module Gmap = Forest_graph.Map(Cache.Dependecy_graph) in
277
+
let module Gmap = Forest_graph.Map (Cache.Dependecy_graph) in
292
278
let tbl = Dependency_tbl.create 100 in
293
279
let now = Unix.time () in
294
280
let g =
295
281
import_graph
296
282
|> Gmap.map @@ function
297
-
| T.Content_vertex _ ->
298
-
(*Import graph has no content vertices*)
299
-
assert false
300
-
| T.Uri_vertex uri ->
301
-
let item = Item.Tree uri in
302
-
Dependency_tbl.add tbl item Item.{timestamp = Some now; color = Green};
303
-
item
283
+
| T.Content_vertex _ ->
284
+
(*Import graph has no content vertices*)
285
+
assert false
286
+
| T.Uri_vertex uri ->
287
+
let item = Item.Tree uri in
288
+
Dependency_tbl.add tbl item
289
+
Item.{timestamp = Some now; color = Green};
290
+
item
304
291
in
305
-
{Cache.empty with graph = g; tbl;}
292
+
{Cache.empty with graph = g; tbl}
306
293
307
-
let reconstruct = fun ~env: _ ~(_config : Config.t) paths cache ->
294
+
let reconstruct =
295
+
fun ~env:_ ~(_config : Config.t) paths cache ->
308
296
match cache with
309
297
| {search_index = _; _} ->
310
298
(* let init = Phases.init ~env ~config ~dev: true in *)
···
317
305
(* | Some tree -> *)
318
306
(* match check_timestamp path tree.timestamp with *)
319
307
(* | _ -> () *)
320
-
()
321
-
)
308
+
())
322
309
323
310
let rec lsp_uri_of_uri (uri : URI.t) (forest : t) : Lsp.Uri.t option =
324
311
let@ tree = Option.bind @@ find_opt forest uri in
···
333
320
334
321
and lsp_uri_of_resource (resource : resource) (forest : t) : Lsp.Uri.t option =
335
322
match resource with
336
-
| Article article -> Option.map Lsp.Uri.of_string article.frontmatter.source_path
323
+
| Article article ->
324
+
Option.map Lsp.Uri.of_string article.frontmatter.source_path
337
325
| Asset _ | Syndication _ -> None
338
326
339
327
and lsp_uri_of_origin (origin : origin) (forest : t) : Lsp.Uri.t option =
···
343
331
| Undefined -> None
344
332
345
333
and lsp_uri_of_identity (identity : identity) (forest : t) : Lsp.Uri.t option =
346
-
match identity with
347
-
| URI uri -> lsp_uri_of_uri uri forest
348
-
| Anonymous -> None
334
+
match identity with URI uri -> lsp_uri_of_uri uri forest | Anonymous -> None
349
335
350
336
let source_path_of_uri uri forest =
351
-
Option.map Lsp.Uri.to_path @@ lsp_uri_of_uri uri forest
337
+
Option.map Lsp.Uri.to_path @@ lsp_uri_of_uri uri forest
+17
-21
lib/compiler/Suggestions.ml
+17
-21
lib/compiler/Suggestions.ml
···
10
10
11
11
(* TODO: remove this in favor of https://github.com/ocaml/ocaml/pull/13760 *)
12
12
let edit_distance ~cutoff x y =
13
-
let len_x, len_y = String.length x, String.length y in
13
+
let len_x, len_y = (String.length x, String.length y) in
14
14
let grid = Array.make_matrix (len_x + 1) (len_y + 1) 0 in
15
15
for i = 1 to len_x do
16
16
grid.(i).(0) <- i
···
23
23
let cost = if x.[i - 1] = y.[j - 1] then 0 else 1 in
24
24
let k = Int.min (grid.(i - 1).(j) + 1) (grid.(i).(j - 1) + 1) in
25
25
grid.(i).(j) <- Int.min k (grid.(i - 1).(j - 1) + cost)
26
-
done;
26
+
done
27
27
done;
28
28
let result = grid.(len_x).(len_y) in
29
-
if result > cutoff then None
30
-
else
31
-
Some result
29
+
if result > cutoff then None else Some result
32
30
33
-
let suggestions ?prefix ~(cutoff : int) (p : Trie.bwd_path) : ('data, 'tag) Trie.t -> ('data, int) Trie.t =
31
+
let suggestions ?prefix ~(cutoff : int) (p : Trie.bwd_path) :
32
+
('data, 'tag) Trie.t -> ('data, int) Trie.t =
34
33
let compare p d =
35
-
edit_distance
36
-
~cutoff
34
+
edit_distance ~cutoff
37
35
(String.concat "" (Bwd.to_list p))
38
36
(String.concat "" (Bwd.to_list d))
39
37
in
···
42
40
if i > cutoff then None else Some (data, i)
43
41
44
42
let suggestions ~visible path =
45
-
suggestions ~cutoff: 2 (Bwd.of_list path) visible
43
+
suggestions ~cutoff:2 (Bwd.of_list path) visible
46
44
|> Trie.to_seq
47
45
|> Seq.map (fun (path, (data, distance)) -> (path, data, distance))
48
46
|> List.of_seq
···
52
50
let suggestions = suggestions ~visible path in
53
51
let extra_remarks =
54
52
if List.length suggestions > 0 then
55
-
let (path, data, _) = List.hd suggestions in
53
+
let path, data, _ = List.hd suggestions in
56
54
let location_hint =
57
55
match data with
58
-
| Syn.Term ({loc = Some loc; _} :: _) ->
59
-
begin
60
-
match Range.view loc with
61
-
| `End_of_file {source; _}
62
-
| `Range ({source; _}, _) ->
63
-
match Range.title source with
64
-
| Some string ->
65
-
[Asai.Diagnostic.loctextf "defined in %s" string]
66
-
| _ -> []
67
-
end
56
+
| Syn.Term ({loc = Some loc; _} :: _) -> begin
57
+
match Range.view loc with
58
+
| `End_of_file {source; _} | `Range ({source; _}, _) -> (
59
+
match Range.title source with
60
+
| Some string -> [Asai.Diagnostic.loctextf "defined in %s" string]
61
+
| _ -> [])
62
+
end
68
63
| _ -> []
69
64
in
70
-
[Asai.Diagnostic.loctextf "Did you mean %a?" Trie.pp_path path] @ location_hint
65
+
[Asai.Diagnostic.loctextf "Did you mean %a?" Trie.pp_path path]
66
+
@ location_hint
71
67
else []
72
68
in
73
69
extra_remarks
+19
-11
lib/compiler/Tape_effect.ml
+19
-11
lib/compiler/Tape_effect.ml
···
7
7
open Forester_core
8
8
9
9
module type S = sig
10
-
val run : tape: Syn.t -> (unit -> 'a) -> 'a
10
+
val run : tape:Syn.t -> (unit -> 'a) -> 'a
11
11
val pop_node_opt : unit -> Syn.node Range.located option
12
-
13
12
val pop_arg_opt : unit -> Syn.t Range.located option
14
-
val pop_arg : loc: Range.t option -> Syn.t Range.located
13
+
val pop_arg : loc:Range.t option -> Syn.t Range.located
15
14
val pop_args : unit -> Syn.t Range.located list
16
15
end
17
16
18
17
module Make () = struct
19
18
open Bwd
20
19
21
-
module T = Algaeff.State.Make(struct type t = Syn.t end)
20
+
module T = Algaeff.State.Make (struct
21
+
type t = Syn.t
22
+
end)
22
23
23
24
let pop_node_opt () =
24
25
match T.get () with
···
29
30
30
31
let pop_arg_opt () =
31
32
match T.get () with
32
-
| Range.{value = Syn.Group (Braces, arg); _} as node :: nodes ->
33
+
| (Range.{value = Syn.Group (Braces, arg); _} as node) :: nodes ->
33
34
T.set nodes;
34
-
Some ({node with value = arg})
35
-
| Range.{value = (Syn.Sym _ | Syn.Verbatim _ | Syn.Var _ | Syn.Dx_sequent _ | Syn.Dx_query _); _} as node :: nodes ->
35
+
Some {node with value = arg}
36
+
| (Range.
37
+
{
38
+
value =
39
+
( Syn.Sym _ | Syn.Verbatim _ | Syn.Var _ | Syn.Dx_sequent _
40
+
| Syn.Dx_query _ );
41
+
_;
42
+
} as node)
43
+
:: nodes ->
36
44
T.set nodes;
37
-
Some ({node with value = [node]})
45
+
Some {node with value = [node]}
38
46
| _ -> None
39
47
40
48
let pop_arg ~loc =
41
49
match pop_arg_opt () with
42
50
| Some arg -> arg
43
-
| None -> Reporter.fatal ?loc (Type_error {got = None; expected = [Argument]})
51
+
| None ->
52
+
Reporter.fatal ?loc (Type_error {got = None; expected = [Argument]})
44
53
45
54
let pop_args () =
46
55
let rec loop acc =
···
50
59
in
51
60
loop Bwd.Emp
52
61
53
-
let run ~tape =
54
-
T.run ~init: tape
62
+
let run ~tape = T.run ~init:tape
55
63
end
+2
-3
lib/compiler/Tape_effect.mli
+2
-3
lib/compiler/Tape_effect.mli
···
7
7
open Forester_core
8
8
9
9
module type S = sig
10
-
val run : tape: Syn.t -> (unit -> 'a) -> 'a
10
+
val run : tape:Syn.t -> (unit -> 'a) -> 'a
11
11
val pop_node_opt : unit -> Syn.node Range.located option
12
-
13
12
val pop_arg_opt : unit -> Syn.t Range.located option
14
-
val pop_arg : loc: Range.t option -> Syn.t Range.located
13
+
val pop_arg : loc:Range.t option -> Syn.t Range.located
15
14
val pop_args : unit -> Syn.t Range.located list
16
15
end
17
16
+26
-21
lib/compiler/URI_util.ml
+26
-21
lib/compiler/URI_util.ml
···
6
6
7
7
open Forester_prelude
8
8
open Forester_core
9
+
9
10
open struct
10
11
module L = Lsp.Types
11
12
end
12
13
13
14
let rec random_not_in keys =
14
-
let attempt = Random.int (36 * 36 * 36 * 36 - 1) in
15
-
if List.fold_left (fun x y -> x || y) false (List.map (fun k -> k = attempt) keys) then
16
-
random_not_in keys
17
-
else
18
-
attempt
15
+
let attempt = Random.int ((36 * 36 * 36 * 36) - 1) in
16
+
if
17
+
List.fold_left
18
+
(fun x y -> x || y)
19
+
false
20
+
(List.map (fun k -> k = attempt) keys)
21
+
then random_not_in keys
22
+
else attempt
19
23
20
-
let next_uri ~(prefix : string option) ~(mode : [< `Random | `Sequential]) ~(forest : State.t) : string =
21
-
let addrs =
22
-
forest.index
23
-
|> URI.Tbl.to_seq
24
-
|> Seq.map fst
25
-
in
24
+
let next_uri ~(prefix : string option) ~(mode : [< `Random | `Sequential])
25
+
~(forest : State.t) : string =
26
+
let addrs = forest.index |> URI.Tbl.to_seq |> Seq.map fst in
26
27
let config = forest.config in
27
28
let keys =
28
-
List.of_seq @@
29
-
let@ uri = Seq.filter_map @~ addrs in
30
-
if URI.host config.url = URI.host uri then
31
-
let@ prefix', key = Option.bind @@ URI_scheme.split_addr uri in
32
-
if prefix = prefix' then Some key else None
33
-
else None
29
+
List.of_seq
30
+
@@
31
+
let@ uri = Seq.filter_map @~ addrs in
32
+
if URI.host config.url = URI.host uri then
33
+
let@ prefix', key = Option.bind @@ URI_scheme.split_addr uri in
34
+
if prefix = prefix' then Some key else None
35
+
else None
34
36
in
35
37
let next =
36
38
match mode with
37
39
| `Sequential ->
38
-
let last_sequential = List.fold_left (fun acc_i i -> if i > acc_i then i else acc_i) 0 keys in
40
+
let last_sequential =
41
+
List.fold_left (fun acc_i i -> if i > acc_i then i else acc_i) 0 keys
42
+
in
39
43
last_sequential + 1
40
44
| `Random -> random_not_in keys
41
45
in
42
-
(match prefix with (None | Some "") -> "" | Some prefix -> prefix ^ "-") ^ BaseN.Base36.string_of_int next
46
+
(match prefix with None | Some "" -> "" | Some prefix -> prefix ^ "-")
47
+
^ BaseN.Base36.string_of_int next
43
48
44
49
let start_of_file =
45
-
let beginning = L.Position.create ~character: 0 ~line: 0 in
46
-
L.Range.create ~start: beginning ~end_: beginning
50
+
let beginning = L.Position.create ~character:0 ~line:0 in
51
+
L.Range.create ~start:beginning ~end_:beginning
+5
-37
lib/compiler/Xml_forester.ml
+5
-37
lib/compiler/Xml_forester.ml
···
10
10
let forester_xmlns = {prefix = "fr"; xmlns = "http://www.forester-notes.org"}
11
11
let html_xlmns = {prefix = "html"; xmlns = "http://www.w3.org/1999/xhtml"}
12
12
let xml_xmlns = {prefix = "xml"; xmlns = "http://www.w3.org/XML/1998/namespace"}
13
-
14
13
let reserved_xmlnss = [forester_xmlns; html_xlmns; xml_xmlns]
15
-
16
14
let null = HTML.null
17
15
let null_ = HTML.null_
18
-
19
-
let conditional b n =
20
-
if b then
21
-
n
22
-
else null []
23
-
24
-
let optional kont opt =
25
-
match opt with
26
-
| Some x -> kont x
27
-
| None -> null []
28
-
29
-
let optional_ kont opt =
30
-
match opt with
31
-
| Some x -> kont x
32
-
| None -> null_
33
-
16
+
let conditional b n = if b then n else null []
17
+
let optional kont opt = match opt with Some x -> kont x | None -> null []
18
+
let optional_ kont opt = match opt with Some x -> kont x | None -> null_
34
19
let add_forester_ns name = Format.sprintf "%s:%s" forester_xmlns.prefix name
35
20
let add_html_ns name = Format.sprintf "%s:%s" html_xlmns.prefix name
36
-
37
21
let f_std_tag name = std_tag @@ add_forester_ns name
38
22
let f_text_tag name = text_tag @@ add_forester_ns name
39
-
40
23
let f_void_tag name attrs = std_tag (add_forester_ns name) attrs []
41
24
let html_void_tag name attrs = std_tag (add_html_ns name) attrs []
42
-
43
25
let info = f_std_tag "info"
44
-
45
26
let tree = f_std_tag "tree"
46
27
let numbered = bool_attr "numbered"
47
28
let toc = bool_attr "toc"
···
50
31
let show_heading = bool_attr "show-heading"
51
32
let show_metadata = bool_attr "show-metadata"
52
33
let root = bool_attr "root"
53
-
54
34
let frontmatter = f_std_tag "frontmatter"
55
35
let mainmatter = f_std_tag "mainmatter"
56
36
let backmatter = f_std_tag "backmatter"
57
-
58
37
let taxon attrs = f_std_tag "taxon" attrs
59
38
let uri attrs = f_text_tag "uri" attrs
60
39
let display_uri attrs = f_text_tag "display-uri" attrs
···
70
49
let author = f_std_tag "author"
71
50
let contributor = f_std_tag "contributor"
72
51
let title = f_std_tag "title"
73
-
74
52
let link = f_std_tag "link"
75
53
let type_ fmt = string_attr "type" fmt
76
54
let uri_ fmt = string_attr "uri" fmt
77
55
let display_uri_ fmt = string_attr "display-uri" fmt
78
56
let text_ fmt = string_attr "text" fmt
79
-
80
57
let number attrs = f_text_tag "number" attrs
81
-
82
58
let meta = f_std_tag "meta"
83
59
let name fmt = string_attr "name" fmt
84
-
85
-
let tex attrs = f_text_tag ~raw: true "tex" attrs
60
+
let tex attrs = f_text_tag ~raw:true "tex" attrs
86
61
let display fmt = string_attr "display" fmt
87
-
88
62
let title_ fmt = string_attr "title" fmt
89
-
90
63
let ref = f_void_tag "ref"
91
-
92
64
let number_ fmt = string_attr "number" fmt
93
-
94
65
let img = html_void_tag "img"
95
66
let src fmt = string_attr "src" fmt
96
-
97
67
let resource = f_std_tag "resource"
98
68
let resource_content = f_std_tag "resource-content"
99
-
let resource_source attrs = f_text_tag ~raw: true "resource-source" attrs
69
+
let resource_source attrs = f_text_tag ~raw:true "resource-source" attrs
100
70
let resource_part fmt = string_attr "part" fmt
101
-
102
71
let contextual_number = f_void_tag "contextual-number"
103
-
104
72
let hash fmt = string_attr "hash" fmt
-19
lib/compiler/Xml_forester.mli
-19
lib/compiler/Xml_forester.mli
···
8
8
open Forester_xml_names
9
9
10
10
val reserved_xmlnss : xmlns_attr list
11
-
12
11
val conditional : bool -> node -> node
13
12
val optional : ('a -> node) -> 'a option -> node
14
13
val optional_ : ('a -> attr) -> 'a option -> attr
15
-
16
14
val null : node list -> node
17
15
val null_ : attr
18
-
19
16
val tree : std_tag
20
-
21
17
val numbered : bool to_attr
22
18
val toc : bool to_attr
23
19
val expanded : bool to_attr
24
20
val show_heading : bool to_attr
25
21
val show_metadata : bool to_attr
26
22
val hidden_when_empty : bool to_attr
27
-
28
23
val root : bool to_attr
29
-
30
24
val info : std_tag
31
-
32
25
val frontmatter : std_tag
33
26
val mainmatter : std_tag
34
27
val backmatter : std_tag
35
-
36
28
val taxon : std_tag
37
29
val uri : _ text_tag
38
30
val display_uri : _ text_tag
···
41
33
val date : std_tag
42
34
val last_changed : std_tag
43
35
val title : std_tag
44
-
45
36
val href : _ string_attr
46
37
val year : _ text_tag
47
38
val month : _ text_tag
48
39
val day : _ text_tag
49
-
50
40
val authors : std_tag
51
41
val author : std_tag
52
42
val contributor : std_tag
53
-
54
43
val link : std_tag
55
44
val type_ : _ string_attr
56
45
val uri_ : _ string_attr
57
46
val display_uri_ : _ string_attr
58
47
val title_ : _ string_attr
59
48
val text_ : _ string_attr
60
-
61
49
val number : _ text_tag
62
-
63
50
val meta : std_tag
64
51
val name : _ string_attr
65
-
66
52
val tex : _ text_tag
67
53
val display : _ string_attr
68
-
69
54
val ref : void_tag
70
55
val number_ : _ string_attr
71
-
72
56
val img : void_tag
73
57
val src : _ string_attr
74
-
75
58
val contextual_number : void_tag
76
-
77
59
val resource : std_tag
78
60
val resource_content : std_tag
79
61
val resource_source : _ text_tag
80
62
val resource_part : _ string_attr
81
-
82
63
val hash : _ string_attr
+91
-83
lib/compiler/test/Test_compiler.ml
+91
-83
lib/compiler/test/Test_compiler.ml
···
11
11
open Testables
12
12
open State.Syntax
13
13
14
-
open struct module T = Types end
14
+
open struct
15
+
module T = Types
16
+
end
15
17
16
18
let config = Config.default ()
17
19
···
24
26
let t6 = {path = "t6.tree"; content = {||}} in
25
27
let t7 = {path = "t7.tree"; content = {||}} in
26
28
let t8 = {path = "t8.tree"; content = {||}} in
27
-
[t1; t2; t3; t4; t5; t6; t7; t8;]
29
+
[t1; t2; t3; t4; t5; t6; t7; t8]
28
30
29
31
let test_batch_run ~env () =
30
32
let forest, history =
31
-
let@ path =
32
-
with_test_forest
33
-
~raw_trees
34
-
~env
35
-
~config
36
-
in
33
+
let@ path = with_test_forest ~raw_trees ~env ~config in
37
34
Sys.chdir (Eio.Path.native_exn path);
38
35
let@ () = Reporter.easy_run in
39
-
let forest = State.make ~env ~config ~dev: false () in
36
+
let forest = State.make ~env ~config ~dev:false () in
40
37
Driver.run_with_history Load_all_configured_dirs forest
41
38
in
42
39
Alcotest.(check @@ list action)
···
51
48
Done;
52
49
]
53
50
history;
54
-
Alcotest.(check @@ int) "no tree is unparsed" 0 (Seq.length (State.get_all_unparsed forest));
55
-
Alcotest.(check @@ int) "no tree is unexpanded" 0 (Seq.length (State.get_all_unexpanded forest));
56
-
Alcotest.(check @@ int) "no tree is unevaluated" 0 (Seq.length (State.get_all_unevaluated forest));
57
-
Alcotest.(check @@ int) "has correct number of articles" 8 (Seq.length (State.get_all_articles forest))
51
+
Alcotest.(check @@ int)
52
+
"no tree is unparsed" 0
53
+
(Seq.length (State.get_all_unparsed forest));
54
+
Alcotest.(check @@ int)
55
+
"no tree is unexpanded" 0
56
+
(Seq.length (State.get_all_unexpanded forest));
57
+
Alcotest.(check @@ int)
58
+
"no tree is unevaluated" 0
59
+
(Seq.length (State.get_all_unevaluated forest));
60
+
Alcotest.(check @@ int)
61
+
"has correct number of articles" 8
62
+
(Seq.length (State.get_all_articles forest))
58
63
59
64
let test_includes_paths ~env () =
60
65
let@ () = Reporter.easy_run in
61
66
let config = Config.default () in
62
67
with_test_forest ~raw_trees ~env ~config (fun path ->
63
-
Sys.chdir (Eio.Path.native_exn path);
64
-
let@ () = Reporter.easy_run in
65
-
let forest, history =
66
-
State.make ~env ~config ~dev: true ()
67
-
|> Driver.run_with_history Load_all_configured_dirs
68
-
in
69
-
Alcotest.(check int) "number of parsed trees" 8 (URI.Tbl.length forest.index);
70
-
Alcotest.(check int) "number of trees in resolver" 8 (URI.Tbl.length forest.resolver);
71
-
Alcotest.(check @@ list action)
72
-
"evaluation succeeded"
73
-
[
74
-
Load_all_configured_dirs;
75
-
Parse_all;
76
-
Build_import_graph;
77
-
Expand_all;
78
-
Eval_all;
79
-
(Run_jobs []);
80
-
Done
81
-
]
82
-
history;
83
-
let uri = (URI.of_string_exn "http://forest.local/t8/") in
84
-
let path =
85
-
match forest.@{uri} with
86
-
| Some (Article {frontmatter = {source_path; _}; _}) ->
87
-
source_path
88
-
| Some _ ->
89
-
Alcotest.fail "not an article"
90
-
| None ->
91
-
URI.Tbl.iter (fun uri _ -> Logs.debug (fun m -> m "%a" URI.pp uri)) forest.index;
92
-
Alcotest.fail "not found"
93
-
in
94
-
Alcotest.(check bool) "path is some" true (Option.is_some path)
95
-
)
68
+
Sys.chdir (Eio.Path.native_exn path);
69
+
let@ () = Reporter.easy_run in
70
+
let forest, history =
71
+
State.make ~env ~config ~dev:true ()
72
+
|> Driver.run_with_history Load_all_configured_dirs
73
+
in
74
+
Alcotest.(check int)
75
+
"number of parsed trees" 8
76
+
(URI.Tbl.length forest.index);
77
+
Alcotest.(check int)
78
+
"number of trees in resolver" 8
79
+
(URI.Tbl.length forest.resolver);
80
+
Alcotest.(check @@ list action)
81
+
"evaluation succeeded"
82
+
[
83
+
Load_all_configured_dirs;
84
+
Parse_all;
85
+
Build_import_graph;
86
+
Expand_all;
87
+
Eval_all;
88
+
Run_jobs [];
89
+
Done;
90
+
]
91
+
history;
92
+
let uri = URI.of_string_exn "http://forest.local/t8/" in
93
+
let path =
94
+
match forest.@{uri} with
95
+
| Some (Article {frontmatter = {source_path; _}; _}) -> source_path
96
+
| Some _ -> Alcotest.fail "not an article"
97
+
| None ->
98
+
URI.Tbl.iter
99
+
(fun uri _ -> Logs.debug (fun m -> m "%a" URI.pp uri))
100
+
forest.index;
101
+
Alcotest.fail "not found"
102
+
in
103
+
Alcotest.(check bool) "path is some" true (Option.is_some path))
96
104
97
105
let test_reparsing ~env () =
98
106
let config = Config.default () in
99
107
let@ tmp_path = with_test_forest ~raw_trees ~env ~config in
100
-
Logs.app (fun m -> m "In temp dir %s" (Unix.realpath @@ Eio.Path.native_exn tmp_path));
108
+
Logs.app (fun m ->
109
+
m "In temp dir %s" (Unix.realpath @@ Eio.Path.native_exn tmp_path));
101
110
let@ () = Reporter.easy_run in
102
111
let forest =
103
-
State.make ~env ~config ~dev: false ()
112
+
State.make ~env ~config ~dev:false ()
104
113
|> Driver.run_until_done Load_all_configured_dirs
105
114
in
106
115
let reparse_addr = "t8.tree" in
107
-
let reparse_uri = URI_scheme.path_to_uri ~base: config.url reparse_addr in
116
+
let reparse_uri = URI_scheme.path_to_uri ~base:config.url reparse_addr in
108
117
let vtx = T.Uri_vertex reparse_uri in
109
118
Alcotest.(check int)
110
-
"Number of vertices before reparsing"
111
-
8
119
+
"Number of vertices before reparsing" 8
112
120
(Forest_graph.nb_vertex forest.import_graph);
113
121
Alcotest.(check int)
114
-
"old vertex has no import"
115
-
0
122
+
"old vertex has no import" 0
116
123
(Forest_graph.in_degree forest.import_graph vtx);
117
124
let _, path =
118
-
Option.get @@
119
-
Seq.find_map
120
-
(fun (uri, path) ->
121
-
if String.ends_with ~suffix: "t8.tree" path then
122
-
begin
123
-
Logs.debug (fun m -> m "%s" path);
124
-
Some (uri, Eio.Path.(forest.env#fs / path))
125
-
end
126
-
else
127
-
None
128
-
)
129
-
(URI.Tbl.to_seq forest.resolver)
125
+
Option.get
126
+
@@ Seq.find_map
127
+
(fun (uri, path) ->
128
+
if String.ends_with ~suffix:"t8.tree" path then begin
129
+
Logs.debug (fun m -> m "%s" path);
130
+
Some (uri, Eio.Path.(forest.env#fs / path))
131
+
end
132
+
else None)
133
+
(URI.Tbl.to_seq forest.resolver)
130
134
in
131
-
Eio.Path.save ~create: (`Or_truncate 0o644) path {|\import{t1}|};
135
+
Eio.Path.save ~create:(`Or_truncate 0o644) path {|\import{t1}|};
132
136
let reparsed = Driver.run_until_done (Load_tree path) forest in
133
-
Alcotest.(check bool) "vertex has an import" true (Forest_graph.in_degree reparsed.import_graph vtx > 0)
137
+
Alcotest.(check bool)
138
+
"vertex has an import" true
139
+
(Forest_graph.in_degree reparsed.import_graph vtx > 0)
134
140
135
141
let test_omits_paths ~env () =
136
142
let@ () = Reporter.easy_run in
137
-
let forest = Driver.batch_run ~env ~config ~dev: false in
143
+
let forest = Driver.batch_run ~env ~config ~dev:false in
138
144
let path =
139
145
match forest.@{URI.of_string_exn "http://forest.local/t8/"} with
140
146
| Some (Article {frontmatter = {source_path; _}; _}) -> source_path
141
-
| Some _ ->
142
-
Alcotest.fail "not an article"
147
+
| Some _ -> Alcotest.fail "not an article"
143
148
| None ->
144
-
URI.Tbl.iter (fun uri _ -> Logs.debug (fun m -> m "%a" URI.pp uri)) forest.index;
149
+
URI.Tbl.iter
150
+
(fun uri _ -> Logs.debug (fun m -> m "%a" URI.pp uri))
151
+
forest.index;
145
152
Alcotest.fail "not found"
146
153
in
147
154
Alcotest.(check bool) "" true @@ Option.is_none path
···
151
158
Logs.set_level (Some Debug);
152
159
Logs.set_reporter (Logs.format_reporter ());
153
160
let open Alcotest in
154
-
run
155
-
"Test_driver"
161
+
run "Test_driver"
156
162
[
157
-
"Steps",
158
-
[
159
-
test_case "Batch compilation steps" `Quick (test_batch_run ~env);
160
-
test_case "reparsing" `Quick (test_reparsing ~env);
161
-
];
162
-
"dev mode",
163
-
[
164
-
test_case "includes paths in dev mode" `Quick (test_includes_paths ~env);
165
-
test_case "omits paths outside dev mode" `Quick (test_omits_paths ~env);
166
-
]
163
+
( "Steps",
164
+
[
165
+
test_case "Batch compilation steps" `Quick (test_batch_run ~env);
166
+
test_case "reparsing" `Quick (test_reparsing ~env);
167
+
] );
168
+
( "dev mode",
169
+
[
170
+
test_case "includes paths in dev mode" `Quick
171
+
(test_includes_paths ~env);
172
+
test_case "omits paths outside dev mode" `Quick
173
+
(test_omits_paths ~env);
174
+
] );
167
175
]
-1
lib/compiler/test/Test_diagnostic_store.ml
-1
lib/compiler/test/Test_diagnostic_store.ml
···
1
-
+23
-35
lib/compiler/test/Test_errors.ml
+23
-35
lib/compiler/test/Test_errors.ml
···
17
17
18
18
let _test_parse_error_explanation src expect =
19
19
Alcotest.(check @@ result code string)
20
-
""
21
-
(Result.Error expect)
22
-
(
23
-
parse_string src
24
-
|> Result.map_error
25
-
(fun d -> Asai.Diagnostic.string_of_text d.explanation.value)
26
-
)
20
+
"" (Result.Error expect)
21
+
(parse_string src
22
+
|> Result.map_error (fun d ->
23
+
Asai.Diagnostic.string_of_text d.explanation.value))
27
24
28
-
let raw_trees = [
29
-
{
30
-
path = "parse_error.tree";
31
-
content = "\\})--aa]jv"
32
-
};
33
-
{
34
-
path = "import_error.tree";
35
-
content = {|\import{nonexistent}|}
36
-
}
37
-
]
25
+
let raw_trees =
26
+
[
27
+
{path = "parse_error.tree"; content = "\\})--aa]jv"};
28
+
{path = "import_error.tree"; content = {|\import{nonexistent}|}};
29
+
]
38
30
39
31
let check_diagnostic expect kont =
40
-
let fatal = fun d ->
41
-
Alcotest.(check message)
42
-
""
43
-
expect
44
-
(d.message)
45
-
in
32
+
let fatal = fun d -> Alcotest.(check message) "" expect d.message in
46
33
let emit = Fun.const () in
47
-
Reporter.run ~fatal ~emit (fun () -> kont (); ())
34
+
Reporter.run ~fatal ~emit (fun () ->
35
+
kont ();
36
+
())
48
37
49
38
let () =
50
39
let@ env = Eio_main.run in
···
52
41
let _test () =
53
42
let@ tmp_dir = with_test_forest ~env ~raw_trees ~config in
54
43
Sys.chdir (Eio.Path.native_exn tmp_dir);
55
-
let@ () = check_diagnostic (Resource_not_found (URI.of_string_exn "asdf")) in
44
+
let@ () =
45
+
check_diagnostic (Resource_not_found (URI.of_string_exn "asdf"))
46
+
in
56
47
let@ () = Reporter.easy_run in
57
-
let forest = Driver.batch_run ~env ~config ~dev: false in
48
+
let forest = Driver.batch_run ~env ~config ~dev:false in
58
49
Alcotest.(check @@ list action)
59
50
""
60
51
[
···
63
54
Build_import_graph;
64
55
Expand_all;
65
56
Eval_all;
66
-
(Run_jobs []);
67
-
Done
57
+
Run_jobs [];
58
+
Done;
68
59
]
69
60
(List.rev forest.history);
70
-
Alcotest.(check int) "" 1 (URI.Tbl.length forest.diagnostics);
61
+
Alcotest.(check int) "" 1 (URI.Tbl.length forest.diagnostics)
71
62
in
72
63
let open Alcotest in
73
-
run
74
-
"verify error reporting"
75
-
[
76
-
(* "parsing", *)
64
+
run "verify error reporting"
65
+
[ (* "parsing", *)
77
66
(* [ *)
78
67
(* test_case "nonexistent tree" `Quick test; *)
79
68
(* ]; *)
···
84
73
(* [ *)
85
74
(* ]; *)
86
75
(* "driver", *)
87
-
(* []; *)
88
-
]
76
+
(* []; *) ]
+37
-41
lib/compiler/test/Test_expansion.ml
+37
-41
lib/compiler/test/Test_expansion.ml
···
12
12
open Forester_frontend
13
13
open Testables
14
14
15
-
open struct module T = Types end
15
+
open struct
16
+
module T = Types
17
+
end
16
18
17
19
open struct
18
20
module S = Resolver.Scope
19
21
module P = Resolver.P
22
+
20
23
let config = Config.default ()
21
-
let _data = Alcotest.testable Syn.pp_resolver_data (=)
24
+
let _data = Alcotest.testable Syn.pp_resolver_data ( = )
22
25
end
23
26
24
27
open State.Syntax
25
28
26
29
let expand ~forest src =
27
30
let@ code = Result.map @~ parse_string_no_loc src in
28
-
S.run ~init_visible: Expand.initial_visible_trie @@ fun () ->
31
+
S.run ~init_visible:Expand.initial_visible_trie @@ fun () ->
29
32
Expand.expand ~forest code
30
33
31
34
let render ~forest expanded =
32
35
Result.map
33
36
(fun expanded ->
34
37
let Eval.{articles; _}, _ =
35
-
Eval.eval_tree
36
-
~config: (Config.default ())
37
-
~uri: (URI.of_string_exn "http://localhost/test")
38
-
~source_path: None
39
-
expanded
38
+
Eval.eval_tree ~config:(Config.default ())
39
+
~uri:(URI.of_string_exn "http://localhost/test")
40
+
~source_path:None expanded
40
41
in
41
42
let () =
42
43
List.iter
43
44
(fun article ->
44
45
let@ uri = Option.iter @~ T.(article.frontmatter.uri) in
45
-
forest.={uri} <- Resource {resource = Article article; expanded = None; route_locally = true; include_in_manifest = true}
46
-
)
46
+
forest.={uri} <-
47
+
Resource
48
+
{
49
+
resource = Article article;
50
+
expanded = None;
51
+
route_locally = true;
52
+
include_in_manifest = true;
53
+
})
47
54
articles
48
55
in
49
56
let rendered =
50
57
List.map
51
58
(fun article ->
52
-
Plain_text_client.string_of_content ~forest T.(article.mainmatter)
53
-
)
59
+
Plain_text_client.string_of_content ~forest T.(article.mainmatter))
54
60
articles
55
61
in
56
-
String.concat "" rendered
57
-
)
62
+
String.concat "" rendered)
58
63
expanded
59
64
60
65
let test_subtree ~env () =
61
66
let@ () = Reporter.easy_run in
62
-
let forest = State.make ~env ~config ~dev: false () in
67
+
let forest = State.make ~env ~config ~dev:false () in
63
68
let expanded =
64
-
expand
65
-
~forest
69
+
expand ~forest
66
70
{|
67
71
\subtree[foo]{
68
72
\title{Hello}
···
72
76
in
73
77
let evaluated = render ~forest expanded in
74
78
Alcotest.(check @@ result string diagnostic)
75
-
""
76
-
(
77
-
Ok
78
-
{|<omitted content: Hello>|}
79
-
)
80
-
evaluated
79
+
"" (Ok {|<omitted content: Hello>|}) evaluated
81
80
82
81
let test_visible ~env () =
83
-
let forest = State.make ~env ~config ~dev: false () in
82
+
let forest = State.make ~env ~config ~dev:false () in
84
83
let code =
85
-
Result.get_ok @@
86
-
parse_string
87
-
{|
84
+
Result.get_ok
85
+
@@ parse_string {|
88
86
\def\greet[name]{Hello, \name!}
89
87
\p{\greet{Jon}}
90
88
|}
91
89
in
92
90
let result =
93
-
Trie.to_seq @@
94
-
Analysis.get_visible ~forest ~position: {line = 2; character = 5;} code
91
+
Trie.to_seq
92
+
@@ Analysis.get_visible ~forest ~position:{line = 2; character = 5} code
95
93
in
96
94
let greet =
97
-
let@ (path, _) = Option.map @~ Seq.find (fun (p, _) -> p = ["greet"]) result in
95
+
let@ path, _ =
96
+
Option.map @~ Seq.find (fun (p, _) -> p = ["greet"]) result
97
+
in
98
98
path
99
99
in
100
-
Alcotest.(check (option path))
101
-
"greet is visible"
102
-
(Some (["greet"]))
103
-
greet
100
+
Alcotest.(check (option path)) "greet is visible" (Some ["greet"]) greet
104
101
105
102
let () =
106
103
Logs.set_level (Some Debug);
107
104
Logs.set_reporter (Logs.format_reporter ());
108
105
let open Alcotest in
109
106
let@ env = Eio_main.run in
110
-
run
111
-
"Test_expansion"
107
+
run "Test_expansion"
112
108
[
113
-
"",
114
-
[
115
-
test_case "subtree" `Quick (test_subtree ~env);
116
-
test_case "get_visible" `Quick (test_visible ~env);
117
-
]
109
+
( "",
110
+
[
111
+
test_case "subtree" `Quick (test_subtree ~env);
112
+
test_case "get_visible" `Quick (test_visible ~env);
113
+
] );
118
114
]
+50
-70
lib/compiler/test/Test_import_graph.ml
+50
-70
lib/compiler/test/Test_import_graph.ml
···
10
10
open Forester_test
11
11
open Testables
12
12
13
-
open struct module T = Types end
13
+
open struct
14
+
module T = Types
15
+
end
14
16
15
17
let config = {(Config.default ()) with trees = ["imports"]}
16
-
17
-
let mk_vertex v = T.Uri_vertex (URI_scheme.named_uri ~base: config.url v)
18
-
19
-
let has_edge g v w =
20
-
Forest_graph.mem_edge g (mk_vertex v) (mk_vertex w)
18
+
let mk_vertex v = T.Uri_vertex (URI_scheme.named_uri ~base:config.url v)
19
+
let has_edge g v w = Forest_graph.mem_edge g (mk_vertex v) (mk_vertex w)
21
20
22
21
(*
23
-
┌─1
24
-
│ ┌─4
25
-
│ ├─5
26
-
├─2─┬─3─┼─6
27
-
index─┤ │ └─7
28
-
│ └─8
29
-
├─9
30
-
└─10
22
+
┌─1 │ ┌─4 │ ├─5 ├─2─┬─3─┼─6 index─┤ │ └─7 │ └─8 ├─9 └─10
31
23
*)
32
24
33
-
let raw_trees = [
34
-
{
35
-
path = "index.tree";
36
-
content = {|
25
+
let raw_trees =
26
+
[
27
+
{
28
+
path = "index.tree";
29
+
content =
30
+
{|
37
31
\import{1}
38
32
\import{2}
39
33
\import{9}
40
34
\import{10}
41
-
|}
42
-
};
43
-
{
44
-
path = "1.tree";
45
-
content = {||}
46
-
};
47
-
{
48
-
path = "2.tree";
49
-
content = {|
35
+
|};
36
+
};
37
+
{path = "1.tree"; content = {||}};
38
+
{path = "2.tree"; content = {|
50
39
\import{3}
51
40
\import{8}
52
-
|}
53
-
};
54
-
{
55
-
path = "3.tree";
56
-
content = {|
41
+
|}};
42
+
{
43
+
path = "3.tree";
44
+
content =
45
+
{|
57
46
\import{4}
58
47
\import{5}
59
48
\import{6}
60
49
\import{7}
61
-
|}
62
-
};
63
-
{path = "4.tree"; content = {||}};
64
-
{path = "5.tree"; content = {||}};
65
-
{path = "6.tree"; content = {||}};
66
-
{path = "7.tree"; content = {||}};
67
-
{path = "8.tree"; content = {||}};
68
-
{path = "9.tree"; content = {||}};
69
-
{path = "10.tree"; content = {||}};
70
-
{path = "11.tree"; content = {||}};
71
-
{path = "12.tree"; content = {||}};
72
-
]
50
+
|};
51
+
};
52
+
{path = "4.tree"; content = {||}};
53
+
{path = "5.tree"; content = {||}};
54
+
{path = "6.tree"; content = {||}};
55
+
{path = "7.tree"; content = {||}};
56
+
{path = "8.tree"; content = {||}};
57
+
{path = "9.tree"; content = {||}};
58
+
{path = "10.tree"; content = {||}};
59
+
{path = "11.tree"; content = {||}};
60
+
{path = "12.tree"; content = {||}};
61
+
]
73
62
74
63
let test_import_graph ~env () =
75
64
let@ () = Reporter.easy_run in
76
65
let@ tmp_dir = with_test_forest ~env ~config ~raw_trees in
77
66
Sys.chdir (Eio.Path.native_exn tmp_dir);
78
67
let forest, history =
79
-
State.make ~env ~config ~dev: false ()
68
+
State.make ~env ~config ~dev:false ()
80
69
|> Driver.run_with_history Load_all_configured_dirs
81
70
in
82
71
Alcotest.(check @@ list action)
···
87
76
Build_import_graph;
88
77
Expand_all;
89
78
Eval_all;
90
-
(Run_jobs []);
91
-
Done
79
+
Run_jobs [];
80
+
Done;
92
81
]
93
82
history;
94
83
(* Alcotest.(check int) *)
···
96
85
(* (Hashtbl.length forest.documents) *)
97
86
(* (Forest.length forest.parsed); *)
98
87
Alcotest.(check bool)
99
-
"has some edges"
100
-
true
101
-
(
102
-
List.for_all
103
-
Fun.id
104
-
[
105
-
List.for_all
106
-
(fun v -> has_edge forest.import_graph v "3")
107
-
[
108
-
"4";
109
-
"5";
110
-
"6";
111
-
"7";
112
-
];
113
-
has_edge forest.import_graph "2" "index";
114
-
]
115
-
)
88
+
"has some edges" true
89
+
(List.for_all Fun.id
90
+
[
91
+
List.for_all
92
+
(fun v -> has_edge forest.import_graph v "3")
93
+
["4"; "5"; "6"; "7"];
94
+
has_edge forest.import_graph "2" "index";
95
+
])
116
96
117
97
let () =
118
98
let@ env = Eio_main.run in
119
99
Logs.set_level (Some Debug);
120
100
Logs.set_reporter (Logs_fmt.reporter ());
121
101
let open Alcotest in
122
-
run
123
-
"Import_graph"
102
+
run "Import_graph"
124
103
[
125
-
"creating import graph",
126
-
[
127
-
test_case "parsing and creating the import graph" `Quick (test_import_graph ~env);
128
-
];
104
+
( "creating import graph",
105
+
[
106
+
test_case "parsing and creating the import graph" `Quick
107
+
(test_import_graph ~env);
108
+
] );
129
109
]
+5
-8
lib/compiler/test/Test_incremental_compilation.ml
+5
-8
lib/compiler/test/Test_incremental_compilation.ml
···
9
9
open Forester_prelude
10
10
open Forester_frontend
11
11
12
-
open struct module T = Types end
12
+
open struct
13
+
module T = Types
14
+
end
13
15
14
16
let () =
15
17
let@ env = Eio_main.run in
16
18
let open Alcotest in
17
-
run
18
-
"Test_incremental_compilation"
19
-
[
20
-
"",
21
-
[]
22
-
(* [test_case "separate" `Quick test_separate] *)
23
-
]
19
+
run "Test_incremental_compilation"
20
+
[("", []) (* [test_case "separate" `Quick test_separate] *)]
+3
-11
lib/compiler/test/Test_uri_util.ml
+3
-11
lib/compiler/test/Test_uri_util.ml
···
8
8
9
9
let test_baseN () =
10
10
Alcotest.(check @@ option int)
11
-
""
12
-
(Some 460198)
11
+
"" (Some 460198)
13
12
(BaseN.Base36.int_of_string "9V3A");
14
-
Alcotest.(check string)
15
-
""
16
-
"9V3A"
17
-
(BaseN.Base36.string_of_int 460198)
13
+
Alcotest.(check string) "" "9V3A" (BaseN.Base36.string_of_int 460198)
18
14
19
15
let () =
20
16
let open Alcotest in
21
-
run
22
-
"URI_util"
23
-
[
24
-
"BaseN", [test_case "" `Quick test_baseN];
25
-
]
17
+
run "URI_util" [("BaseN", [test_case "" `Quick test_baseN])]
+16
-39
lib/core/Base.ml
+16
-39
lib/core/Base.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
type eval_mode =
8
-
| Text_mode
9
-
| TeX_mode
10
-
[@@deriving show, repr]
11
-
12
-
type binding_info =
13
-
| Strict
14
-
| Lazy
15
-
[@@deriving show, repr]
16
-
17
-
type 'a binding = binding_info * 'a
18
-
[@@deriving show, repr]
19
-
20
-
type delim =
21
-
Braces | Squares | Parens
22
-
[@@deriving show, repr]
7
+
type eval_mode = Text_mode | TeX_mode [@@deriving show, repr]
8
+
type binding_info = Strict | Lazy [@@deriving show, repr]
9
+
type 'a binding = binding_info * 'a [@@deriving show, repr]
10
+
type delim = Braces | Squares | Parens [@@deriving show, repr]
23
11
24
12
let delim_to_strings = function
25
-
| Braces -> "{", "}"
26
-
| Squares -> "[", "]"
27
-
| Parens -> "(", ")"
13
+
| Braces -> ("{", "}")
14
+
| Squares -> ("[", "]")
15
+
| Parens -> ("(", ")")
28
16
29
-
type math_mode =
30
-
| Inline
31
-
| Display
32
-
[@@deriving show, repr]
33
-
34
-
type visibility =
35
-
Private | Public
36
-
[@@deriving show, repr]
17
+
type math_mode = Inline | Display [@@deriving show, repr]
18
+
type visibility = Private | Public [@@deriving show, repr]
19
+
type identity = Anonymous | URI of URI.t [@@deriving show]
37
20
38
-
type identity =
39
-
| Anonymous
40
-
| URI of URI.t
41
-
[@@deriving show]
42
-
43
-
let identity_to_uri = function
44
-
| URI uri -> Some uri
45
-
| Anonymous -> None
21
+
let identity_to_uri = function URI uri -> Some uri | Anonymous -> None
46
22
47
23
type origin =
48
24
| Physical of
49
-
(Lsp.Text_document.t [@printer fun ppf doc ->
50
-
Format.pp_print_string
51
-
ppf
52
-
(Lsp.(Uri.to_path @@ Text_document.documentUri doc))])
25
+
(Lsp.Text_document.t
26
+
[@printer
27
+
fun ppf doc ->
28
+
Format.pp_print_string ppf
29
+
Lsp.(Uri.to_path @@ Text_document.documentUri doc)])
53
30
| Subtree of {parent: identity}
54
31
| Undefined
55
32
[@@deriving show]
+12
-24
lib/core/Base.mli
+12
-24
lib/core/Base.mli
···
6
6
7
7
(** {1 Base} *)
8
8
9
-
type eval_mode =
10
-
| Text_mode
11
-
| TeX_mode
12
-
[@@deriving show, repr]
13
-
14
-
type binding_info =
15
-
| Strict
16
-
| Lazy
17
-
[@@deriving show, repr]
9
+
type eval_mode = Text_mode | TeX_mode [@@deriving show, repr]
10
+
type binding_info = Strict | Lazy [@@deriving show, repr]
18
11
19
12
(** {2 Delimiters} *)
20
13
21
14
type delim = Braces | Squares | Parens
22
-
val pp_delim :
23
-
Format.formatter -> delim -> unit
15
+
16
+
val pp_delim : Format.formatter -> delim -> unit
24
17
val show_delim : delim -> string
25
18
val delim_t : delim Repr.t
26
19
val delim_to_strings : delim -> string * string
27
20
21
+
type 'a binding = binding_info * 'a [@@deriving show, repr]
28
22
(** {2 Variable binding} *)
29
-
type 'a binding = binding_info * 'a
30
-
[@@deriving show, repr]
31
23
32
24
(** {2 Math modes} *)
33
25
34
26
type math_mode = Inline | Display
35
27
36
-
val pp_math_mode :
37
-
Format.formatter ->
38
-
math_mode ->
39
-
unit
40
-
28
+
val pp_math_mode : Format.formatter -> math_mode -> unit
41
29
val show_math_mode : math_mode -> string
42
-
43
30
val math_mode_t : math_mode Repr.t
44
31
45
32
(** {2 Import visibility} *)
46
33
47
34
type visibility = Private | Public
48
35
49
-
val pp_visibility :
50
-
Format.formatter ->
51
-
visibility ->
52
-
unit
36
+
val pp_visibility : Format.formatter -> visibility -> unit
53
37
val show_visibility : visibility -> string
38
+
54
39
type identity = Anonymous | URI of URI.t
40
+
55
41
val pp_identity : Format.formatter -> identity -> unit
56
42
val show_identity : identity -> string
57
43
val identity_to_uri : identity -> URI.t option
44
+
58
45
type origin =
59
46
| Physical of Lsp.Text_document.t
60
-
| Subtree of {parent: identity;}
47
+
| Subtree of {parent: identity}
61
48
| Undefined
49
+
62
50
val pp_origin : Format.formatter -> origin -> unit
63
51
val show_origin : origin -> string
64
52
val visibility_t : visibility Repr.t
+46
-38
lib/core/Builtin_queries.ml
+46
-38
lib/core/Builtin_queries.ml
···
9
9
let context_datalog vtx : _ Dx.query =
10
10
let open Dx.Notation in
11
11
let x = "X" in
12
-
Dx.{
13
-
var = x;
14
-
positives = [Builtin_relation.transcludes @* [var x; const vtx]];
15
-
negatives = []
16
-
}
12
+
Dx.
13
+
{
14
+
var = x;
15
+
positives = [Builtin_relation.transcludes @* [var x; const vtx]];
16
+
negatives = [];
17
+
}
17
18
18
19
let children_datalog vtx : _ Dx.query =
19
20
let open Dx.Notation in
20
21
let x = "X" in
21
-
Dx.{
22
-
var = x;
23
-
positives = [Builtin_relation.transcludes @* [const vtx; var x]];
24
-
negatives = []
25
-
}
22
+
Dx.
23
+
{
24
+
var = x;
25
+
positives = [Builtin_relation.transcludes @* [const vtx; var x]];
26
+
negatives = [];
27
+
}
26
28
27
29
let backlinks_datalog vtx : _ Dx.query =
28
30
let open Dx.Notation in
29
31
let x = "X" in
30
-
Dx.{
31
-
var = x;
32
-
positives = [Builtin_relation.links_to @* [var x; const vtx]];
33
-
negatives = []
34
-
}
32
+
Dx.
33
+
{
34
+
var = x;
35
+
positives = [Builtin_relation.links_to @* [var x; const vtx]];
36
+
negatives = [];
37
+
}
35
38
36
39
let fwdlinks_datalog vtx : _ Dx.query =
37
40
let open Dx.Notation in
38
41
let x = "X" in
39
-
Dx.{
40
-
var = x;
41
-
positives = [Builtin_relation.links_to @* [const vtx; var x]];
42
-
negatives = []
43
-
}
42
+
Dx.
43
+
{
44
+
var = x;
45
+
positives = [Builtin_relation.links_to @* [const vtx; var x]];
46
+
negatives = [];
47
+
}
44
48
45
49
let related_datalog vtx : _ Dx.query =
46
50
let open Dx.Notation in
47
51
let x = "X" in
48
-
Dx.{
49
-
var = x;
50
-
positives = [Builtin_relation.links_to @* [const vtx; var x]];
51
-
negatives = [Builtin_relation.is_reference @* [var x]]
52
-
}
52
+
Dx.
53
+
{
54
+
var = x;
55
+
positives = [Builtin_relation.links_to @* [const vtx; var x]];
56
+
negatives = [Builtin_relation.is_reference @* [var x]];
57
+
}
53
58
54
59
let contributions_datalog vtx : _ Dx.query =
55
60
let open Dx.Notation in
56
61
let x = "X" in
57
-
Dx.{
58
-
var = x;
59
-
positives = [
60
-
Builtin_relation.has_direct_contributor @* [var x; const vtx];
61
-
Builtin_relation.is_reference @* [var x]
62
-
];
63
-
negatives = []
64
-
}
62
+
Dx.
63
+
{
64
+
var = x;
65
+
positives =
66
+
[
67
+
Builtin_relation.has_direct_contributor @* [var x; const vtx];
68
+
Builtin_relation.is_reference @* [var x];
69
+
];
70
+
negatives = [];
71
+
}
65
72
66
73
let references_datalog vtx : _ Datalog_expr.query =
67
74
let open Dx.Notation in
68
75
let x = "X" in
69
-
Dx.{
70
-
var = x;
71
-
positives = [Builtin_relation.references @* [const vtx; var x]];
72
-
negatives = []
73
-
}
76
+
Dx.
77
+
{
78
+
var = x;
79
+
positives = [Builtin_relation.references @* [const vtx; var x]];
80
+
negatives = [];
81
+
}
+24
-19
lib/core/Builtin_relation.ml
+24
-19
lib/core/Builtin_relation.ml
···
5
5
*)
6
6
7
7
let make_builtin name = "org.forester.rel." ^ name
8
-
9
8
let links_to = make_builtin "links-to"
10
9
let transcludes = make_builtin "transcludes"
11
10
let has_author = make_builtin "authored-by"
···
15
14
let is_asset = make_builtin "is-asset"
16
15
let is_article = make_builtin "is-article"
17
16
let in_host = make_builtin "in-host"
18
-
19
17
let transcludes_rtc = make_builtin "transcludes.reflexive-transitive-closure"
20
18
let transcludes_tc = make_builtin "transcludes.transitive-closure"
21
19
let references = make_builtin "references"
22
20
let is_reference = make_builtin "is-reference"
23
21
let is_person = make_builtin "is-person"
24
-
25
22
let has_direct_contributor = make_builtin "has-direct-contributor"
26
23
let has_indirect_contributor = make_builtin "has-indirect-contributor"
27
24
···
34
31
let person_taxon : Vertex.t Dx.term =
35
32
Const (Content_vertex (Content [Text "Person"]))
36
33
37
-
let axioms : _ Dx.script = [
38
-
is_reference @* [var "X"] << [has_taxon @* [var "X"; reference_taxon]];
39
-
is_person @* [var "X"] << [has_taxon @* [var "X"; person_taxon]];
40
-
transcludes_tc @* [var "X"; var "Y"] << [transcludes @* [var "X"; var "Y"]];
41
-
transcludes_tc @* [var "X"; var "Z"] << [transcludes_tc @* [var "X"; var "Y"]; transcludes @* [var "Y"; var "Z"]];
42
-
transcludes_rtc @* [var "X"; var "X"] << [is_node @* [var "X"]];
43
-
transcludes_rtc @* [var "X"; var "Y"] << [transcludes_tc @* [var "X"; var "Y"]];
44
-
references @* [var "X"; var "Z"]
45
-
<< [
46
-
transcludes_rtc @* [var "X"; var "Y"];
47
-
links_to @* [var "Y"; var "Z"];
48
-
is_reference @* [var "Z"]
49
-
];
50
-
has_direct_contributor @* [var "X"; var "Y"] << [has_author @* [var "X"; var "Y"]];
51
-
has_indirect_contributor @* [var "X"; var "Z"] << [transcludes_rtc @* [var "X"; var "Y"]; has_direct_contributor @* [var "Y"; var "Z"]];
52
-
]
34
+
let axioms : _ Dx.script =
35
+
[
36
+
is_reference @* [var "X"] << [has_taxon @* [var "X"; reference_taxon]];
37
+
is_person @* [var "X"] << [has_taxon @* [var "X"; person_taxon]];
38
+
transcludes_tc @* [var "X"; var "Y"] << [transcludes @* [var "X"; var "Y"]];
39
+
transcludes_tc @* [var "X"; var "Z"]
40
+
<< [transcludes_tc @* [var "X"; var "Y"]; transcludes @* [var "Y"; var "Z"]];
41
+
transcludes_rtc @* [var "X"; var "X"] << [is_node @* [var "X"]];
42
+
transcludes_rtc @* [var "X"; var "Y"]
43
+
<< [transcludes_tc @* [var "X"; var "Y"]];
44
+
references @* [var "X"; var "Z"]
45
+
<< [
46
+
transcludes_rtc @* [var "X"; var "Y"];
47
+
links_to @* [var "Y"; var "Z"];
48
+
is_reference @* [var "Z"];
49
+
];
50
+
has_direct_contributor @* [var "X"; var "Y"]
51
+
<< [has_author @* [var "X"; var "Y"]];
52
+
has_indirect_contributor @* [var "X"; var "Z"]
53
+
<< [
54
+
transcludes_rtc @* [var "X"; var "Y"];
55
+
has_direct_contributor @* [var "Y"; var "Z"];
56
+
];
57
+
]
+27
-40
lib/core/Code.ml
+27
-40
lib/core/Code.ml
···
6
6
7
7
open Base
8
8
9
-
open struct module T = Types end
9
+
open struct
10
+
module T = Types
11
+
end
10
12
11
-
type 'a _object = {
12
-
self: string option;
13
-
methods: (string * 'a) list
14
-
}
13
+
type 'a _object = {self: string option; methods: (string * 'a) list}
15
14
[@@deriving show, repr]
16
15
17
16
type 'a patch = {
18
17
obj: 'a;
19
18
self: string option;
20
19
super: string option;
21
-
methods: (string * 'a) list
20
+
methods: (string * 'a) list;
22
21
}
23
22
[@@deriving show, repr]
24
23
···
56
55
| Error of string
57
56
[@@deriving show, repr]
58
57
59
-
and t = node Range.located list
60
-
[@@deriving show, repr]
58
+
and t = node Range.located list [@@deriving show, repr]
61
59
62
60
type tree = {
63
61
source_path: string option;
64
62
uri: URI.t option;
65
63
timestamp: float option;
66
-
code: t
64
+
code: t;
67
65
}
68
66
[@@deriving show, repr]
69
67
70
68
let import_private x = Import (Private, x)
71
69
let import_public x = Import (Public, x)
72
-
73
70
let inline_math e = Math (Inline, e)
74
71
let display_math e = Math (Display, e)
75
72
let parens e = Group (Parens, e)
···
94
91
| Put (p, t) -> Put (p, f t)
95
92
| Fun (b, t) -> Fun (b, f t)
96
93
| Call (t, s) -> Call (f t, s)
97
-
| Object {self; methods} -> Object {self; methods = List.map (fun (s, t) -> (s, f t)) methods}
98
-
| Patch {obj; self; super; methods} -> Patch {obj = f obj; self; super; methods = List.map (fun (s, t) -> (s, f t)) methods}
99
-
| Text _
100
-
| Verbatim _
101
-
| Ident _
102
-
| Hash_ident _
94
+
| Object {self; methods} ->
95
+
Object {self; methods = List.map (fun (s, t) -> (s, f t)) methods}
96
+
| Patch {obj; self; super; methods} ->
97
+
Patch
98
+
{
99
+
obj = f obj;
100
+
self;
101
+
super;
102
+
methods = List.map (fun (s, t) -> (s, f t)) methods;
103
+
}
104
+
| Text _ | Verbatim _ | Ident _ | Hash_ident _
103
105
| Xml_ident (_, _)
104
-
| Open _
105
-
| Get _
106
+
| Open _ | Get _
106
107
| Import (_, _)
107
108
| Decl_xmlns (_, _)
108
-
| Alloc _
109
-
| Dx_var _
110
-
| Comment _
111
-
| Error _ ->
109
+
| Alloc _ | Dx_var _ | Comment _ | Error _ ->
112
110
node
113
111
114
112
let children (node : node Range.located) =
···
127
125
| Call (t, _)
128
126
| Subtree (_, t) ->
129
127
t
130
-
| Dx_prop (_, t)
131
-
| Dx_query (_, _, t)
132
-
| Dx_sequent (_, t) ->
133
-
(List.concat t)
134
-
| Object {methods; _} ->
135
-
(methods |> List.map snd |> List.concat)
128
+
| Dx_prop (_, t) | Dx_query (_, _, t) | Dx_sequent (_, t) -> List.concat t
129
+
| Object {methods; _} -> methods |> List.map snd |> List.concat
136
130
| Patch {obj; methods; _} ->
137
-
let methods = (methods |> List.map snd |> List.concat) in
138
-
(List.append obj methods)
139
-
| Text _
140
-
| Verbatim _
141
-
| Ident _
142
-
| Hash_ident _
131
+
let methods = methods |> List.map snd |> List.concat in
132
+
List.append obj methods
133
+
| Text _ | Verbatim _ | Ident _ | Hash_ident _
143
134
| Xml_ident (_, _)
144
-
| Open _
145
-
| Get _
135
+
| Open _ | Get _
146
136
| Import (_, _)
147
137
| Decl_xmlns (_, _)
148
-
| Alloc _
149
-
| Dx_var _
150
-
| Comment _
151
-
| Error _ ->
138
+
| Alloc _ | Dx_var _ | Comment _ | Error _ ->
152
139
[]
+3
-16
lib/core/Code.mli
+3
-16
lib/core/Code.mli
···
5
5
*)
6
6
7
7
open Base
8
-
9
8
module T := Types
10
9
11
10
type node =
···
17
16
| Hash_ident of string
18
17
| Xml_ident of string option * string
19
18
| Subtree of string option * t
20
-
| Let of
21
-
Trie.path
22
-
* string binding list
23
-
* t
19
+
| Let of Trie.path * string binding list * t
24
20
| Open of Trie.path
25
21
| Scope of t
26
22
| Put of Trie.path * t
···
31
27
| Patch of t patch
32
28
| Call of t * string
33
29
| Import of visibility * string
34
-
| Def of
35
-
Trie.path
36
-
* string binding list
37
-
* t
30
+
| Def of Trie.path * string binding list * t
38
31
| Decl_xmlns of string * string
39
32
| Alloc of Trie.path
40
33
| Namespace of Trie.path * t
···
49
42
[@@deriving show]
50
43
51
44
and t = node Range.located list
52
-
53
-
and 'a _object = {
54
-
self: string option;
55
-
methods: (string * 'a) list;
56
-
}
45
+
and 'a _object = {self: string option; methods: (string * 'a) list}
57
46
58
47
and 'a patch = {
59
48
obj: 'a;
···
76
65
val parens : t -> node
77
66
val squares : t -> node
78
67
val braces : t -> node
79
-
80
68
val import_private : string -> node
81
69
val import_public : string -> node
82
70
val inline_math : t -> node
83
71
val display_math : t -> node
84
-
85
72
val map : (t -> t) -> node -> node
86
73
val children : node Range.located -> t
+9
-12
lib/core/Config.ml
+9
-12
lib/core/Config.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
type foreign = {
8
-
path: string;
9
-
route_locally: bool;
10
-
include_in_manifest: bool
11
-
}
7
+
type foreign = {path: string; route_locally: bool; include_in_manifest: bool}
12
8
[@@deriving show, repr]
13
9
14
10
type t = {
···
22
18
23
19
let default_url = URI.of_string_exn "http://forest.local/"
24
20
25
-
let default ?(url = default_url) () : t = {
26
-
trees = ["trees"];
27
-
assets = [];
28
-
foreign = [];
29
-
url;
30
-
home = URI_scheme.named_uri ~base: url "index";
31
-
}
21
+
let default ?(url = default_url) () : t =
22
+
{
23
+
trees = ["trees"];
24
+
assets = [];
25
+
foreign = [];
26
+
url;
27
+
home = URI_scheme.named_uri ~base:url "index";
28
+
}
32
29
33
30
let home_uri config = config.home
+2
-6
lib/core/Config.mli
+2
-6
lib/core/Config.mli
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
type foreign = {
8
-
path: string;
9
-
route_locally: bool;
10
-
include_in_manifest: bool
11
-
}
7
+
type foreign = {path: string; route_locally: bool; include_in_manifest: bool}
12
8
[@@deriving show]
13
9
14
10
type t = {
···
21
17
[@@deriving show]
22
18
23
19
val default_url : URI.t
24
-
val default : ?url: URI.t -> unit -> t
20
+
val default : ?url:URI.t -> unit -> t
25
21
val home_uri : t -> URI.t
+5
-6
lib/core/Datalog_engine.ml
+5
-6
lib/core/Datalog_engine.ml
···
6
6
7
7
module V = struct
8
8
include Vertex
9
+
9
10
let to_string = show
10
11
end
11
12
12
-
module S = Datalog.BottomUp.Hashcons(V)
13
+
module S = Datalog.BottomUp.Hashcons (V)
13
14
14
15
open struct
15
16
module T = Types
16
-
module D = Datalog.BottomUp.Make(S)
17
+
module D = Datalog.BottomUp.Make (S)
17
18
end
18
19
19
20
type relation = string
···
28
29
S.make vtx
29
30
30
31
let pack_vertex vtx : D.symbol = S.make vtx
31
-
32
32
let var_of_string = String.hash
33
-
34
33
let mk_var = D.mk_var
35
34
let mk_const vtx = D.mk_const (pack_vertex vtx)
36
35
let mk_literal rel = D.mk_literal (symbol_of_string rel)
···
41
40
| _ -> failwith "const_of_term: unexpected variable"
42
41
43
42
type db = D.db
43
+
44
44
let db_create = D.db_create
45
45
let db_add_fact db lit = D.db_add_fact db lit
46
46
let db_add db clause = D.db_add db clause
···
48
48
type answers = D.Query.set
49
49
50
50
let list_of_answers answers =
51
-
List.map (Array.map vertex_of_term) @@
52
-
D.Query.to_list answers
51
+
List.map (Array.map vertex_of_term) @@ D.Query.to_list answers
53
52
54
53
let ask = D.Query.ask
+4
-3
lib/core/Datalog_engine.mli
+4
-3
lib/core/Datalog_engine.mli
···
9
9
type term
10
10
type literal
11
11
type clause
12
-
13
12
type var
13
+
14
14
val var_of_string : string -> var
15
-
16
15
val mk_var : var -> term
17
16
val mk_const : vertex -> term
18
17
val mk_literal : relation -> term list -> literal
19
18
val mk_clause : literal -> literal list -> clause
20
19
21
20
type db
21
+
22
22
val db_create : unit -> db
23
23
val db_add_fact : db -> literal -> unit
24
24
val db_add : db -> clause -> unit
25
25
26
26
type answers
27
+
27
28
val list_of_answers : answers -> vertex array list
28
-
val ask : db -> ?neg: literal list -> var array -> literal list -> answers
29
+
val ask : db -> ?neg:literal list -> var array -> literal list -> answers
+10
-18
lib/core/Datalog_eval.ml
+10
-18
lib/core/Datalog_eval.ml
···
5
5
*)
6
6
7
7
open Forester_prelude
8
-
9
8
module Dx = Datalog_expr
10
9
module D = Datalog_engine
11
10
12
-
let eval_var (var : Dx.var) =
13
-
D.mk_var (D.var_of_string var)
14
-
15
-
let eval_const (vtx : Vertex.t) =
16
-
D.mk_const vtx
11
+
let eval_var (var : Dx.var) = D.mk_var (D.var_of_string var)
12
+
let eval_const (vtx : Vertex.t) = D.mk_const vtx
17
13
18
14
let eval_term : _ Dx.term -> D.term = function
19
15
| Dx.Var var -> eval_var var
···
26
22
let eval_premises = List.map eval_prop
27
23
28
24
let eval_sequent (sequent : _ Dx.sequent) : D.clause =
29
-
D.mk_clause (eval_prop sequent.conclusion) @@
30
-
eval_premises sequent.premises
25
+
D.mk_clause (eval_prop sequent.conclusion) @@ eval_premises sequent.premises
31
26
32
-
let eval_script : _ Dx.script -> D.clause list =
33
-
List.map eval_sequent
27
+
let eval_script : _ Dx.script -> D.clause list = List.map eval_sequent
34
28
35
29
let run_query (db : D.db) (query : (string, Vertex.t) Dx.query) : Vertex_set.t =
36
30
let answers =
37
-
D.ask
38
-
db
39
-
~neg: (eval_premises query.negatives)
40
-
[|D.var_of_string query.var|] @@
41
-
eval_premises query.positives
31
+
D.ask db ~neg:(eval_premises query.negatives) [|D.var_of_string query.var|]
32
+
@@ eval_premises query.positives
42
33
in
43
-
Vertex_set.of_list @@
44
-
let@ answer = List.map @~ D.list_of_answers answers in
45
-
answer.(0)
34
+
Vertex_set.of_list
35
+
@@
36
+
let@ answer = List.map @~ D.list_of_answers answers in
37
+
answer.(0)
-1
lib/core/Datalog_eval.mli
-1
lib/core/Datalog_eval.mli
+24
-36
lib/core/Datalog_expr.ml
+24
-36
lib/core/Datalog_expr.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
type var = string
8
-
[@@deriving show, repr]
9
-
10
-
type 'a term =
11
-
| Const of 'a
12
-
| Var of var
13
-
[@@deriving show, repr]
14
-
15
-
type ('sym, 'a) prop = {
16
-
rel: 'sym;
17
-
args: 'a term list
18
-
}
19
-
[@@deriving show, repr]
7
+
type var = string [@@deriving show, repr]
8
+
type 'a term = Const of 'a | Var of var [@@deriving show, repr]
9
+
type ('sym, 'a) prop = {rel: 'sym; args: 'a term list} [@@deriving show, repr]
20
10
21
11
type ('sym, 'a) sequent = {
22
12
conclusion: ('sym, 'a) prop;
23
-
premises: ('sym, 'a) prop list
13
+
premises: ('sym, 'a) prop list;
24
14
}
25
15
[@@deriving show, repr]
26
16
27
-
type ('sym, 'a) script = ('sym, 'a) sequent list
28
-
[@@deriving show, repr]
17
+
type ('sym, 'a) script = ('sym, 'a) sequent list [@@deriving show, repr]
29
18
30
19
type ('sym, 'a) query = {
31
20
var: var;
32
21
positives: ('sym, 'a) prop list;
33
-
negatives: ('sym, 'a) prop list
22
+
negatives: ('sym, 'a) prop list;
34
23
}
35
24
[@@deriving show, repr]
36
25
37
-
let map_term f = function
38
-
| Const c -> Const (f c)
39
-
| Var x -> Var x
26
+
let map_term f = function Const c -> Const (f c) | Var x -> Var x
40
27
41
-
let map_prop f g prop = {rel = f prop.rel; args = List.map (map_term g) prop.args}
28
+
let map_prop f g prop =
29
+
{rel = f prop.rel; args = List.map (map_term g) prop.args}
42
30
43
31
let map_premises f g = List.map (map_prop f g)
44
32
45
-
let map_sequent f g sequent = {
46
-
conclusion = map_prop f g sequent.conclusion;
47
-
premises = map_premises f g sequent.premises
48
-
}
33
+
let map_sequent f g sequent =
34
+
{
35
+
conclusion = map_prop f g sequent.conclusion;
36
+
premises = map_premises f g sequent.premises;
37
+
}
49
38
50
39
let map_script f g = List.map (map_sequent f g)
51
40
52
-
let map_query f g query = {query with
53
-
positives = map_premises f g query.positives;
54
-
negatives = map_premises f g query.negatives
55
-
}
56
-
57
-
let iter_script f script =
58
-
ignore @@ map_script Fun.id f script
41
+
let map_query f g query =
42
+
{
43
+
query with
44
+
positives = map_premises f g query.positives;
45
+
negatives = map_premises f g query.negatives;
46
+
}
59
47
60
-
let iter_query f query =
61
-
ignore @@ map_query Fun.id f query
48
+
let iter_script f script = ignore @@ map_script Fun.id f script
49
+
let iter_query f query = ignore @@ map_query Fun.id f query
62
50
63
51
module Constructors = struct
64
52
let const x = Const x
···
70
58
module Notation = struct
71
59
include Constructors
72
60
73
-
let (<<) conclusion premises = {conclusion; premises}
74
-
let (@*) rel args = {rel; args}
61
+
let ( << ) conclusion premises = {conclusion; premises}
62
+
let ( @* ) rel args = {rel; args}
75
63
end
+27
-31
lib/core/Forest_graph.ml
+27
-31
lib/core/Forest_graph.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
module G = Graph.Imperative.Digraph.ConcreteBidirectional(Vertex)
7
+
module G = Graph.Imperative.Digraph.ConcreteBidirectional (Vertex)
8
8
include G
9
-
include Graph.Oper.I(G)
10
-
module Map = Graph.Gmap.Vertex(G)
9
+
include Graph.Oper.I (G)
10
+
module Map = Graph.Gmap.Vertex (G)
11
11
12
-
module Reachability = Graph.Fixpoint.Make(G)(struct
13
-
type vertex = G.E.vertex
14
-
type edge = G.E.t
15
-
type g = G.t
16
-
type data = bool
17
-
let direction = Graph.Fixpoint.Forward
18
-
let equal = (=)
19
-
let join = (||)
20
-
let analyze _ = (fun x -> x)
21
-
end)
12
+
module Reachability =
13
+
Graph.Fixpoint.Make
14
+
(G)
15
+
(struct
16
+
type vertex = G.E.vertex
17
+
type edge = G.E.t
18
+
type g = G.t
19
+
type data = bool
22
20
23
-
module Topo = Graph.Topological.Make(G)
24
-
let topo_fold = Topo.fold
25
-
let topo_iter = Topo.iter
21
+
let direction = Graph.Fixpoint.Forward
22
+
let equal = ( = )
23
+
let join = ( || )
24
+
let analyze _ = fun x -> x
25
+
end)
26
26
27
-
let safe_succ g x =
28
-
if mem_vertex g x then succ g x else []
27
+
module Topo = Graph.Topological.Make (G)
29
28
29
+
let topo_fold = Topo.fold
30
+
let topo_iter = Topo.iter
31
+
let safe_succ g x = if mem_vertex g x then succ g x else []
30
32
let safe_dependents = safe_succ
31
-
32
-
let safe_pred g x =
33
-
if mem_vertex g x then pred g x else []
34
-
33
+
let safe_pred g x = if mem_vertex g x then pred g x else []
35
34
let immediate_dependencies = safe_pred
36
35
37
36
let dependencies graph vertex : t =
···
40
39
iter_pred
41
40
(fun dep ->
42
41
if mem_vertex dep_graph dep then ()
43
-
else
44
-
begin
45
-
add_edge dep_graph dep v;
46
-
go dep
47
-
end
48
-
)
49
-
graph
50
-
v
42
+
else begin
43
+
add_edge dep_graph dep v;
44
+
go dep
45
+
end)
46
+
graph v
51
47
in
52
48
go vertex;
53
49
dep_graph
54
50
55
-
module Graphviz = Graph.Graphviz.Dot(struct
51
+
module Graphviz = Graph.Graphviz.Dot (struct
56
52
include G
57
53
module V = Vertex
58
54
+4
-10
lib/core/Forest_graph.mli
+4
-10
lib/core/Forest_graph.mli
···
6
6
7
7
type t
8
8
9
-
module Map (G_Dst : Graph.Gmap.V_DST) :
10
-
sig
9
+
module Map (G_Dst : Graph.Gmap.V_DST) : sig
11
10
val map : (Vertex.t -> G_Dst.vertex) -> t -> G_Dst.t
12
11
val filter_map : (Vertex.t -> G_Dst.vertex option) -> t -> G_Dst.t
13
12
end
14
13
15
-
val create : ?size: int -> unit -> t
14
+
val create : ?size:int -> unit -> t
16
15
val add_vertex : t -> Vertex.t -> unit
17
16
val add_edge : t -> Vertex.t -> Vertex.t -> unit
18
-
19
17
val safe_pred : t -> Vertex.t -> Vertex.t list
20
18
val safe_succ : t -> Vertex.t -> Vertex.t list
21
19
val immediate_dependencies : t -> Vertex.t -> Vertex.t list
22
20
val safe_dependents : t -> Vertex.t -> Vertex.t list
23
21
val mem_edge : t -> Vertex.t -> Vertex.t -> bool
24
-
val transitive_closure : ?reflexive: bool -> t -> t
25
-
22
+
val transitive_closure : ?reflexive:bool -> t -> t
26
23
val out_degree : t -> Vertex.t -> int
27
24
val in_degree : t -> Vertex.t -> int
28
-
29
25
val remove_vertex : t -> Vertex.t -> unit
30
26
val remove_edge : t -> Vertex.t -> Vertex.t -> unit
31
-
val transitive_reduction : ?reflexive: bool -> t -> t
27
+
val transitive_reduction : ?reflexive:bool -> t -> t
32
28
val nb_vertex : t -> int
33
29
val iter_edges : (Vertex.t -> Vertex.t -> unit) -> t -> unit
34
30
val iter_vertex : (Vertex.t -> unit) -> t -> unit
35
31
val mem_vertex : t -> Vertex.t -> bool
36
32
val topo_fold : (Vertex.t -> 'a -> 'a) -> t -> 'a -> 'a
37
33
val topo_iter : (Vertex.t -> unit) -> t -> unit
38
-
39
34
val iter_succ : (Vertex.t -> unit) -> t -> Vertex.t -> unit
40
-
41
35
val dependencies : t -> Vertex.t -> t
42
36
43
37
module Graphviz : sig
+13
-10
lib/core/Forest_graphs.ml
+13
-10
lib/core/Forest_graphs.ml
···
17
17
end
18
18
19
19
let init (db : Dl.db) : (module S) =
20
-
(module struct
21
-
let dl_db = db
20
+
(module struct
21
+
let dl_db = db
22
22
23
-
let register_uri uri =
24
-
let vtx : Vertex.t = T.Uri_vertex uri in
25
-
Dl.db_add_fact dl_db @@ Dl.mk_literal Builtin_relation.is_node [Dl.mk_const vtx];
26
-
let@ host = Option.iter @~ URI.host uri in
27
-
let host_vtx = T.Content_vertex (T.Content [T.Text host]) in
28
-
Dl.db_add_fact dl_db @@ Dl.mk_literal Builtin_relation.in_host [Dl.mk_const vtx; Dl.mk_const host_vtx]
29
-
end)
23
+
let register_uri uri =
24
+
let vtx : Vertex.t = T.Uri_vertex uri in
25
+
Dl.db_add_fact dl_db
26
+
@@ Dl.mk_literal Builtin_relation.is_node [Dl.mk_const vtx];
27
+
let@ host = Option.iter @~ URI.host uri in
28
+
let host_vtx = T.Content_vertex (T.Content [T.Text host]) in
29
+
Dl.db_add_fact dl_db
30
+
@@ Dl.mk_literal Builtin_relation.in_host
31
+
[Dl.mk_const vtx; Dl.mk_const host_vtx]
32
+
end)
30
33
31
-
module Make () : S = (val (init @@ Dl.db_create ()))
34
+
module Make () : S = (val init @@ Dl.db_create ())
+2
-1
lib/core/Forest_graphs.mli
+2
-1
lib/core/Forest_graphs.mli
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
(** A simple graph database. Used to record the {{!Forester_core.Builtin_relation}relations} that exist between trees.*)
7
+
(** A simple graph database. Used to record the
8
+
{{!Forester_core.Builtin_relation}relations} that exist between trees.*)
8
9
9
10
module type S = sig
10
11
val dl_db : Datalog_engine.db
+6
-10
lib/core/Forester_core.ml
+6
-10
lib/core/Forester_core.ml
···
15
15
16
16
(** {1 Vertices}
17
17
18
-
The type of vertices used by the {{!Forester_core.Forest_graphs}graph database}
19
-
20
-
*)
18
+
The type of vertices used by the
19
+
{{!Forester_core.Forest_graphs}graph database} *)
21
20
22
21
module Vertex = Vertex
23
22
module Vertex_set = Vertex_set
···
33
32
34
33
module Range = Range
35
34
35
+
module Builtin_relation = Builtin_relation
36
36
(** {2 Builtins}*)
37
-
module Builtin_relation = Builtin_relation
37
+
38
38
module Builtin_queries = Builtin_queries
39
39
40
40
module Forest_graph = Forest_graph
41
-
(** The graph type used by the datalog database. Used in particular to track imports, links and transclusions. *)
41
+
(** The graph type used by the datalog database. Used in particular to track
42
+
imports, links and transclusions. *)
42
43
43
44
module Forest_graphs = Forest_graphs
44
45
(** The graph database*)
···
48
49
module Datalog_engine = Datalog_engine
49
50
module Datalog_expr = Datalog_expr
50
51
module Datalog_eval = Datalog_eval
51
-
52
52
module Prim = Prim
53
-
54
53
module TeX_cs = TeX_cs
55
-
56
54
module Types = Types
57
55
module TeX_like = TeX_like (* TODO: rename this *)
58
-
59
56
module Trie = Trie
60
-
61
57
module Syn = Syn
62
58
module Symbol = Symbol
63
59
module Value = Value
+12
-1
lib/core/Prim.ml
+12
-1
lib/core/Prim.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
type t = [`P | `Ol | `Ul | `Li | `Em | `Strong | `Code | `Blockquote | `Pre | `Figure | `Figcaption]
7
+
type t =
8
+
[ `P
9
+
| `Ol
10
+
| `Ul
11
+
| `Li
12
+
| `Em
13
+
| `Strong
14
+
| `Code
15
+
| `Blockquote
16
+
| `Pre
17
+
| `Figure
18
+
| `Figcaption ]
8
19
[@@deriving show, repr]
+6
-15
lib/core/Range.ml
+6
-15
lib/core/Range.ml
···
6
6
7
7
include Asai.Range
8
8
9
-
let pp_located pp_arg fmt (x : 'a located) =
10
-
pp_arg fmt x.value
11
-
9
+
let pp_located pp_arg fmt (x : 'a located) = pp_arg fmt x.value
12
10
let map f node = {node with value = f node.value}
13
11
14
12
type string_source = Asai.Range.string_source = {
···
17
15
}
18
16
[@@deriving repr]
19
17
20
-
type source = [
21
-
| `File of string
22
-
| `String of string_source
23
-
]
24
-
[@@deriving repr]
18
+
type source = [`File of string | `String of string_source] [@@deriving repr]
25
19
26
20
type position = Asai.Range.position = {
27
21
source: source;
···
33
27
34
28
let t : t Repr.t =
35
29
let open Repr in
36
-
variant
37
-
"t"
38
-
begin
39
-
fun range end_of_file t ->
40
-
match view t with
41
-
| `Range (x, y) -> range (x, y)
42
-
| `End_of_file x -> end_of_file x
30
+
variant "t" begin fun range end_of_file t ->
31
+
match view t with
32
+
| `Range (x, y) -> range (x, y)
33
+
| `End_of_file x -> end_of_file x
43
34
end
44
35
|~ case1 "Range" (pair position_t position_t) make
45
36
|~ case1 "End_of_file" position_t eof
+18
-22
lib/core/Reporter.ml
+18
-22
lib/core/Reporter.ml
···
6
6
7
7
module R = Resolver
8
8
module Sc = R.Scope
9
-
10
9
module Message = Reporter_message
11
-
12
-
include Asai.StructuredReporter.Make(Message)
10
+
include Asai.StructuredReporter.Make (Message)
13
11
14
12
type diagnostic = Message.t Asai.Diagnostic.t
15
13
16
-
let log pp s =
17
-
Logs.info (fun m -> m "%a...@." pp s)
14
+
let log pp s = Logs.info (fun m -> m "%a...@." pp s)
18
15
19
16
let profile msg body =
20
17
let before = Unix.gettimeofday () in
21
18
let result = body () in
22
19
let after = Unix.gettimeofday () in
23
-
emit ~extra_remarks: [Asai.Diagnostic.loctextf "%s" msg] (Profiling (after, before));
20
+
emit
21
+
~extra_remarks:[Asai.Diagnostic.loctextf "%s" msg]
22
+
(Profiling (after, before));
24
23
result
25
24
26
-
module Tty = Asai.Tty.Make(Message)
25
+
module Tty = Asai.Tty.Make (Message)
27
26
28
27
let easy_run k =
29
28
let fatal diagnostics =
30
29
Tty.display diagnostics;
31
30
exit 1
32
31
in
33
-
run ~emit: Tty.display ~fatal k
32
+
run ~emit:Tty.display ~fatal k
34
33
35
34
let silence k =
36
35
let fatal diagnostics =
37
36
Tty.display diagnostics;
38
37
exit 1
39
38
in
40
-
run ~emit: Tty.display ~fatal k
39
+
run ~emit:Tty.display ~fatal k
41
40
42
41
let test_run k =
43
42
let fatal diagnostics =
44
-
Tty.display
45
-
~use_color: false
46
-
~use_ansi: false
47
-
diagnostics;
43
+
Tty.display ~use_color:false ~use_ansi:false diagnostics;
48
44
exit 1
49
45
in
50
46
let emit _diagnostics = () in
···
53
49
(* Reporting diagnostics requires a document URI to publish *)
54
50
let guess_uri (d : diagnostic) =
55
51
match d with
56
-
| {explanation; _} ->
52
+
| {explanation; _} -> (
57
53
match explanation.loc with
58
54
| None -> None
59
-
| Some loc ->
55
+
| Some loc -> (
60
56
match Range.view loc with
61
-
| `End_of_file {source; _}
62
-
| `Range ({source; _}, _) ->
57
+
| `End_of_file {source; _} | `Range ({source; _}, _) -> (
63
58
match source with
64
59
| `String _ -> None
65
-
| `File path ->
66
-
if path <> "" then
67
-
Some (Lsp.Uri.of_path path)
68
-
else None
60
+
| `File path -> if path <> "" then Some (Lsp.Uri.of_path path) else None
61
+
)))
69
62
70
63
let ignore =
71
64
let emit _ = () in
72
-
let fatal _ = fatal Message.Internal_error ~extra_remarks: [Asai.Diagnostic.loctext "ignoring error"] in
65
+
let fatal _ =
66
+
fatal Message.Internal_error
67
+
~extra_remarks:[Asai.Diagnostic.loctext "ignoring error"]
68
+
in
73
69
run ~emit ~fatal
+5
-6
lib/core/Reporter.mli
+5
-6
lib/core/Reporter.mli
···
5
5
*)
6
6
7
7
module Message : module type of Reporter_message
8
-
9
-
include module type of Asai.StructuredReporter.Make(Message)
10
-
module Tty : module type of Asai.Tty.Make(Message)
8
+
include module type of Asai.StructuredReporter.Make (Message)
9
+
module Tty : module type of Asai.Tty.Make (Message)
11
10
12
11
type diagnostic = Message.t Asai.Diagnostic.t
12
+
13
13
val log : (Format.formatter -> 'a -> unit) -> 'a -> unit
14
14
val profile : string -> (unit -> 'a) -> 'a
15
15
val easy_run : (unit -> 'a) -> 'a
16
16
val silence : (unit -> 'a) -> 'a
17
17
val test_run : (unit -> 'a) -> 'a
18
-
19
18
val guess_uri : diagnostic -> Lsp.Uri.t option
20
19
21
20
val ignore :
22
-
?init_loc: Asai.Range.t ->
23
-
?init_backtrace: Asai.Diagnostic.backtrace ->
21
+
?init_loc:Asai.Range.t ->
22
+
?init_backtrace:Asai.Diagnostic.backtrace ->
24
23
(unit -> 'a) ->
25
24
'a
+74
-86
lib/core/Reporter_message.ml
+74
-86
lib/core/Reporter_message.ml
···
30
30
| Parse_error
31
31
| Unbound_method of (string * Value.obj)
32
32
| Type_warning
33
-
| Type_error of
34
-
{
35
-
got: Value.t option;
36
-
expected: expected_value list
37
-
}
33
+
| Type_error of {got: Value.t option; expected: expected_value list}
38
34
| Unbound_fluid_symbol of Symbol.t
39
35
| Unbound_variable of string
40
-
| Unresolved_identifier of ((Sc.data, R.P.tag) Trie.t [@opaque]) * Trie.path
36
+
| Unresolved_identifier of ((Sc.data, R.P.tag) Trie.t[@opaque]) * Trie.path
41
37
| Unresolved_xmlns of string
42
38
| Reference_error of URI.t
43
39
| Unhandled_case
···
94
90
let short_code : t -> string = function
95
91
| Import_not_found _ -> "import_not_found"
96
92
| Invalid_URI -> "invalid_uri"
97
-
| Asset_has_no_content_address _ -> "asset_not_found" (* This is taken from the original wording of the message, but I think this is very confusing.*)
93
+
| Asset_has_no_content_address _ ->
94
+
"asset_not_found"
95
+
(* This is taken from the original wording of the message, but I think this
96
+
is very confusing.*)
98
97
| Asset_not_found _ -> "asset_not_found"
99
98
| Current_tree_has_no_uri -> "current_tree_has_no_uri"
100
99
| Duplicate_tree _ -> "duplicate_tree"
···
152
151
let default_text : t -> Asai.Diagnostic.text = function
153
152
| Import_not_found uri -> Asai.Diagnostic.textf "%a not found" URI.pp uri
154
153
| Unresolved_xmlns prefix ->
155
-
Asai.Diagnostic.textf "Could not resolve prefix `%s` to XML namespace" prefix
154
+
Asai.Diagnostic.textf "Could not resolve prefix `%s` to XML namespace"
155
+
prefix
156
156
| Unresolved_identifier (_, p) ->
157
-
Asai.Diagnostic.textf "Unknown binding \\%a. To interpret as a TeX control sequence, explicitly enter TeX mode using #{...}." Trie.pp_path p
158
-
| Type_error {got; expected} ->
159
-
begin
160
-
let expected_msg =
161
-
match expected with
162
-
| [] -> Asai.Diagnostic.textf "An unknown type error ocurred"
163
-
| expected :: [] ->
164
-
Asai.Diagnostic.textf "Expected %s" (show_expected_value expected)
165
-
| _ ->
166
-
Asai.Diagnostic.textf "Expected one of %a" (Format.pp_print_list ~pp_sep: (fun out () -> Format.fprintf out ", ") pp_expected_value) expected
167
-
in
168
-
let got_msg =
169
-
match got with
170
-
| None -> Asai.Diagnostic.textf ""
171
-
| Some v ->
172
-
Asai.Diagnostic.textf " but this is %s" (this_is v)
173
-
in
174
-
let hint =
175
-
match got with
176
-
| Some Value.Clo (_, _, _) -> Asai.Diagnostic.textf "Did you forget to supply an argument?"
177
-
| Some Value.Content _
178
-
| Some Value.Dx_prop _
179
-
| Some Value.Dx_sequent _
180
-
| Some Value.Dx_query _
181
-
| Some Value.Dx_var _
182
-
| Some Value.Dx_const _
183
-
| Some Value.Sym _
184
-
| Some Value.Obj _
185
-
| None ->
186
-
Asai.Diagnostic.textf ""
187
-
in
188
-
Asai.Diagnostic.textf "%t%t.\n%t" expected_msg got_msg hint
189
-
end
157
+
Asai.Diagnostic.textf
158
+
"Unknown binding \\%a. To interpret as a TeX control sequence, \
159
+
explicitly enter TeX mode using #{...}."
160
+
Trie.pp_path p
161
+
| Type_error {got; expected} -> begin
162
+
let expected_msg =
163
+
match expected with
164
+
| [] -> Asai.Diagnostic.textf "An unknown type error ocurred"
165
+
| expected :: [] ->
166
+
Asai.Diagnostic.textf "Expected %s" (show_expected_value expected)
167
+
| _ ->
168
+
Asai.Diagnostic.textf "Expected one of %a"
169
+
(Format.pp_print_list
170
+
~pp_sep:(fun out () -> Format.fprintf out ", ")
171
+
pp_expected_value)
172
+
expected
173
+
in
174
+
let got_msg =
175
+
match got with
176
+
| None -> Asai.Diagnostic.textf ""
177
+
| Some v -> Asai.Diagnostic.textf " but this is %s" (this_is v)
178
+
in
179
+
let hint =
180
+
match got with
181
+
| Some (Value.Clo (_, _, _)) ->
182
+
Asai.Diagnostic.textf "Did you forget to supply an argument?"
183
+
| Some (Value.Content _)
184
+
| Some (Value.Dx_prop _)
185
+
| Some (Value.Dx_sequent _)
186
+
| Some (Value.Dx_query _)
187
+
| Some (Value.Dx_var _)
188
+
| Some (Value.Dx_const _)
189
+
| Some (Value.Sym _)
190
+
| Some (Value.Obj _)
191
+
| None ->
192
+
Asai.Diagnostic.textf ""
193
+
in
194
+
Asai.Diagnostic.textf "%t%t.\n%t" expected_msg got_msg hint
195
+
end
190
196
| Asset_not_found msg -> Asai.Diagnostic.text msg
191
197
| Unbound_method (mthd, {prototype = _; methods; _}) ->
192
198
let method_names = List.map fst @@ Value.Method_table.to_list methods in
193
-
Asai.Diagnostic.textf
194
-
"Unbound method %s. Available methods are:@.%a"
195
-
mthd
199
+
Asai.Diagnostic.textf "Unbound method %s. Available methods are:@.%a" mthd
196
200
Format.(pp_print_list (fun ppf s -> fprintf ppf " %s" s))
197
201
method_names
198
202
| Uninterpreted_config_options keys ->
199
-
Asai.Diagnostic.textf
200
-
"Uninterpreted config option%s: %a"
201
-
(
202
-
if List.length keys = 1 then ""
203
-
else if List.length keys > 1 then "s"
204
-
else assert false
205
-
)
203
+
Asai.Diagnostic.textf "Uninterpreted config option%s: %a"
204
+
(if List.length keys = 1 then ""
205
+
else if List.length keys > 1 then "s"
206
+
else assert false)
206
207
Format.(
207
208
pp_print_list
208
-
~pp_sep: (fun out () -> fprintf out ", ")
209
+
~pp_sep:(fun out () -> fprintf out ", ")
209
210
(fun ppf k ->
210
-
fprintf ppf "%a" (pp_print_list ~pp_sep: (fun out () -> fprintf out ".") pp_print_string) k
211
-
)
212
-
)
211
+
fprintf ppf "%a"
212
+
(pp_print_list
213
+
~pp_sep:(fun out () -> fprintf out ".")
214
+
pp_print_string)
215
+
k))
213
216
keys
214
217
| Using_default_option k ->
215
218
Asai.Diagnostic.textf
216
219
"Configuration option %a is not set. Using default value."
217
-
Format.(pp_print_list ~pp_sep: (fun out () -> fprintf out ".") pp_print_string)
220
+
Format.(
221
+
pp_print_list ~pp_sep:(fun out () -> fprintf out ".") pp_print_string)
218
222
k
219
223
| Required_config_option k ->
220
224
Asai.Diagnostic.textf "Required option %s is not set." k
221
-
| Broken_link {uri; suggestion} ->
222
-
begin
223
-
match suggestion with
224
-
| None ->
225
-
Asai.Diagnostic.textf "Potentially broken link to `%a`" URI.pp uri
226
-
| Some suggestion ->
227
-
Asai.Diagnostic.textf "Potentially broken link to `%a`; did you mean `%a`?" URI.pp uri URI.pp suggestion
228
-
end
225
+
| Broken_link {uri; suggestion} -> begin
226
+
match suggestion with
227
+
| None -> Asai.Diagnostic.textf "Potentially broken link to `%a`" URI.pp uri
228
+
| Some suggestion ->
229
+
Asai.Diagnostic.textf
230
+
"Potentially broken link to `%a`; did you mean `%a`?" URI.pp uri URI.pp
231
+
suggestion
232
+
end
229
233
| Resource_not_found uri ->
230
234
Asai.Diagnostic.textf "Resource not found: %a" URI.pp uri
231
235
| Duplicate_tree (o1, o2) ->
···
234
238
| Subtree {parent} -> Format.asprintf "%a" pp_identity parent
235
239
| Undefined -> "undefined"
236
240
in
237
-
Asai.Diagnostic.textf
238
-
"%s@ and@ %s@ use@ the@ same@ URI"
239
-
(show_origin o1)
241
+
Asai.Diagnostic.textf "%s@ and@ %s@ use@ the@ same@ URI" (show_origin o1)
240
242
(show_origin o2)
241
-
| Invalid_URI
242
-
| Asset_has_no_content_address _
243
-
| Reference_error _
244
-
| Parse_error
245
-
| Type_warning
246
-
| Unbound_fluid_symbol _
247
-
| Unbound_variable _
248
-
| Unhandled_case
249
-
| Transclusion_loop
250
-
| Internal_error
251
-
| Configuration_error
252
-
| Initialization_warning
253
-
| Routing_error
254
-
| Profiling _
255
-
| External_error
256
-
| Current_tree_has_no_uri
257
-
| IO_error
258
-
| Log
259
-
| Missing_argument ->
243
+
| Invalid_URI | Asset_has_no_content_address _ | Reference_error _
244
+
| Parse_error | Type_warning | Unbound_fluid_symbol _ | Unbound_variable _
245
+
| Unhandled_case | Transclusion_loop | Internal_error | Configuration_error
246
+
| Initialization_warning | Routing_error | Profiling _ | External_error
247
+
| Current_tree_has_no_uri | IO_error | Log | Missing_argument ->
260
248
Asai.Diagnostic.text ""
+11
-16
lib/core/Resolver.ml
+11
-16
lib/core/Resolver.ml
···
6
6
7
7
module P = struct
8
8
type data = Syn.resolver_data
9
-
10
9
type tag = Asai.Range.t option
11
-
12
10
type hook = unit (* for modifier hooks; unused here *)
13
11
type context = unit (* for advanced printing and reporting; unused here *)
14
12
end
15
13
16
14
module Scope = struct
17
-
include Yuujinchou.Scope.Make(P)
18
-
type data = P.data
15
+
include Yuujinchou.Scope.Make (P)
19
16
20
-
let import_singleton x v =
21
-
import_singleton (x, v)
17
+
type data = P.data
22
18
23
-
let include_singleton x v =
24
-
include_singleton (x, v)
19
+
let import_singleton x v = import_singleton (x, v)
20
+
let include_singleton x v = include_singleton (x, v)
25
21
26
22
let import_subtree ?modifier path subtree =
27
23
import_subtree ?modifier (path, subtree)
···
31
27
32
28
let pp_path ppf path =
33
29
let pp_slash ppf () = Format.fprintf ppf "/" in
34
-
Format.(fprintf ppf "%a" (pp_print_list ~pp_sep: pp_slash pp_print_string) path)
30
+
Format.(
31
+
fprintf ppf "%a" (pp_print_list ~pp_sep:pp_slash pp_print_string) path)
35
32
36
33
let pp_trie =
37
34
let pp_print_pair pp1 pp2 ppf (left, right) =
38
-
pp1 ppf left; pp2 ppf right
35
+
pp1 ppf left;
36
+
pp2 ppf right
39
37
in
40
38
Format.(
41
39
pp_print_seq
42
-
(
43
-
pp_print_pair
44
-
Trie.pp_path
45
-
(pp_print_pair Syn.pp_resolver_data (pp_print_option Asai.Range.dump))
46
-
)
47
-
)
40
+
(pp_print_pair Trie.pp_path
41
+
(pp_print_pair Syn.pp_resolver_data
42
+
(pp_print_option Asai.Range.dump))))
48
43
end
49
44
50
45
module Lang = Yuujinchou.Language
+4
-13
lib/core/Symbol.ml
+4
-13
lib/core/Symbol.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
type t = (Trie.path [@repr Repr.(list string)]) * int
8
-
[@@deriving repr]
7
+
type t = (Trie.path[@repr Repr.(list string)]) * int [@@deriving repr]
9
8
10
9
let counter = ref 0
11
10
12
11
let named path =
13
12
counter := !counter + 1;
14
-
path, !counter
13
+
(path, !counter)
15
14
16
15
let fresh () = named []
17
-
18
16
let clone (path, _) = named path
19
-
20
-
let pp fmt (sym, ix) =
21
-
Format.fprintf fmt "%a@%i" Trie.pp_path sym ix
22
-
17
+
let pp fmt (sym, ix) = Format.fprintf fmt "%a@%i" Trie.pp_path sym ix
23
18
let show x = Format.asprintf "%a" pp x
24
-
25
19
let compare = compare
26
-
27
20
let name (sym, _) = sym
28
-
29
-
let repr : t Repr.t =
30
-
Repr.pair (Repr.list Repr.string) Repr.int
21
+
let repr : t Repr.t = Repr.pair (Repr.list Repr.string) Repr.int
-3
lib/core/Symbol.mli
-3
lib/core/Symbol.mli
+30
-60
lib/core/Syn.ml
+30
-60
lib/core/Syn.ml
···
22
22
| Get of t
23
23
| Xml_tag of xml_qname * (xml_qname * t) list * t
24
24
| TeX_cs of TeX_cs.t
25
-
| Unresolved_ident of ((resolver_data, Range.t option) Trie.t [@opaque]) * Trie.path
25
+
| Unresolved_ident of
26
+
((resolver_data, Range.t option) Trie.t[@opaque]) * Trie.path
26
27
| Prim of Prim.t
27
28
| Object of {self: string option; methods: (string * t) list}
28
-
| Patch of {obj: t; self: string option; super: string option; methods: (string * t) list}
29
+
| Patch of {
30
+
obj: t;
31
+
self: string option;
32
+
super: string option;
33
+
methods: (string * t) list;
34
+
}
29
35
| Call of t * string
30
36
| Results_of_query
31
37
| Transclude
···
51
57
| Current_tree
52
58
[@@deriving show]
53
59
54
-
and t = node Range.located list
55
-
[@@deriving show]
60
+
and t = node Range.located list [@@deriving show]
56
61
57
-
and resolver_data =
58
-
| Term of t
59
-
| Xmlns of {xmlns: string; prefix: string}
62
+
and resolver_data = Term of t | Xmlns of {xmlns: string; prefix: string}
60
63
[@@deriving show]
61
64
62
65
let map f node =
···
69
72
| Put (r, s, t) -> Put (f r, f s, f t)
70
73
| Default (r, s, t) -> Default (f r, f s, f t)
71
74
| Get t -> Get (f t)
72
-
| Xml_tag (q, qs, t) -> Xml_tag (q, List.map (fun (q, t) -> q, f t) qs, f t)
75
+
| Xml_tag (q, qs, t) -> Xml_tag (q, List.map (fun (q, t) -> (q, f t)) qs, f t)
73
76
| Call (t, s) -> Call (f t, s)
74
77
| Object {self; methods} ->
75
-
Object {self; methods = List.map (fun (str, t) -> str, f t) methods}
78
+
Object {self; methods = List.map (fun (str, t) -> (str, f t)) methods}
76
79
| Patch {obj; self; super; methods} ->
77
-
Patch {obj = f obj; self; super; methods = List.map (fun (str, t) -> str, f t) methods}
80
+
Patch
81
+
{
82
+
obj = f obj;
83
+
self;
84
+
super;
85
+
methods = List.map (fun (str, t) -> (str, f t)) methods;
86
+
}
78
87
| Dx_sequent (t, ts) -> Dx_sequent (f t, List.map f ts)
79
88
| Dx_query (s, ps, ns) -> Dx_query (s, List.map f ps, List.map f ns)
80
89
| Dx_const (s, n) -> Dx_const (s, f n)
81
90
| Dx_prop (t, ts) -> Dx_prop (f t, List.map f ts)
82
-
| Text _
83
-
| Verbatim _
84
-
| Var _
85
-
| Sym _
86
-
| TeX_cs _
87
-
| Unresolved_ident _
88
-
| Prim _
89
-
| Results_of_query
90
-
| Transclude
91
-
| Embed_tex
92
-
| Ref
93
-
| Title
94
-
| Parent
95
-
| Taxon
91
+
| Text _ | Verbatim _ | Var _ | Sym _ | TeX_cs _ | Unresolved_ident _ | Prim _
92
+
| Results_of_query | Transclude | Embed_tex | Ref | Title | Parent | Taxon
96
93
| Meta
97
94
| Attribution (_, _)
98
-
| Tag _
99
-
| Date
100
-
| Number
101
-
| Dx_var _
102
-
| Dx_execute
103
-
| Route_asset
104
-
| Syndicate_current_tree_as_atom_feed
105
-
| Syndicate_query_as_json_blob
95
+
| Tag _ | Date | Number | Dx_var _ | Dx_execute | Route_asset
96
+
| Syndicate_current_tree_as_atom_feed | Syndicate_query_as_json_blob
106
97
| Current_tree ->
107
98
node
108
99
···
111
102
| Group (_, t) -> t
112
103
| Math (_, t) -> t
113
104
| Subtree (_, t) -> t
114
-
| Link {dest; title} -> Option.fold ~some: (fun t -> t @ dest) ~none: dest title
105
+
| Link {dest; title} -> Option.fold ~some:(fun t -> t @ dest) ~none:dest title
115
106
| Fun (_, t) -> t
116
107
| Put (r, s, t) -> r @ s @ t
117
108
| Default (r, s, t) -> r @ s @ t
118
109
| Get t -> t
119
110
| Xml_tag (_, qs, t) -> List.concat_map snd qs @ t
120
111
| Call (t, _) -> t
121
-
| Object {methods; _} ->
122
-
List.concat_map snd methods
123
-
| Patch {obj; methods; _} ->
124
-
List.concat_map snd methods @
125
-
obj
112
+
| Object {methods; _} -> List.concat_map snd methods
113
+
| Patch {obj; methods; _} -> List.concat_map snd methods @ obj
126
114
| Dx_sequent (t, ts) -> t @ List.concat ts
127
115
| Dx_query (_, ps, ns) -> List.concat ps @ List.concat ns
128
116
| Dx_const (_, n) -> n
129
117
| Dx_prop (t, ts) -> t @ List.concat ts
130
-
| Text _
131
-
| Verbatim _
132
-
| Var _
133
-
| Sym _
134
-
| TeX_cs _
135
-
| Unresolved_ident _
136
-
| Prim _
137
-
| Results_of_query
138
-
| Transclude
139
-
| Embed_tex
140
-
| Ref
141
-
| Title
142
-
| Parent
143
-
| Taxon
118
+
| Text _ | Verbatim _ | Var _ | Sym _ | TeX_cs _ | Unresolved_ident _ | Prim _
119
+
| Results_of_query | Transclude | Embed_tex | Ref | Title | Parent | Taxon
144
120
| Meta
145
121
| Attribution (_, _)
146
-
| Tag _
147
-
| Date
148
-
| Number
149
-
| Dx_var _
150
-
| Dx_execute
151
-
| Route_asset
152
-
| Syndicate_current_tree_as_atom_feed
153
-
| Syndicate_query_as_json_blob
122
+
| Tag _ | Date | Number | Dx_var _ | Dx_execute | Route_asset
123
+
| Syndicate_current_tree_as_atom_feed | Syndicate_query_as_json_blob
154
124
| Current_tree ->
155
125
[]
+7
-14
lib/core/TeX_cs.ml
+7
-14
lib/core/TeX_cs.ml
···
6
6
7
7
open Forester_prelude
8
8
9
-
type t =
10
-
| Word of string
11
-
| Symbol of char
12
-
[@@deriving repr]
9
+
type t = Word of string | Symbol of char [@@deriving repr]
13
10
14
11
let pp fmt = function
15
12
| Word x -> Format.fprintf fmt "%s" x
···
19
16
20
17
let is_alpha c =
21
18
let i = Char.code c in
22
-
i >= 65 && i <= 90 || i >= 97 && i <= 122
19
+
(i >= 65 && i <= 90) || (i >= 97 && i <= 122)
23
20
24
21
let rec parse_word acc xs =
25
22
match xs with
26
-
| [] -> Word (String_util.implode_bwd acc), ""
23
+
| [] -> (Word (String_util.implode_bwd acc), "")
27
24
| x :: xs ->
28
-
if is_alpha x then
29
-
parse_word (Bwd.Snoc (acc, x)) xs
30
-
else
31
-
Word (String_util.implode_bwd acc), String_util.implode (x :: xs)
25
+
if is_alpha x then parse_word (Bwd.Snoc (acc, x)) xs
26
+
else (Word (String_util.implode_bwd acc), String_util.implode (x :: xs))
32
27
33
28
let parse input =
34
29
match String_util.explode input with
35
30
| x :: xs ->
36
-
if is_alpha x then
37
-
Some (parse_word (Bwd.Snoc (Bwd.Emp, x)) xs)
38
-
else
39
-
Some (Symbol x, String_util.implode xs)
31
+
if is_alpha x then Some (parse_word (Bwd.Snoc (Bwd.Emp, x)) xs)
32
+
else Some (Symbol x, String_util.implode xs)
40
33
| [] -> None
+1
-5
lib/core/TeX_cs.mli
+1
-5
lib/core/TeX_cs.mli
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
type t =
8
-
| Word of string
9
-
| Symbol of char
7
+
type t = Word of string | Symbol of char
10
8
11
9
val pp : Format.formatter -> t -> unit
12
10
val show : t -> string
13
-
14
11
val t : t Repr.t
15
-
16
12
val parse : string -> (t * string) option
+11
-6
lib/core/TeX_like.ml
+11
-6
lib/core/TeX_like.ml
···
8
8
open Types
9
9
10
10
let rec pp_content fmt = function
11
-
| Content nodes ->
12
-
List.iter (pp_content_node fmt) nodes
11
+
| Content nodes -> List.iter (pp_content_node fmt) nodes
13
12
14
13
and pp_content_node fmt = function
15
14
| Text str -> Format.fprintf fmt "%s" str
16
15
| CDATA str -> Format.fprintf fmt "%s" str
17
16
| KaTeX (_, xs) -> pp_content fmt xs
18
-
| Xml_elt _ | Transclude _ | Contextual_number _ | Section _ | Link _ | Artefact _ | Uri _ | Route_of_uri _ | Datalog_script _ | Results_of_datalog_query _ ->
19
-
Reporter.fatal Internal_error ~extra_remarks: [Asai.Diagnostic.loctextf "Cannot render this kind of content node as TeX-like string"]
17
+
| Xml_elt _ | Transclude _ | Contextual_number _ | Section _ | Link _
18
+
| Artefact _ | Uri _ | Route_of_uri _ | Datalog_script _
19
+
| Results_of_datalog_query _ ->
20
+
Reporter.fatal Internal_error
21
+
~extra_remarks:
22
+
[
23
+
Asai.Diagnostic.loctextf
24
+
"Cannot render this kind of content node as TeX-like string";
25
+
]
20
26
21
-
let string_of_content =
22
-
Format.asprintf "%a" pp_content
27
+
let string_of_content = Format.asprintf "%a" pp_content
+50
-72
lib/core/Tree.ml
+50
-72
lib/core/Tree.ml
···
38
38
[@@deriving show]
39
39
40
40
type t =
41
-
| Document of (Lsp.Text_document.t [@opaque])
41
+
| Document of (Lsp.Text_document.t[@opaque])
42
42
| Parsed of code
43
43
| Expanded of syn
44
44
| Resource of evaluated
···
48
48
| Document doc -> Physical doc
49
49
| Parsed parsed -> parsed.origin
50
50
| Expanded expanded -> expanded.code.origin
51
-
| Resource resource ->
51
+
| Resource resource -> (
52
52
match resource.expanded with
53
53
| None -> Undefined
54
-
| Some expanded -> expanded.code.origin
54
+
| Some expanded -> expanded.code.origin)
55
55
56
56
let show_phase = function
57
57
| Document _ -> "document"
···
76
76
(* IDK if subtrees should resolve to their parent document*)
77
77
let to_doc : t -> Lsp.Text_document.t option = function
78
78
| Document doc -> Some doc
79
-
| Resource {expanded; _} ->
80
-
begin
81
-
match expanded with
82
-
| None -> None
83
-
| Some {code; _} ->
84
-
match code.origin with
85
-
| Physical doc ->
86
-
Some doc
87
-
| Subtree _ -> None
88
-
| Undefined -> None
89
-
end
90
-
| Parsed {origin; _;}
91
-
| Expanded {code = {origin; _}; _;} ->
79
+
| Resource {expanded; _} -> begin
80
+
match expanded with
81
+
| None -> None
82
+
| Some {code; _} -> (
83
+
match code.origin with
84
+
| Physical doc -> Some doc
85
+
| Subtree _ -> None
86
+
| Undefined -> None)
87
+
end
88
+
| Parsed {origin; _} | Expanded {code = {origin; _}; _} -> (
92
89
match origin with
93
-
| Physical doc ->
94
-
Some doc
90
+
| Physical doc -> Some doc
95
91
| Subtree _ -> None
96
-
| Undefined -> None
92
+
| Undefined -> None)
97
93
98
94
let to_resource : t -> T.content T.resource option = function
99
-
| Document _
100
-
| Parsed _
101
-
| Expanded _ ->
102
-
None
103
-
| Resource {resource; _;} -> Some resource
95
+
| Document _ | Parsed _ | Expanded _ -> None
96
+
| Resource {resource; _} -> Some resource
104
97
105
98
let to_evaluated : t -> evaluated option = function
106
-
| Document _
107
-
| Parsed _
108
-
| Expanded _ ->
109
-
None
99
+
| Document _ | Parsed _ | Expanded _ -> None
110
100
| Resource evaluated -> Some evaluated
111
101
112
102
let to_article : t -> T.content T.article option = function
113
-
| Document _
114
-
| Parsed _
115
-
| Expanded _ ->
116
-
None
117
-
| Resource {resource; _;} ->
118
-
match resource with
119
-
| T.Article a -> Some a
120
-
| _ -> None
103
+
| Document _ | Parsed _ | Expanded _ -> None
104
+
| Resource {resource; _} -> (
105
+
match resource with T.Article a -> Some a | _ -> None)
121
106
122
107
let get_frontmatter : t -> T.content T.frontmatter option = function
123
108
| Resource {resource = Types.Article {frontmatter; _}; _} -> Some frontmatter
···
129
114
(* assert false *)
130
115
None
131
116
| Parsed code -> Some code
132
-
| Resource {expanded; _} ->
133
-
begin
134
-
match expanded with
135
-
| None -> None
136
-
| Some {code; _} -> Some code
137
-
end
138
-
| Expanded {code; _;} -> Some code
117
+
| Resource {expanded; _} -> begin
118
+
match expanded with None -> None | Some {code; _} -> Some code
119
+
end
120
+
| Expanded {code; _} -> Some code
139
121
140
122
let to_syn : t -> syn option = function
141
123
| Document _ -> None
142
124
| Parsed _ -> None
143
125
| Expanded syn -> Some syn
144
-
| Resource {expanded; _} ->
145
-
expanded
126
+
| Resource {expanded; _} -> expanded
146
127
147
-
let get_units : t -> exports option = fun item ->
128
+
let get_units : t -> exports option =
129
+
fun item ->
148
130
match item with
149
131
| Document _ -> None
150
132
| Parsed _ -> None
151
133
| Expanded {units; _} -> Some units
152
-
| Resource {expanded; _} ->
153
-
match expanded with
154
-
| Some {units; _} -> Some units
155
-
| None -> None
134
+
| Resource {expanded; _} -> (
135
+
match expanded with Some {units; _} -> Some units | None -> None)
156
136
157
-
let is_unparsed = function
158
-
| Document _ -> true
159
-
| _ -> false
160
-
137
+
let is_unparsed = function Document _ -> true | _ -> false
161
138
let is_parsed t = not @@ is_unparsed t
162
139
163
140
let is_unexpanded = function
···
175
152
176
153
let is_asset = function
177
154
| Document _ | Parsed _ | Expanded _ -> false
178
-
| Resource {resource; _} ->
179
-
match resource with
180
-
| T.Asset _ -> true
181
-
| _ -> false
155
+
| Resource {resource; _} -> (
156
+
match resource with T.Asset _ -> true | _ -> false)
182
157
183
-
let update_units
184
-
: t -> exports -> t
185
-
= fun item units ->
158
+
let update_units : t -> exports -> t =
159
+
fun item units ->
186
160
match item with
187
-
| Document _
188
-
| Parsed _ ->
189
-
Reporter.fatal
190
-
Internal_error
191
-
~extra_remarks: [Asai.Diagnostic.loctext "can't update units for this item. It has not been expanded yet"]
161
+
| Document _ | Parsed _ ->
162
+
Reporter.fatal Internal_error
163
+
~extra_remarks:
164
+
[
165
+
Asai.Diagnostic.loctext
166
+
"can't update units for this item. It has not been expanded yet";
167
+
]
192
168
| Expanded e -> Expanded {e with units}
193
-
| Resource ({expanded; _} as e) ->
169
+
| Resource ({expanded; _} as e) -> (
194
170
match expanded with
195
171
| None ->
196
-
Reporter.fatal
197
-
Internal_error
198
-
~extra_remarks: [Asai.Diagnostic.loctext "can't update units for this item. It is not a tree."]
199
-
| Some expanded ->
200
-
Resource {e with expanded = Some {expanded with units}}
172
+
Reporter.fatal Internal_error
173
+
~extra_remarks:
174
+
[
175
+
Asai.Diagnostic.loctext
176
+
"can't update units for this item. It is not a tree.";
177
+
]
178
+
| Some expanded -> Resource {e with expanded = Some {expanded with units}})
+1
-2
lib/core/Trie.ml
+1
-2
lib/core/Trie.ml
+90
-85
lib/core/Types.ml
+90
-85
lib/core/Types.ml
···
8
8
open Forester_xml_names
9
9
open Base
10
10
11
-
type xml_qname = Forester_xml_names.xml_qname = {prefix: string; uname: string; xmlns: string option}
11
+
type xml_qname = Forester_xml_names.xml_qname = {
12
+
prefix: string;
13
+
uname: string;
14
+
xmlns: string option;
15
+
}
12
16
13
-
type 'content vertex =
14
-
| Uri_vertex of URI.t
15
-
| Content_vertex of 'content
17
+
type 'content vertex = Uri_vertex of URI.t | Content_vertex of 'content
16
18
[@@deriving show, repr]
17
19
18
20
type section_flags = {
···
21
23
header_shown: bool option;
22
24
metadata_shown: bool option;
23
25
numbered: bool option;
24
-
expanded: bool option
26
+
expanded: bool option;
25
27
}
26
28
[@@deriving show, repr]
27
29
28
-
type title_flags = {empty_when_untitled: bool}
29
-
[@@deriving show, repr]
30
+
type title_flags = {empty_when_untitled: bool} [@@deriving show, repr]
30
31
31
-
let default_section_flags = {
32
-
hidden_when_empty = None;
33
-
included_in_toc = None;
34
-
header_shown = None;
35
-
metadata_shown = Some false;
36
-
numbered = None;
37
-
expanded = None
38
-
}
32
+
let default_section_flags =
33
+
{
34
+
hidden_when_empty = None;
35
+
included_in_toc = None;
36
+
header_shown = None;
37
+
metadata_shown = Some false;
38
+
numbered = None;
39
+
expanded = None;
40
+
}
39
41
40
42
type 'content xml_attr = {key: xml_qname; value: 'content}
41
43
[@@deriving show, repr]
···
43
45
type 'content xml_elt = {
44
46
name: xml_qname;
45
47
attrs: 'content xml_attr list;
46
-
content: 'content
48
+
content: 'content;
47
49
}
48
50
[@@deriving show, repr]
49
51
50
-
type attribution_role =
51
-
| Author
52
-
| Contributor
53
-
[@@deriving show, repr]
52
+
type attribution_role = Author | Contributor [@@deriving show, repr]
54
53
55
-
type 'content attribution = {
56
-
role: attribution_role;
57
-
vertex: 'content vertex
58
-
}
54
+
type 'content attribution = {role: attribution_role; vertex: 'content vertex}
59
55
[@@deriving show, repr]
60
56
61
57
type 'content frontmatter = {
···
76
72
type 'content section = {
77
73
frontmatter: 'content frontmatter;
78
74
mainmatter: 'content;
79
-
flags: section_flags
75
+
flags: section_flags;
80
76
}
81
77
[@@deriving show, repr]
82
78
···
87
83
}
88
84
[@@deriving show, repr]
89
85
90
-
type asset = {uri: URI.t; content: string}
91
-
[@@deriving show, repr]
86
+
type asset = {uri: URI.t; content: string} [@@deriving show, repr]
92
87
93
-
type 'a json_blob_syndication = {blob_uri: URI.t; query: (string, 'a vertex) Datalog_expr.query}
88
+
type 'a json_blob_syndication = {
89
+
blob_uri: URI.t;
90
+
query: (string, 'a vertex) Datalog_expr.query;
91
+
}
94
92
[@@deriving show, repr]
95
93
96
94
type atom_feed_syndication = {source_uri: URI.t; feed_uri: URI.t}
···
107
105
| Syndication of 'content syndication
108
106
[@@deriving show, repr]
109
107
110
-
type 'content forest = 'content resource list
111
-
[@@deriving show, repr]
108
+
type 'content forest = 'content resource list [@@deriving show, repr]
112
109
113
110
type content_target =
114
111
| Full of section_flags
···
117
114
| Taxon
118
115
[@@deriving show, repr]
119
116
120
-
type transclusion = {
121
-
href: URI.t;
122
-
target: content_target
123
-
}
117
+
type transclusion = {href: URI.t; target: content_target}
124
118
[@@deriving show, repr]
125
119
126
-
type 'content link = {
127
-
href: URI.t;
128
-
content: 'content
129
-
}
130
-
[@@deriving show, repr]
120
+
type 'content link = {href: URI.t; content: 'content} [@@deriving show, repr]
131
121
132
-
type artefact_source = {
133
-
type_: string;
134
-
part: string;
135
-
source: string
136
-
}
122
+
type artefact_source = {type_: string; part: string; source: string}
137
123
[@@deriving show, repr]
138
124
139
125
type 'content artefact = {
140
126
hash: string;
141
127
content: 'content;
142
-
sources: artefact_source list
128
+
sources: artefact_source list;
143
129
}
144
130
[@@deriving show, repr]
145
131
···
159
145
| Results_of_datalog_query of (string, 'content vertex) Datalog_expr.query
160
146
[@@deriving show, repr]
161
147
162
-
type content =
163
-
Content of content content_node list
164
-
[@@deriving show, repr]
148
+
type content = Content of content content_node list [@@deriving show, repr]
165
149
166
150
let rec compress_nodes = function
167
151
| [] -> []
···
173
157
174
158
let concat_compressed_content (Content xs) (Content ys) =
175
159
let rec loop xs ys =
176
-
match xs, ys with
160
+
match (xs, ys) with
177
161
| Bwd.Emp, ys -> ys
178
162
| _, [] -> Bwd.prepend xs []
179
163
| Bwd.Snoc (xs, Text x), Text y :: ys -> loop xs (Text (x ^ y) :: ys)
···
182
166
Content (loop (Bwd.append Bwd.Emp xs) ys)
183
167
184
168
let html_elt uname (content : 'content) : 'content content_node =
185
-
let name = {prefix = "html"; uname; xmlns = Some "http://www.w3.org/1999/xhtml"} in
169
+
let name =
170
+
{prefix = "html"; uname; xmlns = Some "http://www.w3.org/1999/xhtml"}
171
+
in
186
172
Xml_elt {content; name; attrs = []}
187
173
188
174
let prim (p : Prim.t) : 'content -> 'content content_node =
189
-
html_elt @@
190
-
match p with
191
-
| `P -> "p"
192
-
| `Ol -> "ol"
193
-
| `Ul -> "ul"
194
-
| `Li -> "li"
195
-
| `Figure -> "figure"
196
-
| `Figcaption -> "figcaption"
197
-
| `Em -> "em"
198
-
| `Strong -> "strong"
199
-
| `Blockquote -> "blockquote"
200
-
| `Pre -> "pre"
201
-
| `Code -> "code"
175
+
html_elt
176
+
@@
177
+
match p with
178
+
| `P -> "p"
179
+
| `Ol -> "ol"
180
+
| `Ul -> "ul"
181
+
| `Li -> "li"
182
+
| `Figure -> "figure"
183
+
| `Figcaption -> "figcaption"
184
+
| `Em -> "em"
185
+
| `Strong -> "strong"
186
+
| `Blockquote -> "blockquote"
187
+
| `Pre -> "pre"
188
+
| `Code -> "code"
202
189
203
190
let map_content f = function Content nodes -> Content (f nodes)
204
191
let extract_content = function Content nodes -> nodes
···
206
193
type dx_query = (string, content vertex) Datalog_expr.query [@@deriving show]
207
194
208
195
let is_whitespace node =
209
-
match node with
210
-
| Text txt -> String.trim txt = ""
211
-
| _ -> false
196
+
match node with Text txt -> String.trim txt = "" | _ -> false
212
197
213
198
let strip_whitespace =
214
-
map_content @@
215
-
List.filter @@
216
-
Fun.compose not is_whitespace
199
+
map_content @@ List.filter @@ Fun.compose not is_whitespace
217
200
218
201
let trim_whitespace xs =
219
202
let rec trim_front = function
220
203
| x :: xs when is_whitespace x -> trim_front xs
221
204
| xs -> xs
222
-
and trim_back xs = List.rev @@ trim_front @@ List.rev xs
223
-
in
205
+
and trim_back xs = List.rev @@ trim_front @@ List.rev xs in
224
206
trim_back @@ trim_front xs
225
207
226
-
let default_frontmatter ?uri ?source_path ?designated_parent ?(dates = []) ?(attributions = []) ?taxon ?number ?(metas = []) ?(tags = []) ?title ?last_changed () = {uri; source_path; designated_parent; dates; attributions; taxon; number; metas; tags; title; last_changed}
208
+
let default_frontmatter ?uri ?source_path ?designated_parent ?(dates = [])
209
+
?(attributions = []) ?taxon ?number ?(metas = []) ?(tags = []) ?title
210
+
?last_changed () =
211
+
{
212
+
uri;
213
+
source_path;
214
+
designated_parent;
215
+
dates;
216
+
attributions;
217
+
taxon;
218
+
number;
219
+
metas;
220
+
tags;
221
+
title;
222
+
last_changed;
223
+
}
227
224
228
225
let article_to_section ?(flags = default_section_flags) (article : 'a article) =
229
226
let mainmatter =
···
231
228
| Some href -> Content [Transclude {href; target = Mainmatter}]
232
229
| None -> article.mainmatter
233
230
in
234
-
{
235
-
frontmatter = article.frontmatter;
236
-
mainmatter;
237
-
flags
238
-
}
231
+
{frontmatter = article.frontmatter; mainmatter; flags}
239
232
240
233
let uri_for_syndication = function
241
234
| Atom_feed feed -> Some feed.feed_uri
···
246
239
| Asset asset -> Some asset.uri
247
240
| Syndication syndication -> uri_for_syndication syndication
248
241
249
-
module Comparators (I : sig val string_of_content : content -> string end) = struct
250
-
let compare_content =
251
-
Compare.under I.string_of_content String.compare
242
+
module Comparators (I : sig
243
+
val string_of_content : content -> string
244
+
end) =
245
+
struct
246
+
let compare_content = Compare.under I.string_of_content String.compare
252
247
253
248
let compare_frontmatter =
254
249
let latest_date (fm : content frontmatter) =
255
-
let sorted_dates = fm.dates |> List.sort @@ Compare.invert Human_datetime.compare in
250
+
let sorted_dates =
251
+
fm.dates |> List.sort @@ Compare.invert Human_datetime.compare
252
+
in
256
253
List.nth_opt sorted_dates 0
257
254
in
258
-
let by_date = Fun.flip @@ Compare.under latest_date @@ Compare.option Human_datetime.compare in
259
-
let by_title = Compare.option compare_content |> Compare.under @@ fun fm -> fm.title in
260
-
let by_parent = compare |> Compare.under @@ fun fm -> Option.is_some fm.designated_parent in
255
+
let by_date =
256
+
Fun.flip @@ Compare.under latest_date
257
+
@@ Compare.option Human_datetime.compare
258
+
in
259
+
let by_title =
260
+
Compare.option compare_content |> Compare.under @@ fun fm -> fm.title
261
+
in
262
+
let by_parent =
263
+
compare |> Compare.under @@ fun fm -> Option.is_some fm.designated_parent
264
+
in
261
265
Compare.cascade by_parent @@ Compare.cascade by_date by_title
262
266
263
-
let compare_article = compare_frontmatter |> Compare.under @@ fun x -> x.frontmatter
267
+
let compare_article =
268
+
compare_frontmatter |> Compare.under @@ fun x -> x.frontmatter
264
269
end
+36
-48
lib/core/URI.ml
+36
-48
lib/core/URI.ml
···
18
18
let hydrate {scheme; userinfo; host; port; path; query; fragment} =
19
19
Uri.make ?scheme ?userinfo ?host ?port ~path ~query ?fragment ()
20
20
21
-
let dehydrate x = {
22
-
scheme = Uri.scheme x;
23
-
userinfo = Uri.userinfo x;
24
-
host = Uri.host x;
25
-
port = Uri.port x;
26
-
path = Uri.path x;
27
-
query = Uri.query x;
28
-
fragment = Uri.fragment x
29
-
}
21
+
let dehydrate x =
22
+
{
23
+
scheme = Uri.scheme x;
24
+
userinfo = Uri.userinfo x;
25
+
host = Uri.host x;
26
+
port = Uri.port x;
27
+
path = Uri.path x;
28
+
query = Uri.query x;
29
+
fragment = Uri.fragment x;
30
+
}
30
31
31
32
let host x = x.host
32
33
let scheme x = x.scheme
33
34
let port x = x.port
34
-
35
-
let path_components x =
36
-
String.split_on_char '/' @@ Uri.pct_decode x.path
35
+
let path_components x = String.split_on_char '/' @@ Uri.pct_decode x.path
37
36
38
37
let rec strip_path_components xs =
39
-
match xs with
40
-
| "" :: xs -> strip_path_components xs
41
-
| xs -> xs
38
+
match xs with "" :: xs -> strip_path_components xs | xs -> xs
42
39
43
-
let stripped_path_components x =
44
-
strip_path_components @@ path_components x
45
-
46
-
let path_string x =
47
-
String.concat "/" @@ path_components x
40
+
let stripped_path_components x = strip_path_components @@ path_components x
41
+
let path_string x = String.concat "/" @@ path_components x
48
42
49
43
let append_path_component xs x =
50
-
List.rev @@ x :: strip_path_components (List.rev xs)
44
+
List.rev @@ (x :: strip_path_components (List.rev xs))
51
45
52
-
let equal = (=)
46
+
let equal = ( = )
53
47
let compare = compare
54
-
55
-
let resolve ~base x =
56
-
dehydrate @@ Uri.resolve "" (hydrate base) (hydrate x)
57
-
48
+
let resolve ~base x = dehydrate @@ Uri.resolve "" (hydrate base) (hydrate x)
58
49
let canonicalise uri = dehydrate @@ Uri.canonicalize @@ hydrate uri
59
50
let hash (uri : t) = Hashtbl.hash uri
60
51
61
52
let with_path_components xs uri =
62
-
dehydrate @@
63
-
Uri.canonicalize @@
64
-
Uri.with_path (hydrate uri) @@ String.concat "/" xs
53
+
dehydrate @@ Uri.canonicalize
54
+
@@ Uri.with_path (hydrate uri)
55
+
@@ String.concat "/" xs
65
56
66
57
let pp (fmt : Format.formatter) (uri : t) =
67
-
Format.fprintf fmt "%s" @@
68
-
Uri.pct_decode @@ Uri.to_string @@ hydrate uri
58
+
Format.fprintf fmt "%s" @@ Uri.pct_decode @@ Uri.to_string @@ hydrate uri
69
59
70
-
let to_string x =
71
-
Uri.pct_decode @@ Uri.to_string @@ hydrate x
72
-
60
+
let to_string x = Uri.pct_decode @@ Uri.to_string @@ hydrate x
73
61
let t = Repr.map Repr.string (Fun.compose dehydrate Uri.of_string) to_string
74
-
75
-
let of_string_exn str =
76
-
dehydrate @@ Uri.canonicalize @@ Uri.of_string str
62
+
let of_string_exn str = dehydrate @@ Uri.canonicalize @@ Uri.of_string str
77
63
78
64
let make ?scheme ?user ?host ?port ?path () =
79
65
let path = Option.map (String.concat "/") path in
80
-
dehydrate @@ Uri.canonicalize @@ Uri.make ?scheme ?userinfo: user ?host ?port ?path ()
66
+
dehydrate @@ Uri.canonicalize
67
+
@@ Uri.make ?scheme ?userinfo:user ?host ?port ?path ()
81
68
82
69
let relative_path_string ~(base : t) uri : string =
83
-
Str.replace_first (Str.regexp (Format.asprintf "^%a" pp base)) "" @@
84
-
to_string uri
70
+
Str.replace_first (Str.regexp (Format.asprintf "^%a" pp base)) ""
71
+
@@ to_string uri
85
72
86
73
let display_path_string ~base uri =
87
74
if host uri = host base then
88
-
Str.replace_first (Str.regexp (Format.asprintf "^%a" pp base)) "" @@
89
-
to_string @@ with_path_components (List.rev @@ strip_path_components @@ List.rev @@ path_components uri) uri
90
-
else
91
-
to_string uri
75
+
Str.replace_first (Str.regexp (Format.asprintf "^%a" pp base)) ""
76
+
@@ to_string
77
+
@@ with_path_components
78
+
(List.rev @@ strip_path_components @@ List.rev @@ path_components uri)
79
+
uri
80
+
else to_string uri
92
81
end
93
82
94
-
module Set = Set.Make(Basics)
95
-
module Map = Map.Make(Basics)
96
-
module Tbl = Hashtbl.Make(Basics)
97
-
83
+
module Set = Set.Make (Basics)
84
+
module Map = Map.Make (Basics)
85
+
module Tbl = Hashtbl.Make (Basics)
98
86
include Basics
+8
-9
lib/core/URI.mli
+8
-9
lib/core/URI.mli
···
13
13
val append_path_component : string list -> string -> string list
14
14
val path_components : t -> string list
15
15
val with_path_components : string list -> t -> t
16
-
17
16
val canonicalise : t -> t
18
-
val relative_path_string : base: t -> t -> string
19
-
val display_path_string : base: t -> t -> string
20
-
val resolve : base: t -> t -> t
17
+
val relative_path_string : base:t -> t -> string
18
+
val display_path_string : base:t -> t -> string
19
+
val resolve : base:t -> t -> t
21
20
val equal : t -> t -> bool
22
21
val compare : t -> t -> int
23
22
24
23
val make :
25
-
?scheme: string ->
26
-
?user: string ->
27
-
?host: string ->
28
-
?port: int ->
29
-
?path: string list ->
24
+
?scheme:string ->
25
+
?user:string ->
26
+
?host:string ->
27
+
?port:int ->
28
+
?path:string list ->
30
29
unit ->
31
30
t
32
31
+15
-27
lib/core/URI_scheme.ml
+15
-27
lib/core/URI_scheme.ml
···
7
7
open Forester_prelude
8
8
9
9
let named_uri ~base name =
10
-
URI.resolve ~base @@
11
-
let path =
12
-
if Filename.extension name = "" then [name; ""] else [name]
13
-
in
14
-
URI.make ~path ()
10
+
URI.resolve ~base
11
+
@@
12
+
let path = if Filename.extension name = "" then [name; ""] else [name] in
13
+
URI.make ~path ()
15
14
16
-
let last_segment str =
17
-
str
18
-
|> String.split_on_char '/'
19
-
|> List.rev
20
-
|> List.hd
15
+
let last_segment str = str |> String.split_on_char '/' |> List.rev |> List.hd
21
16
22
17
let name (uri : URI.t) : string option =
23
-
uri
24
-
|> URI.path_components
18
+
uri |> URI.path_components
25
19
|> List.filter (fun x -> not (x = ""))
26
-
|> List.rev
27
-
|> (List.nth_opt @~ 0)
20
+
|> List.rev |> List.nth_opt @~ 0
28
21
29
22
let split_addr (uri : URI.t) : (string option * int) option =
30
23
let@ name = Option.bind @@ name uri in
31
24
(* primitively check for address of form YYYY-MM-DD *)
32
-
let date_regex = Str.regexp {|^[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]$|} in
25
+
let date_regex =
26
+
Str.regexp {|^[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]$|}
27
+
in
33
28
if Str.string_match date_regex name 0 then None
34
29
else
35
30
match String.rindex_opt name '-' with
36
31
| Some i ->
37
32
let prefix = String.sub name 0 i
38
-
and suffix = String.sub name (i + 1) (String.length name - i - 1)
39
-
in
33
+
and suffix = String.sub name (i + 1) (String.length name - i - 1) in
40
34
let@ key = Option.map @~ BaseN.Base36.int_of_string suffix in
41
-
Some prefix, key
35
+
(Some prefix, key)
42
36
| _ ->
43
37
let@ key = Option.map @~ BaseN.Base36.int_of_string name in
44
-
None, key
38
+
(None, key)
45
39
46
40
let lsp_uri_to_uri ~(base : URI.t) (uri : Lsp.Uri.t) : URI.t =
47
41
let uri =
48
-
uri
49
-
|> Lsp.Uri.to_path
50
-
|> Filename.chop_extension
51
-
|> last_segment
42
+
uri |> Lsp.Uri.to_path |> Filename.chop_extension |> last_segment
52
43
|> named_uri ~base
53
44
in
54
45
uri
55
46
56
47
let path_to_uri ~(base : URI.t) str =
57
-
str
58
-
|> last_segment
59
-
|> Filename.chop_extension
60
-
|> named_uri ~base
48
+
str |> last_segment |> Filename.chop_extension |> named_uri ~base
+4
-19
lib/core/URI_scheme.mli
+4
-19
lib/core/URI_scheme.mli
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
val named_uri :
8
-
base: URI.t ->
9
-
string ->
10
-
URI.t
11
-
12
-
val lsp_uri_to_uri :
13
-
base: URI.t ->
14
-
Lsp.Uri.t ->
15
-
URI.t
16
-
17
-
val split_addr :
18
-
URI.t ->
19
-
(string option * int) option
20
-
21
-
val path_to_uri :
22
-
base: URI.t ->
23
-
string ->
24
-
URI.t
25
-
7
+
val named_uri : base:URI.t -> string -> URI.t
8
+
val lsp_uri_to_uri : base:URI.t -> Lsp.Uri.t -> URI.t
9
+
val split_addr : URI.t -> (string option * int) option
10
+
val path_to_uri : base:URI.t -> string -> URI.t
26
11
val last_segment : string -> string
27
12
val name : URI.t -> string option
+12
-11
lib/core/Value.ml
+12
-11
lib/core/Value.ml
···
7
7
open Forester_prelude
8
8
open Base
9
9
10
-
open struct module T = Types end
10
+
open struct
11
+
module T = Types
12
+
end
11
13
12
-
module String_map = Map.Make(String)
13
-
module Symbol_map = Map.Make(Symbol)
14
+
module String_map = Map.Make (String)
15
+
module Symbol_map = Map.Make (Symbol)
14
16
15
17
type t =
16
18
| Content of T.content
17
-
| Clo of (t String_map.t [@opaque]) * string option binding list * Syn.t
19
+
| Clo of (t String_map.t[@opaque]) * string option binding list * Syn.t
18
20
| Dx_prop of (string, T.content T.vertex) Datalog_expr.prop
19
21
| Dx_sequent of (string, T.content T.vertex) Datalog_expr.sequent
20
22
| Dx_query of (string, T.content T.vertex) Datalog_expr.query
···
28
30
body: Syn.t;
29
31
self: string option;
30
32
super: string option;
31
-
env: t String_map.t [@opaque]
33
+
env: t String_map.t; [@opaque]
32
34
}
33
35
[@@deriving show]
34
36
35
37
module Method_table = struct
36
-
include Map.Make(String)
37
-
let pp (pp_el : Format.formatter -> 'a -> unit) (fmt : Format.formatter) (map : 'a t) =
38
+
include Map.Make (String)
39
+
40
+
let pp (pp_el : Format.formatter -> 'a -> unit) (fmt : Format.formatter)
41
+
(map : 'a t) =
38
42
Format.fprintf fmt "@[<v1>{";
39
43
begin
40
44
let@ k, v = Seq.iter @~ to_seq map in
···
43
47
Format.fprintf fmt "}@]"
44
48
end
45
49
46
-
type obj = {
47
-
prototype: Symbol.t option;
48
-
methods: obj_method Method_table.t
49
-
}
50
+
type obj = {prototype: Symbol.t option; methods: obj_method Method_table.t}
50
51
[@@deriving show]
+1
-3
lib/core/Vertex.ml
+1
-3
lib/core/Vertex.ml
···
6
6
7
7
open Types
8
8
9
-
type t = content vertex
10
-
[@@deriving show]
9
+
type t = content vertex [@@deriving show]
11
10
12
11
let clean = function
13
12
| Content_vertex x -> Content_vertex x
14
13
| Uri_vertex uri -> Uri_vertex uri
15
14
16
15
let hash x = Hashtbl.hash (clean x)
17
-
18
16
let compare x y = compare (clean x) (clean y)
19
17
let equal x y = clean x = clean y
20
18
+2
-2
lib/core/Vertex.mli
+2
-2
lib/core/Vertex.mli
+1
-1
lib/core/Vertex_set.ml
+1
-1
lib/core/Vertex_set.ml
-4
lib/core/Vertex_set.mli
-4
lib/core/Vertex_set.mli
···
9
9
val empty : t
10
10
val add : Vertex.t -> t -> t
11
11
val diff : t -> t -> t
12
-
13
12
val of_list : Vertex.t list -> t
14
13
val to_list : t -> Vertex.t list
15
14
val to_seq : t -> Vertex.t Seq.t
16
15
val of_seq : Vertex.t Seq.t -> t
17
16
val union : t -> t -> t
18
17
val filter : (Vertex.t -> bool) -> t -> t
19
-
20
18
val elements : t -> Vertex.t list
21
-
22
19
val cardinal : t -> int
23
-
24
20
val mem : Vertex.t -> t -> bool
25
21
val fold : (Vertex.t -> 'acc -> 'acc) -> t -> 'acc -> 'acc
26
22
val iter : (Vertex.t -> unit) -> t -> unit
+9
-11
lib/core/test/Test_uri_util.ml
+9
-11
lib/core/test/Test_uri_util.ml
···
6
6
7
7
open Forester_core
8
8
9
-
10
9
let test_split_addr_1 () =
11
10
let uri = URI.of_string_exn "forest://test/foo-bar" in
12
11
Alcotest.(check @@ option @@ pair (option string) int)
···
44
43
45
44
let () =
46
45
let open Alcotest in
47
-
run
48
-
"Test_uri_util"
46
+
run "Test_uri_util"
49
47
[
50
-
"split_addr",
51
-
[
52
-
test_case "split_addr" `Quick test_split_addr_1;
53
-
test_case "split_addr" `Quick test_split_addr_2;
54
-
test_case "split_addr" `Quick test_split_addr_3;
55
-
test_case "split_addr" `Quick test_split_addr_4;
56
-
test_case "split_addr" `Quick test_split_addr_5;
57
-
]
48
+
( "split_addr",
49
+
[
50
+
test_case "split_addr" `Quick test_split_addr_1;
51
+
test_case "split_addr" `Quick test_split_addr_2;
52
+
test_case "split_addr" `Quick test_split_addr_3;
53
+
test_case "split_addr" `Quick test_split_addr_4;
54
+
test_case "split_addr" `Quick test_split_addr_5;
55
+
] );
58
56
]
+62
-57
lib/frontend/Atom_client.ml
+62
-57
lib/frontend/Atom_client.ml
···
17
17
let null = P.HTML.null
18
18
19
19
let feed attrs =
20
-
P.std_tag "feed" @@
21
-
P.string_attr "xmlns" "http://www.w3.org/2005/Atom" :: attrs
20
+
P.std_tag "feed"
21
+
@@ (P.string_attr "xmlns" "http://www.w3.org/2005/Atom" :: attrs)
22
22
23
23
let title fmt = P.text_tag "title" fmt
24
24
let link = P.void_tag "link"
25
-
26
25
let href fmt = P.string_attr "href" fmt
27
-
28
26
let updated fmt = P.text_tag "updated" fmt
29
27
let published fmt = P.text_tag "published" fmt
30
28
let author = P.std_tag "author"
···
40
38
let rel fmt = P.string_attr "rel" fmt
41
39
end
42
40
43
-
open struct module A = Atom end
41
+
open struct
42
+
module A = Atom
43
+
end
44
44
45
-
let get_date_range (dates : Human_datetime.t list) : (Human_datetime.t * Human_datetime.t) option =
45
+
let get_date_range (dates : Human_datetime.t list) :
46
+
(Human_datetime.t * Human_datetime.t) option =
46
47
let sorted = List.sort Human_datetime.compare dates in
47
48
let@ first = Option.bind @@ List.nth_opt sorted 0 in
48
49
let@ last = Option.bind @@ List.nth_opt (List.rev sorted) 0 in
49
50
Some (first, last)
50
51
51
52
let render_title forest ?scope (frontmatter : _ T.frontmatter) =
52
-
A.title
53
-
[]
54
-
"%s" @@
55
-
Plain_text_client.string_of_content ~forest @@
56
-
State.get_expanded_title ?scope frontmatter forest
53
+
A.title [] "%s"
54
+
@@ Plain_text_client.string_of_content ~forest
55
+
@@ State.get_expanded_title ?scope frontmatter forest
57
56
58
57
let render_dates_exn dates =
59
58
match get_date_range dates with
···
61
60
| Some (oldest, newest) ->
62
61
A.null
63
62
[
64
-
A.published [] "%s" @@ Format.asprintf "%a" Human_datetime.pp_rfc_3399 oldest;
65
-
A.updated [] "%s" @@ Format.asprintf "%a" Human_datetime.pp_rfc_3399 newest
63
+
A.published [] "%s"
64
+
@@ Format.asprintf "%a" Human_datetime.pp_rfc_3399 oldest;
65
+
A.updated [] "%s"
66
+
@@ Format.asprintf "%a" Human_datetime.pp_rfc_3399 newest;
66
67
]
67
68
68
69
let render_updated_date dates =
69
70
let sorted_dates = List.sort Human_datetime.compare dates in
70
71
match List.nth_opt (List.rev sorted_dates) 0 with
71
72
| None -> A.null []
72
-
| Some newest -> A.updated [] "%s" @@ Format.asprintf "%a" Human_datetime.pp newest
73
-
74
-
let render_dates dates =
75
-
try render_dates_exn dates with _ -> A.null []
73
+
| Some newest ->
74
+
A.updated [] "%s" @@ Format.asprintf "%a" Human_datetime.pp newest
76
75
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
79
let render_attribution forest (attribution : _ T.attribution) =
···
87
87
| T.Content_vertex content ->
88
88
[A.name [] "%s" @@ string_of_content forest content]
89
89
| T.Uri_vertex href ->
90
-
let content = T.Content [T.Transclude {href; target = Title {empty_when_untitled = false}}] in
91
-
[A.name [] "%s" @@ string_of_content forest content; A.uri [] "%s" @@ URI.to_string href]
90
+
let content =
91
+
T.Content
92
+
[T.Transclude {href; target = Title {empty_when_untitled = false}}]
93
+
in
94
+
[
95
+
A.name [] "%s" @@ string_of_content forest content;
96
+
A.uri [] "%s" @@ URI.to_string href;
97
+
]
92
98
in
93
99
tag [] body
94
100
95
101
let render_attributions (forest : State.t) uri_opt attributions : P.node =
96
-
A.null @@
97
-
List.map (render_attribution forest) @@
98
-
Forest_util.collect_attributions forest uri_opt attributions
102
+
A.null
103
+
@@ List.map (render_attribution forest)
104
+
@@ Forest_util.collect_attributions forest uri_opt attributions
99
105
100
106
let get_embedded_articles (forest : State.t) (article : _ T.article) =
101
107
let visit_node = function
102
108
| T.Transclude {href; target = Full _; _} ->
103
109
Vertex_set.add @@ Uri_vertex href
104
110
| T.Section section ->
105
-
Option.fold ~none: Fun.id ~some: (fun x -> Vertex_set.add @@ T.Uri_vertex x) section.frontmatter.uri
111
+
Option.fold ~none:Fun.id
112
+
~some:(fun x -> Vertex_set.add @@ T.Uri_vertex x)
113
+
section.frontmatter.uri
106
114
| T.Results_of_datalog_query query ->
107
115
Vertex_set.union @@ Forest.run_datalog_query forest.graphs query
108
116
| _ -> Fun.id
109
117
in
110
-
let vertices = List.fold_left (Fun.flip visit_node) Vertex_set.empty @@ T.extract_content article.mainmatter in
118
+
let vertices =
119
+
List.fold_left (Fun.flip visit_node) Vertex_set.empty
120
+
@@ T.extract_content article.mainmatter
121
+
in
111
122
Forest_util.get_sorted_articles forest vertices
112
123
113
-
let render_entry ~(forest : State.t) ?(scope : URI.t option) (article : T.content T.article) : P.node =
114
-
A.entry
115
-
[]
124
+
let render_entry ~(forest : State.t) ?(scope : URI.t option)
125
+
(article : T.content T.article) : P.node =
126
+
A.entry []
116
127
[
117
128
render_title forest ?scope article.frontmatter;
118
129
render_dates article.frontmatter.dates;
119
-
render_attributions forest article.frontmatter.uri article.frontmatter.attributions;
120
-
begin
121
-
match article.frontmatter.uri with
122
-
| None -> A.null []
123
-
| Some uri ->
124
-
let uri_string = URI.to_string uri in
125
-
A.null
126
-
[
127
-
A.link
128
-
[
129
-
A.rel "alternate";
130
-
A.type_ "text/html";
131
-
A.href "%s" uri_string
132
-
];
133
-
A.id [] "%s" uri_string
134
-
]
130
+
render_attributions forest article.frontmatter.uri
131
+
article.frontmatter.attributions;
132
+
begin match article.frontmatter.uri with
133
+
| None -> A.null []
134
+
| Some uri ->
135
+
let uri_string = URI.to_string uri in
136
+
A.null
137
+
[
138
+
A.link
139
+
[A.rel "alternate"; A.type_ "text/html"; A.href "%s" uri_string];
140
+
A.id [] "%s" uri_string;
141
+
]
135
142
end;
136
143
A.content
137
-
[
138
-
A.type_ "xhtml"
139
-
]
140
-
[
141
-
Html_client.render_article_as_div ~heading_level: 1 forest article
142
-
]
144
+
[A.type_ "xhtml"]
145
+
[Html_client.render_article_as_div ~heading_level:1 forest article];
143
146
]
144
147
145
-
let render_feed (forest : State.t) ~(source_uri : URI.t) ~(feed_uri : URI.t) : P.node =
148
+
let render_feed (forest : State.t) ~(source_uri : URI.t) ~(feed_uri : URI.t) :
149
+
P.node =
146
150
match State.get_article source_uri forest with
147
151
| None -> Reporter.fatal @@ Resource_not_found source_uri
148
152
| Some blog ->
149
153
let articles = get_embedded_articles forest blog in
150
154
let all_dates =
151
-
let@ article = List.concat_map @~ blog :: articles in
155
+
let@ article = List.concat_map @~ (blog :: articles) in
152
156
article.frontmatter.dates
153
157
in
154
158
let blog_uri_string = URI.to_string source_uri in
155
-
A.feed
156
-
[]
159
+
A.feed []
157
160
[
158
-
render_attributions forest blog.frontmatter.uri blog.frontmatter.attributions;
161
+
render_attributions forest blog.frontmatter.uri
162
+
blog.frontmatter.attributions;
159
163
render_updated_date all_dates;
160
164
render_title forest blog.frontmatter;
161
165
A.id [] "%s" blog_uri_string;
162
166
A.link [A.rel "alternate"; A.href "%s" blog_uri_string];
163
167
A.link [A.rel "self"; A.href "%s" @@ URI.to_string feed_uri];
164
-
A.null @@
165
-
let@ article = List.map @~ articles in
166
-
render_entry ~forest ~scope: source_uri article
168
+
(A.null
169
+
@@
170
+
let@ article = List.map @~ articles in
171
+
render_entry ~forest ~scope:source_uri article);
167
172
]
+36
-39
lib/frontend/Config_parser.ml
+36
-39
lib/frontend/Config_parser.ml
···
7
7
open Forester_prelude
8
8
open Forester_core
9
9
10
-
(* type keys = (Toml.Types.Table.key [@printer fun fmt key -> fprintf fmt "%s" (Toml.Types.Table.Key.to_string key)]) list list [@@deriving show] *)
10
+
(* type keys = (Toml.Types.Table.key
11
+
[@printer fun fmt key -> fprintf fmt "%s" (Toml.Types.Table.Key.to_string
12
+
key)]) list list [@@deriving show] *)
11
13
12
14
module Key_set = struct
13
-
include Set.Make(struct
15
+
include Set.Make (struct
14
16
type t = Toml.Types.Table.key list
17
+
15
18
let compare = compare
16
19
end)
17
20
18
-
let remove : string list -> t -> t = fun strs set ->
21
+
let remove : string list -> t -> t =
22
+
fun strs set ->
19
23
let key = List.map Toml.Types.Table.Key.of_string strs in
20
24
remove key set
21
25
end
···
23
27
let keys (tbl : Toml.Types.value Toml.Types.Table.t) =
24
28
let rec go current keys tbl =
25
29
List.fold_left
26
-
begin
27
-
fun acc (key, value) ->
28
-
match value with
29
-
| Toml.Types.TBool _
30
-
| TInt _
31
-
| TFloat _
32
-
| TString _
33
-
| TDate _
34
-
| TArray _ ->
35
-
(key :: current) :: acc
36
-
| TTable tbl ->
37
-
go (key :: current) acc tbl
30
+
begin fun acc (key, value) ->
31
+
match value with
32
+
| Toml.Types.TBool _ | TInt _ | TFloat _ | TString _ | TDate _
33
+
| TArray _ ->
34
+
(key :: current) :: acc
35
+
| TTable tbl -> go (key :: current) acc tbl
38
36
end
39
37
keys
40
38
(Toml.Types.Table.to_list tbl)
···
46
44
match Toml.Parser.parse lexbuf filename with
47
45
| `Error (desc, {source; _}) ->
48
46
let@ () = Reporter.tracef "when parsing configuration file" in
49
-
let loc = Asai.Range.of_lexbuf ~source: (`File source) lexbuf in
50
-
Reporter.fatal ~loc Configuration_error ~extra_remarks: [Asai.Diagnostic.loctextf "%s" desc]
47
+
let loc = Asai.Range.of_lexbuf ~source:(`File source) lexbuf in
48
+
Reporter.fatal ~loc Configuration_error
49
+
~extra_remarks:[Asai.Diagnostic.loctextf "%s" desc]
51
50
| `Ok tbl ->
52
51
let open Toml.Lenses in
53
52
let keys = ref (keys tbl) in
···
67
66
match get tbl (forest |-- key "url" |-- string) with
68
67
| Some url ->
69
68
keys := Key_set.remove k !keys;
70
-
begin
71
-
try
72
-
URI.of_string_exn url
73
-
with
74
-
| _ -> Reporter.fatal Configuration_error ~extra_remarks: [Asai.Diagnostic.loctext "Invalid URL specified in `url` key."]
69
+
begin try URI.of_string_exn url
70
+
with _ ->
71
+
Reporter.fatal Configuration_error
72
+
~extra_remarks:
73
+
[Asai.Diagnostic.loctext "Invalid URL specified in `url` key."]
75
74
end
76
75
| None ->
77
76
Reporter.emit (Using_default_option k);
···
80
79
let default = Config.default ~url () in
81
80
let trees =
82
81
let k = ["forest"; "trees"] in
83
-
with_default ~value: default.trees k (forest |-- key "trees" |-- array |-- strings)
82
+
with_default ~value:default.trees k
83
+
(forest |-- key "trees" |-- array |-- strings)
84
84
in
85
85
let foreign =
86
86
let k = ["forest"; "foreign"] in
···
107
107
Config.{path; route_locally; include_in_manifest}
108
108
in
109
109
let assets =
110
-
with_default
111
-
~value: default.assets
112
-
["forest"; "assets"]
110
+
with_default ~value:default.assets ["forest"; "assets"]
113
111
(forest |-- key "assets" |-- array |-- strings)
114
112
in
115
113
let home =
116
114
let k = ["forest"; "home"] in
117
-
URI_scheme.named_uri ~base: url @@
118
-
with_default ~value: "index" k (forest |-- key "home" |-- string)
115
+
URI_scheme.named_uri ~base:url
116
+
@@ with_default ~value:"index" k (forest |-- key "home" |-- string)
119
117
in
120
-
begin
121
-
if not (Key_set.is_empty !keys) then
122
-
let keys =
123
-
!keys
124
-
|> Key_set.to_list
125
-
|> List.map (List.map (Toml.Types.Table.Key.to_string))
126
-
in
127
-
Reporter.emit (Uninterpreted_config_options keys);
118
+
begin if not (Key_set.is_empty !keys) then
119
+
let keys =
120
+
!keys |> Key_set.to_list
121
+
|> List.map (List.map Toml.Types.Table.Key.to_string)
122
+
in
123
+
Reporter.emit (Uninterpreted_config_options keys)
128
124
end;
129
125
Config.{url; assets; trees; foreign; home}
130
126
···
135
131
let parse_forest_config_file filename =
136
132
try
137
133
let ch = open_in filename in
138
-
let@ () = Fun.protect ~finally: (fun _ -> close_in ch) in
134
+
let@ () = Fun.protect ~finally:(fun _ -> close_in ch) in
139
135
let lexbuf = Lexing.from_channel ch in
140
136
let result = parse lexbuf filename in
141
137
Sys.chdir @@ Filename.dirname filename;
142
138
result
143
-
with
144
-
| exn -> Reporter.fatal Configuration_error ~extra_remarks: [Asai.Diagnostic.loctextf "%a" Eio.Exn.pp exn]
139
+
with exn ->
140
+
Reporter.fatal Configuration_error
141
+
~extra_remarks:[Asai.Diagnostic.loctextf "%a" Eio.Exn.pp exn]
+13
-42
lib/frontend/DSL.ml
+13
-42
lib/frontend/DSL.ml
···
8
8
9
9
open Forester_core
10
10
11
-
open struct module T = Types end
11
+
open struct
12
+
module T = Types
13
+
end
12
14
13
15
let txt str = T.Text str
14
-
15
16
let p content = T.prim `P @@ T.Content content
16
17
let ul content = T.prim `Ul @@ T.Content content
17
18
let ol content = T.prim `Ol @@ T.Content content
···
30
31
31
32
module Datalog = struct
32
33
open Datalog_expr
34
+
33
35
let premises ~rel ~args = {rel; args}
34
36
let prop premises conclusion = {premises; conclusion}
35
37
let const v = Const v
···
37
39
38
40
let datalog_script script = T.Datalog_script script
39
41
40
-
let section
41
-
~mainmatter
42
-
?(frontmatter = T.default_frontmatter ())
43
-
?(flags = T.default_section_flags)
44
-
()
45
-
=
46
-
T.Section
47
-
{
48
-
frontmatter;
49
-
mainmatter = T.Content mainmatter;
50
-
flags;
51
-
}
42
+
let section ~mainmatter ?(frontmatter = T.default_frontmatter ())
43
+
?(flags = T.default_section_flags) () =
44
+
T.Section {frontmatter; mainmatter = T.Content mainmatter; flags}
52
45
53
46
let xml_elt (prefix, uname) content =
54
-
let prefix = Option.value ~default: "" prefix in
47
+
let prefix = Option.value ~default:"" prefix in
55
48
let qname = T.{prefix; uname; xmlns = None} in
56
-
T.Xml_elt
57
-
{
58
-
name = qname;
59
-
attrs = [];
60
-
content = T.Content content
61
-
}
49
+
T.Xml_elt {name = qname; attrs = []; content = T.Content content}
62
50
63
51
let transclude href =
64
-
T.Transclude
65
-
T.{
66
-
href = URI.of_string_exn href;
67
-
target = Mainmatter
68
-
}
52
+
T.Transclude T.{href = URI.of_string_exn href; target = Mainmatter}
69
53
70
54
let artefact content =
71
-
T.Artefact
72
-
T.{
73
-
hash = "";
74
-
content = Content content;
75
-
sources = []
76
-
}
55
+
T.Artefact T.{hash = ""; content = Content content; sources = []}
77
56
78
57
let link href content =
79
-
T.Link
80
-
{
81
-
href = URI.of_string_exn href;
82
-
content = T.Content content;
83
-
}
58
+
T.Link {href = URI.of_string_exn href; content = T.Content content}
84
59
85
60
module Code = struct
86
61
open Code
···
88
63
89
64
let import_private = Fun.compose (locate_opt None) @@ Code.import_private
90
65
let import_public = Fun.compose (locate_opt None) @@ Code.import_public
91
-
92
66
let inline_math = Fun.compose (locate_opt None) @@ Code.inline_math
93
67
let display_math = Fun.compose (locate_opt None) @@ Code.display_math
94
68
let parens = Fun.compose (locate_opt None) @@ Code.parens
95
69
let squares = Fun.compose (locate_opt None) @@ Code.squares
96
70
let braces = Fun.compose (locate_opt None) @@ Code.braces
97
-
98
71
let ident i = locate_opt None @@ Ident i
99
72
let hash_ident str = locate_opt None @@ Hash_ident str
100
-
101
73
let ul = ident ["ul"]
102
74
let li = ident ["li"]
103
75
let text str = locate_opt None @@ Text str
···
114
86
module Syn = struct
115
87
open Forester_core.Syn
116
88
open Asai.Range
89
+
117
90
let fun_ b t = locate_opt None @@ Fun (b, t)
118
91
let prim p = locate_opt None @@ Prim p
119
-
120
92
let text s = locate_opt None @@ Text s
121
-
122
93
let parens e = locate_opt None @@ Group (Parens, e)
123
94
let squares e = locate_opt None @@ Group (Squares, e)
124
95
let braces e = locate_opt None @@ Group (Braces, e)
+24
-11
lib/frontend/Forest_util.ml
+24
-11
lib/frontend/Forest_util.ml
···
7
7
open Forester_prelude
8
8
open Forester_core
9
9
open Forester_compiler
10
-
open struct module T = Types end
10
+
11
+
open struct
12
+
module T = Types
13
+
end
11
14
12
15
let compare_article ~forest =
13
-
let module C = Types.Comparators(struct
16
+
let module C = Types.Comparators (struct
14
17
let string_of_content x = Plain_text_client.string_of_content ~forest x
15
18
end) in
16
19
C.compare_article
17
20
18
21
let get_sorted_articles (forest : State.t) addrs =
19
-
addrs
20
-
|> Vertex_set.to_seq
22
+
addrs |> Vertex_set.to_seq
21
23
|> Seq.filter_map Vertex.uri_of_vertex
22
24
|> Seq.filter_map (fun uri -> State.get_article uri forest)
23
25
|> List.of_seq
24
26
|> List.sort (compare_article ~forest)
25
27
26
-
let collect_attributions (forest : State.t) (uri_opt : URI.t option) (primary_attributions : _ T.attribution list) =
28
+
let collect_attributions (forest : State.t) (uri_opt : URI.t option)
29
+
(primary_attributions : _ T.attribution list) =
27
30
match uri_opt with
28
31
| None -> primary_attributions
29
32
| Some uri ->
···
31
34
let open Datalog_expr.Notation in
32
35
let articles =
33
36
let x = "X" in
34
-
let positives = [Builtin_relation.has_indirect_contributor @* [const (T.Uri_vertex uri); var x]] in
37
+
let positives =
38
+
[
39
+
Builtin_relation.has_indirect_contributor
40
+
@* [const (T.Uri_vertex uri); var x];
41
+
]
42
+
in
35
43
let negatives = [] in
36
44
Datalog_expr.{var = x; positives; negatives}
37
45
|> Forest.run_datalog_query forest.graphs
···
41
49
let@ uri = Option.map @~ biotree.frontmatter.uri in
42
50
T.{vertex = T.Uri_vertex uri; role = Contributor}
43
51
in
44
-
primary_attributions @
45
-
let@ attribution = List.filter_map @~ indirect_attributions in
46
-
if List.exists (fun (existing : _ T.attribution) -> Vertex.equal attribution.vertex existing.vertex) primary_attributions then None
47
-
else
48
-
Some attribution
52
+
primary_attributions
53
+
@
54
+
let@ attribution = List.filter_map @~ indirect_attributions in
55
+
if
56
+
List.exists
57
+
(fun (existing : _ T.attribution) ->
58
+
Vertex.equal attribution.vertex existing.vertex)
59
+
primary_attributions
60
+
then None
61
+
else Some attribution
+101
-70
lib/frontend/Forester.ml
+101
-70
lib/frontend/Forester.ml
···
16
16
17
17
type env = Eio_unix.Stdenv.base
18
18
type dir = Eio.Fs.dir_ty EP.t
19
-
20
19
type target = HTML | JSON | XML | STRING
21
20
22
21
let output_dir_name = "output"
···
29
28
match template with
30
29
| None -> ""
31
30
| Some name ->
32
-
EP.load
33
-
EP.(Eio.Stdenv.cwd env / "templates" / (name ^ ".tree"))
31
+
EP.load EP.(Eio.Stdenv.cwd env / "templates" / (name ^ ".tree"))
34
32
in
35
33
let body = Format.asprintf "\\date{%a}\n" Human_datetime.pp now in
36
34
let create = `Exclusive 0o644 in
···
38
36
let dir =
39
37
match dest_dir with
40
38
| Some dir -> dir
41
-
| None ->
39
+
| None -> (
42
40
match forest.config.trees with
43
41
| dir :: _ -> dir
44
-
| [] -> Reporter.fatal Missing_argument ~extra_remarks: [Asai.Diagnostic.loctext "Unable to guess destination director for new tree; please supply one."]
45
-
in
46
-
let path =
47
-
EP.(env#fs / dir / fname)
42
+
| [] ->
43
+
Reporter.fatal Missing_argument
44
+
~extra_remarks:
45
+
[
46
+
Asai.Diagnostic.loctext
47
+
"Unable to guess destination director for new tree; please \
48
+
supply one.";
49
+
])
48
50
in
51
+
let path = EP.(env#fs / dir / fname) in
49
52
EP.save ~create path @@ body ^ template_content;
50
53
EP.native_exn path
51
54
52
55
let complete ~(forest : State.t) prefix : (string * string) List.t =
53
56
let config = forest.config in
54
-
let@ article = List.filter_map @~ List.of_seq @@ State.get_all_articles forest in
57
+
let@ article =
58
+
List.filter_map @~ List.of_seq @@ State.get_all_articles forest
59
+
in
55
60
let@ uri = Option.bind article.frontmatter.uri in
56
-
let short_uri = URI.display_path_string ~base: config.url uri in
61
+
let short_uri = URI.display_path_string ~base:config.url uri in
57
62
let@ title = Option.bind article.frontmatter.title in
58
63
let title = Plain_text_client.string_of_content ~forest title in
59
-
if String.starts_with ~prefix title then
60
-
Some (short_uri, title)
61
-
else
62
-
None
64
+
if String.starts_with ~prefix title then Some (short_uri, title) else None
63
65
64
-
let is_hidden_file fname =
65
-
String.starts_with ~prefix: "." fname
66
+
let is_hidden_file fname = String.starts_with ~prefix:"." fname
66
67
67
68
let output_path ~cwd ~(forest : State.t) =
68
69
let suffix =
69
-
String.concat "/" @@
70
-
List.filter (fun x -> not (x = "")) @@
71
-
URI.path_components forest.config.url
70
+
String.concat "/"
71
+
@@ List.filter (fun x -> not (x = ""))
72
+
@@ URI.path_components forest.config.url
72
73
in
73
74
Eio.Path.(cwd / output_dir_name / suffix)
74
75
75
76
let copy_contents_of_dir ~env ~(forest : State.t) dir =
76
77
let cwd = Eio.Stdenv.cwd env in
77
78
let dest_dir = EP.native_exn @@ output_path ~cwd ~forest in
78
-
Logs.debug (fun m -> m "copying contents of directory %s to %s." (Eio.Path.native_exn dir) dest_dir);
79
+
Logs.debug (fun m ->
80
+
m "copying contents of directory %s to %s." (Eio.Path.native_exn dir)
81
+
dest_dir);
79
82
let@ fname = List.iter @~ EP.read_dir dir in
80
83
if not @@ is_hidden_file fname then
81
84
let path = EP.(dir / fname) in
···
87
90
let articles =
88
91
let@ tree = Seq.filter_map @~ Forest.to_seq_values forest.index in
89
92
let@ evaluated = Option.bind @@ Tree.to_evaluated tree in
90
-
if evaluated.include_in_manifest
91
-
then Tree.to_article tree
92
-
else None
93
+
if evaluated.include_in_manifest then Tree.to_article tree else None
93
94
in
94
-
articles
95
-
|> List.of_seq
95
+
articles |> List.of_seq
96
96
|> List.sort (Forest_util.compare_article ~forest)
97
97
|> List.filter_map (fun tree -> render ~dev tree)
98
98
|> (fun t -> `List t)
99
99
|> Yojson.Safe.to_string
100
100
101
101
let html_redirect uri_string =
102
-
Pure_html.to_xml @@
103
-
let open Pure_html in
104
-
let open HTML in
105
-
html
106
-
[]
107
-
[
108
-
head
109
-
[]
110
-
[
111
-
meta
112
-
[
113
-
http_equiv `refresh;
114
-
content "0;url=%s" uri_string
115
-
];
116
-
meta [charset "utf-8"]
117
-
]
118
-
]
102
+
Pure_html.to_xml
103
+
@@
104
+
let open Pure_html in
105
+
let open HTML in
106
+
html []
107
+
[
108
+
head []
109
+
[
110
+
meta [http_equiv `refresh; content "0;url=%s" uri_string];
111
+
meta [charset "utf-8"];
112
+
];
113
+
]
119
114
120
115
let outputs_for_article ~(forest : State.t) (article : _ T.article) =
121
116
match article.frontmatter.uri with
122
117
| None -> []
123
118
| Some uri ->
124
-
let xml_route = URI.with_path_components (URI.append_path_component (URI.path_components uri) "index.xml") uri in
125
-
let html_route = URI.with_path_components (URI.append_path_component (URI.path_components uri) "index.html") uri in
126
-
let xml_content = Format.asprintf "%a" (Legacy_xml_client.pp_xml ~forest ~stylesheet: "default.xsl") article in
119
+
let xml_route =
120
+
URI.with_path_components
121
+
(URI.append_path_component (URI.path_components uri) "index.xml")
122
+
uri
123
+
in
124
+
let html_route =
125
+
URI.with_path_components
126
+
(URI.append_path_component (URI.path_components uri) "index.html")
127
+
uri
128
+
in
129
+
let xml_content =
130
+
Format.asprintf "%a"
131
+
(Legacy_xml_client.pp_xml ~forest ~stylesheet:"default.xsl")
132
+
article
133
+
in
127
134
let html_content =
128
-
html_redirect @@ String.concat "/" @@ "" :: Legacy_xml_client.local_path_components forest.config xml_route
135
+
html_redirect @@ String.concat "/"
136
+
@@ ("" :: Legacy_xml_client.local_path_components forest.config xml_route)
129
137
in
130
-
[xml_route, xml_content; html_route, html_content]
138
+
[(xml_route, xml_content); (html_route, html_content)]
131
139
132
140
let outputs_for_asset (asset : T.asset) =
133
141
let route = asset.uri in
134
-
[route, asset.content]
142
+
[(route, asset.content)]
135
143
136
-
let outputs_for_json_blob_syndication ~(forest : State.t) (syndication : _ T.json_blob_syndication) =
144
+
let outputs_for_json_blob_syndication ~(forest : State.t)
145
+
(syndication : _ T.json_blob_syndication) =
137
146
if URI.host syndication.blob_uri = URI.host forest.config.url then
138
147
let vertices = Forest.run_datalog_query forest.graphs syndication.query in
139
148
let resources =
···
142
151
| Content_vertex _ -> None
143
152
| Uri_vertex uri -> State.get_resource forest uri
144
153
in
145
-
let json_content = Repr.to_json_string ~minify: true (T.forest_t T.content_t) resources in
146
-
[syndication.blob_uri, json_content]
147
-
else
148
-
[]
154
+
let json_content =
155
+
Repr.to_json_string ~minify:true (T.forest_t T.content_t) resources
156
+
in
157
+
[(syndication.blob_uri, json_content)]
158
+
else []
149
159
150
-
let outputs_for_atom_feed_syndication ~(forest : State.t) (syndication : T.atom_feed_syndication) =
151
-
let atom_nodes = Atom_client.render_feed forest ~source_uri: syndication.source_uri ~feed_uri: syndication.feed_uri in
152
-
let atom_content = Format.asprintf "%a" (Pure_html.pp_xml ~header: true) atom_nodes in
153
-
[syndication.feed_uri, atom_content]
160
+
let outputs_for_atom_feed_syndication ~(forest : State.t)
161
+
(syndication : T.atom_feed_syndication) =
162
+
let atom_nodes =
163
+
Atom_client.render_feed forest ~source_uri:syndication.source_uri
164
+
~feed_uri:syndication.feed_uri
165
+
in
166
+
let atom_content =
167
+
Format.asprintf "%a" (Pure_html.pp_xml ~header:true) atom_nodes
168
+
in
169
+
[(syndication.feed_uri, atom_content)]
154
170
155
171
let outputs_for_syndication ~(forest : State.t) = function
156
-
| T.Json_blob syndication -> outputs_for_json_blob_syndication ~forest syndication
157
-
| T.Atom_feed syndication -> outputs_for_atom_feed_syndication ~forest syndication
172
+
| T.Json_blob syndication ->
173
+
outputs_for_json_blob_syndication ~forest syndication
174
+
| T.Atom_feed syndication ->
175
+
outputs_for_atom_feed_syndication ~forest syndication
158
176
159
177
let outputs_for_resource ~(forest : State.t) (evaluated : Tree.evaluated) =
160
178
if not evaluated.route_locally then []
···
174
192
begin
175
193
let json_string = json_manifest ~dev ~forest in
176
194
let json_path = EP.(output_path ~cwd ~forest / "forest.json") in
177
-
Eio_util.ensure_context_of_path ~perm: 0o755 json_path;
178
-
EP.save ~create: (`Or_truncate 0o644) json_path json_string
195
+
Eio_util.ensure_context_of_path ~perm:0o755 json_path;
196
+
EP.save ~create:(`Or_truncate 0o644) json_path json_string
179
197
end;
180
198
let jobs =
181
199
let bare_host_uri = URI.with_path_components [] forest.config.url in
182
-
let home_route = URI.with_path_components (URI.append_path_component (URI.path_components forest.config.url) "index.html") forest.config.url in
183
-
let home_content = html_redirect @@ "/" ^ URI.relative_path_string ~base: bare_host_uri (Config.home_uri forest.config) in
184
-
List.cons [home_route, home_content] @@
185
-
let@ resource = Eio.Fiber.List.map ~max_fibers: 40 @~ List.of_seq all_resources in
186
-
let@ () = Reporter.easy_run in
187
-
outputs_for_resource ~forest resource
200
+
let home_route =
201
+
URI.with_path_components
202
+
(URI.append_path_component
203
+
(URI.path_components forest.config.url)
204
+
"index.html")
205
+
forest.config.url
206
+
in
207
+
let home_content =
208
+
html_redirect @@ "/"
209
+
^ URI.relative_path_string ~base:bare_host_uri
210
+
(Config.home_uri forest.config)
211
+
in
212
+
List.cons [(home_route, home_content)]
213
+
@@
214
+
let@ resource =
215
+
Eio.Fiber.List.map ~max_fibers:40 @~ List.of_seq all_resources
216
+
in
217
+
let@ () = Reporter.easy_run in
218
+
outputs_for_resource ~forest resource
188
219
in
189
220
Logs.debug (fun m -> m "Writing %i files to output" (List.length jobs));
190
221
begin
191
222
(* Note: this part appears to be fast! *)
192
-
let@ items = Eio.Fiber.List.iter ~max_fibers: 20 @~ jobs in
223
+
let@ items = Eio.Fiber.List.iter ~max_fibers:20 @~ jobs in
193
224
let@ (route : URI.t), content = List.iter @~ items in
194
225
let@ () = Reporter.easy_run in
195
226
let path = EP.(cwd / output_dir_name / uri_to_local_path ~forest route) in
196
-
Eio_util.ensure_context_of_path ~perm: 0o755 path;
197
-
EP.save ~create: (`Or_truncate 0o644) path content;
227
+
Eio_util.ensure_context_of_path ~perm:0o755 path;
228
+
EP.save ~create:(`Or_truncate 0o644) path content
198
229
end
+10
-26
lib/frontend/Forester.mli
+10
-26
lib/frontend/Forester.mli
···
8
8
9
9
type env = Eio_unix.Stdenv.base
10
10
type dir = Eio.Fs.dir_ty Eio.Path.t
11
-
12
11
type target = HTML | JSON | XML | STRING
13
12
14
-
val render_forest :
15
-
dev: bool ->
16
-
forest: State.t ->
17
-
unit
18
-
19
-
val copy_contents_of_dir :
20
-
env: env ->
21
-
forest: State.t ->
22
-
dir ->
23
-
unit
13
+
val render_forest : dev:bool -> forest:State.t -> unit
14
+
val copy_contents_of_dir : env:env -> forest:State.t -> dir -> unit
24
15
25
16
val create_tree :
26
-
env: env ->
27
-
dest_dir: string option ->
28
-
prefix: string option ->
29
-
template: string option ->
30
-
mode: [`Sequential | `Random] ->
31
-
forest: State.t ->
32
-
string
33
-
34
-
val json_manifest :
35
-
dev: bool ->
36
-
forest: State.t ->
17
+
env:env ->
18
+
dest_dir:string option ->
19
+
prefix:string option ->
20
+
template:string option ->
21
+
mode:[`Sequential | `Random] ->
22
+
forest:State.t ->
37
23
string
38
24
39
-
val complete :
40
-
forest: State.t ->
41
-
string ->
42
-
(string * string) List.t
25
+
val json_manifest : dev:bool -> forest:State.t -> string
26
+
val complete : forest:State.t -> string -> (string * string) List.t
-2
lib/frontend/Forester_frontend.ml
-2
lib/frontend/Forester_frontend.ml
+62
-67
lib/frontend/Html_client.ml
+62
-67
lib/frontend/Html_client.ml
···
17
17
end
18
18
19
19
module Xmlns = Xmlns_effect.Make ()
20
-
module Scope = Algaeff.Reader.Make(struct type t = URI.t option end)
21
-
module Section_depth = Algaeff.Reader.Make(struct type t = int end)
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
+
22
29
module Loop_detection = Loop_detection_effect.Make ()
23
30
24
-
let hx attrs children = P.std_tag (Format.sprintf "h%i" @@ min 6 @@ Section_depth.read ()) attrs children
31
+
let hx attrs children =
32
+
P.std_tag
33
+
(Format.sprintf "h%i" @@ min 6 @@ Section_depth.read ())
34
+
attrs children
25
35
26
36
let incr_section_depth k =
27
37
let i = Section_depth.read () in
28
-
Section_depth.run ~env: (i + 1) k
38
+
Section_depth.run ~env:(i + 1) k
29
39
30
40
let route uri = URI.to_string uri
31
41
32
42
let get_expanded_title frontmatter forest =
33
43
let scope = Scope.read () in
34
-
State.get_expanded_title ?scope ~flags: T.{empty_when_untitled = true} frontmatter forest
44
+
State.get_expanded_title ?scope
45
+
~flags:T.{empty_when_untitled = true}
46
+
frontmatter forest
35
47
36
48
let render_xml_qname qname =
37
49
let qname = Xmlns.normalise_qname qname in
···
40
52
| _ -> Format.sprintf "%s:%s" qname.prefix qname.uname
41
53
42
54
let render_xml_attr (forest : State.t) T.{key; value} =
43
-
let str_value = Plain_text_client.string_of_content ~forest: forest value in
55
+
let str_value = Plain_text_client.string_of_content ~forest value in
44
56
P.string_attr (render_xml_qname key) "%s" str_value
45
57
46
-
let render_xmlns_prefix ({prefix; xmlns}: Forester_xml_names.xmlns_attr) =
58
+
let render_xmlns_prefix ({prefix; xmlns} : Forester_xml_names.xmlns_attr) =
47
59
let attr = match prefix with "" -> "xmlns" | _ -> "xmlns:" ^ prefix in
48
60
P.string_attr attr "%s" xmlns
49
61
50
-
let rec render_content (forest : State.t) (Content content: T.content) : P.node list =
62
+
let rec render_content (forest : State.t) (Content content : T.content) :
63
+
P.node list =
51
64
match content with
52
65
| T.Text txt0 :: T.Text txt1 :: content ->
53
66
render_content forest (Content (T.Text (txt0 ^ txt1) :: content))
···
57
70
xs @ ys
58
71
| [] -> []
59
72
60
-
and render_content_node (forest : State.t) (node : 'a T.content_node) : P.node list =
73
+
and render_content_node (forest : State.t) (node : 'a T.content_node) :
74
+
P.node list =
61
75
let config = forest.config in
62
76
match node with
63
-
| Text str ->
64
-
[P.txt "%s" str]
65
-
| CDATA str ->
66
-
[P.txt ~raw: true "<![CDATA[%s]]>" str]
67
-
| Uri uri ->
68
-
[P.txt "%s" (URI.to_string uri)]
77
+
| Text str -> [P.txt "%s" str]
78
+
| CDATA str -> [P.txt ~raw:true "<![CDATA[%s]]>" str]
79
+
| Uri uri -> [P.txt "%s" (URI.to_string uri)]
69
80
| Xml_elt elt ->
70
81
let prefixes_to_add, (name, attrs, content) =
71
82
let@ () = Xmlns.within_scope in
72
-
render_xml_qname elt.name,
73
-
List.map (render_xml_attr forest) elt.attrs,
74
-
render_content forest elt.content
83
+
( render_xml_qname elt.name,
84
+
List.map (render_xml_attr forest) elt.attrs,
85
+
render_content forest elt.content )
75
86
in
76
87
let attrs =
77
88
let xmlns_attrs = List.map render_xmlns_prefix prefixes_to_add in
78
89
attrs @ xmlns_attrs
79
90
in
80
91
[P.std_tag name attrs content]
81
-
| Route_of_uri uri ->
82
-
[P.txt "%s" (route uri)]
92
+
| Route_of_uri uri -> [P.txt "%s" (route uri)]
83
93
| Contextual_number uri ->
84
94
let custom_number =
85
95
let@ resource = Option.bind @@ forest.@{uri} in
86
96
match resource with
87
-
| T.Article article ->
88
-
article.frontmatter.number
97
+
| T.Article article -> article.frontmatter.number
89
98
| _ -> None
90
99
in
91
-
begin
92
-
match custom_number with
93
-
| None -> [P.txt "%s" @@ URI.relative_path_string ~base: config.url uri]
94
-
| Some num -> [P.txt "%s" num]
100
+
begin match custom_number with
101
+
| None -> [P.txt "%s" @@ URI.relative_path_string ~base:config.url uri]
102
+
| Some num -> [P.txt "%s" num]
95
103
end
96
-
| KaTeX (_, content) ->
97
-
[P.HTML.code [] @@ render_content forest content]
104
+
| KaTeX (_, content) -> [P.HTML.code [] @@ render_content forest content]
98
105
| Artefact artefact -> render_content forest @@ artefact.content
99
106
| Section section -> render_section forest section
100
107
| Transclude transclusion -> render_transclusion forest transclusion
···
102
109
| Results_of_datalog_query _ -> [] (* TODO: just make a list of links *)
103
110
| Datalog_script _ -> []
104
111
105
-
and render_link (forest : State.t) (link : T.content T.link) : P.node list = [
106
-
P.HTML.a
107
-
[
108
-
P.HTML.href "%s" (Format.asprintf "%a" URI.pp link.href);
109
-
] @@
110
-
render_content forest link.content
111
-
]
112
+
and render_link (forest : State.t) (link : T.content T.link) : P.node list =
113
+
[
114
+
P.HTML.a [P.HTML.href "%s" (Format.asprintf "%a" URI.pp link.href)]
115
+
@@ render_content forest link.content;
116
+
]
112
117
113
-
and render_transclusion (forest : State.t) (transclusion : T.transclusion) : P.node list =
118
+
and render_transclusion (forest : State.t) (transclusion : T.transclusion) :
119
+
P.node list =
114
120
match State.get_content_of_transclusion transclusion forest with
115
-
| None ->
116
-
Reporter.fatal (Resource_not_found transclusion.href)
117
-
| Some content ->
118
-
render_content forest content
121
+
| None -> Reporter.fatal (Resource_not_found transclusion.href)
122
+
| Some content -> render_content forest content
119
123
120
124
and render_section forest (section : T.content T.section) : P.node list =
121
-
let@ () = Scope.run ~env: section.frontmatter.uri in
125
+
let@ () = Scope.run ~env:section.frontmatter.uri in
122
126
let@ () = incr_section_depth in
123
127
[
124
-
P.HTML.section
125
-
[]
128
+
P.HTML.section []
126
129
[
127
-
begin
128
-
match section.frontmatter.title with
129
-
| None -> P.HTML.null []
130
-
| Some title ->
131
-
P.HTML.header
132
-
[]
133
-
[
134
-
hx [] @@ render_content forest title
135
-
]
130
+
begin match section.frontmatter.title with
131
+
| None -> P.HTML.null []
132
+
| Some title -> P.HTML.header [] [hx [] @@ render_content forest title]
136
133
end;
137
-
if Loop_detection.have_seen_uri_opt section.frontmatter.uri then
138
-
P.txt "Transclusion loop detected, rendering stopped."
139
-
else
140
-
let@ () = Loop_detection.add_seen_uri_opt section.frontmatter.uri in
141
-
P.HTML.null @@ render_content forest section.mainmatter
142
-
]
134
+
(if Loop_detection.have_seen_uri_opt section.frontmatter.uri then
135
+
P.txt "Transclusion loop detected, rendering stopped."
136
+
else
137
+
let@ () = Loop_detection.add_seen_uri_opt section.frontmatter.uri in
138
+
P.HTML.null @@ render_content forest section.mainmatter);
139
+
];
143
140
]
144
141
145
-
let render_article_as_div ?(heading_level = 0) (forest : State.t) (article : T.content T.article) : P.node =
146
-
let@ () = Section_depth.run ~env: heading_level in
147
-
let@ () = Scope.run ~env: article.frontmatter.uri in
142
+
let render_article_as_div ?(heading_level = 0) (forest : State.t)
143
+
(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
148
146
let@ () = Loop_detection.run in
149
-
let reserved = [
150
-
{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}
151
-
]
152
-
in
147
+
let reserved = [{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}] in
153
148
let@ () = Xmlns.run ~reserved in
154
149
P.HTML.div
155
150
(List.map render_xmlns_prefix reserved)
156
151
[
157
-
let@ () = Loop_detection.add_seen_uri_opt article.frontmatter.uri in
158
-
P.HTML.null @@ render_content forest article.mainmatter
152
+
(let@ () = Loop_detection.add_seen_uri_opt article.frontmatter.uri in
153
+
P.HTML.null @@ render_content forest article.mainmatter);
159
154
]
+214
-276
lib/frontend/Htmx_client.ml
+214
-276
lib/frontend/Htmx_client.ml
···
9
9
open Forester_core
10
10
open Forester_compiler
11
11
12
-
open struct module T = Types end
12
+
open struct
13
+
module T = Types
14
+
end
15
+
13
16
open Pure_html
14
17
open HTML
15
18
···
22
25
23
26
let local_path_components (uri : URI.t) =
24
27
let host =
25
-
match URI.host uri with
26
-
| Some host -> host
27
-
| None -> assert false (* TODO*)
28
+
match URI.host uri with Some host -> host | None -> assert false (* TODO*)
28
29
in
29
30
host :: URI.path_components uri
30
31
···
39
40
let title_flags_to_http_header (flags : T.title_flags) =
40
41
match flags with
41
42
| {empty_when_untitled} ->
42
-
`Assoc ([("Empty-When-Untitled", `String (Bool.to_string empty_when_untitled))])
43
+
`Assoc
44
+
[("Empty-When-Untitled", `String (Bool.to_string empty_when_untitled))]
43
45
44
-
(* I am encoding these headers to JSON because that is what HTMX
45
-
requires, but it would be more beautiful if we could directly use the
46
-
header type*)
46
+
(* I am encoding these headers to JSON because that is what HTMX requires, but
47
+
it would be more beautiful if we could directly use the header type*)
47
48
let section_flags_to_http_header (flags : T.section_flags) =
48
49
match flags with
49
-
| {hidden_when_empty;
50
-
included_in_toc;
51
-
header_shown;
52
-
metadata_shown;
53
-
numbered;
54
-
expanded
50
+
| {
51
+
hidden_when_empty;
52
+
included_in_toc;
53
+
header_shown;
54
+
metadata_shown;
55
+
numbered;
56
+
expanded;
55
57
} ->
56
58
let to_header l t =
57
59
match t with
58
60
| Some v -> Some (l, `String (Bool.to_string v))
59
61
| None -> None
60
62
in
61
-
let headers = [
62
-
to_header "Hidden-When-Empty" hidden_when_empty;
63
-
to_header "Included-In-Toc" included_in_toc;
64
-
to_header "Header-Shown" header_shown;
65
-
to_header "Metadata-Shown" metadata_shown;
66
-
to_header "Numbered" numbered;
67
-
to_header "Expanded" expanded;
68
-
]
63
+
let headers =
64
+
[
65
+
to_header "Hidden-When-Empty" hidden_when_empty;
66
+
to_header "Included-In-Toc" included_in_toc;
67
+
to_header "Header-Shown" header_shown;
68
+
to_header "Metadata-Shown" metadata_shown;
69
+
to_header "Numbered" numbered;
70
+
to_header "Expanded" expanded;
71
+
]
69
72
in
70
73
`Assoc (List.filter_map Fun.id headers)
71
74
72
75
let content_target_to_http_header (target : T.content_target) =
73
76
match target with
74
77
| T.Full flags ->
75
-
let `Assoc flags = section_flags_to_http_header flags in
78
+
let (`Assoc flags) = section_flags_to_http_header flags in
76
79
`Assoc (("Full", `String "true") :: flags)
77
-
| T.Mainmatter ->
78
-
`Assoc ["Mainmatter", `String "true"]
80
+
| T.Mainmatter -> `Assoc [("Mainmatter", `String "true")]
79
81
| T.Title flags ->
80
-
let `Assoc flags = title_flags_to_http_header flags in
82
+
let (`Assoc flags) = title_flags_to_http_header flags in
81
83
`Assoc (("Title", `String "true") :: flags)
82
-
| T.Taxon ->
83
-
`Assoc ["Taxon", `String "true"]
84
+
| T.Taxon -> `Assoc [("Taxon", `String "true")]
84
85
85
86
let render_xml_qname = function
86
87
| {prefix = ""; uname; _} -> uname
87
88
| {prefix; uname; _} -> Format.sprintf "%s:%s" prefix uname
88
89
89
-
let render_xml_attr
90
-
: T.content T.xml_attr -> _
91
-
= fun T.{key; value = _} ->
92
-
string_attr (render_xml_qname key) "todo"
90
+
let render_xml_attr : T.content T.xml_attr -> _ =
91
+
fun T.{key; value = _} -> string_attr (render_xml_qname key) "todo"
93
92
(* "%a" render_content value *)
94
93
95
-
let render_xmlns_prefix ({prefix; xmlns}: xmlns_attr) =
94
+
let render_xmlns_prefix ({prefix; xmlns} : xmlns_attr) =
96
95
let attr = match prefix with "" -> "xmlns" | _ -> "xmlns:" ^ prefix in
97
96
string_attr attr "%s" xmlns
98
97
···
101
100
let month =
102
101
match Human_datetime.month date with
103
102
| None -> None
104
-
| Some i ->
103
+
| Some i -> (
105
104
match i with
106
105
| 1 -> Some (txt "January")
107
106
| 2 -> Some (txt "February")
···
115
114
| 10 -> Some (txt "October")
116
115
| 11 -> Some (txt "November")
117
116
| 12 -> Some (txt "December")
118
-
| _ -> assert false
117
+
| _ -> assert false)
119
118
in
120
119
let day =
121
-
match Human_datetime.day date with
122
-
| None -> null []
123
-
| Some i -> txt "%i" i
120
+
match Human_datetime.day date with None -> null [] | Some i -> txt "%i" i
124
121
in
125
122
li
126
123
[class_ "meta-item"]
···
128
125
a
129
126
[class_ "link local"]
130
127
[
131
-
Option.value ~default: (null []) month;
132
-
if Option.is_some month then txt " " else null [];
128
+
Option.value ~default:(null []) month;
129
+
(if Option.is_some month then txt " " else null []);
133
130
day;
134
-
if Option.is_some month then txt ", " else null [];
135
-
year
136
-
]
131
+
(if Option.is_some month then txt ", " else null []);
132
+
year;
133
+
];
137
134
]
138
135
139
136
(*This type is just temporary until I figure out the logic *)
···
142
139
taxon: string;
143
140
number: string;
144
141
fallback_number: string;
145
-
146
142
(* In XSL, hese require querying the ancestors. We can't do this here, so we
147
-
explicitly pass these parameters down*)
143
+
explicitly pass these parameters down*)
148
144
in_backmatter: bool;
149
145
is_root: bool;
150
146
implicitly_unnumbered: bool;
151
147
}
152
148
153
-
let default_toc_config
154
-
?(suffix = "")
155
-
?(taxon = "")
156
-
?(number = "")
157
-
?(fallback_number = "")
158
-
?(in_backmatter = false)
159
-
()
160
-
= {
161
-
suffix;
162
-
taxon;
163
-
number;
164
-
fallback_number;
165
-
in_backmatter;
166
-
is_root = false;
167
-
implicitly_unnumbered = false;
168
-
}
149
+
let default_toc_config ?(suffix = "") ?(taxon = "") ?(number = "")
150
+
?(fallback_number = "") ?(in_backmatter = false) () =
151
+
{
152
+
suffix;
153
+
taxon;
154
+
number;
155
+
fallback_number;
156
+
in_backmatter;
157
+
is_root = false;
158
+
implicitly_unnumbered = false;
159
+
}
169
160
170
-
let rec render_article (forest : State.t) (article : T.content T.article) : node =
161
+
let rec render_article (forest : State.t) (article : T.content T.article) : node
162
+
=
171
163
(* FIXME: What should reserved be here? *)
172
-
let@ () = Xmlns.run ~reserved: [] in
164
+
let@ () = Xmlns.run ~reserved:[] in
173
165
HTML.article
174
-
[id "tree-container";]
166
+
[id "tree-container"]
175
167
[
176
168
(* FIXME: Should be reusing render_section *)
177
169
HTML.section
178
170
[class_ "block"]
179
171
[
180
-
details
181
-
[
182
-
(* TODO: check if expanded*)
183
-
open_
184
-
] @@
185
-
summary
186
-
[]
187
-
[render_frontmatter forest article.frontmatter] :: render_content forest article.mainmatter;
172
+
details [(* TODO: check if expanded*) open_]
173
+
@@ summary [] [render_frontmatter forest article.frontmatter]
174
+
:: render_content forest article.mainmatter;
188
175
];
189
-
match article.frontmatter.uri with
176
+
(match article.frontmatter.uri with
190
177
| None -> footer [] @@ render_backmatter forest article.backmatter
191
178
| Some uri ->
192
179
if URI.equal (Config.home_uri forest.config) uri then null []
193
-
else footer [] @@ render_backmatter forest article.backmatter
180
+
else footer [] @@ render_backmatter forest article.backmatter);
194
181
]
195
182
196
183
and render_section (forest : State.t) (section : T.content T.section) : node =
···
212
199
(* string_attr "data-taxon" () *)
213
200
null_
214
201
in
215
-
HTML.section
202
+
HTML.section [class_; data_taxon]
216
203
[
217
-
class_;
218
-
data_taxon;
219
-
]
220
-
[
221
-
if test true flags.header_shown then
222
-
details
223
-
[if test true flags.expanded then open_ else null_]
224
-
[
225
-
summary [] [render_frontmatter forest frontmatter];
226
-
null @@ render_content forest mainmatter;
227
-
]
228
-
else null @@ render_content forest mainmatter;
204
+
(if test true flags.header_shown then
205
+
details
206
+
[(if test true flags.expanded then open_ else null_)]
207
+
[
208
+
summary [] [render_frontmatter forest frontmatter];
209
+
null @@ render_content forest mainmatter;
210
+
]
211
+
else null @@ render_content forest mainmatter);
229
212
(* render_frontmatter forest frontmatter; *)
230
213
(* null @@ render_content forest mainmatter; *)
231
214
]
···
239
222
and render_attributions forest (attributions : T.content T.attribution list) =
240
223
let render_attribution attribution =
241
224
match attribution with
242
-
| T.{vertex; _} ->
225
+
| T.{vertex; _} -> (
243
226
match vertex with
244
227
| T.Uri_vertex href ->
245
-
let content = T.Content [T.Transclude {href; target = Title {empty_when_untitled = false}}] in
228
+
let content =
229
+
T.Content
230
+
[T.Transclude {href; target = Title {empty_when_untitled = false}}]
231
+
in
246
232
null @@ render_link forest T.{href; content}
247
-
| T.Content_vertex content ->
248
-
null @@ render_content forest content
233
+
| T.Content_vertex content -> null @@ render_content forest content)
249
234
in
250
235
let authors, contributors =
251
236
attributions
252
237
|> List.partition_map @@ fun a ->
253
-
match T.(a.role) with
254
-
| T.Author -> Left a
255
-
| Contributor -> Right a
238
+
match T.(a.role) with T.Author -> Left a | Contributor -> Right a
256
239
in
257
240
li
258
241
[class_ "meta-item"]
259
242
[
260
-
address [class_ "author"] @@
261
-
List.map render_attribution authors @
262
-
begin
263
-
if List.length contributors > 0 then
264
-
[txt "with contributions from "]
265
-
else []
266
-
end @
267
-
List.map render_attribution contributors
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;
268
250
]
269
251
270
-
and render_frontmatter (forest : State.t) (frontmatter : T.content T.frontmatter) : node =
252
+
and render_frontmatter (forest : State.t)
253
+
(frontmatter : T.content T.frontmatter) : node =
271
254
let taxon =
272
-
Option.value ~default: [] @@
273
-
let@ c = Option.map @~ frontmatter.taxon in
274
-
render_content forest c @ [txt ". "]
255
+
Option.value ~default:[]
256
+
@@
257
+
let@ c = Option.map @~ frontmatter.taxon in
258
+
render_content forest c @ [txt ". "]
275
259
in
276
260
let title =
277
-
Option.value ~default: [] @@
278
-
let@ c = Option.map @~ frontmatter.title in
279
-
render_content forest c
261
+
Option.value ~default:[]
262
+
@@
263
+
let@ c = Option.map @~ frontmatter.title in
264
+
render_content forest c
280
265
in
281
266
let uri =
282
267
match frontmatter.uri with
···
286
271
(* TODO: replace with proper routing from legacy xml client *)
287
272
Format.asprintf "%a" URI.pp (route forest uri)
288
273
in
289
-
a
290
-
[class_ "slug"; href "%s" uri_str;]
291
-
[txt "[%s]" uri_str]
274
+
a [class_ "slug"; href "%s" uri_str] [txt "[%s]" uri_str]
292
275
in
293
276
let source_path =
294
277
match frontmatter.source_path with
···
298
281
in
299
282
let find_meta key =
300
283
let@ str, content = List.find_map @~ frontmatter.metas in
301
-
if str = key then Some content
302
-
else None
284
+
if str = key then Some content else None
303
285
in
304
286
let render_meta key f =
305
-
Option.value
306
-
~default: (null [])
307
-
(Option.map f (find_meta key))
287
+
Option.value ~default:(null []) (Option.map f (find_meta key))
308
288
in
309
289
let default_meta_item content =
310
-
li
311
-
[class_ "meta-item"]
312
-
(render_content forest content)
290
+
li [class_ "meta-item"] (render_content forest content)
313
291
in
314
292
let labelled_external_link ~href ~label =
315
-
li
316
-
[class_ "meta-item"]
317
-
[a [class_ "link external"; href] [txt "%s" label]]
293
+
li [class_ "meta-item"] [a [class_ "link external"; href] [txt "%s" label]]
318
294
in
319
295
let to_string =
320
-
Plain_text_client.string_of_content
321
-
~forest
322
-
~router: (Legacy_xml_client.route forest)
296
+
Plain_text_client.string_of_content ~forest
297
+
~router:(Legacy_xml_client.route forest)
323
298
in
324
299
let position = render_meta "position" default_meta_item in
325
300
let institution = render_meta "institution" default_meta_item in
···
333
308
[class_ "meta-item"]
334
309
[
335
310
a
336
-
[class_ "doi link"; href "https://www.doi.org/%s" content;]
337
-
[txt "%s" content]
311
+
[class_ "doi link"; href "https://www.doi.org/%s" content]
312
+
[txt "%s" content];
338
313
]
339
314
in
340
315
let external_ =
···
342
317
let content = to_string c in
343
318
li
344
319
[class_ "meta-item"]
345
-
[
346
-
a
347
-
[class_ "link external"; href "%s" content;]
348
-
[txt "%s" content]
349
-
]
320
+
[a [class_ "link external"; href "%s" content] [txt "%s" content]]
350
321
in
351
322
let slides =
352
323
render_meta "slides" @@ fun c ->
353
-
labelled_external_link ~href: (href "%s" (to_string c)) ~label: "Slides"
324
+
labelled_external_link ~href:(href "%s" (to_string c)) ~label:"Slides"
354
325
in
355
326
let video =
356
327
render_meta "video" @@ fun c ->
357
-
labelled_external_link ~href: (href "%s" (to_string c)) ~label: "Video"
328
+
labelled_external_link ~href:(href "%s" (to_string c)) ~label:"Video"
358
329
in
359
-
header
360
-
[]
330
+
header []
361
331
[
362
-
h1 [] @@ [span [class_ "taxon"] taxon] @ title @ [txt " "; uri] @ source_path;
332
+
h1 []
333
+
@@ [span [class_ "taxon"] taxon]
334
+
@ title
335
+
@ [txt " "; uri]
336
+
@ source_path;
363
337
div
364
338
[class_ "metadata"]
365
339
[
366
-
ul [] @@
367
-
List.map render_date frontmatter.dates @
368
-
[
369
-
render_attributions forest frontmatter.attributions;
370
-
position;
371
-
institution;
372
-
venue;
373
-
source;
374
-
doi;
375
-
orcid;
376
-
external_;
377
-
slides;
378
-
video;
379
-
]
340
+
ul []
341
+
@@ List.map render_date frontmatter.dates
342
+
@ [
343
+
render_attributions forest frontmatter.attributions;
344
+
position;
345
+
institution;
346
+
venue;
347
+
source;
348
+
doi;
349
+
orcid;
350
+
external_;
351
+
slides;
352
+
video;
353
+
];
380
354
];
381
355
]
382
356
383
357
and render_transclusion transclusion =
384
358
match transclusion with
385
359
| T.{href; target} ->
386
-
let headers = Yojson.Safe.to_string @@ content_target_to_http_header target in
360
+
let headers =
361
+
Yojson.Safe.to_string @@ content_target_to_http_header target
362
+
in
387
363
[
388
364
span
389
365
[
···
393
369
Hx.swap "outerHTML";
394
370
Hx.headers "%s" headers;
395
371
]
396
-
[txt "transclusion: %s" (Format.asprintf "%a" URI.pp href)]
372
+
[txt "transclusion: %s" (Format.asprintf "%a" URI.pp href)];
397
373
]
398
374
399
-
and render_content (forest : State.t) (Content content: T.content) : node list =
375
+
and render_content (forest : State.t) (Content content : T.content) : node list
376
+
=
400
377
List.concat_map (render_content_node forest) content
401
378
402
-
and render_content_node (forest : State.t) (node : 'a T.content_node) : node list =
379
+
and render_content_node (forest : State.t) (node : 'a T.content_node) :
380
+
node list =
403
381
match node with
404
-
| Text str ->
405
-
[txt "%s" str]
406
-
| CDATA str ->
407
-
[txt ~raw: true "<![CDATA[%s]]>" str]
382
+
| Text str -> [txt "%s" str]
383
+
| CDATA str -> [txt ~raw:true "<![CDATA[%s]]>" str]
408
384
| Xml_elt elt ->
409
385
let prefixes_to_add, (name, attrs, content) =
410
386
let@ () = Xmlns.within_scope in
411
-
render_xml_qname elt.name,
412
-
List.map render_xml_attr elt.attrs,
413
-
render_content forest elt.content
387
+
( render_xml_qname elt.name,
388
+
List.map render_xml_attr elt.attrs,
389
+
render_content forest elt.content )
414
390
in
415
391
let attrs =
416
392
let xmlns_attrs = List.map render_xmlns_prefix prefixes_to_add in
417
393
attrs @ xmlns_attrs
418
394
in
419
395
[std_tag name attrs content]
420
-
| Transclude transclusion ->
421
-
render_transclusion transclusion
422
-
| Contextual_number addr ->
423
-
begin
424
-
match (State.get_article addr) forest with
425
-
| Some a ->
426
-
[
427
-
contextual_number
428
-
(T.article_to_section a)
429
-
(default_toc_config ())
430
-
]
431
-
| None -> []
432
-
end
433
-
396
+
| Transclude transclusion -> render_transclusion transclusion
397
+
| Contextual_number addr -> begin
398
+
match (State.get_article addr) forest with
399
+
| Some a ->
400
+
[contextual_number (T.article_to_section a) (default_toc_config ())]
401
+
| None -> []
402
+
end
434
403
(* let custom_number = *)
435
404
(* article.frontmatter.number *)
436
405
(* in *)
···
440
409
(* | Some num -> num *)
441
410
(* in *)
442
411
(* [txt "%s" num] *)
443
-
| Link link ->
444
-
render_link forest link
445
-
| Section section ->
446
-
[render_section forest section]
412
+
| Link link -> render_link forest link
413
+
| Section section -> [render_section forest section]
447
414
| KaTeX (mode, content) ->
448
415
let body = Plain_text_client.string_of_content ~forest content in
449
416
(* [txt ~raw: true "%s%s%s" l body r] *)
450
-
begin
451
-
match mode with
452
-
| Inline ->
453
-
[span [class_ "math"] [txt ~raw: true "%s" body]]
454
-
| Display ->
455
-
[div [class_ "math"] [txt ~raw: true "%s" body]]
417
+
begin match mode with
418
+
| Inline -> [span [class_ "math"] [txt ~raw:true "%s" body]]
419
+
| Display -> [div [class_ "math"] [txt ~raw:true "%s" body]]
456
420
end
457
421
| Results_of_datalog_query q ->
458
422
(* We could just evaluate the query immediately. This is just experimental*)
···
463
427
Hx.trigger "load";
464
428
Hx.swap "outerHTML";
465
429
Hx.target "this";
466
-
Hx.vals
467
-
"%s"
468
-
Repr.(
469
-
to_json_string
470
-
~minify: true
471
-
query_t
472
-
{query = q}
473
-
)
430
+
Hx.vals "%s" Repr.(to_json_string ~minify:true query_t {query = q});
474
431
]
475
-
[]
432
+
[];
476
433
]
477
434
| T.Datalog_script _ -> []
478
-
| T.Artefact _
479
-
| T.Uri _
480
-
| T.Route_of_uri _ ->
481
-
[txt "todo"]
435
+
| T.Artefact _ | T.Uri _ | T.Route_of_uri _ -> [txt "todo"]
482
436
483
437
(* TODO: links need to be flattened in order to produce valid HTML. *)
484
438
and render_link (forest : State.t) (link : T.content T.link) : node list =
···
486
440
match State.get_article link.href forest with
487
441
| None ->
488
442
(* TODO: rendering of hrefs is suboptimal... *)
489
-
[
490
-
href "%s" (Format.asprintf "%a" URI.pp link.href);
491
-
]
492
-
| Some article ->
493
-
begin
494
-
match article.frontmatter.uri with
495
-
| Some _uri ->
496
-
[
497
-
title_ "%s" @@
498
-
Option.value ~default: "" @@
499
-
Option.map
500
-
(
501
-
Plain_text_client.string_of_content
502
-
~forest
503
-
~router: (Legacy_xml_client.route forest)
504
-
)
505
-
article.frontmatter.title;
506
-
href "/trees%s" (Format.asprintf "%s" (URI.path_string link.href));
507
-
Hx.target "#tree-container";
508
-
Hx.swap "innerHTML";
509
-
]
510
-
| None -> [HTML.null_]
511
-
end;
443
+
[href "%s" (Format.asprintf "%a" URI.pp link.href)]
444
+
| Some article -> begin
445
+
match article.frontmatter.uri with
446
+
| Some _uri ->
447
+
[
448
+
title_ "%s" @@ Option.value ~default:""
449
+
@@ Option.map
450
+
(Plain_text_client.string_of_content ~forest
451
+
~router:(Legacy_xml_client.route forest))
452
+
article.frontmatter.title;
453
+
href "/trees%s" (Format.asprintf "%s" (URI.path_string link.href));
454
+
Hx.target "#tree-container";
455
+
Hx.swap "innerHTML";
456
+
]
457
+
| None -> [HTML.null_]
458
+
end
512
459
in
513
-
[
514
-
span
515
-
[class_ "link local"]
516
-
[a attrs (render_content forest link.content)]
517
-
]
460
+
[span [class_ "link local"] [a attrs (render_content forest link.content)]]
518
461
519
462
and contextual_number (_tree : T.content T.section) (cfg : toc_config) =
520
463
let should_number =
521
464
cfg.number <> ""
522
-
|| (
523
-
not cfg.in_backmatter
524
-
&& not cfg.is_root
525
-
&& not cfg.implicitly_unnumbered
526
-
)
465
+
|| (not cfg.in_backmatter) && (not cfg.is_root)
466
+
&& not cfg.implicitly_unnumbered
527
467
in
528
468
let taxon =
529
469
if cfg.taxon <> "" then
530
-
cfg.taxon ^
531
-
if should_number || cfg.fallback_number <> "" then " "
532
-
else ""
470
+
cfg.taxon ^ if should_number || cfg.fallback_number <> "" then " " else ""
533
471
else ""
534
472
in
535
473
let number =
536
474
if should_number then
537
475
if cfg.number <> String.empty then cfg.number
538
476
else
539
-
(* TODO: Implement this:
540
-
<xsl:number format="1.1" count="f:tree[ancestor::f:tree and (not(@toc='false' or @numbered='false'))]" level="multiple" />
477
+
(* TODO: Implement this: <xsl:number format="1.1"
478
+
count="f:tree[ancestor::f:tree and (not(@toc='false' or
479
+
@numbered='false'))]" level="multiple" />
541
480
*)
542
481
assert false
543
-
else if cfg.fallback_number <> String.empty then
544
-
cfg.fallback_number
482
+
else if cfg.fallback_number <> String.empty then cfg.fallback_number
545
483
else ""
546
484
in
547
485
let suffix =
548
-
if cfg.taxon <> String.empty
486
+
if
487
+
cfg.taxon <> String.empty
549
488
|| cfg.fallback_number <> String.empty
550
-
|| should_number then cfg.suffix
489
+
|| should_number
490
+
then cfg.suffix
551
491
else ""
552
492
in
553
493
null [txt "%s %s %s" taxon suffix number]
···
557
497
contextual_number _tree cfg
558
498
559
499
and _render_toc_item (forest : State.t) (item : T.content T.section) =
560
-
let to_str = Plain_text_client.string_of_content ~forest ~router: (Legacy_xml_client.route forest) in
500
+
let to_str =
501
+
Plain_text_client.string_of_content ~forest
502
+
~router:(Legacy_xml_client.route forest)
503
+
in
561
504
null
562
505
[
563
506
a
564
507
[
565
508
class_ "bullet";
566
509
href "";
567
-
title_
568
-
"%s%s"
569
-
(Option.value ~default: "" @@ Option.map to_str item.frontmatter.title)
570
-
(
571
-
Option.value ~default: "" @@
572
-
Option.map (Format.asprintf "[%a]" URI.pp) item.frontmatter.uri
573
-
)
510
+
title_ "%s%s"
511
+
(Option.value ~default:""
512
+
@@ Option.map to_str item.frontmatter.title)
513
+
(Option.value ~default:""
514
+
@@ Option.map (Format.asprintf "[%a]" URI.pp) item.frontmatter.uri);
574
515
]
575
516
[txt "■"];
576
517
span
···
581
522
[_tree_taxon_with_number item (default_toc_config ())];
582
523
(* null @@ render_content forest item.mainmatter; *)
583
524
];
584
-
ul [] (render_content forest item.mainmatter)
525
+
ul [] (render_content forest item.mainmatter);
585
526
]
586
527
587
528
and render_toc_mainmatter content =
588
-
let T.Content nodes = content in
589
-
ul [class_ "block"] @@
590
-
let@ node = List.filter_map @~ nodes in
591
-
match node with
592
-
| T.Section section ->
593
-
Some (render_toc section)
594
-
| _ -> None
529
+
let (T.Content nodes) = content in
530
+
ul [class_ "block"]
531
+
@@
532
+
let@ node = List.filter_map @~ nodes in
533
+
match node with T.Section section -> Some (render_toc section) | _ -> None
595
534
596
535
and render_toc (section : T.content T.section) =
597
-
if Some false
536
+
if
537
+
Some false
598
538
= List.find_map
599
539
(fun (k, v) ->
600
-
if k = "toc" && v = T.Content [T.Text "true"] then Some true
601
-
else None
602
-
)
603
-
section.frontmatter.metas then null []
540
+
if k = "toc" && v = T.Content [T.Text "true"] then Some true else None)
541
+
section.frontmatter.metas
542
+
then null []
604
543
else
605
544
nav
606
545
[id "toc"; Hx.swap_oob "true"]
···
610
549
[
611
550
h1 [] [txt "Table of contents"];
612
551
render_toc_mainmatter section.mainmatter;
613
-
]
552
+
];
614
553
]
615
554
616
555
let render_query_result (forest : State.t) (vs : Vertex_set.t) =
617
-
let module C = Types.Comparators(struct
556
+
let module C = Types.Comparators (struct
618
557
let string_of_content =
619
-
Plain_text_client.string_of_content
620
-
~forest
621
-
~router: (route forest)
558
+
Plain_text_client.string_of_content ~forest ~router:(route forest)
622
559
end) in
623
560
let make_section =
624
561
T.article_to_section
625
-
~flags: {T.default_section_flags with
626
-
expanded = Some false;
627
-
numbered = Some false;
628
-
included_in_toc = Some false;
629
-
metadata_shown = Some true
630
-
}
562
+
~flags:
563
+
{
564
+
T.default_section_flags with
565
+
expanded = Some false;
566
+
numbered = Some false;
567
+
included_in_toc = Some false;
568
+
metadata_shown = Some true;
569
+
}
631
570
in
632
571
let nodes =
633
-
vs
634
-
|> Vertex_set.to_seq
572
+
vs |> Vertex_set.to_seq
635
573
|> Seq.filter_map Vertex.uri_of_vertex
636
574
|> Seq.filter_map (State.get_article @~ forest)
637
575
|> List.of_seq
+1
-5
lib/frontend/Htmx_client.mli
+1
-5
lib/frontend/Htmx_client.mli
···
6
6
7
7
open Forester_core
8
8
open Forester_compiler
9
-
10
9
module T := Types
11
10
12
11
type query = {
13
12
query: (string, T.content T.vertex) Forester_core.Datalog_expr.query;
14
13
}
15
-
val query_t : query Repr.t
16
14
15
+
val query_t : query Repr.t
17
16
val route : State.t -> URI.t -> URI.t
18
17
val render_article : State.t -> T.content T.article -> Pure_html.node
19
-
20
18
val render_content : State.t -> T.content -> Pure_html.node list
21
19
val render_frontmatter : State.t -> T.content T.frontmatter -> Pure_html.node
22
-
23
20
val render_query_result : State.t -> Vertex_set.t -> Pure_html.node option
24
-
25
21
val render_toc : T.content T.section -> Pure_html.node
+22
-19
lib/frontend/Json_manifest_client.ml
+22
-19
lib/frontend/Json_manifest_client.ml
···
13
13
module PT = Plain_text_client
14
14
end
15
15
16
-
let render_tree ~dev ~(forest : State.t) (doc : T.content T.article) : Yojson.Safe.t option =
16
+
let render_tree ~dev ~(forest : State.t) (doc : T.content T.article) :
17
+
Yojson.Safe.t option =
17
18
let@ uri = Option.bind doc.frontmatter.uri in
18
19
(* TODO : Check routing *)
19
20
let route = Legacy_xml_client.route forest uri in
20
21
let title_string =
21
-
PT.string_of_content ~forest @@
22
-
State.get_expanded_title doc.frontmatter forest
22
+
PT.string_of_content ~forest
23
+
@@ State.get_expanded_title doc.frontmatter forest
23
24
in
24
25
let title = `String title_string in
25
26
let taxon =
26
27
match doc.frontmatter.taxon with
27
28
| None -> `Null
28
-
| Some content ->
29
-
`String (PT.string_of_content ~forest content)
29
+
| Some content -> `String (PT.string_of_content ~forest content)
30
30
in
31
31
let tags =
32
32
`List
33
33
begin
34
34
let@ tag = List.filter_map @~ doc.frontmatter.tags in
35
-
let@ content = Option.map @~ State.get_title_or_content_of_vertex tag forest in
35
+
let@ content =
36
+
Option.map @~ State.get_title_or_content_of_vertex tag forest
37
+
in
36
38
`String (PT.string_of_content ~forest content)
37
39
end
38
40
in
···
50
52
else []
51
53
in
52
54
(* TODO: filter out anonymous stuff *)
53
-
Option.some @@
54
-
let fm =
55
-
path @
56
-
[
57
-
("title", title);
58
-
("uri", `String (URI.display_path_string ~base: forest.config.url uri));
59
-
("taxon", taxon);
60
-
("tags", tags);
61
-
("route", route);
62
-
("metas", metas)
63
-
]
64
-
in
65
-
`Assoc fm
55
+
Option.some
56
+
@@
57
+
let fm =
58
+
path
59
+
@ [
60
+
("title", title);
61
+
("uri", `String (URI.display_path_string ~base:forest.config.url uri));
62
+
("taxon", taxon);
63
+
("tags", tags);
64
+
("route", route);
65
+
("metas", metas);
66
+
]
67
+
in
68
+
`Assoc fm
+1
-5
lib/frontend/Json_manifest_client.mli
+1
-5
lib/frontend/Json_manifest_client.mli
+180
-153
lib/frontend/Legacy_xml_client.ml
+180
-153
lib/frontend/Legacy_xml_client.ml
···
20
20
include Xmlns_effect.Make ()
21
21
22
22
let run (k : xmlns_attr list -> 'a) =
23
-
run ~reserved: X.reserved_xmlnss @@ fun () ->
24
-
k X.reserved_xmlnss
23
+
run ~reserved:X.reserved_xmlnss @@ fun () -> k X.reserved_xmlnss
25
24
end
26
25
27
-
module In_backmatter = Algaeff.Reader.Make(struct type t = bool end)
26
+
module In_backmatter = Algaeff.Reader.Make (struct
27
+
type t = bool
28
+
end)
28
29
29
30
let local_path_components (config : Config.t) (uri : URI.t) =
30
31
let host = Option.get @@ URI.host uri in
31
32
let base_host = Option.get @@ URI.host config.url in
32
-
if host = base_host then
33
-
URI.stripped_path_components uri
34
-
else
35
-
"foreign" :: host :: URI.stripped_path_components uri
33
+
if host = base_host then URI.stripped_path_components uri
34
+
else "foreign" :: host :: URI.stripped_path_components uri
36
35
37
36
let local_base_url_string (config : Config.t) =
38
37
let path = URI.path_components config.url in
···
41
40
let route (forest : State.t) uri : URI.t =
42
41
match forest.={uri} with
43
42
| None -> uri
44
-
| Some tree ->
43
+
| Some tree -> (
45
44
match Tree.to_evaluated tree with
46
45
| Some evaluated when evaluated.route_locally ->
47
46
let path = "" :: local_path_components forest.config uri in
48
47
URI.make ~path ()
49
-
| _ -> uri
48
+
| _ -> uri)
50
49
51
50
module Scope = struct
52
-
open struct module E = Algaeff.Reader.Make(struct type t = URI.t option end) end
51
+
open struct
52
+
module E = Algaeff.Reader.Make (struct
53
+
type t = URI.t option
54
+
end)
55
+
end
56
+
53
57
let read = E.read
54
58
55
59
let run ~(forest : State.t) ~env kont =
···
57
61
let loc_opt =
58
62
let@ uri = Option.bind env in
59
63
let@ path = Option.map @~ State.source_path_of_uri uri forest in
60
-
let position = Range.{source = `File path; offset = 0; start_of_line = 0; line_num = 0} in
64
+
let position =
65
+
Range.{source = `File path; offset = 0; start_of_line = 0; line_num = 0}
66
+
in
61
67
Range.make (position, position)
62
68
in
63
69
let@ () = Reporter.with_loc loc_opt in
···
75
81
| _ -> Format.sprintf "%s:%s" qname.prefix qname.uname
76
82
77
83
let render_xml_attr (forest : State.t) T.{key; value} =
78
-
let str_value = Plain_text_client.string_of_content ~forest ~router: (route forest) value in
84
+
let str_value =
85
+
Plain_text_client.string_of_content ~forest ~router:(route forest) value
86
+
in
79
87
P.string_attr (render_xml_qname key) "%s" str_value
80
88
81
-
let render_xmlns_prefix ({prefix; xmlns}: Forester_xml_names.xmlns_attr) =
89
+
let render_xmlns_prefix ({prefix; xmlns} : Forester_xml_names.xmlns_attr) =
82
90
let attr = match prefix with "" -> "xmlns" | _ -> "xmlns:" ^ prefix in
83
91
P.string_attr attr "%s" xmlns
84
92
85
-
let render_section_flags (dict : T.section_flags) = [
86
-
X.optional_ X.show_heading dict.header_shown;
87
-
X.optional_ X.show_metadata dict.metadata_shown;
88
-
X.optional_ X.hidden_when_empty dict.hidden_when_empty;
89
-
X.optional_ X.expanded dict.expanded;
90
-
X.optional_ X.toc dict.included_in_toc;
91
-
X.optional_ X.numbered dict.numbered
92
-
]
93
+
let render_section_flags (dict : T.section_flags) =
94
+
[
95
+
X.optional_ X.show_heading dict.header_shown;
96
+
X.optional_ X.show_metadata dict.metadata_shown;
97
+
X.optional_ X.hidden_when_empty dict.hidden_when_empty;
98
+
X.optional_ X.expanded dict.expanded;
99
+
X.optional_ X.toc dict.included_in_toc;
100
+
X.optional_ X.numbered dict.numbered;
101
+
]
93
102
94
103
let rec render_section forest (section : T.content T.section) : P.node =
95
104
let@ _ = Xmlns.run in
···
97
106
(render_section_flags section.flags)
98
107
[
99
108
render_frontmatter forest section.frontmatter;
100
-
let@ () = Scope.run ~forest ~env: section.frontmatter.uri in
101
-
X.mainmatter [] @@
102
-
if Loop_detection.have_seen_uri_opt section.frontmatter.uri then
103
-
[X.info [] [P.txt "Transclusion loop detected, rendering stopped."]]
104
-
else
105
-
let@ () = Loop_detection.add_seen_uri_opt section.frontmatter.uri in
106
-
render_mainmatter forest section
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);
107
117
]
108
118
109
119
and render_mainmatter forest (section : T.content T.section) =
110
120
match section.frontmatter.uri with
111
121
| None -> render_content forest section.mainmatter
112
-
| Some uri ->
122
+
| Some uri -> (
113
123
match Hashtbl.find_opt mainmatter_cache uri with
114
124
| None ->
115
125
let nodes = render_content forest section.mainmatter in
116
126
Hashtbl.add mainmatter_cache uri nodes;
117
127
nodes
118
-
| Some nodes -> nodes
128
+
| Some nodes -> nodes)
119
129
120
-
and render_frontmatter (forest : State.t) (frontmatter : T.content T.frontmatter) : P.node =
130
+
and render_frontmatter (forest : State.t)
131
+
(frontmatter : T.content T.frontmatter) : P.node =
121
132
let result =
122
-
X.frontmatter
123
-
[]
133
+
X.frontmatter []
124
134
[
125
135
render_attributions forest frontmatter.uri frontmatter.attributions;
126
136
render_dates forest frontmatter.dates;
127
-
X.conditional forest.dev (X.optional (X.source_path [] "%s") frontmatter.source_path);
128
-
X.optional (fun uri -> X.uri [] "%s" @@ URI.to_string uri) frontmatter.uri;
129
-
X.optional (fun uri -> X.display_uri [] "%s" @@ URI.display_path_string ~base: forest.config.url uri) frontmatter.uri;
130
-
X.optional (X.route [] "%s") @@ Option.map (Fun.compose URI.to_string (route forest)) frontmatter.uri;
131
-
begin
132
-
match frontmatter.title with
133
-
| None -> X.null []
134
-
| Some _ ->
135
-
let title = State.get_expanded_title ?scope: (Scope.read ()) frontmatter forest in
136
-
X.title [X.text_ "%s" @@ Plain_text_client.string_of_content ~forest ~router: (route forest) title] @@
137
-
render_content forest title
137
+
X.conditional forest.dev
138
+
(X.optional (X.source_path [] "%s") frontmatter.source_path);
139
+
X.optional
140
+
(fun uri -> X.uri [] "%s" @@ URI.to_string uri)
141
+
frontmatter.uri;
142
+
X.optional
143
+
(fun uri ->
144
+
X.display_uri [] "%s"
145
+
@@ URI.display_path_string ~base:forest.config.url uri)
146
+
frontmatter.uri;
147
+
X.optional (X.route [] "%s")
148
+
@@ Option.map (Fun.compose URI.to_string (route forest)) frontmatter.uri;
149
+
begin match frontmatter.title with
150
+
| None -> X.null []
151
+
| Some _ ->
152
+
let title =
153
+
State.get_expanded_title ?scope:(Scope.read ()) frontmatter forest
154
+
in
155
+
X.title
156
+
[
157
+
X.text_ "%s"
158
+
@@ Plain_text_client.string_of_content ~forest
159
+
~router:(route forest) title;
160
+
]
161
+
@@ render_content forest title
138
162
end;
139
-
begin
140
-
match frontmatter.taxon with
141
-
| None -> X.null []
142
-
| Some taxon ->
143
-
X.taxon [] @@ render_content forest taxon
163
+
begin match frontmatter.taxon with
164
+
| None -> X.null []
165
+
| Some taxon -> X.taxon [] @@ render_content forest taxon
144
166
end;
145
-
X.null @@ List.map (render_meta forest) frontmatter.metas
167
+
X.null @@ List.map (render_meta forest) frontmatter.metas;
146
168
]
147
169
in
148
170
result
149
171
150
172
and render_meta forest (key, body) =
151
-
X.meta [X.name "%s" key] @@
152
-
render_content forest body
173
+
X.meta [X.name "%s" key] @@ render_content forest body
153
174
154
-
and render_content (forest : State.t) (Content content: T.content) : P.node list =
175
+
and render_content (forest : State.t) (Content content : T.content) :
176
+
P.node list =
155
177
match content with
156
178
| T.Text txt0 :: T.Text txt1 :: content ->
157
179
render_content forest (Content (T.Text (txt0 ^ txt1) :: content))
···
161
183
xs @ ys
162
184
| [] -> []
163
185
164
-
and render_content_node (forest : State.t) (node : 'a T.content_node) : P.node list =
186
+
and render_content_node (forest : State.t) (node : 'a T.content_node) :
187
+
P.node list =
165
188
match node with
166
-
| Text str ->
167
-
[P.txt "%s" str]
168
-
| CDATA str ->
169
-
[P.txt ~raw: true "<![CDATA[%s]]>" str]
189
+
| Text str -> [P.txt "%s" str]
190
+
| CDATA str -> [P.txt ~raw:true "<![CDATA[%s]]>" str]
170
191
| Uri uri ->
171
-
[P.txt "%s" (URI.display_path_string ~base: forest.config.url uri)]
172
-
| Route_of_uri uri ->
173
-
[P.txt "%s" (URI.to_string (route forest 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))]
174
194
| Xml_elt elt ->
175
195
let prefixes_to_add, (name, attrs, content) =
176
196
let@ () = Xmlns.within_scope in
177
-
render_xml_qname elt.name,
178
-
List.map (render_xml_attr forest) elt.attrs,
179
-
render_content forest elt.content
197
+
( render_xml_qname elt.name,
198
+
List.map (render_xml_attr forest) elt.attrs,
199
+
render_content forest elt.content )
180
200
in
181
201
let attrs =
182
202
let xmlns_attrs = List.map render_xmlns_prefix prefixes_to_add in
183
203
attrs @ xmlns_attrs
184
204
in
185
205
[P.std_tag name attrs content]
186
-
| Transclude transclusion ->
187
-
render_transclusion forest transclusion
206
+
| Transclude transclusion -> render_transclusion forest transclusion
188
207
| Contextual_number uri ->
189
208
let custom_number =
190
209
let@ resource = Option.bind @@ forest.@{uri} in
191
210
match resource with
192
-
| T.Article article ->
193
-
article.frontmatter.number
211
+
| T.Article article -> article.frontmatter.number
194
212
| _ -> None
195
213
in
196
-
begin
197
-
match custom_number with
198
-
| None ->
199
-
[
200
-
X.contextual_number
201
-
[
202
-
X.uri_ "%s" @@ URI.to_string uri;
203
-
X.display_uri_ "%s" @@ URI.display_path_string ~base: forest.config.url uri
204
-
]
205
-
]
206
-
| Some num -> [P.txt "%s" num]
214
+
begin match custom_number with
215
+
| None ->
216
+
[
217
+
X.contextual_number
218
+
[
219
+
X.uri_ "%s" @@ URI.to_string uri;
220
+
X.display_uri_ "%s"
221
+
@@ URI.display_path_string ~base:forest.config.url uri;
222
+
];
223
+
]
224
+
| Some num -> [P.txt "%s" num]
207
225
end
208
-
| Link link ->
209
-
render_link forest link
226
+
| Link link -> render_link forest link
210
227
| Results_of_datalog_query q ->
211
228
let article_to_section =
212
229
T.article_to_section
213
-
~flags: {T.default_section_flags with
214
-
expanded = Some false;
215
-
numbered = Some false;
216
-
included_in_toc = Some false;
217
-
metadata_shown = Some true
218
-
}
230
+
~flags:
231
+
{
232
+
T.default_section_flags with
233
+
expanded = Some false;
234
+
numbered = Some false;
235
+
included_in_toc = Some false;
236
+
metadata_shown = Some true;
237
+
}
219
238
in
220
239
let results = Forest.run_datalog_query forest.graphs q in
221
240
let@ article = List.map @~ Forest_util.get_sorted_articles forest results in
222
241
render_section forest @@ article_to_section article
223
-
| Section section ->
224
-
[render_section forest section]
242
+
| Section section -> [render_section forest section]
225
243
| KaTeX (mode, content) ->
226
-
let display =
227
-
match mode with
228
-
| Inline -> "inline"
229
-
| Display -> "block"
230
-
in
244
+
let display = match mode with Inline -> "inline" | Display -> "block" in
231
245
let body = Format.asprintf "%a" TeX_like.pp_content content in
232
246
[X.tex [X.display "%s" display] "<![CDATA[%s]]>" body]
233
-
| Artefact resource ->
234
-
[render_artefact forest resource]
247
+
| Artefact resource -> [render_artefact forest resource]
235
248
| Datalog_script _ -> []
236
249
237
250
and render_artefact forest (resource : T.content T.artefact) =
···
239
252
[X.hash "%s" resource.hash]
240
253
[
241
254
X.resource_content [] @@ render_content forest resource.content;
242
-
render_resource_sources resource.sources
255
+
render_resource_sources resource.sources;
243
256
]
244
257
245
258
and render_resource_sources sources =
246
259
X.null @@ List.map render_resource_source sources
247
260
248
261
and render_resource_source source =
249
-
X.resource_source [X.type_ "%s" source.type_; X.resource_part "%s" source.part] "<![CDATA[%s]]>" source.source
262
+
X.resource_source
263
+
[X.type_ "%s" source.type_; X.resource_part "%s" source.part]
264
+
"<![CDATA[%s]]>" source.source
250
265
251
-
and render_transclusion (forest : State.t) (transclusion : T.transclusion) : P.node list =
266
+
and render_transclusion (forest : State.t) (transclusion : T.transclusion) :
267
+
P.node list =
252
268
match State.get_content_of_transclusion transclusion forest with
253
-
| None ->
254
-
Reporter.fatal (Resource_not_found transclusion.href)
255
-
| Some content ->
256
-
render_content forest content
269
+
| None -> Reporter.fatal (Resource_not_found transclusion.href)
270
+
| Some content -> render_content forest content
257
271
258
272
and render_link (forest : State.t) (link : T.content T.link) : P.node list =
259
273
let article_opt = State.get_article link.href forest in
260
274
let attrs =
261
275
match article_opt with
262
276
| None ->
263
-
begin
264
-
if not @@ In_backmatter.read () then
265
-
match State.suggestion_for_uri link.href forest with
266
-
| Ok -> ()
267
-
| Not_found {suggestion} -> Reporter.emit @@ Broken_link {uri = link.href; suggestion}
277
+
begin if not @@ In_backmatter.read () then
278
+
match State.suggestion_for_uri link.href forest with
279
+
| Ok -> ()
280
+
| Not_found {suggestion} ->
281
+
Reporter.emit @@ Broken_link {uri = link.href; suggestion}
268
282
end;
269
283
[
270
284
X.href "%s" @@ URI.to_string @@ route forest link.href;
271
-
X.type_ "external"
285
+
X.type_ "external";
272
286
]
273
287
| Some article ->
274
288
[
275
289
X.href "%s" @@ URI.to_string @@ route forest link.href;
276
-
X.title_ "%s" @@
277
-
Plain_text_client.string_of_content ~forest: forest ~router: (route forest) @@
278
-
State.get_expanded_title ?scope: (Scope.read ()) article.frontmatter forest;
279
-
X.optional_ (X.uri_ "%s") @@ Option.map URI.to_string article.frontmatter.uri;
280
-
X.optional_ (X.display_uri_ "%s") @@ Option.map (URI.display_path_string ~base: forest.config.url) article.frontmatter.uri;
281
-
X.type_ "local"
290
+
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;
294
+
X.optional_ (X.uri_ "%s")
295
+
@@ Option.map URI.to_string article.frontmatter.uri;
296
+
X.optional_ (X.display_uri_ "%s")
297
+
@@ Option.map
298
+
(URI.display_path_string ~base:forest.config.url)
299
+
article.frontmatter.uri;
300
+
X.type_ "local";
282
301
]
283
302
in
284
303
[X.link attrs @@ render_content forest link.content]
285
304
286
-
and render_attributions (forest : State.t) (scope : URI.t option) (primary_attributions : _ T.attribution list) =
287
-
X.authors [] @@
288
-
List.map (render_attribution forest) @@
289
-
Forest_util.collect_attributions forest scope primary_attributions
305
+
and render_attributions (forest : State.t) (scope : URI.t option)
306
+
(primary_attributions : _ T.attribution list) =
307
+
X.authors []
308
+
@@ List.map (render_attribution forest)
309
+
@@ Forest_util.collect_attributions forest scope primary_attributions
290
310
291
311
and render_attribution forest (attrib : _ T.attribution) =
292
312
let tag =
293
-
match attrib.role with
294
-
| Author -> X.author
295
-
| Contributor -> X.contributor
313
+
match attrib.role with Author -> X.author | Contributor -> X.contributor
296
314
in
297
315
tag [] @@ render_attribution_vertex forest attrib.vertex
298
316
299
317
and render_attribution_vertex (forest : State.t) vtx =
300
318
match vtx with
301
319
| T.Uri_vertex href ->
302
-
let content = T.Content [T.Transclude {href; target = Title {empty_when_untitled = false}}] in
320
+
let content =
321
+
T.Content
322
+
[T.Transclude {href; target = Title {empty_when_untitled = false}}]
323
+
in
303
324
render_link forest T.{href; content}
304
-
| T.Content_vertex content ->
305
-
render_content forest content
325
+
| T.Content_vertex content -> render_content forest content
306
326
307
-
and render_dates forest dates =
308
-
X.null @@ List.map (render_date forest) dates
327
+
and render_dates forest dates = X.null @@ List.map (render_date forest) dates
309
328
310
329
and render_date forest (date : Human_datetime.t) =
311
330
let config = forest.config in
312
331
let href_attr =
313
-
let str = Format.asprintf "%a" Human_datetime.pp (Human_datetime.drop_time date) in
314
-
let uri = URI_scheme.named_uri ~base: config.url str in
332
+
let str =
333
+
Format.asprintf "%a" Human_datetime.pp (Human_datetime.drop_time date)
334
+
in
335
+
let uri = URI_scheme.named_uri ~base:config.url str in
315
336
match State.get_article uri forest with
316
337
| None -> X.null_
317
338
| Some _ -> X.href "%s" @@ URI.to_string @@ route forest uri
318
339
in
319
-
X.date
320
-
[href_attr]
340
+
X.date [href_attr]
321
341
[
322
342
X.year [] "%i" (Human_datetime.year date);
323
343
Human_datetime.month date |> X.optional @@ X.month [] "%i";
324
-
Human_datetime.day date |> X.optional @@ X.day [] "%i"
344
+
Human_datetime.day date |> X.optional @@ X.day [] "%i";
325
345
]
326
346
327
347
let render_article (forest : State.t) (article : T.content T.article) : P.node =
328
348
let before = Unix.gettimeofday () in
329
-
let@ () = fun kont ->
349
+
let@ () =
350
+
fun kont ->
330
351
let result = kont () in
331
352
let after = Unix.gettimeofday () in
332
353
let elapsed = after -. before in
333
354
if elapsed > 0.1 then
334
-
Logs.debug (fun m -> m "[Performance] rendering %a took %f seconds" Format.(pp_print_option URI.pp) article.frontmatter.uri elapsed);
355
+
Logs.debug (fun m ->
356
+
m "[Performance] rendering %a took %f seconds"
357
+
Format.(pp_print_option URI.pp)
358
+
article.frontmatter.uri elapsed);
335
359
result
336
360
in
337
361
let config = forest.config in
338
362
let@ () = Loop_detection.run in
339
-
let@ () = Scope.run ~forest ~env: article.frontmatter.uri in
363
+
let@ () = Scope.run ~forest ~env:article.frontmatter.uri in
340
364
let@ xmlnss = Xmlns.run in
341
-
let@ () = In_backmatter.run ~env: false in
365
+
let@ () = In_backmatter.run ~env:false in
342
366
X.tree
343
367
begin
344
-
List.map render_xmlns_prefix xmlnss @
345
-
[
346
-
X.optional_ X.root @@
347
-
begin
348
-
let@ uri = Option.map @~ article.frontmatter.uri in
349
-
URI.equal (Config.home_uri config) uri
350
-
end;
351
-
P.string_attr "base-url" "%s" (local_base_url_string config)
368
+
List.map render_xmlns_prefix xmlnss
369
+
@ [
370
+
X.optional_ X.root
371
+
@@ begin
372
+
let@ uri = Option.map @~ article.frontmatter.uri in
373
+
URI.equal (Config.home_uri config) uri
374
+
end;
375
+
P.string_attr "base-url" "%s" (local_base_url_string config);
352
376
]
353
377
end
354
378
[
355
379
render_frontmatter forest article.frontmatter;
356
-
X.mainmatter [] @@
357
-
begin
358
-
let@ () = Loop_detection.add_seen_uri_opt article.frontmatter.uri in
359
-
render_mainmatter forest @@ T.article_to_section article
360
-
end;
361
-
X.backmatter [] @@
362
-
let@ () = In_backmatter.run ~env: true in
363
-
render_content forest article.backmatter
380
+
X.mainmatter []
381
+
@@ begin
382
+
let@ () = Loop_detection.add_seen_uri_opt article.frontmatter.uri in
383
+
render_mainmatter forest @@ T.article_to_section article
384
+
end;
385
+
(X.backmatter []
386
+
@@
387
+
let@ () = In_backmatter.run ~env:true in
388
+
render_content forest article.backmatter);
364
389
]
365
390
366
391
let pp_xml ~(forest : State.t) ?stylesheet fmt (article : _ T.article) =
···
368
393
Format.pp_print_newline fmt ();
369
394
begin
370
395
let@ xsl_path = Option.iter @~ stylesheet in
371
-
Format.fprintf fmt "<?xml-stylesheet type=\"text/xsl\" href=\"%s%s\"?>" (local_base_url_string forest.config) xsl_path
396
+
Format.fprintf fmt "<?xml-stylesheet type=\"text/xsl\" href=\"%s%s\"?>"
397
+
(local_base_url_string forest.config)
398
+
xsl_path
372
399
end;
373
400
Format.pp_print_newline fmt ();
374
401
P.pp_xml fmt @@ render_article forest article
+7
-3
lib/frontend/Legacy_xml_client.mli
+7
-3
lib/frontend/Legacy_xml_client.mli
···
6
6
7
7
open Forester_core
8
8
open Forester_compiler
9
-
10
9
module T := Types
11
10
module P := Pure_html
12
11
13
12
val local_path_components : Config.t -> URI.t -> string list
14
13
val route : State.t -> URI.t -> URI.t
15
-
16
14
val render_article : State.t -> T.content T.article -> P.node
17
-
val pp_xml : forest: State.t -> ?stylesheet: string -> Format.formatter -> T.content T.article -> unit
15
+
16
+
val pp_xml :
17
+
forest:State.t ->
18
+
?stylesheet:string ->
19
+
Format.formatter ->
20
+
T.content T.article ->
21
+
unit
+9
-12
lib/frontend/Loop_detection_effect.ml
+9
-12
lib/frontend/Loop_detection_effect.ml
···
7
7
open Forester_core
8
8
9
9
module Make () = struct
10
-
open Algaeff.Reader.Make(struct type t = URI.Set.t end)
11
-
let add_seen_uri uri =
12
-
scope @@ URI.Set.add uri
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
13
15
14
16
let add_seen_uri_opt uri_opt kont =
15
-
match uri_opt with
16
-
| None -> kont ()
17
-
| Some uri -> add_seen_uri uri kont
17
+
match uri_opt with None -> kont () | Some uri -> add_seen_uri uri kont
18
18
19
-
let have_seen_uri uri =
20
-
URI.Set.mem uri @@ read ()
19
+
let have_seen_uri uri = URI.Set.mem uri @@ read ()
21
20
22
21
let have_seen_uri_opt uri_opt =
23
-
match uri_opt with
24
-
| None -> false
25
-
| Some uri -> have_seen_uri uri
22
+
match uri_opt with None -> false | Some uri -> have_seen_uri uri
26
23
27
-
let run k = run ~env: URI.Set.empty k
24
+
let run k = run ~env:URI.Set.empty k
28
25
end
+16
-6
lib/frontend/Plain_text_client.ml
+16
-6
lib/frontend/Plain_text_client.ml
···
7
7
open Forester_core
8
8
open Forester_compiler
9
9
10
-
open struct module T = Types end
10
+
open struct
11
+
module T = Types
12
+
end
11
13
12
14
let rec pp_content ~forest ~router fmt = function
13
15
| T.Content c -> c |> List.iter @@ pp_content_node ~forest ~router fmt
14
16
15
-
and pp_content_node ~forest ~(router : URI.t -> URI.t) fmt : 'a T.content_node -> unit = function
17
+
and pp_content_node ~forest ~(router : URI.t -> URI.t) fmt :
18
+
'a T.content_node -> unit = function
16
19
| Text txt | CDATA txt -> Format.pp_print_string fmt txt
17
20
| Uri uri -> URI.pp fmt uri
18
21
| Route_of_uri uri -> Format.fprintf fmt "%a" URI.pp (router uri)
···
24
27
| Link link -> pp_link ~forest ~router fmt link
25
28
| Results_of_datalog_query _ | Artefact _ | Datalog_script _ -> ()
26
29
27
-
and pp_transclusion ~forest ~(router : URI.t -> URI.t) fmt (transclusion : T.transclusion) =
30
+
and pp_transclusion ~forest ~(router : URI.t -> URI.t) fmt
31
+
(transclusion : T.transclusion) =
28
32
match State.get_content_of_transclusion transclusion forest with
29
-
| None -> Format.fprintf fmt "<could not resolve transclusion of %a>" URI.pp transclusion.href
33
+
| None ->
34
+
Format.fprintf fmt "<could not resolve transclusion of %a>" URI.pp
35
+
transclusion.href
30
36
| Some content -> pp_content ~forest ~router fmt content
31
37
32
38
and pp_link ~forest ~(router : URI.t -> URI.t) fmt (link : T.content T.link) =
33
39
pp_content ~forest ~router fmt link.content
34
40
35
-
and pp_section ~forest ~(router : URI.t -> URI.t) fmt (section : T.content T.section) =
41
+
and pp_section ~forest ~(router : URI.t -> URI.t) fmt
42
+
(section : T.content T.section) =
36
43
match section.frontmatter.title with
37
44
| None -> Format.fprintf fmt "<omitted content>"
38
-
| Some title -> Format.fprintf fmt "<omitted content: %a>" (pp_content ~forest ~router) title
45
+
| Some title ->
46
+
Format.fprintf fmt "<omitted content: %a>"
47
+
(pp_content ~forest ~router)
48
+
title
39
49
40
50
let string_of_content ~forest ?(router : URI.t -> URI.t = Fun.id) =
41
51
Format.asprintf "%a" (pp_content ~forest ~router)
+3
-7
lib/frontend/Plain_text_client.mli
+3
-7
lib/frontend/Plain_text_client.mli
···
6
6
7
7
open Forester_core
8
8
open Forester_compiler
9
-
10
9
module T := Types
11
10
12
11
val string_of_content :
13
-
forest: State.t ->
14
-
?router: (URI.t -> URI.t) ->
15
-
Types.content ->
16
-
string
12
+
forest:State.t -> ?router:(URI.t -> URI.t) -> Types.content -> string
17
13
18
14
val pp_content :
19
-
forest: State.t ->
20
-
router: (URI.t -> URI.t) ->
15
+
forest:State.t ->
16
+
router:(URI.t -> URI.t) ->
21
17
Format.formatter ->
22
18
Types.content ->
23
19
unit
+77
-62
lib/frontend/test/Test_DSL.ml
+77
-62
lib/frontend/test/Test_DSL.ml
···
6
6
7
7
open Forester_frontend.DSL
8
8
open Forester_core
9
-
open struct module T = Types end
9
+
10
+
open struct
11
+
module T = Types
12
+
end
10
13
11
14
let content_node =
12
-
(module struct
13
-
type t = T.content T.content_node
14
-
let equal = (=)
15
-
let pp = T.pp_content_node T.pp_content
16
-
end: Alcotest.TESTABLE with type t = T.content T.content_node)
15
+
(module struct
16
+
type t = T.content T.content_node
17
+
18
+
let equal = ( = )
19
+
let pp = T.pp_content_node T.pp_content
20
+
end : Alcotest.TESTABLE
21
+
with type t = T.content T.content_node)
17
22
18
23
let content =
19
24
p
20
25
[
21
-
ol
22
-
[
23
-
li [txt "First item"];
24
-
li [txt "Second item"]
25
-
];
26
-
ul
27
-
[
28
-
li [txt "First item"];
29
-
li [txt "Second item"]
30
-
];
31
-
section ~mainmatter: ([p [txt "section"]]) ();
26
+
ol [li [txt "First item"]; li [txt "Second item"]];
27
+
ul [li [txt "First item"]; li [txt "Second item"]];
28
+
section ~mainmatter:[p [txt "section"]] ();
32
29
em [txt "Emphasized item"];
33
30
strong [txt "Strong text"];
34
31
code [txt "fun _ -> ()"];
···
48
45
let test () =
49
46
Alcotest.(check @@ content_node)
50
47
"works"
51
-
(
52
-
T.prim `P @@
53
-
T.Content
54
-
[
55
-
T.prim `Ol @@
56
-
T.Content
48
+
(T.prim `P
49
+
@@ T.Content
50
+
[
51
+
T.prim `Ol
52
+
@@ T.Content
57
53
[
58
54
T.prim `Li @@ T.Content [Text "First item"];
59
-
T.prim `Li @@ T.Content [Text "Second item"]
55
+
T.prim `Li @@ T.Content [Text "Second item"];
60
56
];
61
-
T.prim `Ul @@
62
-
T.Content
57
+
T.prim `Ul
58
+
@@ T.Content
63
59
[
64
60
T.prim `Li @@ T.Content [Text "First item"];
65
-
T.prim `Li @@ T.Content [Text "Second item"]
61
+
T.prim `Li @@ T.Content [Text "Second item"];
66
62
];
67
-
Section
68
-
{
69
-
frontmatter = {
70
-
uri = None;
71
-
title = None;
72
-
dates = [];
73
-
attributions = [];
74
-
taxon = None;
75
-
number = None;
76
-
designated_parent = None;
77
-
source_path = None;
78
-
tags = [];
79
-
metas = [];
80
-
last_changed = None
81
-
};
82
-
mainmatter = Content [T.prim `P @@ T.Content [Text "section"]];
83
-
flags = {hidden_when_empty = None; included_in_toc = None; header_shown = None; metadata_shown = (Some false); numbered = None; expanded = None}
84
-
};
85
-
T.prim `Em @@ T.Content [Text "Emphasized item"];
86
-
T.prim `Strong @@ T.Content [Text "Strong text"];
87
-
T.prim `Code @@ T.Content [Text "fun _ -> ()"];
88
-
T.prim `Blockquote @@ T.Content [Text "blockquote"];
89
-
T.prim `Pre @@ T.Content [Text "pre"];
90
-
T.prim `Figure @@ T.Content [Text "figure"];
91
-
T.prim `Figcaption @@ T.Content [Text "caption"];
92
-
CDATA "cdata";
93
-
Xml_elt {name = {prefix = ""; uname = "html"; xmlns = None}; attrs = []; content = (Content [])};
94
-
Transclude {href = URI.of_string_exn "foo-001"; target = Mainmatter};
95
-
Contextual_number (URI.of_string_exn "chapter-3");
96
-
KaTeX (Inline, Content [Text "a = b"]);
97
-
Link {href = URI.of_string_exn "https://git.sr.ht/~jonsterling/ocaml-forester"; content = Content [Text "Forester"]};
98
-
Artefact {hash = ""; content = (Content [Text "res"]); sources = []}
99
-
]
100
-
)
63
+
Section
64
+
{
65
+
frontmatter =
66
+
{
67
+
uri = None;
68
+
title = None;
69
+
dates = [];
70
+
attributions = [];
71
+
taxon = None;
72
+
number = None;
73
+
designated_parent = None;
74
+
source_path = None;
75
+
tags = [];
76
+
metas = [];
77
+
last_changed = None;
78
+
};
79
+
mainmatter = Content [T.prim `P @@ T.Content [Text "section"]];
80
+
flags =
81
+
{
82
+
hidden_when_empty = None;
83
+
included_in_toc = None;
84
+
header_shown = None;
85
+
metadata_shown = Some false;
86
+
numbered = None;
87
+
expanded = None;
88
+
};
89
+
};
90
+
T.prim `Em @@ T.Content [Text "Emphasized item"];
91
+
T.prim `Strong @@ T.Content [Text "Strong text"];
92
+
T.prim `Code @@ T.Content [Text "fun _ -> ()"];
93
+
T.prim `Blockquote @@ T.Content [Text "blockquote"];
94
+
T.prim `Pre @@ T.Content [Text "pre"];
95
+
T.prim `Figure @@ T.Content [Text "figure"];
96
+
T.prim `Figcaption @@ T.Content [Text "caption"];
97
+
CDATA "cdata";
98
+
Xml_elt
99
+
{
100
+
name = {prefix = ""; uname = "html"; xmlns = None};
101
+
attrs = [];
102
+
content = Content [];
103
+
};
104
+
Transclude {href = URI.of_string_exn "foo-001"; target = Mainmatter};
105
+
Contextual_number (URI.of_string_exn "chapter-3");
106
+
KaTeX (Inline, Content [Text "a = b"]);
107
+
Link
108
+
{
109
+
href =
110
+
URI.of_string_exn
111
+
"https://git.sr.ht/~jonsterling/ocaml-forester";
112
+
content = Content [Text "Forester"];
113
+
};
114
+
Artefact {hash = ""; content = Content [Text "res"]; sources = []};
115
+
])
101
116
content
102
117
103
118
let () =
104
119
let open Alcotest in
105
-
run "DSL" ["works", [test_case "" `Quick test]]
120
+
run "DSL" [("works", [test_case "" `Quick test])]
+29
-26
lib/frontend/test/Test_config.ml
+29
-26
lib/frontend/test/Test_config.ml
···
12
12
let test_parsing () =
13
13
Alcotest.(check config)
14
14
"is the same"
15
-
Config.{
16
-
trees = ["trees"];
17
-
assets = [];
18
-
url = URI.of_string_exn "https://www.forester-notes.org/";
19
-
home = URI.of_string_exn "https://www.forester-notes.org/index/";
20
-
foreign = [{path = "foreign/forest.json"; route_locally = true; include_in_manifest = true}];
21
-
}
15
+
Config.
16
+
{
17
+
trees = ["trees"];
18
+
assets = [];
19
+
url = URI.of_string_exn "https://www.forester-notes.org/";
20
+
home = URI.of_string_exn "https://www.forester-notes.org/index/";
21
+
foreign =
22
+
[
23
+
{
24
+
path = "foreign/forest.json";
25
+
route_locally = true;
26
+
include_in_manifest = true;
27
+
};
28
+
];
29
+
}
22
30
begin
23
31
Forester_core.Reporter.easy_run @@ fun () ->
24
32
Config_parser.parse_forest_config_string
···
34
42
let test_missing_fields () =
35
43
Alcotest.(check config)
36
44
"is the same"
37
-
Config.{
38
-
trees = ["trees"];
39
-
assets = [];
40
-
foreign = [];
41
-
url = URI.of_string_exn "/";
42
-
home = URI.of_string_exn "/index/";
43
-
}
44
-
(
45
-
Forester_core.Reporter.easy_run @@ fun () ->
45
+
Config.
46
+
{
47
+
trees = ["trees"];
48
+
assets = [];
49
+
foreign = [];
50
+
url = URI.of_string_exn "/";
51
+
home = URI.of_string_exn "/index/";
52
+
}
53
+
( Forester_core.Reporter.easy_run @@ fun () ->
46
54
Config_parser.parse_forest_config_string
47
55
{|
48
56
[forest]
···
55
63
let open Alcotest in
56
64
Logs.set_level (Some Debug);
57
65
Logs.set_reporter (Logs.format_reporter ());
58
-
run
59
-
"Config parsing"
66
+
run "Config parsing"
60
67
[
61
-
"example config works",
62
-
[
63
-
test_case "it parses correctly" `Quick test_parsing;
64
-
];
65
-
"can parse config with missing fields",
66
-
[
67
-
test_case "" `Quick test_missing_fields;
68
-
];
68
+
( "example config works",
69
+
[test_case "it parses correctly" `Quick test_parsing] );
70
+
( "can parse config with missing fields",
71
+
[test_case "" `Quick test_missing_fields] );
69
72
]
+31
-53
lib/frontend/test/Test_transclusion.ml
+31
-53
lib/frontend/test/Test_transclusion.ml
···
22
22
module Transclusions = struct
23
23
(* It would be cool to use quickcheck here, but no good way to test the result*)
24
24
open T
25
-
let full_default = {
26
-
href;
27
-
target = Full default_section_flags
28
-
}
29
25
30
-
let metadata_shown = {default_section_flags with
31
-
metadata_shown =
32
-
Some true
33
-
}
26
+
let full_default = {href; target = Full default_section_flags}
27
+
let metadata_shown = {default_section_flags with metadata_shown = Some true}
34
28
end
35
29
36
30
let () =
···
39
33
let@ () = Reporter.easy_run in
40
34
let uri = URI_scheme.named_uri ~base:config.url "transcludee" in
41
35
let index = URI.Tbl.create 10 in
42
-
URI.Tbl.add index uri @@
43
-
Tree.Resource
44
-
{
45
-
resource =
46
-
T.Article
47
-
{
48
-
frontmatter =
49
-
T.default_frontmatter
50
-
~uri: (URI.of_string_exn "forest://test/transcludee")
51
-
~title: (T.Content [Text "I am being transcluded"])
52
-
();
53
-
mainmatter = Content [Text "Hello"];
54
-
backmatter = Content []
55
-
};
56
-
expanded = None;
57
-
route_locally = true;
58
-
include_in_manifest = true;
59
-
};
60
-
let forest = {(State.make ~env ~config ~dev: false ()) with index} in
61
-
let print_transclusion : T.transclusion -> unit = fun t ->
36
+
URI.Tbl.add index uri
37
+
@@ Tree.Resource
38
+
{
39
+
resource =
40
+
T.Article
41
+
{
42
+
frontmatter =
43
+
T.default_frontmatter
44
+
~uri:(URI.of_string_exn "forest://test/transcludee")
45
+
~title:(T.Content [Text "I am being transcluded"]) ();
46
+
mainmatter = Content [Text "Hello"];
47
+
backmatter = Content [];
48
+
};
49
+
expanded = None;
50
+
route_locally = true;
51
+
include_in_manifest = true;
52
+
};
53
+
let forest = {(State.make ~env ~config ~dev:false ()) with index} in
54
+
let print_transclusion : T.transclusion -> unit =
55
+
fun t ->
62
56
let content = Option.get @@ State.get_content_of_transclusion t forest in
63
-
Format.printf
64
-
"%a"
57
+
Format.printf "%a"
65
58
(Legacy_xml_client.pp_xml ~forest ?stylesheet:None)
66
-
(
67
-
T.{
68
-
frontmatter = default_frontmatter ~uri: href ();
59
+
T.
60
+
{
61
+
frontmatter = default_frontmatter ~uri:href ();
69
62
mainmatter = content;
70
-
backmatter = Content []
63
+
backmatter = Content [];
71
64
}
72
-
)
73
65
in
74
-
let test_full_default () =
75
-
print_transclusion
76
-
Transclusions.full_default
77
-
in
66
+
let test_full_default () = print_transclusion Transclusions.full_default in
78
67
let test_title_default () =
79
68
print_transclusion
80
-
{
81
-
href = uri;
82
-
target = Title {empty_when_untitled = false}
83
-
}
69
+
{href = uri; target = Title {empty_when_untitled = false}}
84
70
in
85
71
let test_full_metadata () =
86
-
print_transclusion
87
-
{
88
-
href = uri;
89
-
target = Full Transclusions.metadata_shown
90
-
}
72
+
print_transclusion {href = uri; target = Full Transclusions.metadata_shown}
91
73
in
92
74
List.iter
93
75
(fun f -> f ())
94
-
[
95
-
test_full_default;
96
-
test_title_default;
97
-
test_full_metadata
98
-
]
76
+
[test_full_default; test_title_default; test_full_metadata]
+16
-20
lib/human_datetime/Conversion.ml
+16
-20
lib/human_datetime/Conversion.ml
···
9
9
type ptime_time_state = {
10
10
mutable hour: int;
11
11
mutable minute: int;
12
-
mutable second: int
12
+
mutable second: int;
13
13
}
14
14
15
15
type ptime_date_state = {
16
16
mutable year: int;
17
17
mutable month: int;
18
-
mutable day: int
18
+
mutable day: int;
19
19
}
20
20
21
21
let ptime_time_state_to_seconds state =
22
-
state.second + 60 * (state.minute + 60 * state.hour)
22
+
state.second + (60 * (state.minute + (60 * state.hour)))
23
23
24
24
type ptime_date_time_state = {
25
25
date: ptime_date_state;
26
26
time: ptime_time_state;
27
-
mutable tz_offset_s: int
27
+
mutable tz_offset_s: int;
28
28
}
29
29
30
30
let init_ptime_time_state () = {hour = 0; minute = 0; second = 0}
31
-
32
31
let init_ptime_date_state () = {year = 0; month = 1; day = 1}
33
32
34
-
let init_ptime_date_time_state () = {
35
-
date = init_ptime_date_state ();
36
-
time = init_ptime_time_state ();
37
-
tz_offset_s = 0
38
-
}
33
+
let init_ptime_date_time_state () =
34
+
{
35
+
date = init_ptime_date_state ();
36
+
time = init_ptime_time_state ();
37
+
tz_offset_s = 0;
38
+
}
39
39
40
40
let to_ptime datetime =
41
41
let go_void (x : void) = match x with _ -> . in
42
-
let go_second state (Second s) =
43
-
state.second <- s
44
-
in
42
+
let go_second state (Second s) = state.second <- s in
45
43
let go_minute state rest (Minute (m, rest_opt)) =
46
44
state.minute <- m;
47
45
Option.iter rest rest_opt
···
56
54
let time_state = init_ptime_time_state () in
57
55
go_hour time_state (go_minute time_state go_void) time;
58
56
let offset = ptime_time_state_to_seconds time_state in
59
-
let sign =
60
-
match pm with
61
-
| Plus -> 1
62
-
| Minus -> -1
63
-
in
57
+
let sign = match pm with Plus -> 1 | Minus -> -1 in
64
58
state.tz_offset_s <- sign * offset
65
59
in
66
60
let go_time_with_offset state ((time, offset) : time_with_offset) =
···
81
75
in
82
76
let state = init_ptime_date_time_state () in
83
77
go_year state datetime;
84
-
let date = state.date.year, state.date.month, state.date.day in
85
-
let time = ((state.time.hour, state.time.minute, state.time.second), state.tz_offset_s) in
78
+
let date = (state.date.year, state.date.month, state.date.day) in
79
+
let time =
80
+
((state.time.hour, state.time.minute, state.time.second), state.tz_offset_s)
81
+
in
86
82
Ptime.of_date_time (date, time)
+3
-7
lib/human_datetime/Human_datetime.ml
+3
-7
lib/human_datetime/Human_datetime.ml
···
10
10
type t = datetime
11
11
12
12
let year = function Year (y, _) -> y
13
-
14
-
let month = function
15
-
| Year (_, Some (Month (m, _))) -> Some m
16
-
| _ -> None
13
+
let month = function Year (_, Some (Month (m, _))) -> Some m | _ -> None
17
14
18
15
let day = function
19
16
| Year (_, Some (Month (_, Some (Day (d, _))))) -> Some d
···
27
24
let pp = pp_datetime
28
25
29
26
let compare dt0 dt1 =
30
-
match to_ptime dt0, to_ptime dt1 with
27
+
match (to_ptime dt0, to_ptime dt1) with
31
28
| Some x0, Some x1 -> Ptime.compare x0 x1
32
29
| None, None -> 0
33
30
| None, Some _ -> -1
···
36
33
let parse lexbuf =
37
34
match Grammar.datetime Lexer.token lexbuf with
38
35
| datetime -> Some datetime
39
-
| exception Grammar.Error ->
40
-
None
36
+
| exception Grammar.Error -> None
41
37
42
38
let parse_string str =
43
39
let lexbuf = Lexing.from_string str in
+1
-5
lib/human_datetime/Human_datetime.mli
+1
-5
lib/human_datetime/Human_datetime.mli
···
5
5
*)
6
6
7
7
type t
8
-
val t : t Repr.t
9
8
9
+
val t : t Repr.t
10
10
val pp : Format.formatter -> t -> unit
11
11
val pp_rfc_3399 : Format.formatter -> t -> unit
12
-
13
12
val compare : t -> t -> int
14
-
15
13
val parse_string : string -> t option
16
14
val parse_string_exn : string -> t
17
-
18
15
val year : t -> int
19
16
val month : t -> int option
20
17
val day : t -> int option
21
-
22
18
val now : unit -> t
23
19
val drop_time : t -> t
+18
-27
lib/human_datetime/Types.ml
+18
-27
lib/human_datetime/Types.ml
···
5
5
*)
6
6
7
7
type void = |
8
-
9
8
type second = Second of int
10
9
type 'a minute = Minute of int * 'a option
11
10
type 'a hour = Hour of int * 'a option
12
-
13
11
type pm = Plus | Minus
14
12
type offset = Z | Offset of pm * void minute hour
15
-
16
13
type time_with_offset = second minute hour * offset
17
-
18
14
type day = Day of int * time_with_offset option
19
15
type month = Month of int * day option
20
16
type year = Year of int * month option
21
-
22
17
type datetime = year
23
18
24
-
let pp_void _fmt (x : void) =
25
-
match x with
26
-
| _ -> .
27
-
28
-
let pp_second fmt (Second s) =
29
-
Format.fprintf fmt "%02d" s
19
+
let pp_void _fmt (x : void) = match x with _ -> .
20
+
let pp_second fmt (Second s) = Format.fprintf fmt "%02d" s
30
21
31
22
let pp_minute pp_rest fmt (Minute (m, rest_opt)) =
32
23
Format.fprintf fmt "%02d" m;
33
24
match rest_opt with
34
25
| None -> ()
35
-
| Some rest ->
36
-
Format.fprintf fmt ":%a" pp_rest rest
26
+
| Some rest -> Format.fprintf fmt ":%a" pp_rest rest
37
27
38
28
let pp_hour pp_rest fmt (Hour (h, rest_opt)) =
39
29
Format.fprintf fmt "%02d" h;
40
30
match rest_opt with
41
31
| None -> ()
42
-
| Some rest ->
43
-
Format.fprintf fmt ":%a" pp_rest rest
32
+
| Some rest -> Format.fprintf fmt ":%a" pp_rest rest
44
33
45
34
let pp_pm fmt = function
46
35
| Plus -> Format.fprintf fmt "+"
···
67
56
Format.fprintf fmt "%02d" m;
68
57
match day_opt with
69
58
| None -> ()
70
-
| Some day ->
71
-
Format.fprintf fmt "-%a" pp_day day
59
+
| Some day -> Format.fprintf fmt "-%a" pp_day day
72
60
73
61
let pp_year fmt (Year (y, month_opt)) =
74
62
Format.fprintf fmt "%04d" y;
75
63
match month_opt with
76
64
| None -> ()
77
-
| Some month ->
78
-
Format.fprintf fmt "-%a" pp_month month
65
+
| Some month -> Format.fprintf fmt "-%a" pp_month month
79
66
80
67
let pp_datetime = pp_year
81
-
82
68
let zero_second = Second 0
83
69
let zero_minute = Minute (0, Some zero_second)
84
70
let zero_hms = Hour (0, Some zero_minute)
85
71
let zero_time_with_offset = (zero_hms, Z)
86
72
let zero_day = Day (1, Some zero_time_with_offset)
87
-
88
73
let zero_month = Month (1, Some zero_day)
89
74
90
75
let expand_minute (Minute (m, sec_opt)) =
91
-
Minute (m, Option.some @@ Option.fold ~none: zero_second ~some: Fun.id sec_opt)
76
+
Minute (m, Option.some @@ Option.fold ~none:zero_second ~some:Fun.id sec_opt)
92
77
93
78
let expand_hour (Hour (h, min_opt)) =
94
-
Hour (h, Option.some @@ Option.fold ~none: zero_minute ~some: expand_minute min_opt)
79
+
Hour
80
+
(h, Option.some @@ Option.fold ~none:zero_minute ~some:expand_minute min_opt)
95
81
96
-
let expand_time_with_offset (hms, offset) = expand_hour hms, offset
82
+
let expand_time_with_offset (hms, offset) = (expand_hour hms, offset)
97
83
98
84
let expand_day (Day (d, time_with_offset_opt)) =
99
-
Day (d, Option.some @@ Option.fold ~none: zero_time_with_offset ~some: expand_time_with_offset time_with_offset_opt)
85
+
Day
86
+
( d,
87
+
Option.some
88
+
@@ Option.fold ~none:zero_time_with_offset ~some:expand_time_with_offset
89
+
time_with_offset_opt )
100
90
101
91
let expand_month (Month (m, day_opt)) =
102
-
Month (m, Option.some @@ Option.fold ~none: zero_day ~some: expand_day day_opt)
92
+
Month (m, Option.some @@ Option.fold ~none:zero_day ~some:expand_day day_opt)
103
93
104
94
let expand_year (Year (y, month_opt)) =
105
-
Year (y, Option.some @@ Option.fold ~none: zero_month ~some: expand_month month_opt)
95
+
Year
96
+
(y, Option.some @@ Option.fold ~none:zero_month ~some:expand_month month_opt)
106
97
107
98
(* TODO *)
108
99
let pp_rfc_3399 fmt dt = pp_datetime fmt @@ expand_year dt
+129
-151
lib/language_server/Analysis.ml
+129
-151
lib/language_server/Analysis.ml
···
10
10
open Forester_core
11
11
12
12
module Item = struct
13
-
type t =
14
-
| Path of Trie.path
15
-
| Addr of string
13
+
type t = Path of Trie.path | Addr of string
14
+
16
15
let addr str = Addr str
17
16
let path p = Path p
18
17
end
···
21
20
module R = Resolver
22
21
module Sc = R.Scope
23
22
module L = Lsp.Types
24
-
module S = Algaeff.Sequencer.Make(struct
23
+
24
+
module S = Algaeff.Sequencer.Make (struct
25
25
type t = Item.t Range.located
26
26
end)
27
27
end
28
28
29
-
let flatten (tree : Code.t) : Code.t =
30
-
List.concat_map Code.children tree
31
-
32
-
let paths_in_bindings =
33
-
List.map (fun (_, x) -> [x])
29
+
let flatten (tree : Code.t) : Code.t = List.concat_map Code.children tree
30
+
let paths_in_bindings = List.map (fun (_, x) -> [x])
34
31
35
32
(* This function should not descend into the nodes!*)
36
33
let paths : Code.node Range.located -> _ = function
37
-
| {value; loc;} ->
34
+
| {value; loc} -> (
38
35
match value with
39
36
| Ident path
40
-
| Open (path)
37
+
| Open path
41
38
| Put (path, _)
42
39
| Default (path, _)
43
40
| Get path
44
41
| Alloc path
45
42
| Namespace (path, _) ->
46
43
Some ([path], loc)
47
-
| Def (path, bindings, _)
48
-
| Let (path, bindings, _) ->
44
+
| Def (path, bindings, _) | Let (path, bindings, _) ->
49
45
Some (path :: paths_in_bindings bindings, loc)
50
-
| Patch {self; _}
51
-
| Object {self; _;} ->
52
-
Option.map (fun x -> [[x]], loc) self
46
+
| Patch {self; _} | Object {self; _} ->
47
+
Option.map (fun x -> ([[x]], loc)) self
53
48
| Fun (bindings, _) -> Some (paths_in_bindings bindings, loc)
54
-
| Subtree _
55
-
| Group _
56
-
| Scope _
57
-
| Math _
58
-
| Dx_sequent _
59
-
| Dx_const_uri _
60
-
| Dx_const_content _
61
-
| Dx_query _
62
-
| Dx_prop _
63
-
| Text _
64
-
| Verbatim _
65
-
| Hash_ident _
66
-
| Xml_ident _
67
-
| Call _
68
-
| Import _
69
-
| Decl_xmlns _
70
-
| Dx_var _
71
-
| Comment _
72
-
| Error _ ->
73
-
None
49
+
| Subtree _ | Group _ | Scope _ | Math _ | Dx_sequent _ | Dx_const_uri _
50
+
| Dx_const_content _ | Dx_query _ | Dx_prop _ | Text _ | Verbatim _
51
+
| Hash_ident _ | Xml_ident _ | Call _ | Import _ | Decl_xmlns _ | Dx_var _
52
+
| Comment _ | Error _ ->
53
+
None)
74
54
75
55
let extract_addr (node : Code.node Range.located) =
76
56
match node.value with
···
78
58
| Group (Parens, [{value = Text addr; _}])
79
59
| Text addr (* SEEEMS DODGY!! *)
80
60
| Import (_, addr) ->
81
-
Some (Range.{value = addr; loc = node.loc})
61
+
Some Range.{value = addr; loc = node.loc}
82
62
| Subtree (addr, _) ->
83
63
Option.map (fun s -> Range.{value = s; loc = node.loc}) addr
84
64
| _ -> None
···
86
66
let rec analyse (node : Code.node Range.located) =
87
67
begin
88
68
let@ {value; loc} = Option.iter @~ extract_addr node in
89
-
S.yield ({value = Item.addr value; loc});
69
+
S.yield {value = Item.addr value; loc}
90
70
end;
91
71
begin
92
72
let@ paths, loc = Option.iter @~ paths node in
93
73
let@ path = List.iter @~ paths in
94
-
S.yield ({value = Item.path path; loc});
74
+
S.yield {value = Item.path path; loc}
95
75
end;
96
76
let children = Code.children node in
97
77
List.iter analyse children
···
100
80
let@ () = S.run in
101
81
List.iter analyse nodes
102
82
103
-
let contains = fun
104
-
~(position : Lsp.Types.Position.t)
105
-
(loc : Range.t option)
106
-
->
107
-
let L.Position.{line = cursor_line; character = cursor_character} = position in
83
+
let contains =
84
+
fun ~(position : Lsp.Types.Position.t) (loc : Range.t option) ->
85
+
let L.Position.{line = cursor_line; character = cursor_character} =
86
+
position
87
+
in
108
88
match loc with
109
-
| Some loc ->
110
-
begin
111
-
match Range.view loc with
112
-
| `Range (start, end_) ->
113
-
let start_pos = Lsp_shims.Loc.lsp_pos_of_pos start in
114
-
let end_pos = Lsp_shims.Loc.lsp_pos_of_pos end_ in
115
-
let at_or_after_start =
116
-
cursor_line < end_pos.line
117
-
|| (cursor_line = start_pos.line && start_pos.character <= cursor_character)
118
-
in
119
-
let before_or_at_end =
120
-
end_pos.line > cursor_line
121
-
|| (cursor_line = end_pos.line && cursor_character <= end_pos.character)
122
-
in
123
-
at_or_after_start && before_or_at_end
124
-
| _ -> false
125
-
end
89
+
| Some loc -> begin
90
+
match Range.view loc with
91
+
| `Range (start, end_) ->
92
+
let start_pos = Lsp_shims.Loc.lsp_pos_of_pos start in
93
+
let end_pos = Lsp_shims.Loc.lsp_pos_of_pos end_ in
94
+
let at_or_after_start =
95
+
cursor_line < end_pos.line
96
+
|| cursor_line = start_pos.line
97
+
&& start_pos.character <= cursor_character
98
+
in
99
+
let before_or_at_end =
100
+
end_pos.line > cursor_line
101
+
|| (cursor_line = end_pos.line && cursor_character <= end_pos.character)
102
+
in
103
+
at_or_after_start && before_or_at_end
104
+
| _ -> false
105
+
end
126
106
| None -> false
127
107
128
-
let rec node_at
129
-
: type a. position: L.Position.t -> children: (a Range.located -> a Range.located list) -> a Range.located list -> a Range.located option
130
-
= fun ~position ~children code ->
108
+
let rec node_at : type a.
109
+
position:L.Position.t ->
110
+
children:(a Range.located -> a Range.located list) ->
111
+
a Range.located list ->
112
+
a Range.located option =
113
+
fun ~position ~children code ->
131
114
match List.find_opt (fun Range.{loc; _} -> contains ~position loc) code with
132
115
| None -> None
133
-
| Some n ->
116
+
| Some n -> (
134
117
match (node_at ~position ~children) (children n) with
135
118
| Some inner -> Some inner
136
-
| None -> Some n
119
+
| None -> Some n)
137
120
138
121
let get_enclosing_code_group ~position tree =
139
122
let rec go ~position nodes =
140
-
match List.find_opt (fun Range.{loc; _} -> contains ~position loc) nodes with
123
+
match
124
+
List.find_opt (fun Range.{loc; _} -> contains ~position loc) nodes
125
+
with
141
126
| None -> None
142
-
| Some n ->
127
+
| Some n -> (
143
128
match n.value with
144
-
| (Code.Group (delim, t)) ->
145
-
begin
146
-
match go ~position t with
147
-
| None -> Some Asai.Range.{value = (delim, t); loc = n.loc}
148
-
| Some t -> Some t
149
-
end
150
-
| _ ->
151
-
(go ~position) (Code.children n)
129
+
| Code.Group (delim, t) -> begin
130
+
match go ~position t with
131
+
| None -> Some Asai.Range.{value = (delim, t); loc = n.loc}
132
+
| Some t -> Some t
133
+
end
134
+
| _ -> (go ~position) (Code.children n))
152
135
in
153
136
match Tree.to_code tree with
154
137
| None -> None
155
-
| Some code ->
156
-
go ~position code.nodes
138
+
| Some code -> go ~position code.nodes
157
139
158
140
let get_enclosing_syn_group ~position tree =
159
141
let rec go ~position nodes =
160
-
match List.find_opt (fun Range.{loc; _} -> contains ~position loc) nodes with
142
+
match
143
+
List.find_opt (fun Range.{loc; _} -> contains ~position loc) nodes
144
+
with
161
145
| None -> None
162
-
| Some n ->
146
+
| Some n -> (
163
147
match n.value with
164
-
| (Syn.Group (delim, children)) ->
165
-
begin
166
-
match go ~position children with
167
-
| None -> Some Asai.Range.{value = (delim, children); loc = n.loc}
168
-
| Some t -> Some t
169
-
end
170
-
| _ ->
171
-
go ~position (Syn.children n)
148
+
| Syn.Group (delim, children) -> begin
149
+
match go ~position children with
150
+
| None -> Some Asai.Range.{value = (delim, children); loc = n.loc}
151
+
| Some t -> Some t
152
+
end
153
+
| _ -> go ~position (Syn.children n))
172
154
in
173
155
match Tree.to_syn tree with
174
156
| None -> None
175
-
| Some syn ->
176
-
go ~position syn.nodes
157
+
| Some syn -> go ~position syn.nodes
177
158
178
-
let enclosing_group_start
179
-
~position
180
-
~(enclosing_group : position: L.Position.t -> Tree.t -> (delim * 'a) Range.located option)
181
-
(tree : Tree.t)
182
-
=
159
+
let enclosing_group_start ~position
160
+
~(enclosing_group :
161
+
position:L.Position.t -> Tree.t -> (delim * 'a) Range.located option)
162
+
(tree : Tree.t) =
183
163
match enclosing_group ~position tree with
184
164
| None -> Some position
185
165
| Some {loc; value = _} ->
186
166
let start =
187
167
Option.map (function
188
168
| `Range (start, _) -> start
189
-
| `End_of_file pos -> pos
190
-
) @@
191
-
Option.map Range.view loc
169
+
| `End_of_file pos -> pos)
170
+
@@ Option.map Range.view loc
192
171
in
193
-
Option.map
194
-
(Lsp_shims.Loc.lsp_pos_of_pos)
195
-
start
172
+
Option.map Lsp_shims.Loc.lsp_pos_of_pos start
196
173
197
174
let find_with_prev ~position =
198
175
let rec go prev = function
199
176
| [] -> None
200
-
| x :: xs -> if contains ~position Asai.Range.(x.loc) then Some (prev, x) else go (Some x) xs
177
+
| x :: xs ->
178
+
if contains ~position Asai.Range.(x.loc) then Some (prev, x)
179
+
else go (Some x) xs
201
180
in
202
181
go None
203
182
204
183
module Context = struct
205
184
(* Kind of like a zipper where you can only go backwards? *)
206
-
type 'a t =
207
-
| Prev of 'a * 'a
208
-
| Parent of 'a
209
-
| Top of 'a
185
+
type 'a t = Prev of 'a * 'a | Parent of 'a | Top of 'a
210
186
end
211
187
212
-
let parent_or_prev_at
213
-
: type a. position: L.Position.t ->
214
-
children: (a Range.located -> a Range.located list) ->
215
-
a Range.located list ->
216
-
a Range.located Context.t option
217
-
= fun ~position ~children code ->
188
+
let parent_or_prev_at : type a.
189
+
position:L.Position.t ->
190
+
children:(a Range.located -> a Range.located list) ->
191
+
a Range.located list ->
192
+
a Range.located Context.t option =
193
+
fun ~position ~children code ->
218
194
let go ~position ~children nodes =
219
195
match find_with_prev ~position nodes with
220
196
| None -> None
221
-
| Some (None, node) ->
222
-
begin
223
-
match (node_at ~position ~children) (children node) with
224
-
| Some inner ->
225
-
(* go ~position ~children (children inner) *)
226
-
Some (Context.Top inner)
227
-
| None -> Some (Top node)
228
-
end
229
-
| Some (Some prev, node) ->
197
+
| Some (None, node) -> begin
198
+
match (node_at ~position ~children) (children node) with
199
+
| Some inner ->
200
+
(* go ~position ~children (children inner) *)
201
+
Some (Context.Top inner)
202
+
| None -> Some (Top node)
203
+
end
204
+
| Some (Some prev, node) -> (
230
205
match (node_at ~position ~children) (children node) with
231
206
| None -> Some (Prev (prev, node))
232
-
| Some inner ->
233
-
Some (Top inner)
207
+
| Some inner -> Some (Top inner))
234
208
in
235
209
go ~position ~children code
236
210
237
-
let parent_or_prev_at_code ~position = parent_or_prev_at ~position ~children: Code.children
238
-
let parent_or_prev_at_syn ~position = parent_or_prev_at ~position ~children: Syn.children
211
+
let parent_or_prev_at_code ~position =
212
+
parent_or_prev_at ~position ~children:Code.children
213
+
214
+
let parent_or_prev_at_syn ~position =
215
+
parent_or_prev_at ~position ~children:Syn.children
239
216
240
-
let node_at_code ~position = node_at ~position ~children: Code.children
241
-
let node_at_syn ~position = node_at ~position ~children: Syn.children
217
+
let node_at_code ~position = node_at ~position ~children:Code.children
218
+
let node_at_syn ~position = node_at ~position ~children:Syn.children
242
219
243
220
let get_visible ~forest ~position code =
244
-
Sc.run ~init_visible: Expand.initial_visible_trie @@ fun () ->
221
+
Sc.run ~init_visible:Expand.initial_visible_trie @@ fun () ->
245
222
let open Effect.Deep in
246
223
match_with
247
224
(Expand.expand_eff ~forest)
···
249
226
{
250
227
retc = (fun _ -> Sc.get_visible ());
251
228
exnc = raise;
252
-
effc = fun (type a) (eff : a Effect.t) ->
253
-
match eff with
254
-
| Expand.Entered_range range ->
255
-
Option.some @@ fun (k : (a, _) continuation) ->
256
-
if contains ~position range then
257
-
Sc.get_visible ()
258
-
else
259
-
continue k ()
260
-
| _ -> None
229
+
effc =
230
+
(fun (type a) (eff : a Effect.t) ->
231
+
match eff with
232
+
| Expand.Entered_range range ->
233
+
Option.some @@ fun (k : (a, _) continuation) ->
234
+
if contains ~position range then Sc.get_visible ()
235
+
else continue k ()
236
+
| _ -> None);
261
237
}
262
238
263
-
let addr_at ~(position : Lsp.Types.Position.t) (code : _ list) : _ Range.located option =
264
-
Option.bind (node_at ~position ~children: Code.children code) extract_addr
239
+
let addr_at ~(position : Lsp.Types.Position.t) (code : _ list) :
240
+
_ Range.located option =
241
+
Option.bind (node_at ~position ~children:Code.children code) extract_addr
265
242
266
243
exception Found of string
267
244
268
245
let word_at ~position (doc : Lsp.Text_document.t) =
269
-
let L.Position.{line; character;} = position in
270
-
let line = List.nth_opt (String.split_on_char '\n' (Lsp.Text_document.text doc)) line in
246
+
let L.Position.{line; character} = position in
247
+
let line =
248
+
List.nth_opt (String.split_on_char '\n' (Lsp.Text_document.text doc)) line
249
+
in
271
250
match line with
272
251
| None -> None
273
-
| Some line ->
252
+
| Some line -> (
274
253
let words = String.split_on_char ' ' line in
275
254
try
276
255
let acc = ref 0 in
···
278
257
(fun word ->
279
258
let length = String.length word in
280
259
if !acc + length + 1 > character then raise (Found word)
281
-
else acc := !acc + length + 1
282
-
)
260
+
else acc := !acc + length + 1)
283
261
words;
284
262
None
285
-
with
286
-
| Found str -> Some str
263
+
with Found str -> Some str)
287
264
288
265
let word_before ~position (doc : Lsp.Text_document.t) =
289
-
let L.Position.{line; character;} = position in
290
-
let line = List.nth_opt (String.split_on_char '\n' (Lsp.Text_document.text doc)) line in
266
+
let L.Position.{line; character} = position in
267
+
let line =
268
+
List.nth_opt (String.split_on_char '\n' (Lsp.Text_document.text doc)) line
269
+
in
291
270
match line with
292
271
| None -> None
293
-
| Some line ->
272
+
| Some line -> (
294
273
try
295
274
let until_cursor = String.sub line 0 character in
296
275
let words = List.rev @@ String.split_on_char ' ' until_cursor in
297
276
Some (List.hd words)
298
-
with
299
-
| _ -> None
277
+
with _ -> None)
+32
-32
lib/language_server/Call_hierarchy.ml
+32
-32
lib/language_server/Call_hierarchy.ml
···
20
20
let config = forest.config in
21
21
let module G = (val forest.graphs) in
22
22
match params with
23
-
| {item; _} ->
23
+
| {item; _} -> (
24
24
let vertex_to_item (v : _ T.vertex) =
25
25
let from = item in
26
26
let fromRanges = [] in
27
27
match v with
28
28
| T.Uri_vertex _ -> L.CallHierarchyIncomingCall.create ~from ~fromRanges
29
-
| T.Content_vertex _ -> L.CallHierarchyIncomingCall.create ~from ~fromRanges
29
+
| T.Content_vertex _ ->
30
+
L.CallHierarchyIncomingCall.create ~from ~fromRanges
30
31
in
31
32
match item with
32
33
| {uri; _} ->
33
-
let uri = URI_scheme.path_to_uri ~base: config.url (Lsp.Uri.to_path uri) in
34
+
let uri = URI_scheme.path_to_uri ~base:config.url (Lsp.Uri.to_path uri) in
34
35
let vertex = T.Uri_vertex uri in
35
36
let run_query = Forest.run_datalog_query forest.graphs in
36
37
let fwdlinks = run_query @@ Builtin_queries.fwdlinks_datalog vertex in
37
38
Eio.traceln "got %i link items" (Vertex_set.cardinal fwdlinks);
38
39
let children = run_query @@ Builtin_queries.children_datalog vertex in
39
40
Eio.traceln "got %i transclusion items" (Vertex_set.cardinal children);
40
-
let items = Vertex_set.union fwdlinks children |> Vertex_set.to_list |> List.map vertex_to_item in
41
-
Some items
41
+
let items =
42
+
Vertex_set.union fwdlinks children
43
+
|> Vertex_set.to_list |> List.map vertex_to_item
44
+
in
45
+
Some items)
42
46
43
47
let outgoing (params : L.CallHierarchyOutgoingCallsParams.t) =
44
48
let Lsp_state.{forest; _} = Lsp_state.get () in
···
46
50
let module G = (val forest.graphs) in
47
51
Eio.traceln "computing outgoing calls";
48
52
match params with
49
-
| {item; _} ->
53
+
| {item; _} -> (
50
54
let vertex_to_item (v : _ T.vertex) =
51
55
let to_ = item in
52
56
let fromRanges = [] in
53
57
match v with
54
58
| T.Uri_vertex _ -> L.CallHierarchyOutgoingCall.create ~to_ ~fromRanges
55
-
| T.Content_vertex _ -> L.CallHierarchyOutgoingCall.create ~to_ ~fromRanges
59
+
| T.Content_vertex _ ->
60
+
L.CallHierarchyOutgoingCall.create ~to_ ~fromRanges
56
61
in
57
62
match item with
58
63
| {uri; _} ->
59
-
let uri = URI_scheme.path_to_uri ~base: config.url (Lsp.Uri.to_path uri) in
64
+
let uri = URI_scheme.path_to_uri ~base:config.url (Lsp.Uri.to_path uri) in
60
65
let vertex = T.Uri_vertex uri in
61
66
let run_query = Forest.run_datalog_query forest.graphs in
62
67
let backlinks = run_query @@ Builtin_queries.backlinks_datalog vertex in
63
68
Eio.traceln "got %i link items" (Vertex_set.cardinal backlinks);
64
69
let parents = run_query @@ Builtin_queries.context_datalog vertex in
65
70
Eio.traceln "got %i transclusion items" (Vertex_set.cardinal parents);
66
-
let items = Vertex_set.union backlinks parents |> Vertex_set.to_list |> List.map vertex_to_item in
67
-
Some items
71
+
let items =
72
+
Vertex_set.union backlinks parents
73
+
|> Vertex_set.to_list |> List.map vertex_to_item
74
+
in
75
+
Some items)
68
76
69
77
let compute (params : L.CallHierarchyPrepareParams.t) =
70
78
let Lsp_state.{forest; _} = Lsp_state.get () in
71
79
match params with
72
-
| {position; textDocument; _} ->
73
-
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url textDocument.uri in
80
+
| {position; textDocument; _} -> (
81
+
let uri =
82
+
URI_scheme.lsp_uri_to_uri ~base:forest.config.url textDocument.uri
83
+
in
74
84
match Imports.resolve_uri_to_code forest uri with
75
85
| None -> None
76
86
| Some tree ->
77
87
let item =
78
88
match Analysis.node_at_code ~position tree.nodes with
79
89
| None -> None
80
-
| Some {loc = _; value} ->
90
+
| Some {loc = _; value} -> (
81
91
match value with
82
-
| Def (_, _, _)
83
-
| Fun (_, _) ->
84
-
None
85
-
| Text _
86
-
| Verbatim _
92
+
| Def (_, _, _) | Fun (_, _) -> None
93
+
| Text _ | Verbatim _
87
94
| Group (_, _)
88
95
| Math (_, _)
89
-
| Ident _
90
-
| Hash_ident _
96
+
| Ident _ | Hash_ident _
91
97
| Xml_ident (_, _)
92
98
| Subtree (_, _)
93
99
| Let (_, _, _)
94
-
| Open _
95
-
| Scope _
100
+
| Open _ | Scope _
96
101
| Put (_, _)
97
102
| Default (_, _)
98
-
| Get _
99
-
| Object _
100
-
| Patch _
103
+
| Get _ | Object _ | Patch _
101
104
| Call (_, _)
102
105
| Import (_, _)
103
106
| Decl_xmlns (_, _)
···
106
109
| Dx_sequent (_, _)
107
110
| Dx_query (_, _, _)
108
111
| Dx_prop (_, _)
109
-
| Dx_var _
110
-
| Dx_const_content _
111
-
| Dx_const_uri _
112
-
| Comment _
113
-
| Error _ ->
114
-
None
112
+
| Dx_var _ | Dx_const_content _ | Dx_const_uri _ | Comment _ | Error _
113
+
->
114
+
None)
115
115
in
116
-
Option.map (fun item -> [item]) item
116
+
Option.map (fun item -> [item]) item)
+17
-20
lib/language_server/Change_configuration.ml
+17
-20
lib/language_server/Change_configuration.ml
···
15
15
(* TODO: set up json conversions for forester config*)
16
16
let compute (params : L.DidChangeConfigurationParams.t) =
17
17
match params.settings with
18
-
| `Assoc xs ->
19
-
begin
20
-
match List.assoc_opt "configuration_file" xs with
21
-
| Some (`String f) ->
22
-
begin
23
-
try
24
-
let config = Config_parser.parse_forest_config_file f in
25
-
Lsp_state.modify @@ fun state ->
26
-
{state with forest = {state.forest with config = config}}
27
-
with
28
-
| _ -> Eio.traceln "failed to parse configuration file"
29
-
end
30
-
| _ -> Eio.traceln "invalid value for configuration_file"
31
-
(* RPC.Response.Error.raise *)
32
-
(* ( *)
33
-
(* RPC.Response.Error.make *)
34
-
(* ~code: InvalidRequest *)
35
-
(* ~message: "invalid value for configuration_file" *)
36
-
(* () *)
37
-
(* ) *)
18
+
| `Assoc xs -> begin
19
+
match List.assoc_opt "configuration_file" xs with
20
+
| Some (`String f) -> begin
21
+
try
22
+
let config = Config_parser.parse_forest_config_file f in
23
+
Lsp_state.modify @@ fun state ->
24
+
{state with forest = {state.forest with config}}
25
+
with _ -> Eio.traceln "failed to parse configuration file"
38
26
end
27
+
| _ -> Eio.traceln "invalid value for configuration_file"
28
+
(* RPC.Response.Error.raise *)
29
+
(* ( *)
30
+
(* RPC.Response.Error.make *)
31
+
(* ~code: InvalidRequest *)
32
+
(* ~message: "invalid value for configuration_file" *)
33
+
(* () *)
34
+
(* ) *)
35
+
end
39
36
| json -> Eio.traceln "unknown configuration value %a" Yojson.Safe.pp json
+27
-23
lib/language_server/Code_action.ml
+27
-23
lib/language_server/Code_action.ml
···
7
7
8
8
open Forester_compiler
9
9
10
-
open struct module L = Lsp.Types end
10
+
open struct
11
+
module L = Lsp.Types
12
+
end
11
13
12
14
let resolve (params : L.CodeAction.t) = params
13
15
14
16
let next_addrs ~(forest : State.t) prefix =
15
-
URI_util.next_uri ~prefix ~mode: `Sequential ~forest, URI_util.next_uri ~prefix ~mode: `Random ~forest
17
+
( URI_util.next_uri ~prefix ~mode:`Sequential ~forest,
18
+
URI_util.next_uri ~prefix ~mode:`Random ~forest )
16
19
17
20
let create_tree_edit ~range ~uri addr dir =
18
21
L.WorkspaceEdit.create
19
-
~documentChanges: [
20
-
`CreateFile
21
-
(
22
-
L.CreateFile.create
23
-
~uri: (Lsp.Uri.of_path (Format.asprintf "%s/%s.tree" dir addr))
24
-
()
25
-
);
26
-
`TextDocumentEdit
27
-
(
28
-
L.TextDocumentEdit.create
29
-
~textDocument: {uri; version = None}
30
-
~edits: [`TextEdit {newText = Format.asprintf "\\transclude{%s}" addr; range}]
31
-
)
32
-
]
22
+
~documentChanges:
23
+
[
24
+
`CreateFile
25
+
(L.CreateFile.create
26
+
~uri:(Lsp.Uri.of_path (Format.asprintf "%s/%s.tree" dir addr))
27
+
());
28
+
`TextDocumentEdit
29
+
(L.TextDocumentEdit.create ~textDocument:{uri; version = None}
30
+
~edits:
31
+
[
32
+
`TextEdit
33
+
{newText = Format.asprintf "\\transclude{%s}" addr; range};
34
+
]);
35
+
]
33
36
()
34
37
35
-
let compute (L.CodeActionParams.{range; textDocument = {uri}; _;}) : L.CodeActionResult.t =
38
+
let compute L.CodeActionParams.{range; textDocument = {uri}; _} :
39
+
L.CodeActionResult.t =
36
40
let Lsp_state.{forest; _} = Lsp_state.get () in
37
41
let actions =
38
42
let next_sequential, next_random = next_addrs ~forest None in
···
41
45
| dir :: _ ->
42
46
let sequential =
43
47
L.CodeAction.create
44
-
~title: (Format.asprintf "create new tree (sequential address)")
45
-
~kind: (L.CodeActionKind.Other "new tree")
46
-
~edit: (create_tree_edit ~range ~uri next_sequential dir)
48
+
~title:(Format.asprintf "create new tree (sequential address)")
49
+
~kind:(L.CodeActionKind.Other "new tree")
50
+
~edit:(create_tree_edit ~range ~uri next_sequential dir)
47
51
()
48
52
in
49
53
let random =
50
54
L.CodeAction.create
51
-
~title: (Format.asprintf "create new tree (random address)")
52
-
~kind: (L.CodeActionKind.Other "new tree")
53
-
~edit: (create_tree_edit ~range ~uri next_random dir)
55
+
~title:(Format.asprintf "create new tree (random address)")
56
+
~kind:(L.CodeActionKind.Other "new tree")
57
+
~edit:(create_tree_edit ~range ~uri next_random dir)
54
58
()
55
59
in
56
60
[`CodeAction sequential; `CodeAction random]
+4
-3
lib/language_server/Code_lens.ml
+4
-3
lib/language_server/Code_lens.ml
+137
-161
lib/language_server/Completion.ml
+137
-161
lib/language_server/Completion.ml
···
16
16
module L = Lsp.Types
17
17
end
18
18
19
-
type completion =
20
-
| Addrs
21
-
| New_addr
22
-
| Assets
23
-
| Visible
24
-
| Date
25
-
[@@deriving show]
19
+
type completion = Addrs | New_addr | Assets | Visible | Date [@@deriving show]
26
20
27
-
module S = Set.Make(struct
21
+
module S = Set.Make (struct
28
22
type t = completion
23
+
29
24
let compare = compare
30
25
end)
31
26
···
47
42
| Prev (_, Asai.Range.{value = Code.Subtree (_, _); _})
48
43
| Parent {value = Code.Subtree (_, _); _} ->
49
44
Some New_addr
50
-
| Parent _
51
-
| Prev (_, _)
52
-
| Top _ ->
53
-
None
45
+
| Parent _ | Prev (_, _) | Top _ -> None
54
46
in
55
47
let syn (context : Syn.node Range.located Analysis.Context.t) =
56
48
match context with
57
-
| (Top {value = Subtree _; _}) -> Some New_addr
58
-
| (Prev (_, {value = Subtree _; _;})) -> Some New_addr
49
+
| Top {value = Subtree _; _} -> Some New_addr
50
+
| Prev (_, {value = Subtree _; _}) -> Some New_addr
59
51
| _ -> None
60
52
in
61
53
{text; code; syn}
···
76
68
let syn (context : Syn.node Range.located Analysis.Context.t) =
77
69
match context with
78
70
| Top {value = Route_asset; _} -> Some Assets
79
-
| Prev (_, {value = Route_asset; _;}) -> Some Assets
71
+
| Prev (_, {value = Route_asset; _}) -> Some Assets
80
72
| _ -> None
81
73
in
82
74
{text; code; syn}
83
75
84
76
let date_completion : completion_kind =
85
77
let text word_before =
86
-
if Str.(string_match (regexp {|.*date.*|}) word_before 0) then
87
-
Some Date
78
+
if Str.(string_match (regexp {|.*date.*|}) word_before 0) then Some Date
88
79
else None
89
80
in
90
81
let code (context : _ Analysis.Context.t) =
···
99
90
100
91
let uri_completion : completion_kind =
101
92
let text word_before =
102
-
if Str.(string_match (regexp {|.*]($|}) word_before 0)
93
+
if
94
+
Str.(string_match (regexp {|.*]($|}) word_before 0)
103
95
|| Str.(string_match (regexp {|.*\[\[$|}) word_before 0)
104
-
|| Str.(string_match (regexp {|.*transclude.*|}) word_before 0) then
105
-
Some Addrs
96
+
|| Str.(string_match (regexp {|.*transclude.*|}) word_before 0)
97
+
then Some Addrs
106
98
else None
107
99
in
108
100
let code (_context : _ Analysis.Context.t) = None in
···
111
103
112
104
let new_uri_completion : completion_kind =
113
105
let text context =
114
-
if Str.(string_match (regexp {|.*subtree\[.*|}) context 0) then Some New_addr
106
+
if Str.(string_match (regexp {|.*subtree\[.*|}) context 0) then
107
+
Some New_addr
115
108
else None
116
109
in
117
-
let code context = Option.map (Fun.const New_addr) (uri_completion.code context) in
118
-
let syn context = Option.map (Fun.const New_addr) (uri_completion.syn context) in
110
+
let code context =
111
+
Option.map (Fun.const New_addr) (uri_completion.code context)
112
+
in
113
+
let syn context =
114
+
Option.map (Fun.const New_addr) (uri_completion.syn context)
115
+
in
119
116
{text; code; syn}
120
117
121
118
let completion_types (t : Tree.t) ~position =
122
-
let completions : completion_kind list = [
123
-
uri_completion;
124
-
asset_completion;
125
-
subtree_completion;
126
-
new_uri_completion;
127
-
date_completion;
128
-
]
119
+
let completions : completion_kind list =
120
+
[
121
+
uri_completion;
122
+
asset_completion;
123
+
subtree_completion;
124
+
new_uri_completion;
125
+
date_completion;
126
+
]
129
127
in
130
128
let code_opt = Tree.to_code t in
131
129
let syn_opt = Tree.to_syn t in
132
130
let doc_opt = Tree.to_doc t in
133
131
let text_context = Option.bind doc_opt @@ Analysis.word_before ~position in
134
-
Logs.debug (fun m -> m "Text_context: %a" Format.(pp_print_option pp_print_string) text_context);
132
+
Logs.debug (fun m ->
133
+
m "Text_context: %a" Format.(pp_print_option pp_print_string) text_context);
135
134
let code_context =
136
135
let enclosing_group = Analysis.get_enclosing_code_group in
137
-
let@ position = Option.bind @@ Analysis.enclosing_group_start ~enclosing_group ~position t in
136
+
let@ position =
137
+
Option.bind @@ Analysis.enclosing_group_start ~enclosing_group ~position t
138
+
in
138
139
let@ code = Option.bind code_opt in
139
140
Analysis.parent_or_prev_at_code ~position code.nodes
140
141
in
141
142
let syn_context =
142
143
let enclosing_group = Analysis.get_enclosing_syn_group in
143
-
let@ position = Option.bind @@ Analysis.enclosing_group_start ~enclosing_group ~position t in
144
+
let@ position =
145
+
Option.bind @@ Analysis.enclosing_group_start ~enclosing_group ~position t
146
+
in
144
147
let@ syn = Option.bind syn_opt in
145
148
Analysis.parent_or_prev_at_syn ~position syn.nodes
146
149
in
147
150
completions
148
151
|> List.fold_left
149
-
begin
150
-
fun acc completion_kind ->
151
-
(* let module Kind = (val completion_kind : CompletionKind) in *)
152
-
let compl =
153
-
List.fold_left
154
-
begin
155
-
fun acc a ->
156
-
match a with
157
-
| None -> acc
158
-
| Some compl -> S.add compl acc
159
-
end
160
-
S.empty
161
-
[
162
-
Option.bind text_context completion_kind.text;
163
-
Option.bind code_context completion_kind.code;
164
-
Option.bind syn_context completion_kind.syn;
165
-
]
166
-
in
167
-
S.union compl acc
168
-
end
169
-
S.empty
152
+
begin fun acc completion_kind ->
153
+
(* let module Kind = (val completion_kind : CompletionKind) in *)
154
+
let compl =
155
+
List.fold_left
156
+
begin fun acc a ->
157
+
match a with None -> acc | Some compl -> S.add compl acc
158
+
end
159
+
S.empty
160
+
[
161
+
Option.bind text_context completion_kind.text;
162
+
Option.bind code_context completion_kind.code;
163
+
Option.bind syn_context completion_kind.syn;
164
+
]
165
+
in
166
+
S.union compl acc
167
+
end
168
+
S.empty
170
169
171
-
let kind
172
-
: Syn.node -> L.CompletionItemKind.t option
173
-
= function
170
+
let kind : Syn.node -> L.CompletionItemKind.t option = function
174
171
| Fun (_, _) -> Some Function
175
172
| Text _ | Verbatim _ -> Some Text
176
173
| Meta -> Some Field
177
174
| Route_asset -> Some File
178
175
| Var _ -> Some Variable
179
-
| Prim _
180
-
| Transclude
181
-
| Embed_tex
182
-
| Title
183
-
| Parent
184
-
| Taxon
176
+
| Prim _ | Transclude | Embed_tex | Title | Parent | Taxon
185
177
| Attribution (_, _)
186
-
| Tag _
187
-
| Date
188
-
| Number ->
178
+
| Tag _ | Date | Number ->
189
179
Some Keyword
190
180
| Ref -> Some Reference
191
181
| Group (_, _)
···
197
187
| Default (_, _, _)
198
188
| Get _
199
189
| Xml_tag (_, _, _)
200
-
| TeX_cs _
201
-
| Unresolved_ident _
202
-
| Object _
203
-
| Patch _
190
+
| TeX_cs _ | Unresolved_ident _ | Object _ | Patch _
204
191
| Call (_, _)
205
192
| Results_of_query
206
193
| Dx_sequent (_, _)
···
208
195
| Dx_prop (_, _)
209
196
| Dx_var _
210
197
| Dx_const (_, _)
211
-
| Dx_execute
212
-
| Syndicate_current_tree_as_atom_feed
213
-
| Syndicate_query_as_json_blob
214
-
| Current_tree ->
198
+
| Dx_execute | Syndicate_current_tree_as_atom_feed
199
+
| Syndicate_query_as_json_blob | Current_tree ->
215
200
None
216
201
217
202
let insert_text path = String.concat "/" path
···
221
206
let paths = List.of_seq @@ Hashtbl.to_seq_keys Asset_router.router in
222
207
let@ asset_path = List.filter_map @~ paths in
223
208
let@ insertText =
224
-
Option.map @~
225
-
List.find_map
226
-
(fun dir ->
227
-
let dir_path = Unix.realpath dir in
228
-
if String.starts_with ~prefix: dir_path asset_path then
229
-
try
230
-
Some
231
-
(
232
-
String.sub
233
-
asset_path
209
+
Option.map
210
+
@~ List.find_map
211
+
(fun dir ->
212
+
let dir_path = Unix.realpath dir in
213
+
if String.starts_with ~prefix:dir_path asset_path then
214
+
try
215
+
Some
216
+
(String.sub asset_path
234
217
(String.length dir_path - String.length dir)
235
-
(String.length asset_path - String.length dir_path + String.length dir)
236
-
)
237
-
with
238
-
| _ -> None
239
-
else None
240
-
)
241
-
asset_dirs
218
+
(String.length asset_path - String.length dir_path
219
+
+ String.length dir))
220
+
with _ -> None
221
+
else None)
222
+
asset_dirs
242
223
in
243
-
L.CompletionItem.create
244
-
~label: insertText
245
-
~kind: File
246
-
~insertText
247
-
()
224
+
L.CompletionItem.create ~label:insertText ~kind:File ~insertText ()
248
225
249
-
let make (path, (data, _): Yuujinchou.Trie.path * (Resolver.P.data * Asai.Range.t option)) =
226
+
let make
227
+
((path, (data, _)) :
228
+
Yuujinchou.Trie.path * (Resolver.P.data * Asai.Range.t option)) =
250
229
match data with
251
230
| Term [] -> None
252
231
| Term (node :: _) ->
253
-
(* NOTE: Eventually we want to analyse the syntax so that, for example,
254
-
you can tab through the snippet for a function of arity n*)
232
+
(* NOTE: Eventually we want to analyse the syntax so that, for example, you
233
+
can tab through the snippet for a function of arity n*)
255
234
let kind = kind node.value in
256
235
let insertText = insert_text path in
257
236
Some
258
-
(
259
-
L.CompletionItem.create
260
-
?kind
261
-
~insertText
262
-
~label: (String.concat "/" path)
263
-
()
264
-
)
265
-
| Xmlns _ ->
266
-
assert false
237
+
(L.CompletionItem.create ?kind ~insertText ~label:(String.concat "/" path)
238
+
())
239
+
| Xmlns _ -> assert false
267
240
268
-
(* These are useful completion items that are handled during parsing, not during expansion and are thus not "builtins"*)
241
+
(* These are useful completion items that are handled during parsing, not during
242
+
expansion and are thus not "builtins"*)
269
243
270
244
module Syntax = struct
271
245
let verb =
272
246
let insertText =
273
247
Lsp.Snippet.(
274
248
let open O in
275
-
to_string @@
276
-
"\\startverb<<|\n" @+ tabstop 1 +@ "\n<<|"
277
-
)
249
+
to_string @@ "\\startverb<<|\n" @+ (tabstop 1 +@ "\n<<|"))
278
250
in
279
-
L.CompletionItem.create
280
-
~insertTextFormat: Snippet
281
-
~insertText
282
-
~label: "startverb"
283
-
~documentation: (`String "Create a verbatim block")
284
-
()
251
+
L.CompletionItem.create ~insertTextFormat:Snippet ~insertText
252
+
~label:"startverb" ~documentation:(`String "Create a verbatim block") ()
285
253
end
286
254
287
-
(* Incomplete. The idea here is to create clever snippets for specific syntax items. *)
255
+
(* Incomplete. The idea here is to create clever snippets for specific syntax
256
+
items. *)
288
257
let syntax_completions =
289
258
[
290
259
("startverb", "startverb");
···
308
277
("xmlns", "xmlns");
309
278
]
310
279
|> List.map @@ fun (insertText, label) ->
311
-
L.CompletionItem.create
312
-
~insertText
313
-
~label
314
-
()
280
+
L.CompletionItem.create ~insertText ~label ()
315
281
316
282
let addr_completions ~(forest : State.t) : L.CompletionItem.t list =
317
283
let articles = List.of_seq @@ State.get_all_articles forest in
···
323
289
let documentation =
324
290
let taxon = frontmatter.taxon in
325
291
let content =
326
-
Format.asprintf
327
-
"# %s\n %s\n "
328
-
(render title)
329
-
(Option.fold ~none: "" ~some: (fun s -> Format.asprintf "taxon: %s" (render s)) taxon)
292
+
Format.asprintf "# %s\n %s\n " (render title)
293
+
(Option.fold ~none:""
294
+
~some:(fun s -> Format.asprintf "taxon: %s" (render s))
295
+
taxon)
330
296
in
331
297
Some (`String content)
332
298
in
333
299
let@ uri = Option.bind @@ frontmatter.uri in
334
300
let@ uri_name = Option.bind @@ URI_scheme.name uri in
335
301
let title_text = render title in
336
-
Option.some @@
337
-
L.CompletionItem.create
338
-
?documentation
339
-
~label: (Format.(asprintf "%a (%s)" pp_print_string title_text uri_name))
340
-
~insertText: uri_name
341
-
~filterText: (uri_name ^ " " ^ title_text)
342
-
()
302
+
Option.some
303
+
@@ L.CompletionItem.create ?documentation
304
+
~label:Format.(asprintf "%a (%s)" pp_print_string title_text uri_name)
305
+
~insertText:uri_name
306
+
~filterText:(uri_name ^ " " ^ title_text)
307
+
()
343
308
344
309
let new_addr_completions ~(forest : State.t) : L.CompletionItem.t list =
345
-
let next mode = URI_util.next_uri ~prefix: None ~mode ~forest in
310
+
let next mode = URI_util.next_uri ~prefix:None ~mode ~forest in
346
311
[
347
-
L.CompletionItem.create ~label: "random" ~insertText: (next `Random) ();
348
-
L.CompletionItem.create ~label: "sequential" ~insertText: (next `Sequential) ()
312
+
L.CompletionItem.create ~label:"random" ~insertText:(next `Random) ();
313
+
L.CompletionItem.create ~label:"sequential" ~insertText:(next `Sequential)
314
+
();
349
315
]
350
316
351
-
let visible_completions ~(forest : State.t) ~(position : L.Position.t) : Tree.code option -> L.CompletionItem.t list = function
317
+
let visible_completions ~(forest : State.t) ~(position : L.Position.t) :
318
+
Tree.code option -> L.CompletionItem.t list = function
352
319
| None ->
353
-
List.append syntax_completions @@
354
-
let@ path, _ = List.map @~ List.of_seq @@ Trie.to_seq Expand.initial_visible_trie in
355
-
L.CompletionItem.create
356
-
~insertText: "todo"
357
-
~label: (String.concat "/" path)
358
-
()
320
+
List.append syntax_completions
321
+
@@
322
+
let@ path, _ =
323
+
List.map @~ List.of_seq @@ Trie.to_seq Expand.initial_visible_trie
324
+
in
325
+
L.CompletionItem.create ~insertText:"todo" ~label:(String.concat "/" path)
326
+
()
359
327
| Some {nodes; _} ->
360
328
Analysis.get_visible ~position ~forest nodes
361
-
|> Trie.to_seq
362
-
|> List.of_seq
363
-
|> List.filter_map make
329
+
|> Trie.to_seq |> List.of_seq |> List.filter_map make
364
330
|> List.append syntax_completions
365
331
366
332
let date_completions () : L.CompletionItem.t list =
367
333
let now = Human_datetime.now () in
368
334
let now_string = Format.asprintf "%a" Human_datetime.pp now in
369
-
[
370
-
L.CompletionItem.create ~label: now_string ~insertText: now_string ()
371
-
]
335
+
[L.CompletionItem.create ~label:now_string ~insertText:now_string ()]
372
336
373
-
let compute ({context; position; textDocument = {uri}; _;}: L.CompletionParams.t) =
374
-
Logs.debug (fun m -> m "when computing completions for %s" (Lsp.Uri.to_string uri));
337
+
let compute
338
+
({context; position; textDocument = {uri}; _} : L.CompletionParams.t) =
339
+
Logs.debug (fun m ->
340
+
m "when computing completions for %s" (Lsp.Uri.to_string uri));
375
341
let triggerCharacter =
376
342
match context with
377
-
| Some {triggerCharacter; _} ->
378
-
triggerCharacter
343
+
| Some {triggerCharacter; _} -> triggerCharacter
379
344
| None -> None
380
345
in
381
346
let Lsp_state.{forest; _} = Lsp_state.get () in
···
385
350
let tree = forest.={uri} in
386
351
match tree with
387
352
| None ->
388
-
Reporter.fatal
389
-
Internal_error
390
-
~backtrace: (Bwd.of_list [Asai.Diagnostic.loctextf "when computing completions for %a" URI.pp uri])
391
-
~extra_remarks: [Asai.Diagnostic.loctextf "%a was not found in the index" URI.pp uri]
353
+
Reporter.fatal Internal_error
354
+
~backtrace:
355
+
(Bwd.of_list
356
+
[
357
+
Asai.Diagnostic.loctextf "when computing completions for %a" URI.pp
358
+
uri;
359
+
])
360
+
~extra_remarks:
361
+
[Asai.Diagnostic.loctextf "%a was not found in the index" URI.pp uri]
392
362
| Some tree ->
393
363
let code = Tree.to_code tree in
394
-
Logs.debug (fun m -> m "Received completion request at %s" (Yojson.Safe.to_string (L.Position.yojson_of_t position)));
364
+
Logs.debug (fun m ->
365
+
m "Received completion request at %s"
366
+
(Yojson.Safe.to_string (L.Position.yojson_of_t position)));
395
367
Logs.debug (fun m -> m "phase is %s" (Tree.show_phase tree));
396
368
let completion_types = completion_types ~position tree in
397
-
Logs.debug (fun m -> m "computed completion types: %a" (Format.pp_print_list pp_completion) (S.to_list completion_types));
369
+
Logs.debug (fun m ->
370
+
m "computed completion types: %a"
371
+
(Format.pp_print_list pp_completion)
372
+
(S.to_list completion_types));
398
373
let items =
399
374
let@ completion = List.concat_map @~ S.to_list completion_types in
400
375
match completion with
···
405
380
| Date -> date_completions ()
406
381
in
407
382
Logs.debug (fun m -> m "items: %d" (List.length items));
408
-
Option.some @@ `CompletionList (L.CompletionList.create ~isIncomplete: false ~items ())
383
+
Option.some
384
+
@@ `CompletionList (L.CompletionList.create ~isIncomplete:false ~items ())
+15
-5
lib/language_server/Definitions.ml
+15
-5
lib/language_server/Definitions.ml
···
9
9
open Forester_core
10
10
open Forester_compiler
11
11
12
-
open struct module L = Lsp.Types end
12
+
open struct
13
+
module L = Lsp.Types
14
+
end
15
+
13
16
open State.Syntax
14
17
15
18
let compute (params : L.DefinitionParams.t) =
16
19
let Lsp_state.{forest; _} = Lsp_state.get () in
17
-
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url params.textDocument.uri in
20
+
let uri =
21
+
URI_scheme.lsp_uri_to_uri ~base:forest.config.url params.textDocument.uri
22
+
in
18
23
let@ tree = Option.bind forest.={uri} in
19
24
let@ {nodes; _} = Option.bind @@ Tree.to_code tree in
20
-
let@ {value = str; _} = Option.bind @@ Analysis.addr_at ~position: params.position nodes in
21
-
let uri = URI_scheme.named_uri ~base: forest.config.url str in
25
+
let@ {value = str; _} =
26
+
Option.bind @@ Analysis.addr_at ~position:params.position nodes
27
+
in
28
+
let uri = URI_scheme.named_uri ~base:forest.config.url str in
22
29
let@ path = Option.map @~ URI.Tbl.find_opt forest.resolver uri in
23
30
let uri = Lsp.Uri.of_path path in
24
-
let range = L.Range.create ~start: {character = 1; line = 0} ~end_: {character = 1; line = 0} in
31
+
let range =
32
+
L.Range.create ~start:{character = 1; line = 0}
33
+
~end_:{character = 1; line = 0}
34
+
in
25
35
`Location [L.Location.{uri; range}]
+8
-4
lib/language_server/Diagnostics.ml
+8
-4
lib/language_server/Diagnostics.ml
···
7
7
8
8
(* When computing the diagnostics for a specific text document, do we know that
9
9
the emitted diagnostics should be reported to the same URI?
10
-
*)
10
+
*)
11
11
12
12
open Forester_core
13
13
open Forester_compiler
14
14
15
-
open struct module L = Lsp.Types end
15
+
open struct
16
+
module L = Lsp.Types
17
+
end
18
+
16
19
open State.Syntax
17
20
18
21
let compute (document : Lsp.Text_document.t) =
19
22
let Lsp_state.{forest; _} = Lsp_state.get () in
20
23
let lsp_uri = Lsp.Text_document.documentUri document in
21
-
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url lsp_uri in
24
+
let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url lsp_uri in
22
25
match forest.?{uri} with
23
26
| [] ->
24
27
Eio.traceln "Clearing diagnostics for %s" (Lsp.Uri.to_path lsp_uri);
25
28
Publish.publish lsp_uri []
26
29
| diagnostics ->
27
-
Eio.traceln "publishing %i diagnostics to %s" (List.length diagnostics) (Lsp.Uri.to_path lsp_uri);
30
+
Eio.traceln "publishing %i diagnostics to %s" (List.length diagnostics)
31
+
(Lsp.Uri.to_path lsp_uri);
28
32
Publish.publish lsp_uri diagnostics
+16
-7
lib/language_server/Did_change.ml
+16
-7
lib/language_server/Did_change.ml
···
9
9
open Forester_core
10
10
open Forester_compiler
11
11
12
-
open struct module L = Lsp.Types end
12
+
open struct
13
+
module L = Lsp.Types
14
+
end
15
+
13
16
open State.Syntax
14
17
15
18
let compute (params : L.DidChangeTextDocumentParams.t) =
16
19
let Lsp_state.{forest; _} = Lsp_state.get () in
17
20
let lsp_uri = params.textDocument.uri in
18
-
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url lsp_uri in
21
+
let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url lsp_uri in
19
22
let@ tree = Option.iter @~ forest.={uri} in
20
23
match Tree.to_doc tree with
21
24
| None ->
22
-
Logs.debug (fun m -> m "Did_change.compute fatal error, could not find tree with uri %a from LSP uri %s" URI.pp uri (Lsp.Uri.to_string lsp_uri));
25
+
Logs.debug (fun m ->
26
+
m
27
+
"Did_change.compute fatal error, could not find tree with uri %a \
28
+
from LSP uri %s"
29
+
URI.pp uri
30
+
(Lsp.Uri.to_string lsp_uri));
23
31
assert false
24
32
| Some doc ->
25
-
let new_doc = Lsp.Text_document.apply_content_changes doc params.contentChanges in
33
+
let new_doc =
34
+
Lsp.Text_document.apply_content_changes doc params.contentChanges
35
+
in
26
36
forest.={uri} <- Document new_doc;
27
37
Lsp_state.modify (fun ({forest; _} as lsp_state) ->
28
-
let new_forest = Driver.run_until_done (Action.Parse lsp_uri) forest in
29
-
{lsp_state with forest = new_forest}
30
-
);
38
+
let new_forest = Driver.run_until_done (Action.Parse lsp_uri) forest in
39
+
{lsp_state with forest = new_forest});
31
40
Diagnostics.compute new_doc
+7
-5
lib/language_server/Did_create_files.ml
+7
-5
lib/language_server/Did_create_files.ml
···
7
7
open Forester_prelude
8
8
open Forester_core
9
9
open Forester_compiler
10
-
11
10
open State.Syntax
12
-
open struct module L = Lsp.Types end
13
11
14
-
let compute ({files}: L.CreateFilesParams.t) =
12
+
open struct
13
+
module L = Lsp.Types
14
+
end
15
+
16
+
let compute ({files} : L.CreateFilesParams.t) =
15
17
Eio.traceln "recieved DidCreateFiles notification";
16
18
Lsp_state.modify @@ fun ({forest; _} as lsp_state) ->
17
19
let env = forest.env in
···
19
21
begin
20
22
let@ {uri} = List.iter @~ files in
21
23
let lsp_uri = L.DocumentUri.of_string uri in
22
-
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url lsp_uri in
23
-
let path = Eio.Path.(env#fs / (L.DocumentUri.to_path lsp_uri)) in
24
+
let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url lsp_uri in
25
+
let path = Eio.Path.(env#fs / L.DocumentUri.to_path lsp_uri) in
24
26
let doc = Imports.load_tree path in
25
27
forest.={uri} <- Document doc
26
28
end;
+8
-6
lib/language_server/Did_open.ml
+8
-6
lib/language_server/Did_open.ml
···
8
8
open Forester_core
9
9
open Forester_compiler
10
10
open State.Syntax
11
-
open struct module L = Lsp.Types end
11
+
12
+
open struct
13
+
module L = Lsp.Types
14
+
end
12
15
13
16
let compute (params : L.DidOpenTextDocumentParams.t) =
14
17
let lsp_uri = params.textDocument.uri in
15
18
let Lsp_state.{forest; _} = Lsp_state.get () in
16
-
let document = Lsp.Text_document.make ~position_encoding: `UTF16 params in
17
-
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url lsp_uri in
19
+
let document = Lsp.Text_document.make ~position_encoding:`UTF16 params in
20
+
let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url lsp_uri in
18
21
forest.={uri} <- Document document;
19
22
Lsp_state.modify (fun ({forest; _} as lsp_state) ->
20
-
let new_forest = Driver.run_until_done (Action.Parse lsp_uri) forest in
21
-
{lsp_state with forest = new_forest}
22
-
);
23
+
let new_forest = Driver.run_until_done (Action.Parse lsp_uri) forest in
24
+
{lsp_state with forest = new_forest});
23
25
Diagnostics.compute document
+12
-6
lib/language_server/Document_link.ml
+12
-6
lib/language_server/Document_link.ml
···
12
12
13
13
open struct
14
14
module L = Lsp.Types
15
-
let (let*) = Option.bind
15
+
16
+
let ( let* ) = Option.bind
16
17
end
18
+
17
19
open State.Syntax
18
20
19
21
(* TODO: handle external links as well? *)
···
23
25
let config = forest.config in
24
26
let Lsp_state.{forest; _} = Lsp_state.get () in
25
27
let links =
26
-
let uri = URI_scheme.lsp_uri_to_uri ~base: config.url params.textDocument.uri in
28
+
let uri =
29
+
URI_scheme.lsp_uri_to_uri ~base:config.url params.textDocument.uri
30
+
in
27
31
(* match Imports.resolve_uri_to_code forest uri with *)
28
32
match Option.bind forest.={uri} Tree.to_code with
29
33
| None -> []
30
-
| Some tree ->
34
+
| Some tree -> (
31
35
let@ node = List.filter_map @~ tree.nodes in
32
36
match Range.(node.value) with
33
37
| Code.Group (Squares, [{value = Text addr; _}])
···
35
39
| Code.Group (Braces, [{value = Text addr; _}]) ->
36
40
(* TODO: Need to analyse syn *)
37
41
let range = Lsp_shims.Loc.lsp_range_of_range node.loc in
38
-
let uri = URI_scheme.named_uri ~base: config.url addr in
39
-
let* target = Option.map Lsp.Uri.of_path @@ URI.Tbl.find_opt forest.resolver uri in
42
+
let uri = URI_scheme.named_uri ~base:config.url addr in
43
+
let* target =
44
+
Option.map Lsp.Uri.of_path @@ URI.Tbl.find_opt forest.resolver uri
45
+
in
40
46
let* {frontmatter; _} = State.get_article uri forest in
41
47
let* tooltip = Option.map (fun c -> render c) frontmatter.title in
42
48
let link = L.DocumentLink.create ~range ~target ~tooltip () in
43
49
Some link
44
-
| _ -> None
50
+
| _ -> None)
45
51
in
46
52
Some links
+38
-22
lib/language_server/Document_symbols.ml
+38
-22
lib/language_server/Document_symbols.ml
···
11
11
12
12
open struct
13
13
module L = Lsp.Types
14
+
14
15
let pp_path = Resolver.Scope.pp_path
15
16
end
16
17
17
18
let compute (params : L.DocumentSymbolParams.t) =
18
19
let uri = params.textDocument.uri in
19
20
let Lsp_state.{forest; _} = Lsp_state.get () in
20
-
match State.get_code forest @@ URI_scheme.lsp_uri_to_uri ~base: forest.config.url uri with
21
+
match
22
+
State.get_code forest
23
+
@@ URI_scheme.lsp_uri_to_uri ~base:forest.config.url uri
24
+
with
21
25
| None ->
22
-
URI.Tbl.iter (fun uri _ -> Logs.debug (fun m -> m "%a" URI.pp uri)) forest.index;
26
+
URI.Tbl.iter
27
+
(fun uri _ -> Logs.debug (fun m -> m "%a" URI.pp uri))
28
+
forest.index;
23
29
Logs.debug (fun m -> m "%s" (Lsp.Uri.to_string uri));
24
-
Logs.debug (fun m -> m "%a" URI.pp (URI_scheme.lsp_uri_to_uri ~base: forest.config.url uri));
30
+
Logs.debug (fun m ->
31
+
m "%a" URI.pp (URI_scheme.lsp_uri_to_uri ~base:forest.config.url uri));
25
32
assert false
26
33
| Some {nodes; _} ->
27
34
let symbols =
···
31
38
let selectionRange = range in
32
39
match value with
33
40
| Subtree (addr, _) ->
34
-
let name = Option.value ~default: "anonymous" addr in
41
+
let name = Option.value ~default:"anonymous" addr in
35
42
let range = Lsp_shims.Loc.lsp_range_of_range loc in
36
43
(* TODO: What should the symbol kind of a subtree be? *)
37
-
Option.some @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind: Namespace ()
44
+
Option.some
45
+
@@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind:Namespace
46
+
()
38
47
| Object {self; _} ->
39
-
let name = Option.value ~default: "anonymous" self in
40
-
Option.some @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind: Object ()
48
+
let name = Option.value ~default:"anonymous" self in
49
+
Option.some
50
+
@@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind:Object ()
41
51
| Def (name, _, _) ->
42
52
let name = Format.asprintf "%a" pp_path name in
43
-
Option.some @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind: Function ()
53
+
Option.some
54
+
@@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind:Function
55
+
()
44
56
| Namespace (name, _) ->
45
57
let name = Format.asprintf "%a" pp_path name in
46
-
Option.some @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind: Namespace ()
58
+
Option.some
59
+
@@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind:Namespace
60
+
()
47
61
| Ident path ->
48
62
let name = Format.asprintf "%a" pp_path path in
49
-
Option.some @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind: Constructor ()
63
+
Option.some
64
+
@@ L.DocumentSymbol.create ~name ~range ~selectionRange
65
+
~kind:Constructor ()
50
66
| Let (path, _, _) ->
51
67
let name = Format.asprintf "%a" pp_path path in
52
-
Option.some @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind: Constructor ()
68
+
Option.some
69
+
@@ L.DocumentSymbol.create ~name ~range ~selectionRange
70
+
~kind:Constructor ()
53
71
| Xml_ident (pfx, ident) ->
54
72
let name =
55
73
match pfx with
56
74
| None -> Format.asprintf "<%s>" ident
57
75
| Some pfx -> Format.asprintf "<%s:%s>" pfx ident
58
76
in
59
-
Option.some @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind: Constructor ()
77
+
Option.some
78
+
@@ L.DocumentSymbol.create ~name ~range ~selectionRange
79
+
~kind:Constructor ()
60
80
| Hash_ident _ ->
61
-
Option.some @@ L.DocumentSymbol.create ~name: "(hash)" ~range ~selectionRange ~kind: Constant ()
62
-
| Text _
63
-
| Verbatim _
81
+
Option.some
82
+
@@ L.DocumentSymbol.create ~name:"(hash)" ~range ~selectionRange
83
+
~kind:Constant ()
84
+
| Text _ | Verbatim _
64
85
| Group (_, _)
65
86
| Math (_, _)
66
-
| Open _
67
-
| Scope _
87
+
| Open _ | Scope _
68
88
| Put (_, _)
69
89
| Default (_, _)
70
90
| Get _
···
77
97
| Dx_sequent (_, _)
78
98
| Dx_query (_, _, _)
79
99
| Dx_prop (_, _)
80
-
| Dx_var _
81
-
| Dx_const_content _
82
-
| Dx_const_uri _
83
-
| Comment _
84
-
| Error _ ->
100
+
| Dx_var _ | Dx_const_content _ | Dx_const_uri _ | Comment _ | Error _ ->
85
101
None
86
102
in
87
103
Some (`DocumentSymbol symbols)
+97
-112
lib/language_server/Forester_lsp.ml
+97
-112
lib/language_server/Forester_lsp.ml
···
12
12
module Lsp_state = Lsp_state
13
13
module LspEio = LspEio
14
14
module Lsp_shims = Lsp_shims
15
-
16
15
module Call_hierarchy = Call_hierarchy
17
16
module Change_configuration = Change_configuration
18
17
module Code_action = Code_action
···
30
29
module Semantic_tokens = Semantic_tokens
31
30
module Workspace_symbols = Workspace_symbols
32
31
module Did_create_files = Did_create_files
33
-
34
32
open Forester_core
35
33
open Forester_compiler
36
-
37
34
open Server
38
35
open Lsp_error
39
36
40
37
let unwrap opt err =
41
-
match opt with
42
-
| Some opt -> opt
43
-
| None -> raise @@ Lsp_error err
38
+
match opt with Some opt -> opt | None -> raise @@ Lsp_error err
44
39
45
40
let print_exn exn =
46
-
let msg = Printexc.to_string exn
47
-
and stack = Printexc.get_backtrace ()
48
-
in
41
+
let msg = Printexc.to_string exn and stack = Printexc.get_backtrace () in
49
42
Eio.traceln "%s\n%s" msg stack
50
43
51
44
let supported_code_actions = [L.CodeActionKind.Other "new tree"]
···
54
47
let server_capabilities =
55
48
let textDocumentSync =
56
49
let opts =
57
-
L.TextDocumentSyncOptions.create
58
-
~change: L.TextDocumentSyncKind.Full
59
-
~openClose: true
60
-
~save: (`SaveOptions (L.SaveOptions.create ~includeText: false ()))
50
+
L.TextDocumentSyncOptions.create ~change:L.TextDocumentSyncKind.Full
51
+
~openClose:true
52
+
~save:(`SaveOptions (L.SaveOptions.create ~includeText:false ()))
61
53
()
62
54
in
63
55
`TextDocumentSyncOptions opts
···
68
60
in
69
61
let codeActionProvider =
70
62
let opts =
71
-
L.CodeActionOptions.create
72
-
~codeActionKinds: supported_code_actions
73
-
()
63
+
L.CodeActionOptions.create ~codeActionKinds:supported_code_actions ()
74
64
in
75
65
`CodeActionOptions opts
76
66
in
77
67
let executeCommandProvider =
78
-
L.ExecuteCommandOptions.create
79
-
~commands: supported_commands
80
-
()
68
+
L.ExecuteCommandOptions.create ~commands:supported_commands ()
81
69
in
82
70
let inlayHintProvider =
83
71
let opts = L.InlayHintOptions.create () in
···
85
73
in
86
74
let definitionProvider = `DefinitionOptions (L.DefinitionOptions.create ()) in
87
75
let completionProvider =
88
-
L.CompletionOptions.create
89
-
~triggerCharacters: ["\\"; "{"; "("; "["]
90
-
~allCommitCharacters: ["}"; ")"; "]"]
91
-
()
76
+
L.CompletionOptions.create ~triggerCharacters:["\\"; "{"; "("; "["]
77
+
~allCommitCharacters:["}"; ")"; "]"] ()
92
78
in
93
79
let documentLinkProvider =
94
-
L.DocumentLinkOptions.create
95
-
~resolveProvider: true
96
-
~workDoneProgress: false
80
+
L.DocumentLinkOptions.create ~resolveProvider:true ~workDoneProgress:false
97
81
()
98
82
in
99
-
let workspaceSymbolProvider = `WorkspaceSymbolOptions (L.WorkspaceSymbolOptions.create ()) in
100
-
let documentSymbolProvider = `DocumentSymbolOptions (L.DocumentSymbolOptions.create ()) in
83
+
let workspaceSymbolProvider =
84
+
`WorkspaceSymbolOptions (L.WorkspaceSymbolOptions.create ())
85
+
in
86
+
let documentSymbolProvider =
87
+
`DocumentSymbolOptions (L.DocumentSymbolOptions.create ())
88
+
in
101
89
let workspace =
102
90
L.ServerCapabilities.create_workspace
103
-
~fileOperations: (
104
-
L.FileOperationOptions.create
105
-
~didCreate: {
106
-
filters = [
107
-
L.FileOperationFilter.create
108
-
~pattern: (L.FileOperationPattern.create ~glob: "**/*.tree" ())
109
-
()
110
-
]
111
-
}
112
-
()
113
-
)
91
+
~fileOperations:
92
+
(L.FileOperationOptions.create
93
+
~didCreate:
94
+
{
95
+
filters =
96
+
[
97
+
L.FileOperationFilter.create
98
+
~pattern:
99
+
(L.FileOperationPattern.create ~glob:"**/*.tree" ())
100
+
();
101
+
];
102
+
}
103
+
())
114
104
()
115
105
in
116
106
117
-
(* [NOTE: Position Encodings]
118
-
For various historical reasons, the spec states that we are _required_ to support UTF-16.
119
-
This causes more trouble than it's worth, so we always select UTF-8 as our encoding, even
120
-
if the client doesn't support it. *)
107
+
(* [NOTE: Position Encodings] For various historical reasons, the spec states
108
+
that we are _required_ to support UTF-16. This causes more trouble than
109
+
it's worth, so we always select UTF-8 as our encoding, even if the client
110
+
doesn't support it. *)
121
111
let positionEncoding = L.PositionEncodingKind.UTF8 in
122
-
(* [FIXME: Reed M, 09/06/2022] The current verison of the LSP library doesn't support 'positionEncoding' *)
123
-
L.ServerCapabilities.create
124
-
~textDocumentSync
125
-
~hoverProvider
126
-
~codeActionProvider
127
-
~executeCommandProvider
128
-
~inlayHintProvider
129
-
~positionEncoding
130
-
~completionProvider
131
-
~definitionProvider
132
-
~documentSymbolProvider
133
-
~documentLinkProvider
134
-
~workspaceSymbolProvider
135
-
~workspace
136
-
()
112
+
(* [FIXME: Reed M, 09/06/2022] The current verison of the LSP library doesn't
113
+
support 'positionEncoding' *)
114
+
L.ServerCapabilities.create ~textDocumentSync ~hoverProvider
115
+
~codeActionProvider ~executeCommandProvider ~inlayHintProvider
116
+
~positionEncoding ~completionProvider ~definitionProvider
117
+
~documentSymbolProvider ~documentLinkProvider ~workspaceSymbolProvider
118
+
~workspace ()
137
119
138
120
let supports_utf8_encoding (init_params : L.InitializeParams.t) =
139
121
let position_encodings =
140
-
Option.value ~default: [] @@
141
-
Option.bind init_params.capabilities.general @@ fun gcap ->
142
-
gcap.positionEncodings
122
+
Option.value ~default:[]
123
+
@@ Option.bind init_params.capabilities.general
124
+
@@ fun gcap -> gcap.positionEncodings
143
125
in
144
126
List.mem L.PositionEncodingKind.UTF8 position_encodings
145
127
146
128
(** Perform the LSP initialization handshake.
147
-
https://microsoft.github.io/language-server-protocol/specifications/specification-current/#initialize *)
129
+
https://microsoft.github.io/language-server-protocol/specifications/specification-current/#initialize
130
+
*)
148
131
let initialize () =
149
-
let (id, req) =
150
-
unwrap (Request.recv ()) @@
151
-
Handshake_error "Initialization must begin with a request."
132
+
let id, req =
133
+
unwrap (Request.recv ())
134
+
@@ Handshake_error "Initialization must begin with a request."
152
135
in
153
136
match req with
154
-
| E (Initialize init_params as init_req) ->
155
-
begin
156
-
(* [HACK: Position Encodings]
157
-
If the client doesn't support UTF-8, we shouldn't give up, as it might be using UTF-8 anyways...
158
-
Therefore, we just produce a warning, and try to use UTF-8 regardless. *)
159
-
if not (supports_utf8_encoding init_params) then
160
-
Eio.traceln "Warning: client does not support UTF-8 encoding, which may lead to inconsistent positions.";
161
-
let resp = L.InitializeResult.create ~capabilities: server_capabilities () in
162
-
Request.respond id init_req resp;
163
-
let notif =
164
-
unwrap (Notification.recv ()) @@
165
-
Handshake_error "Initialization must complete with an initialized notification."
166
-
in
167
-
match notif with
168
-
| Initialized ->
169
-
Eio.traceln "Initialized!"
170
-
| _ ->
171
-
raise @@ Lsp_error (Handshake_error "Initialization must complete with an initialized notification.")
172
-
end
173
-
| (E _) ->
174
-
raise @@ Lsp_error (Handshake_error "Initialization must begin with an initialize request.")
137
+
| E (Initialize init_params as init_req) -> begin
138
+
(* [HACK: Position Encodings] If the client doesn't support UTF-8, we
139
+
shouldn't give up, as it might be using UTF-8 anyways... Therefore, we
140
+
just produce a warning, and try to use UTF-8 regardless. *)
141
+
if not (supports_utf8_encoding init_params) then
142
+
Eio.traceln
143
+
"Warning: client does not support UTF-8 encoding, which may lead to \
144
+
inconsistent positions.";
145
+
let resp = L.InitializeResult.create ~capabilities:server_capabilities () in
146
+
Request.respond id init_req resp;
147
+
let notif =
148
+
unwrap (Notification.recv ())
149
+
@@ Handshake_error
150
+
"Initialization must complete with an initialized notification."
151
+
in
152
+
match notif with
153
+
| Initialized -> Eio.traceln "Initialized!"
154
+
| _ ->
155
+
raise
156
+
@@ Lsp_error
157
+
(Handshake_error
158
+
"Initialization must complete with an initialized notification.")
159
+
end
160
+
| E _ ->
161
+
raise
162
+
@@ Lsp_error
163
+
(Handshake_error
164
+
"Initialization must begin with an initialize request.")
175
165
176
-
(** Perform the LSP shutdown sequence.
177
-
See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#exit *)
166
+
(** Perform the LSP shutdown sequence. See
167
+
https://microsoft.github.io/language-server-protocol/specifications/specification-current/#exit
168
+
*)
178
169
let shutdown () =
179
170
let notif =
180
-
unwrap (Notification.recv ()) @@
181
-
Shutdown_error "No requests can be recieved after a shutdown request."
171
+
unwrap (Notification.recv ())
172
+
@@ Shutdown_error "No requests can be recieved after a shutdown request."
182
173
in
183
174
match notif with
184
-
| Exit ->
185
-
()
175
+
| Exit -> ()
186
176
| _ ->
187
-
raise @@ Lsp_error (Shutdown_error "The only notification that can be recieved after a shutdown request is exit.")
177
+
raise
178
+
@@ Lsp_error
179
+
(Shutdown_error
180
+
"The only notification that can be recieved after a shutdown \
181
+
request is exit.")
188
182
189
183
(** {1 Main Event Loop} *)
190
184
···
196
190
| RPC.Packet.Request req ->
197
191
let resp = Request.handle req in
198
192
send (RPC.Packet.Response resp)
199
-
| RPC.Packet.Notification notif ->
200
-
Notification.handle notif
201
-
| _ ->
202
-
Eio.traceln "Recieved unexpected packet type."
203
-
| exception exn ->
204
-
print_exn exn
193
+
| RPC.Packet.Notification notif -> Notification.handle notif
194
+
| _ -> Eio.traceln "Recieved unexpected packet type."
195
+
| exception exn -> print_exn exn
205
196
in
206
-
if should_shutdown () then
207
-
shutdown ()
208
-
else
209
-
event_loop ()
210
-
| None ->
211
-
Eio.traceln "Recieved an invalid message. Shutting down...@."
197
+
if should_shutdown () then shutdown () else event_loop ()
198
+
| None -> Eio.traceln "Recieved an invalid message. Shutting down...@."
212
199
213
200
let start ~env ~(config : Config.t) =
214
201
let lsp_io = LspEio.init env in
215
202
(* FIXME: A "batch run" should fail early. The lsp should start even when
216
203
there are errors *)
217
204
let forest = Driver.language_server ~env ~config in
218
-
Server.run
219
-
~init: {forest; lsp_io; should_shutdown = false;}
220
-
@@ fun () ->
221
-
begin
222
-
initialize ();
223
-
event_loop ()
224
-
end
205
+
Server.run ~init:{forest; lsp_io; should_shutdown = false} @@ fun () ->
206
+
begin
207
+
initialize ();
208
+
event_loop ()
209
+
end
+9
-14
lib/language_server/Highlight.ml
+9
-14
lib/language_server/Highlight.ml
···
16
16
17
17
let compute (params : L.DocumentHighlightParams.t) =
18
18
let Lsp_state.{forest; _} = Lsp_state.get () in
19
-
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url params.textDocument.uri in
19
+
let uri =
20
+
URI_scheme.lsp_uri_to_uri ~base:forest.config.url params.textDocument.uri
21
+
in
20
22
let@ tree = Option.map @~ State.get_code forest uri in
21
23
let@ Range.{loc; value} = List.map @~ tree.nodes in
22
24
let range = Lsp_shims.Loc.lsp_range_of_range loc in
23
25
let kind =
24
26
match value with
25
-
| Code.Text _
26
-
| Code.Verbatim _
27
+
| Code.Text _ | Code.Verbatim _
27
28
| Code.Group (_, _)
28
29
| Code.Math (_, _)
29
-
| Code.Ident _
30
-
| Code.Hash_ident _
30
+
| Code.Ident _ | Code.Hash_ident _
31
31
| Code.Xml_ident (_, _)
32
32
| Code.Subtree (_, _)
33
33
| Code.Let (_, _, _)
34
-
| Code.Open _
35
-
| Code.Scope _
34
+
| Code.Open _ | Code.Scope _
36
35
| Code.Put (_, _)
37
36
| Code.Default (_, _)
38
37
| Code.Get _
39
38
| Code.Fun (_, _)
40
-
| Code.Object _
41
-
| Code.Patch _
39
+
| Code.Object _ | Code.Patch _
42
40
| Code.Call (_, _)
43
41
| Code.Import (_, _)
44
42
| Code.Def (_, _, _)
···
48
46
| Code.Dx_sequent (_, _)
49
47
| Code.Dx_query (_, _, _)
50
48
| Code.Dx_prop (_, _)
51
-
| Code.Dx_var _
52
-
| Code.Dx_const_content _
53
-
| Code.Dx_const_uri _
54
-
| Code.Comment _
55
-
| Code.Error _ ->
49
+
| Code.Dx_var _ | Code.Dx_const_content _ | Code.Dx_const_uri _
50
+
| Code.Comment _ | Code.Error _ ->
56
51
None
57
52
in
58
53
L.DocumentHighlight.create ~range ?kind ()
+37
-21
lib/language_server/Hover.ml
+37
-21
lib/language_server/Hover.ml
···
15
15
open struct
16
16
module L = Lsp.Types
17
17
module T = Types
18
-
let (let*) = Option.bind
18
+
19
+
let ( let* ) = Option.bind
19
20
end
20
21
21
-
let compute ({position; textDocument; _}: L.HoverParams.t) =
22
+
let compute ({position; textDocument; _} : L.HoverParams.t) =
22
23
let Lsp_state.{forest; _} = Lsp_state.get () in
23
24
let render = Plain_text_client.string_of_content ~forest in
24
-
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url textDocument.uri in
25
+
let uri =
26
+
URI_scheme.lsp_uri_to_uri ~base:forest.config.url textDocument.uri
27
+
in
25
28
let@ content =
26
-
Option.map @~
27
-
match forest.={uri} with
29
+
Option.map
30
+
@~
31
+
match forest.={uri} with
32
+
| None ->
33
+
Reporter.fatal Internal_error
34
+
~extra_remarks:
35
+
[Asai.Diagnostic.loctextf "%a is not in the index" URI.pp uri]
36
+
| Some tree -> (
37
+
let* {nodes; _} = Tree.to_code tree in
38
+
let* node = Analysis.node_at_code ~position nodes in
39
+
let tree_under_cursor =
40
+
let* {value = addr; _} = Analysis.extract_addr node in
41
+
let uri_under_cursor =
42
+
URI_scheme.named_uri ~base:forest.config.url addr
43
+
in
44
+
State.get_article uri_under_cursor forest
45
+
in
46
+
match tree_under_cursor with
47
+
| Some article -> Some (render article.mainmatter)
28
48
| None ->
29
-
Reporter.fatal Internal_error ~extra_remarks: [Asai.Diagnostic.loctextf "%a is not in the index" URI.pp uri]
30
-
| Some tree ->
31
-
let* {nodes; _} = Tree.to_code tree in
32
-
let* node = Analysis.node_at_code ~position nodes in
33
-
let tree_under_cursor =
34
-
let* {value = addr; _} = Analysis.extract_addr node in
35
-
let uri_under_cursor = URI_scheme.named_uri ~base: forest.config.url addr in
36
-
State.get_article uri_under_cursor forest
49
+
let* doc = Tree.to_doc tree in
50
+
let* search_term = Analysis.word_at ~position doc in
51
+
let results =
52
+
List.map snd @@ Index.search forest.search_index search_term
37
53
in
38
-
match tree_under_cursor with
39
-
| Some article -> Some (render article.mainmatter)
40
-
| None ->
41
-
let* doc = Tree.to_doc tree in
42
-
let* search_term = Analysis.word_at ~position doc in
43
-
let results = List.map snd @@ Index.search forest.search_index search_term in
44
-
Some Format.(asprintf "Relevant results:@.%a@." (pp_print_list ~pp_sep: (fun out () -> fprintf out "@.") URI.pp) results)
54
+
Some
55
+
Format.(
56
+
asprintf "Relevant results:@.%a@."
57
+
(pp_print_list ~pp_sep:(fun out () -> fprintf out "@.") URI.pp)
58
+
results))
45
59
in
46
-
L.Hover.create ~contents: (`MarkupContent {kind = L.MarkupKind.Markdown; value = content}) ()
60
+
L.Hover.create
61
+
~contents:(`MarkupContent {kind = L.MarkupKind.Markdown; value = content})
62
+
()
+18
-12
lib/language_server/Inlay_hint.ml
+18
-12
lib/language_server/Inlay_hint.ml
···
15
15
module L = Lsp.Types
16
16
end
17
17
18
-
let list_of_option = function
19
-
| Some x -> [x]
20
-
| None -> []
18
+
let list_of_option = function Some x -> [x] | None -> []
21
19
22
-
let consume_addr_for_inlay ~(config : Config.t) ~(forest : State.t) (node : Syn.node Range.located) : string option * Syn.t =
20
+
let consume_addr_for_inlay ~(config : Config.t) ~(forest : State.t)
21
+
(node : Syn.node Range.located) : string option * Syn.t =
23
22
match node.value with
24
-
| Link {title = None; dest = [{value = Text addr; _}]} -> Some addr, []
25
-
| Subtree (addr, nodes) -> addr, nodes
26
-
| _ -> None, Syn.children node
23
+
| Link {title = None; dest = [{value = Text addr; _}]} -> (Some addr, [])
24
+
| Subtree (addr, nodes) -> (addr, nodes)
25
+
| _ -> (None, Syn.children node)
27
26
28
-
let inlay_hint_for_addr ~(config : Config.t) ~(forest : State.t) ~(pos : Range.position) (addr : string) : L.InlayHint.t option =
29
-
let uri = URI_scheme.named_uri ~base: config.url addr in
27
+
let inlay_hint_for_addr ~(config : Config.t) ~(forest : State.t)
28
+
~(pos : Range.position) (addr : string) : L.InlayHint.t option =
29
+
let uri = URI_scheme.named_uri ~base:config.url addr in
30
30
let@ {frontmatter; _} = Option.bind @@ State.get_article uri forest in
31
31
let@ title = Option.bind frontmatter.title in
32
32
let content = " " ^ Plain_text_client.string_of_content ~forest title in
33
-
Option.some @@ L.InlayHint.create ~position: (Lsp_shims.Loc.lsp_pos_of_pos pos) ~label: (`String content) ()
33
+
Option.some
34
+
@@ L.InlayHint.create
35
+
~position:(Lsp_shims.Loc.lsp_pos_of_pos pos)
36
+
~label:(`String content) ()
34
37
35
38
let pos_of_node (node : 'a Range.located) : Range.position option =
36
39
let@ loc = Option.bind node.loc in
···
38
41
| `End_of_file _ -> None
39
42
| `Range (_, pos) -> Some pos
40
43
41
-
let rec extract_inlayable_hints ~(config : Config.t) ~(forest : State.t) (nodes : Syn.t) : L.InlayHint.t list =
44
+
let rec extract_inlayable_hints ~(config : Config.t) ~(forest : State.t)
45
+
(nodes : Syn.t) : L.InlayHint.t list =
42
46
let@ node = List.concat_map @~ nodes in
43
47
let addr_opt, rest = consume_addr_for_inlay ~config ~forest node in
44
48
let hint_opt =
···
52
56
let compute (params : L.InlayHintParams.t) : L.InlayHint.t list option =
53
57
let Lsp_state.{forest; _} = Lsp_state.get () in
54
58
let config = forest.config in
55
-
let uri = URI_scheme.lsp_uri_to_uri ~base: config.url params.textDocument.uri in
59
+
let uri =
60
+
URI_scheme.lsp_uri_to_uri ~base:config.url params.textDocument.uri
61
+
in
56
62
let@ {nodes; _} = Option.map @~ Option.bind forest.={uri} Tree.to_syn in
57
63
extract_inlayable_hints ~config ~forest nodes
+40
-50
lib/language_server/LspEio.ml
+40
-50
lib/language_server/LspEio.ml
···
7
7
8
8
open Eio
9
9
open Lsp.Import
10
-
11
10
module RPC = Jsonrpc
12
11
13
-
type io = {
14
-
input: Buf_read.t;
15
-
output: Eio_unix.sink_ty Eio.Resource.t;
16
-
}
12
+
type io = {input: Buf_read.t; output: Eio_unix.sink_ty Eio.Resource.t}
17
13
18
-
(** See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#headerPart *)
14
+
(** See
15
+
https://microsoft.github.io/language-server-protocol/specifications/specification-current/#headerPart
16
+
*)
19
17
module Header = struct
20
-
type t = {
21
-
content_length: int;
22
-
content_type: string
23
-
}
18
+
type t = {content_length: int; content_type: string}
24
19
25
-
let empty = {
26
-
content_length = -1;
27
-
content_type = "application/vscode-jsonrpc; charset=utf-8"
28
-
}
20
+
let empty =
21
+
{
22
+
content_length = -1;
23
+
content_type = "application/vscode-jsonrpc; charset=utf-8";
24
+
}
29
25
30
26
let create ~(content_length : int) : t = {empty with content_length}
31
27
···
35
31
let is_content_type key =
36
32
String.equal (String.lowercase_ascii @@ String.trim key) "content-type"
37
33
38
-
(* NOTE: We should never really recieve an invalid header, as
39
-
that would indicate a broken client implementation. Therefore,
40
-
we just bail out when we see an invalid header, as there's
41
-
no way we can really recover anyways. *)
42
-
type header_error =
43
-
| InvalidHeader of string
44
-
| InvalidContentLength of string
34
+
(* NOTE: We should never really recieve an invalid header, as that would
35
+
indicate a broken client implementation. Therefore, we just bail out when
36
+
we see an invalid header, as there's no way we can really recover anyways. *)
37
+
type header_error = InvalidHeader of string | InvalidContentLength of string
45
38
46
39
exception HeaderError of header_error
47
40
48
-
(* If we do see any random header messages, we want to at least print out a decent error message. *)
41
+
(* If we do see any random header messages, we want to at least print out a
42
+
decent error message. *)
49
43
let () =
50
44
Printexc.register_printer @@ function
51
-
| HeaderError (InvalidHeader err) -> Some (Format.asprintf "HeaderError: Invalid Header %s" err)
52
-
| HeaderError (InvalidContentLength n) -> Some (Format.asprintf "HeaderError: Invalid Content Length '%s'" n)
53
-
| _ -> None
45
+
| HeaderError (InvalidHeader err) ->
46
+
Some (Format.asprintf "HeaderError: Invalid Header %s" err)
47
+
| HeaderError (InvalidContentLength n) ->
48
+
Some (Format.asprintf "HeaderError: Invalid Content Length '%s'" n)
49
+
| _ -> None
54
50
55
-
(* [TODO: Reed M, 09/06/2022] I could use some of the Buf_read parser module here, but this code works. *)
51
+
(* [TODO: Reed M, 09/06/2022] I could use some of the Buf_read parser module
52
+
here, but this code works. *)
56
53
let parse_header line headers =
57
-
match String.split_on_char ~sep: ':' @@ String.trim line with
54
+
match String.split_on_char ~sep:':' @@ String.trim line with
58
55
| [key; value] when is_content_length key ->
59
56
let content_length =
60
57
match int_of_string_opt (String.trim value) with
···
68
65
| [_; _] ->
69
66
(* We skip any unknown headers. *)
70
67
headers
71
-
| _ ->
72
-
raise (HeaderError (InvalidHeader line))
68
+
| _ -> raise (HeaderError (InvalidHeader line))
73
69
74
70
(** Read the header section of an LSP message. *)
75
71
let read io =
···
80
76
in
81
77
let headers = loop empty in
82
78
if headers.content_length < 0 then
83
-
raise (HeaderError (InvalidContentLength (string_of_int headers.content_length)))
84
-
else
85
-
headers
79
+
raise
80
+
(HeaderError
81
+
(InvalidContentLength (string_of_int headers.content_length)))
82
+
else headers
86
83
87
84
(** Write out the header section of an LSP message. *)
88
85
let write io headers =
89
86
let header_str =
90
-
Format.asprintf
91
-
"Content-Type: %s\r\nContent-Length: %d\r\n\r\n"
92
-
headers.content_type
93
-
headers.content_length
87
+
Format.asprintf "Content-Type: %s\r\nContent-Length: %d\r\n\r\n"
88
+
headers.content_type headers.content_length
94
89
in
95
90
Flow.copy_string header_str io.output
96
91
end
···
102
97
let len = header.content_length in
103
98
let json = Json.of_string @@ Buf_read.take len io.input in
104
99
Some (RPC.Packet.t_of_yojson json)
105
-
with
106
-
| Sys_error _
107
-
| End_of_file ->
108
-
None
100
+
with Sys_error _ | End_of_file -> None
109
101
110
102
let write io packet =
111
103
let json = RPC.Packet.yojson_of_t packet in
···
116
108
Flow.copy_string data io.output
117
109
end
118
110
119
-
let init (env : Eio_unix.Stdenv.base) = {
120
-
(* [TODO: Reed M, 09/06/2022] I should think about this buffer size... *)
121
-
input = Buf_read.of_flow ~max_size: 1_000_000 @@ Eio.Stdenv.stdin env;
122
-
output = Eio.Stdenv.stdout env
123
-
}
124
-
125
-
let recv io =
126
-
Message.read io
111
+
let init (env : Eio_unix.Stdenv.base) =
112
+
{
113
+
(* [TODO: Reed M, 09/06/2022] I should think about this buffer size... *)
114
+
input = Buf_read.of_flow ~max_size:1_000_000 @@ Eio.Stdenv.stdin env;
115
+
output = Eio.Stdenv.stdout env;
116
+
}
127
117
128
-
let send io packet =
129
-
Message.write io packet
118
+
let recv io = Message.read io
119
+
let send io packet = Message.write io packet
+62
-70
lib/language_server/Lsp_server.ml
+62
-70
lib/language_server/Lsp_server.ml
···
18
18
19
19
let () =
20
20
Printexc.register_printer @@ function
21
-
| Lsp_error (Decode_error err) ->
22
-
Some (Format.asprintf "Lsp Error: Couldn't decode %s" err)
23
-
| Lsp_error (Handshake_error err) ->
24
-
Some (Format.asprintf "Lsp Error: Invalid initialization handshake %s" err)
25
-
| Lsp_error (Shutdown_error err) ->
26
-
Some (Format.asprintf "Lsp Error: Invalid shutdown sequence %s" err)
27
-
| Lsp_error (Unknown_request err) ->
28
-
Some (Format.asprintf "Lsp Error: Unknown request %s" err)
29
-
| Lsp_error (Unknown_notification err) ->
30
-
Some (Format.asprintf "Lsp Error: Unknown notification %s" err)
31
-
| _ -> None
21
+
| Lsp_error (Decode_error err) ->
22
+
Some (Format.asprintf "Lsp Error: Couldn't decode %s" err)
23
+
| Lsp_error (Handshake_error err) ->
24
+
Some (Format.asprintf "Lsp Error: Invalid initialization handshake %s" err)
25
+
| Lsp_error (Shutdown_error err) ->
26
+
Some (Format.asprintf "Lsp Error: Invalid shutdown sequence %s" err)
27
+
| Lsp_error (Unknown_request err) ->
28
+
Some (Format.asprintf "Lsp Error: Unknown request %s" err)
29
+
| Lsp_error (Unknown_notification err) ->
30
+
Some (Format.asprintf "Lsp Error: Unknown notification %s" err)
31
+
| _ -> None
32
32
33
33
let recv () =
34
34
let server = Lsp_state.get () in
···
47
47
48
48
(* I don't understand this request...*)
49
49
let document_link_resolve (params : L.DocumentLink.t) =
50
-
match params with
51
-
| link -> link
50
+
match params with link -> link
52
51
53
52
module Request = struct
54
53
type 'resp t = 'resp Lsp.Client_request.t
55
54
type packed = Lsp_Request.packed
56
55
57
-
let dispatch : type resp. string -> resp Lsp.Client_request.t -> resp = fun mthd ->
58
-
function
59
-
| Initialize _ ->
60
-
let err = "Server can only recieve a single initialization request." in
61
-
raise @@ Lsp_error (Handshake_error err)
62
-
| Shutdown -> initiate_shutdown ()
63
-
| CodeAction params -> Code_action.compute params
64
-
| CodeActionResolve params -> Code_action.resolve params
65
-
(* | ExecuteCommand params -> Code_action.execute params *)
66
-
| TextDocumentHover params -> Hover.compute params
67
-
| TextDocumentCompletion params -> Completion.compute params
68
-
| InlayHint params -> Inlay_hint.compute params
69
-
| TextDocumentDefinition params -> Definitions.compute params
70
-
| DocumentSymbol params -> Document_symbols.compute params
71
-
| TextDocumentLink params -> Document_link.compute params
72
-
| TextDocumentLinkResolve params -> document_link_resolve params
73
-
| WorkspaceSymbol params -> Workspace_symbols.compute params
74
-
| TextDocumentPrepareCallHierarchy params -> Call_hierarchy.compute params
75
-
| CallHierarchyIncomingCalls params -> Call_hierarchy.incoming params
76
-
| CallHierarchyOutgoingCalls params -> Call_hierarchy.outgoing params
77
-
| TextDocumentCodeLens params -> Code_lens.compute params
78
-
| SemanticTokensFull params -> Semantic_tokens.on_full_request params
79
-
| SemanticTokensDelta params -> Semantic_tokens.on_delta_request params
80
-
| _ ->
81
-
raise @@ Lsp_error (Unknown_request mthd)
56
+
let dispatch : type resp. string -> resp Lsp.Client_request.t -> resp =
57
+
fun mthd -> function
58
+
| Initialize _ ->
59
+
let err = "Server can only recieve a single initialization request." in
60
+
raise @@ Lsp_error (Handshake_error err)
61
+
| Shutdown -> initiate_shutdown ()
62
+
| CodeAction params -> Code_action.compute params
63
+
| CodeActionResolve params -> Code_action.resolve params
64
+
(* | ExecuteCommand params -> Code_action.execute params *)
65
+
| TextDocumentHover params -> Hover.compute params
66
+
| TextDocumentCompletion params -> Completion.compute params
67
+
| InlayHint params -> Inlay_hint.compute params
68
+
| TextDocumentDefinition params -> Definitions.compute params
69
+
| DocumentSymbol params -> Document_symbols.compute params
70
+
| TextDocumentLink params -> Document_link.compute params
71
+
| TextDocumentLinkResolve params -> document_link_resolve params
72
+
| WorkspaceSymbol params -> Workspace_symbols.compute params
73
+
| TextDocumentPrepareCallHierarchy params -> Call_hierarchy.compute params
74
+
| CallHierarchyIncomingCalls params -> Call_hierarchy.incoming params
75
+
| CallHierarchyOutgoingCalls params -> Call_hierarchy.outgoing params
76
+
| TextDocumentCodeLens params -> Code_lens.compute params
77
+
| SemanticTokensFull params -> Semantic_tokens.on_full_request params
78
+
| SemanticTokensDelta params -> Semantic_tokens.on_delta_request params
79
+
| _ -> raise @@ Lsp_error (Unknown_request mthd)
82
80
83
81
let handle (msg : RPC.Request.t) =
84
82
Eio.traceln "Request: %s@." msg.method_;
···
87
85
let resp = dispatch msg.method_ r in
88
86
let json = Lsp_Request.yojson_of_result r resp in
89
87
RPC.Response.ok msg.id json
90
-
| Error err ->
91
-
raise (Lsp_error (Decode_error err))
88
+
| Error err -> raise (Lsp_error (Decode_error err))
92
89
93
90
let recv () =
94
91
Option.bind (recv ()) @@ function
95
-
| RPC.Packet.Request req ->
96
-
begin
97
-
match Lsp_Request.of_jsonrpc req with
98
-
| Ok packed -> Some (req.id, packed)
99
-
| Error err -> raise @@ Lsp_error (Decode_error err)
100
-
end
101
-
| _ -> None
92
+
| RPC.Packet.Request req -> begin
93
+
match Lsp_Request.of_jsonrpc req with
94
+
| Ok packed -> Some (req.id, packed)
95
+
| Error err -> raise @@ Lsp_error (Decode_error err)
96
+
end
97
+
| _ -> None
102
98
103
99
let respond id req resp =
104
100
let json = Lsp_Request.yojson_of_result req resp in
···
108
104
module Notification = struct
109
105
type t = Lsp.Client_notification.t
110
106
111
-
let dispatch : string -> t -> unit = fun mthd ->
112
-
function
113
-
| TextDocumentDidOpen params -> Did_open.compute params
114
-
| TextDocumentDidChange params -> Did_change.compute params
115
-
| ChangeConfiguration params -> Change_configuration.compute params
116
-
(* | DidCreateFiles params -> Did_create_files.compute params *)
117
-
| DidSaveTextDocument _ -> ()
118
-
| TextDocumentDidClose _ -> ()
119
-
| CancelRequest _ -> ()
120
-
| _ -> raise @@ Lsp_error (Unknown_notification mthd)
107
+
let dispatch : string -> t -> unit =
108
+
fun mthd -> function
109
+
| TextDocumentDidOpen params -> Did_open.compute params
110
+
| TextDocumentDidChange params -> Did_change.compute params
111
+
| ChangeConfiguration params -> Change_configuration.compute params
112
+
(* | DidCreateFiles params -> Did_create_files.compute params *)
113
+
| DidSaveTextDocument _ -> ()
114
+
| TextDocumentDidClose _ -> ()
115
+
| CancelRequest _ -> ()
116
+
| _ -> raise @@ Lsp_error (Unknown_notification mthd)
121
117
122
118
let handle (msg : RPC.Notification.t) =
123
119
Eio.traceln "Request: %s@." msg.method_;
124
120
match Lsp_Notification.of_jsonrpc msg with
125
-
| Ok notif ->
126
-
dispatch msg.method_ notif
127
-
| Error err ->
128
-
raise @@ Lsp_error (Decode_error err)
121
+
| Ok notif -> dispatch msg.method_ notif
122
+
| Error err -> raise @@ Lsp_error (Decode_error err)
129
123
130
124
let recv () =
131
125
Option.bind (recv ()) @@ function
132
-
| RPC.Packet.Notification msg ->
133
-
begin
134
-
match Lsp_Notification.of_jsonrpc msg with
135
-
| Ok notif -> Some notif
136
-
| Error err -> raise @@ Lsp_error (Decode_error err)
137
-
end
138
-
| _ -> None
126
+
| RPC.Packet.Notification msg -> begin
127
+
match Lsp_Notification.of_jsonrpc msg with
128
+
| Ok notif -> Some notif
129
+
| Error err -> raise @@ Lsp_error (Decode_error err)
130
+
end
131
+
| _ -> None
139
132
end
140
133
141
-
let run ~init k =
142
-
Lsp_state.run ~init k
134
+
let run ~init k = Lsp_state.run ~init k
+1
-3
lib/language_server/Lsp_server.mli
+1
-3
lib/language_server/Lsp_server.mli
···
9
9
10
10
val recv : unit -> Jsonrpc.Packet.t option
11
11
val send : Jsonrpc.Packet.t -> unit
12
-
13
12
val should_shutdown : unit -> bool
14
13
val initiate_shutdown : unit -> unit
15
-
16
-
val run : init: Lsp_state.state -> (unit -> 'a) -> 'a
14
+
val run : init:Lsp_state.state -> (unit -> 'a) -> 'a
17
15
18
16
module Request : sig
19
17
type packed = Lsp.Client_request.packed
+15
-16
lib/language_server/Lsp_shims.ml
+15
-16
lib/language_server/Lsp_shims.ml
···
5
5
*
6
6
*)
7
7
8
-
open struct module L = Lsp.Types end
8
+
open struct
9
+
module L = Lsp.Types
10
+
end
9
11
10
12
module Loc = struct
11
13
let lsp_pos_of_pos (pos : Asai.Range.position) =
12
-
L.Position.create
13
-
~line: (pos.line_num - 1)
14
-
~character: (pos.offset - pos.start_of_line)
14
+
L.Position.create ~line:(pos.line_num - 1)
15
+
~character:(pos.offset - pos.start_of_line)
15
16
16
17
let lsp_range_of_range (r : Asai.Range.t option) =
17
18
match r with
18
19
| Some r ->
19
-
let (start, stop) =
20
+
let start, stop =
20
21
match Asai.Range.view r with
21
-
| `Range (start, stop) -> start, stop
22
-
| `End_of_file pos -> pos, pos
22
+
| `Range (start, stop) -> (start, stop)
23
+
| `End_of_file pos -> (pos, pos)
23
24
in
24
-
L.Range.create
25
-
~start: (lsp_pos_of_pos start)
26
-
~end_: (lsp_pos_of_pos stop)
25
+
L.Range.create ~start:(lsp_pos_of_pos start) ~end_:(lsp_pos_of_pos stop)
27
26
| None ->
28
-
(* When we have a message without a location,
29
-
we set it's location to the start of the file,
30
-
as we don't have any better choices. *)
31
-
let start_of_file = L.Position.create ~line: 0 ~character: 0 in
32
-
L.Range.create ~start: start_of_file ~end_: start_of_file
27
+
(* When we have a message without a location, we set it's location to the
28
+
start of the file, as we don't have any better choices. *)
29
+
let start_of_file = L.Position.create ~line:0 ~character:0 in
30
+
L.Range.create ~start:start_of_file ~end_:start_of_file
33
31
end
34
32
35
33
module Diagnostic = struct
36
-
let lsp_severity_of_severity : Asai.Diagnostic.severity -> L.DiagnosticSeverity.t = function
34
+
let lsp_severity_of_severity :
35
+
Asai.Diagnostic.severity -> L.DiagnosticSeverity.t = function
37
36
| Hint -> Hint
38
37
| Info -> Information
39
38
| Warning -> Warning
+5
-6
lib/language_server/Lsp_state.ml
+5
-6
lib/language_server/Lsp_state.ml
···
7
7
8
8
open Forester_compiler
9
9
10
-
type state = {
11
-
forest: State.t;
12
-
should_shutdown: bool;
13
-
lsp_io: LspEio.io;
14
-
}
10
+
type state = {forest: State.t; should_shutdown: bool; lsp_io: LspEio.io}
11
+
12
+
module M = Algaeff.State.Make (struct
13
+
type t = state
14
+
end)
15
15
16
-
module M = Algaeff.State.Make(struct type t = state end)
17
16
include M
+16
-8
lib/language_server/Publish.ml
+16
-8
lib/language_server/Publish.ml
···
17
17
end
18
18
19
19
type diagnostic = Reporter.Message.t Asai.Diagnostic.t
20
-
21
20
type table = (Lsp.Uri.t, diagnostic list) Hashtbl.t
22
21
23
22
let send packet =
24
23
let server = Lsp_state.get () in
25
24
LspEio.send server.lsp_io packet
26
25
27
-
let render_lsp_related_info (uri : L.DocumentUri.t) (message : Asai.Diagnostic.loctext) : L.DiagnosticRelatedInformation.t =
26
+
let render_lsp_related_info (uri : L.DocumentUri.t)
27
+
(message : Asai.Diagnostic.loctext) : L.DiagnosticRelatedInformation.t =
28
28
let range = Lsp_shims.Loc.lsp_range_of_range message.loc in
29
29
let location = L.Location.create ~uri ~range in
30
30
let message = Asai.Diagnostic.string_of_text message.value in
31
31
L.DiagnosticRelatedInformation.create ~location ~message
32
32
33
-
let render_lsp_diagnostic (uri : L.DocumentUri.t) (diag : diagnostic) : Lsp_Diagnostic.t =
33
+
let render_lsp_diagnostic (uri : L.DocumentUri.t) (diag : diagnostic) :
34
+
Lsp_Diagnostic.t =
34
35
let range = Lsp_shims.Loc.lsp_range_of_range diag.explanation.loc in
35
-
let severity = Lsp_shims.Diagnostic.lsp_severity_of_severity @@ diag.severity in
36
+
let severity =
37
+
Lsp_shims.Diagnostic.lsp_severity_of_severity @@ diag.severity
38
+
in
36
39
let code = `String (Reporter.Message.short_code diag.message) in
37
40
let source =
38
41
let Lsp_state.{forest; _} = Lsp_state.get () in
39
-
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url uri in
40
-
let@ doc = Option.map @~ Option.bind (State.find_opt forest uri) Tree.to_doc in
42
+
let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url uri in
43
+
let@ doc =
44
+
Option.map @~ Option.bind (State.find_opt forest uri) Tree.to_doc
45
+
in
41
46
Lsp.Text_document.text doc
42
47
in
43
48
let message = Asai.Diagnostic.string_of_text diag.explanation.value in
44
-
let relatedInformation = Bwd.to_list @@ Bwd.map (render_lsp_related_info uri) diag.extra_remarks in
45
-
Lsp_Diagnostic.create ~range ~severity ~code ?source ~message: (`String message) ~relatedInformation ()
49
+
let relatedInformation =
50
+
Bwd.to_list @@ Bwd.map (render_lsp_related_info uri) diag.extra_remarks
51
+
in
52
+
Lsp_Diagnostic.create ~range ~severity ~code ?source
53
+
~message:(`String message) ~relatedInformation ()
46
54
47
55
let broadcast notif =
48
56
let msg = Broadcast.to_jsonrpc notif in
+117
-122
lib/language_server/Semantic_tokens.ml
+117
-122
lib/language_server/Semantic_tokens.ml
···
9
9
open Forester_core
10
10
open Forester_compiler
11
11
12
-
open struct module L = Lsp.Types end
12
+
open struct
13
+
module L = Lsp.Types
14
+
end
13
15
14
16
let print_array =
15
-
Format.(
16
-
pp_print_array
17
-
~pp_sep: (fun out () -> fprintf out "; ")
18
-
pp_print_int
19
-
)
17
+
Format.(pp_print_array ~pp_sep:(fun out () -> fprintf out "; ") pp_print_int)
20
18
21
19
module Token_type = struct
22
20
type t = L.SemanticTokenTypes.t
23
-
let legend : L.SemanticTokenTypes.t list = [
24
-
Namespace;
25
-
Type;
26
-
Class;
27
-
Enum;
28
-
Interface;
29
-
Struct;
30
-
TypeParameter;
31
-
Parameter;
32
-
Variable;
33
-
Property;
34
-
EnumMember;
35
-
Event;
36
-
Function;
37
-
Method;
38
-
Macro;
39
-
Keyword;
40
-
Modifier;
41
-
Comment;
42
-
String;
43
-
Number;
44
-
Regexp;
45
-
Operator;
46
-
Decorator
47
-
]
21
+
22
+
let legend : L.SemanticTokenTypes.t list =
23
+
[
24
+
Namespace;
25
+
Type;
26
+
Class;
27
+
Enum;
28
+
Interface;
29
+
Struct;
30
+
TypeParameter;
31
+
Parameter;
32
+
Variable;
33
+
Property;
34
+
EnumMember;
35
+
Event;
36
+
Function;
37
+
Method;
38
+
Macro;
39
+
Keyword;
40
+
Modifier;
41
+
Comment;
42
+
String;
43
+
Number;
44
+
Regexp;
45
+
Operator;
46
+
Decorator;
47
+
]
48
+
48
49
let of_builtin t = t
49
50
50
51
let token_types =
···
52
53
(fun s ->
53
54
match L.SemanticTokenTypes.yojson_of_t s with
54
55
| `String s -> s
55
-
| _ -> assert false
56
-
)
56
+
| _ -> assert false)
57
57
legend
58
58
59
59
let to_int =
60
60
let module Table = MoreLabels.Hashtbl in
61
61
let table =
62
-
lazy(
63
-
let t = Table.create (List.length legend) in
64
-
List.iteri (fun data key -> Table.add t ~key ~data) legend;
65
-
t
66
-
)
62
+
lazy
63
+
(let t = Table.create (List.length legend) in
64
+
List.iteri (fun data key -> Table.add t ~key ~data) legend;
65
+
t)
67
66
in
68
67
fun t -> Table.find (Lazy.force table) t
69
68
···
74
73
end
75
74
76
75
module Token_modifiers_set = struct
77
-
let list = [
78
-
"declaration";
79
-
"definition";
80
-
"readonly";
81
-
"static";
82
-
"deprecated";
83
-
"abstract";
84
-
"async";
85
-
"modification";
86
-
"documentation";
87
-
"defaultLibrary"
88
-
]
89
-
;;
76
+
let list =
77
+
[
78
+
"declaration";
79
+
"definition";
80
+
"readonly";
81
+
"static";
82
+
"deprecated";
83
+
"abstract";
84
+
"async";
85
+
"modification";
86
+
"documentation";
87
+
"defaultLibrary";
88
+
]
90
89
end
91
90
92
91
let legend =
93
-
L.SemanticTokensLegend.create
94
-
~tokenTypes: Token_type.token_types
95
-
~tokenModifiers: Token_modifiers_set.list
92
+
L.SemanticTokensLegend.create ~tokenTypes:Token_type.token_types
93
+
~tokenModifiers:Token_modifiers_set.list
96
94
97
95
type token = {
98
96
(* node: string; *)
···
134
132
let node_to_tokens (_ : Code.node Range.located) _ _list = []
135
133
136
134
let tokenize_path ~(start : L.Position.t) (path : string list) : token list =
137
-
let offset = ref (start.character) in
135
+
let offset = ref start.character in
138
136
Eio.traceln "path has %i segments" (List.length path);
139
137
let@ segment = List.concat_map @~ path in
140
138
let length = String.length segment in
···
150
148
token_type;
151
149
token_modifiers = 0;
152
150
(* node = segment *)
153
-
}
151
+
};
154
152
]
155
153
156
154
let shift offset =
157
-
List.map @@ fun token ->
158
-
{token with start_char = token.start_char + offset}
155
+
List.map @@ fun token -> {token with start_char = token.start_char + offset}
159
156
160
157
let builtin ~(start : L.Position.t) str tks =
161
158
let offset = String.length str in
···
165
162
start_char = start.character;
166
163
length = offset;
167
164
token_type = 5;
168
-
token_modifiers = 0
169
-
} :: shift offset tks
165
+
token_modifiers = 0;
166
+
}
167
+
:: shift offset tks
170
168
171
169
let tokens (nodes : Code.t) : token list =
172
170
let@ Range.{loc; value} = List.concat_map @~ nodes in
173
171
let L.Range.{start; end_} = Lsp_shims.Loc.lsp_range_of_range loc in
174
172
(* Multiline tokens not supported*)
175
-
if start.line <> end_.line then
176
-
[]
173
+
if start.line <> end_.line then []
177
174
else
178
175
match value with
179
-
| Code.Ident path ->
180
-
tokenize_path ~start path
176
+
| Code.Ident path -> tokenize_path ~start path
181
177
| Code.Text _ -> []
182
178
| Code.Put (_path, _t) -> []
183
179
(* -> *)
···
194
190
| Code.Hash_ident _
195
191
| Code.Xml_ident (_, _)
196
192
| Code.Subtree (_, _)
197
-
| Code.Open _
198
-
| Code.Scope _
193
+
| Code.Open _ | Code.Scope _
199
194
| Code.Default (_, _)
200
195
| Code.Get _
201
196
| Code.Fun (_, _)
202
-
| Code.Object _
203
-
| Code.Patch _
197
+
| Code.Object _ | Code.Patch _
204
198
| Code.Call (_, _)
205
199
| Code.Decl_xmlns (_, _)
206
200
| Code.Alloc _
207
201
| Code.Dx_sequent (_, _)
208
202
| Code.Dx_query (_, _, _)
209
203
| Code.Dx_prop (_, _)
210
-
| Code.Dx_var _
211
-
| Code.Dx_const_content _
212
-
| Code.Dx_const_uri _
213
-
| Code.Error _
214
-
| Code.Comment _
204
+
| Code.Dx_var _ | Code.Dx_const_content _ | Code.Dx_const_uri _
205
+
| Code.Error _ | Code.Comment _
215
206
| Code.Namespace (_, _) ->
216
207
[]
217
208
218
-
let process_line_delta (index_of_last_line : int option) (tokens : token list) : int * delta_token list =
209
+
let process_line_delta (index_of_last_line : int option) (tokens : token list) :
210
+
int * delta_token list =
219
211
let line = (List.hd tokens).line in
220
212
let deltas =
221
213
List.fold_left
222
-
(fun
223
-
(last_token, acc)
224
-
({start_char;
225
-
length;
226
-
token_type;
227
-
token_modifiers;
228
-
line;
229
-
_;
230
-
} as current_token)
231
-
->
214
+
(fun (last_token, acc)
215
+
({start_char; length; token_type; token_modifiers; line; _} as
216
+
current_token) ->
232
217
match last_token with
233
218
| None ->
234
-
let delta_line = match index_of_last_line with Some i -> i - line | None -> line in
219
+
let delta_line =
220
+
match index_of_last_line with Some i -> i - line | None -> line
221
+
in
235
222
let delta_start_char = start_char in
236
-
let t = {delta_line; delta_start_char; length; token_type; token_modifiers} in
223
+
let t =
224
+
{delta_line; delta_start_char; length; token_type; token_modifiers}
225
+
in
237
226
(Some current_token, t :: acc)
238
227
| Some last_token ->
239
228
(*If there is a previous token, we know we are still on the same line*)
240
229
let delta_line = current_token.line - last_token.line in
241
-
let delta_start_char = if delta_line > 0 then current_token.start_char else current_token.start_char - last_token.start_char in
242
-
let delta = {delta_line; delta_start_char; length = current_token.length; token_type = current_token.token_type; token_modifiers;} in
243
-
(Some current_token, delta :: acc)
244
-
)
245
-
(None, [])
246
-
tokens
230
+
let delta_start_char =
231
+
if delta_line > 0 then current_token.start_char
232
+
else current_token.start_char - last_token.start_char
233
+
in
234
+
let delta =
235
+
{
236
+
delta_line;
237
+
delta_start_char;
238
+
length = current_token.length;
239
+
token_type = current_token.token_type;
240
+
token_modifiers;
241
+
}
242
+
in
243
+
(Some current_token, delta :: acc))
244
+
(None, []) tokens
247
245
in
248
-
line, snd deltas |> List.rev
246
+
(line, snd deltas |> List.rev)
249
247
250
248
let delta_tokens (tokens : token list list) : int array =
251
249
tokens
252
250
|> List.fold_left
253
-
(fun (last_line, acc) tokens_on_line ->
254
-
let line, delta_tokens = process_line_delta last_line tokens_on_line in
255
-
Some line, delta_tokens :: acc
256
-
)
257
-
(None, [])
258
-
|> snd
259
-
|> List.rev
260
-
|> List.concat
251
+
(fun (last_line, acc) tokens_on_line ->
252
+
let line, delta_tokens = process_line_delta last_line tokens_on_line in
253
+
(Some line, delta_tokens :: acc))
254
+
(None, [])
255
+
|> snd |> List.rev |> List.concat
261
256
|> List.concat_map encode_deltas
262
-
|> List.rev
263
-
|> Array.of_list
257
+
|> List.rev |> Array.of_list
264
258
265
-
let semantic_tokens_delta (_code : Code.node Range.located list) : L.SemanticTokensDelta.t = {
266
-
L.SemanticTokensDelta.resultId = None;
267
-
edits = [];
268
-
}
259
+
let semantic_tokens_delta (_code : Code.node Range.located list) :
260
+
L.SemanticTokensDelta.t =
261
+
{L.SemanticTokensDelta.resultId = None; edits = []}
269
262
270
-
let tokenize_document (identifier : L.TextDocumentIdentifier.t) : L.SemanticTokens.t option =
263
+
let tokenize_document (identifier : L.TextDocumentIdentifier.t) :
264
+
L.SemanticTokens.t option =
271
265
let Lsp_state.{forest; _} = Lsp_state.get () in
272
-
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url identifier.uri in
266
+
let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url identifier.uri in
273
267
let@ {nodes; _} = Option.map @~ Imports.resolve_uri_to_code forest uri in
274
268
let tokens = tokens nodes in
275
269
Format.(
276
-
Eio.traceln
277
-
"%a"
278
-
(
279
-
pp_print_list
280
-
~pp_sep: (fun out () -> fprintf out "; ")
281
-
pp_token
282
-
)
283
-
tokens
284
-
);
270
+
Eio.traceln "%a"
271
+
(pp_print_list ~pp_sep:(fun out () -> fprintf out "; ") pp_token)
272
+
tokens);
285
273
let encoded = List.concat_map encode tokens in
286
274
let data = Array.of_list @@ encoded in
287
275
L.SemanticTokens.{data; resultId = None}
288
276
289
-
let tokenize_document_delta (textDocument : L.TextDocumentIdentifier.t) : L.SemanticTokensDelta.t option =
277
+
let tokenize_document_delta (textDocument : L.TextDocumentIdentifier.t) :
278
+
L.SemanticTokensDelta.t option =
290
279
let Lsp_state.{forest; _} = Lsp_state.get () in
291
-
let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url textDocument.uri in
280
+
let uri =
281
+
URI_scheme.lsp_uri_to_uri ~base:forest.config.url textDocument.uri
282
+
in
292
283
let@ tree = Option.map @~ Imports.resolve_uri_to_code forest uri in
293
284
semantic_tokens_delta tree.nodes
294
285
295
-
let on_full_request (params : L.SemanticTokensParams.t) : L.SemanticTokens.t option =
286
+
let on_full_request (params : L.SemanticTokensParams.t) :
287
+
L.SemanticTokens.t option =
296
288
tokenize_document params.textDocument
297
289
298
-
let on_delta_request (params : L.SemanticTokensDeltaParams.t) : [`SemanticTokens of L.SemanticTokens.t | `SemanticTokensDelta of L.SemanticTokensDelta.t] option =
290
+
let on_delta_request (params : L.SemanticTokensDeltaParams.t) :
291
+
[ `SemanticTokens of L.SemanticTokens.t
292
+
| `SemanticTokensDelta of L.SemanticTokensDelta.t ]
293
+
option =
299
294
let@ tokens = Option.map @~ tokenize_document_delta params.textDocument in
300
295
`SemanticTokensDelta tokens
+5
-3
lib/language_server/Util.ml
+5
-3
lib/language_server/Util.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open struct module L = Lsp.Types end
7
+
open struct
8
+
module L = Lsp.Types
9
+
end
8
10
9
11
let start_of_file =
10
-
let beginning = L.Position.create ~character: 0 ~line: 0 in
11
-
L.Range.create ~start: beginning ~end_: beginning
12
+
let beginning = L.Position.create ~character:0 ~line:0 in
13
+
L.Range.create ~start:beginning ~end_:beginning
+55
-66
lib/language_server/Workspace_symbols.ml
+55
-66
lib/language_server/Workspace_symbols.ml
···
13
13
open struct
14
14
module L = Lsp.Types
15
15
module Unit_map = Forester_compiler.Expand.Unit_map
16
-
let (let*) = Option.bind
16
+
17
+
let ( let* ) = Option.bind
17
18
end
18
19
19
20
let location_of_range loc =
20
21
let* view = Option.map Range.view loc in
21
22
match view with
22
-
| `End_of_file {source; _}
23
-
| `Range ({source; _}, _) ->
23
+
| `End_of_file {source; _} | `Range ({source; _}, _) -> (
24
24
match source with
25
25
| `String _ | `File "" -> None
26
26
| `File path ->
27
27
let uri = Lsp.Uri.of_path path in
28
-
Option.some @@ L.Location.{range = Lsp_shims.Loc.lsp_range_of_range loc; uri;}
28
+
Option.some
29
+
@@ L.Location.{range = Lsp_shims.Loc.lsp_range_of_range loc; uri})
29
30
30
31
let exports_to_symbols (exports : Tree.exports) =
31
-
let@ path, (data, range) = List.filter_map @~ List.of_seq @@ Trie.to_seq exports in
32
+
let@ path, (data, range) =
33
+
List.filter_map @~ List.of_seq @@ Trie.to_seq exports
34
+
in
32
35
let@ location = Option.map @~ location_of_range range in
33
36
match data with
34
37
| Xmlns _ ->
35
-
L.SymbolInformation.create
36
-
~kind: Namespace
37
-
~location
38
-
~name: (Format.asprintf "%a" Resolver.Scope.pp_path path)
38
+
L.SymbolInformation.create ~kind:Namespace ~location
39
+
~name:(Format.asprintf "%a" Resolver.Scope.pp_path path)
39
40
()
40
41
| Term syn ->
41
42
let kind =
···
48
49
| Syn.Math (_, _)
49
50
| Syn.Link _
50
51
| Syn.Subtree (_, _)
51
-
| Syn.Var _
52
-
| Syn.Sym _
52
+
| Syn.Var _ | Syn.Sym _
53
53
| Syn.Put (_, _, _)
54
54
| Syn.Default (_, _, _)
55
55
| Syn.Get _
56
56
| Syn.Xml_tag (_, _, _)
57
-
| Syn.TeX_cs _
58
-
| Syn.Unresolved_ident _
59
-
| Syn.Prim _
60
-
| Syn.Patch _
57
+
| Syn.TeX_cs _ | Syn.Unresolved_ident _ | Syn.Prim _ | Syn.Patch _
61
58
| Syn.Call (_, _)
62
-
| Syn.Results_of_query
63
-
| Syn.Transclude
64
-
| Syn.Embed_tex
65
-
| Syn.Ref
66
-
| Syn.Title
67
-
| Syn.Parent
68
-
| Syn.Taxon
69
-
| Syn.Meta
59
+
| Syn.Results_of_query | Syn.Transclude | Syn.Embed_tex | Syn.Ref
60
+
| Syn.Title | Syn.Parent | Syn.Taxon | Syn.Meta
70
61
| Syn.Attribution (_, _)
71
-
| Syn.Tag _
72
-
| Syn.Date
73
-
| Syn.Number
62
+
| Syn.Tag _ | Syn.Date | Syn.Number
74
63
| Syn.Dx_sequent (_, _)
75
64
| Syn.Dx_query (_, _, _)
76
65
| Syn.Dx_prop (_, _)
77
66
| Syn.Dx_var _
78
67
| Syn.Dx_const (_, _)
79
-
| Syn.Dx_execute
80
-
| Syn.Route_asset
68
+
| Syn.Dx_execute | Syn.Route_asset
81
69
| Syn.Syndicate_current_tree_as_atom_feed
82
-
| Syn.Syndicate_query_as_json_blob
83
-
| Syn.Current_tree ->
70
+
| Syn.Syndicate_query_as_json_blob | Syn.Current_tree ->
84
71
Constant
85
72
in
86
-
L.SymbolInformation.create
87
-
~kind
88
-
~location
89
-
~name: (Format.asprintf "%a" Resolver.Scope.pp_path path)
73
+
L.SymbolInformation.create ~kind ~location
74
+
~name:(Format.asprintf "%a" Resolver.Scope.pp_path path)
90
75
()
91
76
92
77
let contains_substring_case_insensitive ~pattern text =
93
78
let text = String.lowercase_ascii text
94
-
and pattern = String.lowercase_ascii pattern
95
-
in
96
-
let n = String.length text
97
-
and m = String.length pattern
98
-
in
79
+
and pattern = String.lowercase_ascii pattern in
80
+
let n = String.length text and m = String.length pattern in
99
81
let rec search i =
100
82
if i + m > n then false
101
83
else if String.sub text i m = pattern then true
···
106
88
let fuzzy_match ~pattern text =
107
89
let pattern = String.lowercase_ascii pattern in
108
90
let text = String.lowercase_ascii text in
109
-
let n = String.length text
110
-
and m = String.length pattern
111
-
in
91
+
let n = String.length text and m = String.length pattern in
112
92
if n = 0 then false
113
93
else
114
94
let rec aux i j =
115
95
if j = m then true (* matched entire pattern *)
116
96
else if i = n then false (* text exhausted first *)
117
-
else if text.[i] = pattern.[j] then
118
-
aux (i + 1) (j + 1) (* match, advance both *)
119
-
else
120
-
aux (i + 1) j (* skip char in text *)
97
+
else if text.[i] = pattern.[j] then aux (i + 1) (j + 1)
98
+
(* match, advance both *)
99
+
else aux (i + 1) j (* skip char in text *)
121
100
in
122
101
aux 0 0
123
102
124
-
(* We no longer show exported functions, as this is really gumming up the editor interfaces. *)
103
+
(* We no longer show exported functions, as this is really gumming up the editor
104
+
interfaces. *)
125
105
let compute (params : L.WorkspaceSymbolParams.t) : _ =
126
106
Logs.debug (fun m -> m "QUERY: %s" params.query);
127
107
let Lsp_state.{forest; _} = Lsp_state.get () in
128
108
let render = Plain_text_client.string_of_content ~forest in
129
-
Option.some @@
130
-
let@ uri, item = List.concat_map @~ List.of_seq @@ State.to_seq forest in
131
-
let@ {frontmatter; _} = List.concat_map @~ Option.to_list (Tree.to_article item) in
132
-
let title = render @@ State.get_expanded_title frontmatter forest in
133
-
let@ () = List.concat_map @~ if fuzzy_match ~pattern: params.query title then [()] else [] in
134
-
let@ file_symbol =
135
-
List.concat_map @~
136
-
Option.to_list @@
137
-
let@ source_path = Option.map @~ State.source_path_of_uri uri forest in
138
-
let lsp_uri = Lsp.Uri.of_string source_path in
139
-
let location =
140
-
L.Location.{
141
-
range = L.Range.{
142
-
end_ = {character = 0; line = 0;};
143
-
start = {character = 0; line = 0;};
144
-
};
109
+
Option.some
110
+
@@
111
+
let@ uri, item = List.concat_map @~ List.of_seq @@ State.to_seq forest in
112
+
let@ {frontmatter; _} =
113
+
List.concat_map @~ Option.to_list (Tree.to_article item)
114
+
in
115
+
let title = render @@ State.get_expanded_title frontmatter forest in
116
+
let@ () =
117
+
List.concat_map
118
+
@~ if fuzzy_match ~pattern:params.query title then [()] else []
119
+
in
120
+
let@ file_symbol =
121
+
List.concat_map @~ Option.to_list
122
+
@@
123
+
let@ source_path = Option.map @~ State.source_path_of_uri uri forest in
124
+
let lsp_uri = Lsp.Uri.of_string source_path in
125
+
let location =
126
+
L.Location.
127
+
{
128
+
range =
129
+
L.Range.
130
+
{
131
+
end_ = {character = 0; line = 0};
132
+
start = {character = 0; line = 0};
133
+
};
145
134
uri = lsp_uri;
146
135
}
147
-
in
148
-
L.SymbolInformation.create ~kind: File ~location ~name: title ()
149
136
in
150
-
[file_symbol]
137
+
L.SymbolInformation.create ~kind:File ~location ~name:title ()
138
+
in
139
+
[file_symbol]
+62
-87
lib/parser/Parse.ml
+62
-87
lib/parser/Parse.ml
···
7
7
open Forester_prelude
8
8
open Forester_core
9
9
open Lexing
10
-
11
10
module I = Grammar.MenhirInterpreter
12
11
13
12
let buffer_lexer lexer =
···
15
14
let rec loop lexbuf =
16
15
match !buf with
17
16
| v :: vs ->
18
-
buf := vs; v
19
-
| [] ->
17
+
buf := vs;
18
+
v
19
+
| [] -> (
20
20
match lexer lexbuf with
21
-
| v :: vs -> buf := vs @ !buf; v
22
-
| [] -> loop lexbuf
21
+
| v :: vs ->
22
+
buf := vs @ !buf;
23
+
v
24
+
| [] -> loop lexbuf)
23
25
in
24
26
loop
25
27
···
31
33
| Ident_fragments -> Lexer.ident_fragments lexbuf
32
34
| Verbatim (herald, buffer) -> Lexer.verbatim herald buffer lexbuf
33
35
34
-
let _get_range
35
-
: I.element option -> (position * position) option
36
-
= fun el ->
36
+
let _get_range : I.element option -> (position * position) option =
37
+
fun el ->
37
38
match el with
38
-
| Some (I.Element (_, _, start_pos, end_pos)) ->
39
-
Some (start_pos, end_pos)
39
+
| Some (I.Element (_, _, start_pos, end_pos)) -> Some (start_pos, end_pos)
40
40
| None -> None
41
41
42
42
let closed_by c o =
43
43
match (o, c) with
44
-
| (Grammar.LSQUARE, Grammar.RSQUARE)
45
-
| (Grammar.LPAREN, Grammar.RPAREN)
46
-
| (Grammar.LBRACE, Grammar.RBRACE)
47
-
| (Grammar.HASH_LBRACE, Grammar.RBRACE)
48
-
| (Grammar.HASH_HASH_LBRACE, Grammar.RBRACE) ->
44
+
| Grammar.LSQUARE, Grammar.RSQUARE
45
+
| Grammar.LPAREN, Grammar.RPAREN
46
+
| Grammar.LBRACE, Grammar.RBRACE
47
+
| Grammar.HASH_LBRACE, Grammar.RBRACE
48
+
| Grammar.HASH_HASH_LBRACE, Grammar.RBRACE ->
49
49
true
50
50
| _ -> false
51
51
52
52
let is_opening_delim = function
53
-
| Grammar.LSQUARE
54
-
| Grammar.LPAREN
55
-
| Grammar.LBRACE
56
-
| Grammar.HASH_LBRACE
53
+
| Grammar.LSQUARE | Grammar.LPAREN | Grammar.LBRACE | Grammar.HASH_LBRACE
57
54
| Grammar.HASH_HASH_LBRACE ->
58
55
true
59
56
| _ -> false
60
57
61
58
let is_closing_delim = function
62
-
| Grammar.RSQUARE
63
-
| Grammar.RPAREN
64
-
| Grammar.RBRACE ->
65
-
true
59
+
| Grammar.RSQUARE | Grammar.RPAREN | Grammar.RBRACE -> true
66
60
| _ -> false
67
61
68
-
let parse
69
-
: ?stop_on_err: bool ->
70
-
lexbuf ->
71
-
(Code.t, Reporter.diagnostic) Result.t
72
-
= fun ?(stop_on_err = true) lexbuf ->
73
-
let initial_checkpoint = (Grammar.Incremental.main lexbuf.lex_curr_p) in
62
+
let parse :
63
+
?stop_on_err:bool -> lexbuf -> (Code.t, Reporter.diagnostic) Result.t =
64
+
fun ?(stop_on_err = true) lexbuf ->
65
+
let initial_checkpoint = Grammar.Incremental.main lexbuf.lex_curr_p in
74
66
let delim_stack = Stack.create () in
75
-
let rec run
76
-
: _ I.checkpoint ->
77
-
_ ->
78
-
(Code.t, Reporter.diagnostic) Result.t
79
-
= fun checkpoint supplier ->
67
+
let rec run : _ I.checkpoint -> _ -> (Code.t, Reporter.diagnostic) Result.t =
68
+
fun checkpoint supplier ->
80
69
match checkpoint with
81
70
| I.InputNeeded _env ->
82
-
(* If the current token is an opening delimiter, save the
83
-
token and its position on the stack.*)
71
+
(* If the current token is an opening delimiter, save the token and its
72
+
position on the stack.*)
84
73
let token, _, _ = supplier () in
85
74
let start_position = lexbuf.lex_start_p in
86
75
let end_position = lexbuf.lex_curr_p in
87
-
if is_opening_delim token then
88
-
let range = Range.of_lex_range (start_position, end_position) in
89
-
Stack.push (token, range) delim_stack; ;
90
-
if is_closing_delim token then
91
-
begin
92
-
match Stack.top_opt delim_stack with
93
-
| Some (open_delim, _) ->
94
-
if (open_delim |> closed_by token) then
95
-
Stack.drop delim_stack
96
-
| None -> ()
97
-
end;
98
-
let checkpoint = I.offer checkpoint (token, start_position, end_position) in
76
+
(if is_opening_delim token then
77
+
let range = Range.of_lex_range (start_position, end_position) in
78
+
Stack.push (token, range) delim_stack);
79
+
if is_closing_delim token then begin
80
+
match Stack.top_opt delim_stack with
81
+
| Some (open_delim, _) ->
82
+
if open_delim |> closed_by token then Stack.drop delim_stack
83
+
| None -> ()
84
+
end;
85
+
let checkpoint =
86
+
I.offer checkpoint (token, start_position, end_position)
87
+
in
99
88
run checkpoint supplier
100
-
| I.Shifting((_, _, _): Code.t I.env * Code.t I.env * bool) ->
101
-
let checkpoint = I.resume checkpoint ~strategy: `Simplified in
89
+
| I.Shifting ((_, _, _) : Code.t I.env * Code.t I.env * bool) ->
90
+
let checkpoint = I.resume checkpoint ~strategy:`Simplified in
102
91
run checkpoint supplier
103
92
| I.AboutToReduce (_, _) ->
104
-
let checkpoint = I.resume checkpoint ~strategy: `Simplified in
93
+
let checkpoint = I.resume checkpoint ~strategy:`Simplified in
105
94
run checkpoint supplier
106
95
| I.HandlingError _ ->
107
96
if not stop_on_err then
108
97
(* TODO: Don't error out here *)
109
98
Error
110
-
(
111
-
Asai.Diagnostic.of_text
112
-
~loc: (Range.of_lexbuf lexbuf)
113
-
Error
114
-
Reporter.Message.Parse_error
115
-
(Asai.Diagnostic.text "")
116
-
)
99
+
(Asai.Diagnostic.of_text ~loc:(Range.of_lexbuf lexbuf) Error
100
+
Reporter.Message.Parse_error (Asai.Diagnostic.text ""))
117
101
else
118
102
(* let range_of_last_unclosed = *)
119
103
(* Option.map snd @@ Stack.top_opt delim_stack *)
···
129
113
(* else [] *)
130
114
(* in *)
131
115
Error
132
-
(
133
-
Asai.Diagnostic.(
134
-
of_loctext
135
-
(* ~extra_remarks *)
136
-
Error
137
-
Forester_core.Reporter.Message.Parse_error
138
-
(loctext ~loc Format.(sprintf "syntax error, unexpected %S" (Lexing.lexeme lexbuf)))
139
-
)
140
-
)
116
+
Asai.Diagnostic.(
117
+
of_loctext
118
+
(* ~extra_remarks *)
119
+
Error Forester_core.Reporter.Message.Parse_error
120
+
(loctext ~loc
121
+
Format.(
122
+
sprintf "syntax error, unexpected %S" (Lexing.lexeme lexbuf))))
141
123
| I.Accepted code -> Ok code
142
-
| I.Rejected ->
143
-
assert false
124
+
| I.Rejected -> assert false
144
125
in
145
126
let supplier = I.lexer_lexbuf_to_supplier lexer lexbuf in
146
-
try
147
-
run initial_checkpoint supplier
127
+
try run initial_checkpoint supplier
148
128
with
149
-
(* NOTE: This should be the only exception we ever need to catch here:
150
-
The parser is driven manually, so we are responsible for creating the
151
-
diagnostics. This means we should not use `fatalf`! This also means
152
-
that we can safely use the returned diagnostic without worrying that
153
-
there might be an unhandled Asai effect. *)
154
-
| Lexer.SyntaxError lexeme ->
155
-
let loc = Range.of_lexbuf lexbuf in
156
-
Error
157
-
(
158
-
Asai.Diagnostic.(
159
-
of_loctext
160
-
Error
161
-
Reporter.Message.Parse_error
162
-
(loctext ~loc Format.(sprintf "syntax error, unexpected %S" lexeme))
163
-
)
164
-
)
129
+
(* NOTE: This should be the only exception we ever need to catch here: The
130
+
parser is driven manually, so we are responsible for creating the
131
+
diagnostics. This means we should not use `fatalf`! This also means that we
132
+
can safely use the returned diagnostic without worrying that there might be
133
+
an unhandled Asai effect. *)
134
+
| Lexer.SyntaxError lexeme ->
135
+
let loc = Range.of_lexbuf lexbuf in
136
+
Error
137
+
Asai.Diagnostic.(
138
+
of_loctext Error Reporter.Message.Parse_error
139
+
(loctext ~loc Format.(sprintf "syntax error, unexpected %S" lexeme)))
+1
-3
lib/parser/Parse.mli
+1
-3
lib/parser/Parse.mli
+49
-95
lib/parser/test/Test_parser.ml
+49
-95
lib/parser/test/Test_parser.ml
···
12
12
let test_prim () =
13
13
Alcotest.(check @@ result code diagnostic)
14
14
"same nodes"
15
-
(
16
-
Ok
17
-
[
18
-
ident ["p"];
19
-
braces
20
-
[
21
-
ident ["ul"];
22
-
braces
23
-
[
24
-
ident ["li"];
25
-
braces
26
-
[text "foo"]
27
-
]
28
-
]
29
-
]
30
-
)
31
-
(
32
-
parse_string_no_loc
33
-
{|\p{\ul{\li{foo}}}|}
34
-
)
15
+
(Ok
16
+
[
17
+
ident ["p"];
18
+
braces [ident ["ul"]; braces [ident ["li"]; braces [text "foo"]]];
19
+
])
20
+
(parse_string_no_loc {|\p{\ul{\li{foo}}}|})
35
21
36
22
let test_open () =
37
23
Alcotest.(check @@ result code diagnostic)
···
46
32
let test_scope () =
47
33
Alcotest.(check @@ result code diagnostic)
48
34
"same nodes"
49
-
(
50
-
Ok
51
-
[
52
-
scope
53
-
[
54
-
ident ["p"];
55
-
braces []
56
-
]
57
-
]
58
-
)
35
+
(Ok [scope [ident ["p"]; braces []]])
59
36
(parse_string_no_loc {|\scope{\p{}}|})
60
37
61
38
let test_verbatim () =
···
67
44
let test_math () =
68
45
Alcotest.(check @@ result code diagnostic)
69
46
"same nodes"
70
-
(
71
-
Ok
72
-
[
73
-
math
74
-
Inline
75
-
[
76
-
(text "a^2");
77
-
(text " ");
78
-
(text "+");
79
-
(text " ");
80
-
(text "b^2");
81
-
(text " ");
82
-
(text "=");
83
-
(text " ");
84
-
(text "c^2")
85
-
]
86
-
]
87
-
)
47
+
(Ok
48
+
[
49
+
math Inline
50
+
[
51
+
text "a^2";
52
+
text " ";
53
+
text "+";
54
+
text " ";
55
+
text "b^2";
56
+
text " ";
57
+
text "=";
58
+
text " ";
59
+
text "c^2";
60
+
];
61
+
])
88
62
(parse_string_no_loc {|#{a^2 + b^2 = c^2}|});
89
63
Alcotest.(check @@ result code diagnostic)
90
64
"same nodes"
91
-
(
92
-
Ok
93
-
[
94
-
math
95
-
Display
96
-
[
97
-
(text "a^2");
98
-
(text " ");
99
-
(text "+");
100
-
(text " ");
101
-
(text "b^2");
102
-
(text " ");
103
-
(text "=");
104
-
(text " ");
105
-
(text "c^2")
106
-
]
107
-
]
108
-
)
65
+
(Ok
66
+
[
67
+
math Display
68
+
[
69
+
text "a^2";
70
+
text " ";
71
+
text "+";
72
+
text " ";
73
+
text "b^2";
74
+
text " ";
75
+
text "=";
76
+
text " ";
77
+
text "c^2";
78
+
];
79
+
])
109
80
(parse_string_no_loc {|##{a^2 + b^2 = c^2}|})
110
81
111
82
let test_hashtag () =
···
117
88
let test_object () =
118
89
Alcotest.(check @@ result code diagnostic)
119
90
"same nodes"
120
-
(
121
-
Ok
122
-
[
123
-
object_
124
-
{
125
-
self = (Some "self");
126
-
methods = [
127
-
(
128
-
"foo",
129
-
[]
130
-
)
131
-
]
132
-
}
133
-
]
134
-
)
135
-
(
136
-
parse_string_no_loc
137
-
{|
91
+
(Ok [object_ {self = Some "self"; methods = [("foo", [])]}])
92
+
(parse_string_no_loc
93
+
{|
138
94
\object[self]{
139
95
[foo]{}
140
-
}|}
141
-
)
96
+
}|})
142
97
143
98
let () =
144
99
let open Alcotest in
145
-
run
146
-
"Parser"
100
+
run "Parser"
147
101
[
148
-
"nodes", [test_case "open" `Quick test_open;];
149
-
"scope", [test_case "scope" `Quick test_scope;];
150
-
"text", [test_case "text" `Quick test_prim];
151
-
"verbatim", [test_case "verbatim" `Quick test_verbatim];
152
-
"math", [test_case "math" `Quick test_math];
153
-
"hashtag", [test_case "hashtag" `Quick test_hashtag];
154
-
"object", [test_case "object" `Quick test_object];
102
+
("nodes", [test_case "open" `Quick test_open]);
103
+
("scope", [test_case "scope" `Quick test_scope]);
104
+
("text", [test_case "text" `Quick test_prim]);
105
+
("verbatim", [test_case "verbatim" `Quick test_verbatim]);
106
+
("math", [test_case "math" `Quick test_math]);
107
+
("hashtag", [test_case "hashtag" `Quick test_hashtag]);
108
+
("object", [test_case "object" `Quick test_object]);
155
109
]
+5
-11
lib/prelude/BaseN.ml
+5
-11
lib/prelude/BaseN.ml
···
28
28
loop sum' place' (r - 1)
29
29
in
30
30
let len = String.length digits in
31
-
match loop 0 1 (len - 1) with
32
-
| sum -> Some sum
33
-
| exception _ -> None
31
+
match loop 0 1 (len - 1) with sum -> Some sum | exception _ -> None
34
32
35
33
let string_of_int n =
36
34
let len =
37
-
max 4 @@
38
-
Int.succ @@
39
-
int_of_float @@
40
-
floor @@
41
-
log (float_of_int n) /. log (float_of_int base)
35
+
max 4 @@ Int.succ @@ int_of_float @@ floor
36
+
@@ (log (float_of_int n) /. log (float_of_int base))
42
37
in
43
38
let bytes = Bytes.init len @@ fun _ -> '0' in
44
39
let rec loop r i =
45
-
if i <= 0 then
46
-
Bytes.unsafe_to_string bytes
40
+
if i <= 0 then Bytes.unsafe_to_string bytes
47
41
else
48
42
let x = String.get I.alphabet (i mod base) in
49
43
Bytes.set bytes r x;
···
52
46
loop (len - 1) n
53
47
end
54
48
55
-
module Base36 = Make(struct
49
+
module Base36 = Make (struct
56
50
let alphabet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
57
51
end)
+4
-9
lib/prelude/Compare.ml
+4
-9
lib/prelude/Compare.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
let under f compare x y =
8
-
compare (f x) (f y)
7
+
let under f compare x y = compare (f x) (f y)
9
8
10
9
let cascade compare0 compare1 x y =
11
-
match compare0 x y with
12
-
| 0 -> compare1 x y
13
-
| i -> i
10
+
match compare0 x y with 0 -> compare1 x y | i -> i
14
11
15
12
let option compare x y =
16
-
match x, y with
13
+
match (x, y) with
17
14
| None, Some _ -> -1
18
15
| Some _, None -> 1
19
16
| None, None -> 0
20
17
| Some x, Some y -> compare x y
21
18
22
-
let sort_map f compare xs =
23
-
List.sort compare @@ List.map f xs
24
-
19
+
let sort_map f compare xs = List.sort compare @@ List.map f xs
25
20
let invert compare x y = 0 - compare x y
-1
lib/prelude/Forester_prelude.ml
-1
lib/prelude/Forester_prelude.ml
+2
-2
lib/prelude/Fun_util.ml
+2
-2
lib/prelude/Fun_util.ml
+2
-7
lib/prelude/Option_util.ml
+2
-7
lib/prelude/Option_util.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
let override x y =
8
-
match x with
9
-
| Some _ -> x
10
-
| None -> y
11
-
12
-
let guard p x =
13
-
if p x then Some x else None
7
+
let override x y = match x with Some _ -> x | None -> y
8
+
let guard p x = if p x then Some x else None
+19
-18
lib/prelude/String_util.ml
+19
-18
lib/prelude/String_util.ml
···
6
6
7
7
open Bwd
8
8
9
-
(* Based on cmap_utf_8 from https://erratique.ch/software/uucp/doc/Uucp/Case/index.html#caseexamples *)
9
+
(* Based on cmap_utf_8 from
10
+
https://erratique.ch/software/uucp/doc/Uucp/Case/index.html#caseexamples *)
10
11
let title_case_word s =
11
12
let did_uppercase = ref false in
12
13
let rec loop buf s i max =
···
14
15
else
15
16
let dec = String.get_utf_8_uchar s i in
16
17
let u = Uchar.utf_decode_uchar dec in
17
-
let should_ignore = Uucp.Case.is_case_ignorable u || not (Uucp.Case.is_cased u) in
18
+
let should_ignore =
19
+
Uucp.Case.is_case_ignorable u || not (Uucp.Case.is_cased u)
20
+
in
18
21
let () =
19
22
match should_ignore || !did_uppercase with
20
-
| true ->
21
-
Buffer.add_utf_8_uchar buf u
22
-
| false ->
23
+
| true -> Buffer.add_utf_8_uchar buf u
24
+
| false -> (
23
25
did_uppercase := true;
24
26
match Uucp.Case.Map.to_upper u with
25
27
| `Self -> Buffer.add_utf_8_uchar buf u
26
-
| `Uchars us -> List.iter (Buffer.add_utf_8_uchar buf) us
28
+
| `Uchars us -> List.iter (Buffer.add_utf_8_uchar buf) us)
27
29
in
28
30
loop buf s (i + Uchar.utf_decode_length dec) max
29
31
in
30
-
let buf = Buffer.create @@ String.length s * 2 in
31
-
loop buf s 0 @@ String.length s - 1
32
+
let buf = Buffer.create @@ (String.length s * 2) in
33
+
loop buf s 0 @@ (String.length s - 1)
32
34
33
35
let sentence_case str =
34
36
let words = String.split_on_char ' ' str in
35
-
String.concat " " @@ List.mapi (fun i word -> if i = 0 then title_case_word word else word) words
37
+
String.concat " "
38
+
@@ List.mapi
39
+
(fun i word -> if i = 0 then title_case_word word else word)
40
+
words
36
41
37
42
let trim_newlines str =
38
43
let rec process_lines lines =
···
42
47
| _ -> lines
43
48
in
44
49
let lines = String.split_on_char '\n' str in
45
-
String.concat "\n" @@ List.rev @@ process_lines @@ List.rev @@ process_lines lines
50
+
String.concat "\n" @@ List.rev @@ process_lines @@ List.rev
51
+
@@ process_lines lines
46
52
47
53
let trim_trailing_whitespace str =
48
54
let rec process_chars rstr =
···
56
62
let chars = List.rev @@ List.init n (String.get str) in
57
63
String.of_seq @@ List.to_seq @@ process_chars @@ chars
58
64
59
-
let explode str =
60
-
List.init (String.length str) (String.get str)
61
-
62
-
let implode chars =
63
-
String.init (List.length chars) (List.nth chars)
64
-
65
-
let implode_bwd chars =
66
-
implode (Bwd.to_list chars)
65
+
let explode str = List.init (String.length str) (String.get str)
66
+
let implode chars = String.init (List.length chars) (List.nth chars)
67
+
let implode_bwd chars = implode (Bwd.to_list chars)
-1
lib/prelude/String_util.mli
-1
lib/prelude/String_util.mli
+68
-96
lib/search/Context.ml
+68
-96
lib/search/Context.ml
···
5
5
*)
6
6
7
7
open Forester_core
8
-
open struct module T = Types end
8
+
9
+
open struct
10
+
module T = Types
11
+
end
9
12
10
13
(* The idea is to render a search result with surrounding context, say 5 words
11
14
on each side. *)
12
15
13
16
type path = int list
14
17
15
-
let show_leaf_node
16
-
: T.content T.content_node -> string
17
-
= fun node ->
18
+
let show_leaf_node : T.content T.content_node -> string =
19
+
fun node ->
18
20
match node with
19
21
| T.Text s -> s
20
22
| T.CDATA s -> s
21
-
| T.Uri i
22
-
| T.Route_of_uri i ->
23
-
Format.asprintf "%a" URI.pp i
24
-
| T.Xml_elt _
25
-
| T.Transclude _
26
-
| T.Contextual_number _
27
-
| T.Section _
23
+
| T.Uri i | T.Route_of_uri i -> Format.asprintf "%a" URI.pp i
24
+
| T.Xml_elt _ | T.Transclude _ | T.Contextual_number _ | T.Section _
28
25
| T.KaTeX (_, _)
29
-
| T.Link _
30
-
| T.Artefact _
31
-
| T.Datalog_script _
32
-
| T.Results_of_datalog_query _ ->
33
-
raise @@
34
-
Invalid_argument (Format.asprintf "%a is not a leaf node" T.(pp_content_node pp_content) node)
26
+
| T.Link _ | T.Artefact _ | T.Datalog_script _ | T.Results_of_datalog_query _
27
+
->
28
+
raise
29
+
@@ Invalid_argument
30
+
(Format.asprintf "%a is not a leaf node"
31
+
T.(pp_content_node pp_content)
32
+
node)
35
33
36
34
let get_nth_word i string =
37
35
Str.(split @@ regexp "[^a-zA-Z0-9]+") string
38
-
|> List.filter_map
39
-
(fun s ->
40
-
let lower = String.lowercase_ascii s in
41
-
if not @@ Tokenizer.(Set.mem lower common_words) then
42
-
Some lower
43
-
else
44
-
None
45
-
)
46
-
|> (fun l -> List.nth l i)
36
+
|> List.filter_map (fun s ->
37
+
let lower = String.lowercase_ascii s in
38
+
if not @@ Tokenizer.(Set.mem lower common_words) then Some lower else None)
39
+
|> fun l -> List.nth l i
47
40
48
-
let render_context_list
49
-
: (path -> 'a -> string) -> path -> 'a list -> string
50
-
= fun f path l ->
41
+
let render_context_list : (path -> 'a -> string) -> path -> 'a list -> string =
42
+
fun f path l ->
51
43
match path with
52
44
| [] -> String.concat "" @@ List.map (f []) l
53
45
| i :: path' ->
54
46
let n = List.nth l i in
55
47
f path' n
56
48
57
-
let rec render_context_frontmatter
58
-
: path -> T.content T.frontmatter -> string
59
-
= fun path frontmatter ->
49
+
let rec render_context_frontmatter : path -> T.content T.frontmatter -> string =
50
+
fun path frontmatter ->
60
51
match path with
61
52
| [] -> raise (Invalid_argument "stopped on non-leaf node")
62
53
| 0 :: _path ->
63
54
Format.(asprintf "%a" (pp_print_option URI.pp) frontmatter.uri)
64
-
| 1 :: path' ->
65
-
begin
66
-
match path' with
67
-
| [] ->
68
-
Option.value ~default: "" @@
69
-
Option.map T.show_content frontmatter.title
70
-
| path ->
71
-
Option.value ~default: "" @@
72
-
Option.map (render_context_content path) frontmatter.title
73
-
end
55
+
| 1 :: path' -> begin
56
+
match path' with
57
+
| [] ->
58
+
Option.value ~default:"" @@ Option.map T.show_content frontmatter.title
59
+
| path ->
60
+
Option.value ~default:""
61
+
@@ Option.map (render_context_content path) frontmatter.title
62
+
end
74
63
| 2 :: path' ->
75
-
begin
76
-
match path' with
77
-
| [] -> assert false
78
-
| _path -> assert false
79
-
end (*frontmatter.dates*)
64
+
(*frontmatter.dates*)
65
+
begin match path' with [] -> assert false | _path -> assert false
66
+
end
80
67
| 3 :: path' ->
81
-
begin
82
-
match path' with
83
-
| [] -> assert false
84
-
| _path -> assert false
85
-
end (*frontmatter.attributions*)
68
+
(*frontmatter.attributions*)
69
+
begin match path' with [] -> assert false | _path -> assert false
70
+
end
86
71
| 4 :: path' ->
87
-
begin
88
-
match path' with
89
-
| [] -> assert false
90
-
| path ->
91
-
Option.value ~default: "" @@
92
-
Option.map (render_context_content path) frontmatter.taxon
93
-
end (*frontmatter.taxon*)
72
+
(*frontmatter.taxon*)
73
+
begin match path' with
74
+
| [] -> assert false
75
+
| path ->
76
+
Option.value ~default:""
77
+
@@ Option.map (render_context_content path) frontmatter.taxon
78
+
end
94
79
| 5 :: path' ->
95
-
begin
96
-
match path' with
97
-
| [] -> assert false
98
-
| _path -> assert false
99
-
end (*frontmatter.number*)
80
+
(*frontmatter.number*)
81
+
begin match path' with [] -> assert false | _path -> assert false
82
+
end
100
83
| 6 :: path' ->
101
-
begin
102
-
match path' with
103
-
| [] -> assert false
104
-
| _path -> assert false
105
-
end (*frontmatter.designated_parent*)
84
+
(*frontmatter.designated_parent*)
85
+
begin match path' with [] -> assert false | _path -> assert false
86
+
end
106
87
| 7 :: path' ->
107
-
begin
108
-
match path' with
109
-
| [] -> assert false
110
-
| _path -> assert false
111
-
end (*frontmatter.source_path*)
88
+
(*frontmatter.source_path*)
89
+
begin match path' with [] -> assert false | _path -> assert false
90
+
end
112
91
| 8 :: path' ->
113
-
begin
114
-
match path' with
115
-
| [] -> assert false
116
-
| _path -> assert false
117
-
end (*frontmatter.tags*)
92
+
(*frontmatter.tags*)
93
+
begin match path' with [] -> assert false | _path -> assert false
94
+
end
118
95
| 9 :: path' ->
119
-
begin
120
-
match path' with
121
-
| [] -> assert false
122
-
| _path -> assert false
123
-
end (*frontmatter.metas*)
96
+
(*frontmatter.metas*)
97
+
begin match path' with [] -> assert false | _path -> assert false
98
+
end
124
99
| _ -> raise (Invalid_argument "out of bound index")
125
100
126
-
and render_context_node
127
-
: path -> T.content T.content_node -> string
128
-
= fun path node ->
101
+
and render_context_node : path -> T.content T.content_node -> string =
102
+
fun path node ->
129
103
match path with
130
104
| [] -> show_leaf_node node
131
-
| i :: path' ->
105
+
| i :: path' -> (
132
106
match node with
133
107
| T.Text s -> get_nth_word i s
134
108
| T.CDATA _ -> raise @@ Invalid_argument "can't descend into CDATA node"
···
142
116
| T.Uri _ -> assert false
143
117
| T.Route_of_uri _ -> assert false
144
118
| T.Datalog_script _ -> assert false
145
-
| T.Results_of_datalog_query _ -> assert false
119
+
| T.Results_of_datalog_query _ -> assert false)
146
120
147
-
and render_context_content
148
-
: path -> T.content -> string
149
-
= fun path content ->
150
-
let T.Content c = content in
121
+
and render_context_content : path -> T.content -> string =
122
+
fun path content ->
123
+
let (T.Content c) = content in
151
124
match path with
152
125
| [] -> T.show_content content
153
126
| i :: path' ->
···
155
128
(* render_context_node in *)
156
129
render_context_node path' node
157
130
158
-
and render_context_article
159
-
: path -> T.content T.article -> string
160
-
= fun path article ->
131
+
and render_context_article : path -> T.content T.article -> string =
132
+
fun path article ->
161
133
match path with
162
134
| [] -> ""
163
135
| 0 :: path' -> render_context_frontmatter path' article.frontmatter
+46
-53
lib/search/Index.ml
+46
-53
lib/search/Index.ml
···
8
8
open Forester_core
9
9
open Spelll
10
10
11
-
open struct module T = Forester_core.Types end
11
+
open struct
12
+
module T = Forester_core.Types
13
+
end
12
14
13
-
module Ocurrences = Set.Make(struct
15
+
module Ocurrences = Set.Make (struct
14
16
type t = int list list * URI.t
17
+
15
18
(* FIXME: *)
16
19
let compare (_i, x) (_j, y) = URI.compare x y
17
20
end)
···
25
28
let average_doc_length {number_of_tokens; number_of_docs; _} : float =
26
29
Float.of_int number_of_tokens /. Float.of_int number_of_docs
27
30
28
-
let add_one (article : T.content T.article) ({index; number_of_tokens; number_of_docs;} as t) : t =
31
+
let add_one (article : T.content T.article)
32
+
({index; number_of_tokens; number_of_docs} as t) : t =
29
33
if Option.is_none T.(article.frontmatter.uri) then t
30
34
else
31
35
let tokens_in_article = Tokenizer.tokenize_article article in
···
33
37
let new_tokens = ref 0 in
34
38
let new_index =
35
39
List.fold_left
36
-
begin
37
-
fun index (ocurrences, token) ->
38
-
match Index.retrieve_l ~limit: 0 index token with
39
-
| [] ->
40
-
(* Unseen token*)
41
-
(* TODO: add to list of ocurrences*)
42
-
let ocurrence = Ocurrences.singleton ([ocurrences], uri) in
43
-
new_tokens := !new_tokens + 1;
44
-
Index.add index token ocurrence
45
-
| ids :: [] ->
46
-
Index.add index token (Ocurrences.add ([ocurrences], uri) ids)
47
-
| _ ->
48
-
(* We are using limit=0, so this shouldn't happen*)
49
-
assert false
40
+
begin fun index (ocurrences, token) ->
41
+
match Index.retrieve_l ~limit:0 index token with
42
+
| [] ->
43
+
(* Unseen token*)
44
+
(* TODO: add to list of ocurrences*)
45
+
let ocurrence = Ocurrences.singleton ([ocurrences], uri) in
46
+
new_tokens := !new_tokens + 1;
47
+
Index.add index token ocurrence
48
+
| ids :: [] ->
49
+
Index.add index token (Ocurrences.add ([ocurrences], uri) ids)
50
+
| _ ->
51
+
(* We are using limit=0, so this shouldn't happen*)
52
+
assert false
50
53
end
51
-
index
52
-
tokens_in_article
54
+
index tokens_in_article
53
55
in
54
56
{
55
57
index = new_index;
56
58
number_of_docs = number_of_docs + 1;
57
-
number_of_tokens = number_of_tokens + !new_tokens
59
+
number_of_tokens = number_of_tokens + !new_tokens;
58
60
}
59
61
60
-
let add : T.content T.article list -> t -> t =
61
-
List.fold_right add_one
62
+
let add : T.content T.article list -> t -> t = List.fold_right add_one
62
63
63
-
let search ?(fuzz = 0) (index : t) (term : string) : (int list list * URI.t) list =
64
+
let search ?(fuzz = 0) (index : t) (term : string) :
65
+
(int list list * URI.t) list =
64
66
let@ str = List.concat_map @~ Tokenizer.tokenize term in
65
-
List.concat_map Ocurrences.to_list @@
66
-
Index.retrieve_l ~limit: fuzz index.index str
67
+
List.concat_map Ocurrences.to_list
68
+
@@ Index.retrieve_l ~limit:fuzz index.index str
67
69
68
70
module BM_25 = struct
69
-
let sum = List.fold_left (+.) 0.
71
+
let sum = List.fold_left ( +. ) 0.
70
72
71
73
(* Inverse document frequency *)
72
74
let idf q (index : t) =
73
-
let n = Float.of_int @@ List.length @@ search ~fuzz: 0 index q in
74
-
log @@ ((Float.of_int index.number_of_docs -. n +. 0.5) /. n +. 0.5) +. 1.
75
+
let n = Float.of_int @@ List.length @@ search ~fuzz:0 index q in
76
+
log @@ (((Float.of_int index.number_of_docs -. n +. 0.5) /. n) +. 0.5 +. 1.)
75
77
76
-
let doc_length d =
77
-
Float.of_int @@
78
-
List.length @@
79
-
Tokenizer.tokenize_article d
78
+
let doc_length d = Float.of_int @@ List.length @@ Tokenizer.tokenize_article d
80
79
81
80
let score (d : T.content T.article) (q : string) (index : t) : float =
82
81
let tokens = Tokenizer.tokenize q in
···
84
83
let avg_len = average_doc_length index in
85
84
let k_1 = 1.5 in
86
85
let b = 0.75 in
87
-
sum @@
88
-
let@ q_i = List.map @~ tokens in
89
-
let num_occurrences =
90
-
Float.of_int @@
91
-
List.length @@ search index q_i
92
-
in
93
-
(* Format.printf "num_occurrences: %f" num_occurrences; *)
94
-
idf q index *.
95
-
begin
96
-
(num_occurrences *. k_1 +. 1.) /.
97
-
(num_occurrences +. k_1 *. (1. -. b +. (b *. doc_length d /. avg_len))) +.
98
-
1.
99
-
end
86
+
sum
87
+
@@
88
+
let@ q_i = List.map @~ tokens in
89
+
let num_occurrences = Float.of_int @@ List.length @@ search index q_i in
90
+
(* Format.printf "num_occurrences: %f" num_occurrences; *)
91
+
idf q index
92
+
*. begin
93
+
((num_occurrences *. k_1) +. 1.)
94
+
/. (num_occurrences
95
+
+. (k_1 *. (1. -. b +. (b *. doc_length d /. avg_len))))
96
+
+. 1.
97
+
end
100
98
end
101
99
102
100
let create articles =
103
-
let index = {
104
-
index = Index.empty;
105
-
number_of_docs = 0;
106
-
number_of_tokens = 0
107
-
}
108
-
in
101
+
let index = {index = Index.empty; number_of_docs = 0; number_of_tokens = 0} in
109
102
add articles index
110
103
111
104
let marshal (v : t) filename =
112
105
let oc = open_out_bin filename in
113
-
let@ () = Fun.protect ~finally: (fun () -> close_out oc) in
106
+
let@ () = Fun.protect ~finally:(fun () -> close_out oc) in
114
107
Marshal.to_channel oc v []
115
108
116
109
let unmarshal filename : t =
117
110
let ic = open_in_bin filename in
118
-
let@ () = Fun.protect ~finally: (fun () -> close_in ic) in
111
+
let@ () = Fun.protect ~finally:(fun () -> close_in ic) in
119
112
Marshal.from_channel ic
+28
-33
lib/search/Search_engine.ml
+28
-33
lib/search/Search_engine.ml
···
10
10
open Forester_search
11
11
open Forester_frontend
12
12
13
-
open struct module T = Types end
13
+
open struct
14
+
module T = Types
15
+
end
14
16
15
-
let ranked_search
16
-
: ?fuzz: int -> State.t -> string -> (URI.t * float) list
17
-
= fun ?fuzz: _ forest terms ->
17
+
let ranked_search : ?fuzz:int -> State.t -> string -> (URI.t * float) list =
18
+
fun ?fuzz:_ forest terms ->
18
19
Tokenizer.tokenize terms |> function
19
-
| tokens ->
20
-
(* In order to rank documents, I search for the first token and then
21
-
rank the returned documents according to all tokens. This duplicates the
22
-
search for the first token, so this should be changed.*)
23
-
let first_token = List.hd tokens in
24
-
let matches = Index.search ~fuzz: 1 forest.search_index first_token in
25
-
let uris =
26
-
List.filter_map
27
-
(fun (_, uri) ->
28
-
match URI.Tbl.find_opt forest.index uri with
29
-
| Some (Resource ({resource = T.Article a; _})) ->
30
-
Some (uri, Index.BM_25.score a terms forest.search_index)
31
-
| None -> assert false
32
-
| _ -> None
33
-
)
34
-
matches
35
-
in
36
-
List.sort
37
-
(fun (_, score_a) (_, score_b) -> Float.compare score_a score_b)
38
-
uris
20
+
| tokens ->
21
+
(* In order to rank documents, I search for the first token and then rank
22
+
the returned documents according to all tokens. This duplicates the
23
+
search for the first token, so this should be changed.*)
24
+
let first_token = List.hd tokens in
25
+
let matches = Index.search ~fuzz:1 forest.search_index first_token in
26
+
let uris =
27
+
List.filter_map
28
+
(fun (_, uri) ->
29
+
match URI.Tbl.find_opt forest.index uri with
30
+
| Some (Resource {resource = T.Article a; _}) ->
31
+
Some (uri, Index.BM_25.score a terms forest.search_index)
32
+
| None -> assert false
33
+
| _ -> None)
34
+
matches
35
+
in
36
+
List.sort
37
+
(fun (_, score_a) (_, score_b) -> Float.compare score_a score_b)
38
+
uris
39
39
40
40
let test_ranked (forest : State.t) =
41
41
let ranked_results =
42
42
Reporter.profile "Ranked search" @@ fun () ->
43
-
ranked_search
44
-
~fuzz: 2
45
-
forest
46
-
"hyprtext format"
43
+
ranked_search ~fuzz:2 forest "hyprtext format"
47
44
in
48
45
Format.printf "got %i ranked results.@." (List.length ranked_results);
49
46
List.iter
50
47
(fun (uri, score) ->
51
48
match State.get_article uri forest with
52
-
| Some _article ->
53
-
Format.printf "%a, %f@." URI.pp uri score;
54
-
| None -> assert false
55
-
)
49
+
| Some _article -> Format.printf "%a, %f@." URI.pp uri score
50
+
| None -> assert false)
56
51
ranked_results
57
52
58
53
let test_search (forest : State.t) =
59
54
let s = read_line () in
60
55
let results =
61
56
(* Reporter.profile "Searching" @@ fun () -> *)
62
-
Index.search ~fuzz: 1 forest.search_index s
57
+
Index.search ~fuzz:1 forest.search_index s
63
58
in
64
59
Format.printf "got %i results@." (List.length results)
65
60
+124
-128
lib/search/Stemming.ml
+124
-128
lib/search/Stemming.ml
···
7
7
exception No_stem of string
8
8
9
9
(* Now for the native OCaml port *)
10
-
let rule_list_1a = [
11
-
(101, "sses", "ss", -1);
12
-
(102, "ies", "i", -1);
13
-
(103, "ss", "ss", -1);
14
-
(104, "s", "", -1)
15
-
]
10
+
let rule_list_1a =
11
+
[
12
+
(101, "sses", "ss", -1);
13
+
(102, "ies", "i", -1);
14
+
(103, "ss", "ss", -1);
15
+
(104, "s", "", -1);
16
+
]
16
17
17
-
let rule_list_1b = [(105, "eed", "ee", 0); (106, "ed", "", -1); (107, "ing", "", -1)]
18
+
let rule_list_1b =
19
+
[(105, "eed", "ee", 0); (106, "ed", "", -1); (107, "ing", "", -1)]
18
20
19
-
let rule_list_1b1 = [
20
-
(108, "at", "ate", -1);
21
-
(109, "bl", "ble", -1);
22
-
(110, "iz", "ize", -1);
23
-
(111, "bb", "b", -1);
24
-
(112, "dd", "d", -1);
25
-
(113, "ff", "f", -1);
26
-
(114, "gg", "g", -1);
27
-
(115, "mm", "m", -1);
28
-
(116, "nn", "n", -1);
29
-
(117, "pp", "p", -1);
30
-
(118, "rr", "r", -1);
31
-
(119, "tt", "t", -1);
32
-
(120, "ww", "w", -1);
33
-
(121, "xx", "x", -1);
34
-
(122, "", "e", -1)
35
-
]
21
+
let rule_list_1b1 =
22
+
[
23
+
(108, "at", "ate", -1);
24
+
(109, "bl", "ble", -1);
25
+
(110, "iz", "ize", -1);
26
+
(111, "bb", "b", -1);
27
+
(112, "dd", "d", -1);
28
+
(113, "ff", "f", -1);
29
+
(114, "gg", "g", -1);
30
+
(115, "mm", "m", -1);
31
+
(116, "nn", "n", -1);
32
+
(117, "pp", "p", -1);
33
+
(118, "rr", "r", -1);
34
+
(119, "tt", "t", -1);
35
+
(120, "ww", "w", -1);
36
+
(121, "xx", "x", -1);
37
+
(122, "", "e", -1);
38
+
]
36
39
37
40
let rule_list_1c = [(123, "y", "i", -1)]
38
41
39
-
let rule_list_2 = [
40
-
(203, "ational", "ate", 0);
41
-
(204, "tional", "tion", 0);
42
-
(205, "enci", "ence", 0);
43
-
(206, "anci", "ance", 0);
44
-
(207, "izer", "ize", 0);
45
-
(208, "abli", "able", 0);
46
-
(209, "alli", "al", 0);
47
-
(210, "entli", "ent", 0);
48
-
(211, "eli", "e", 0);
49
-
(213, "ousli", "ous", 0);
50
-
(214, "ization", "ize", 0);
51
-
(215, "ation", "ate", 0);
52
-
(216, "ator", "ate", 0);
53
-
(217, "alism", "al", 0);
54
-
(218, "iveness", "ive", 0);
55
-
(219, "fulnes", "ful", 0);
56
-
(220, "ousness", "ous", 0);
57
-
(221, "aliti", "al", 0);
58
-
(222, "iviti", "ive", 0);
59
-
(223, "biliti", "ble", 0)
60
-
]
42
+
let rule_list_2 =
43
+
[
44
+
(203, "ational", "ate", 0);
45
+
(204, "tional", "tion", 0);
46
+
(205, "enci", "ence", 0);
47
+
(206, "anci", "ance", 0);
48
+
(207, "izer", "ize", 0);
49
+
(208, "abli", "able", 0);
50
+
(209, "alli", "al", 0);
51
+
(210, "entli", "ent", 0);
52
+
(211, "eli", "e", 0);
53
+
(213, "ousli", "ous", 0);
54
+
(214, "ization", "ize", 0);
55
+
(215, "ation", "ate", 0);
56
+
(216, "ator", "ate", 0);
57
+
(217, "alism", "al", 0);
58
+
(218, "iveness", "ive", 0);
59
+
(219, "fulnes", "ful", 0);
60
+
(220, "ousness", "ous", 0);
61
+
(221, "aliti", "al", 0);
62
+
(222, "iviti", "ive", 0);
63
+
(223, "biliti", "ble", 0);
64
+
]
61
65
62
-
let rule_list_3 = [
63
-
(301, "icate", "ic", 0);
64
-
(302, "ative", "", 0);
65
-
(303, "alize", "al", 0);
66
-
(304, "iciti", "ic", 0);
67
-
(305, "ical", "ic", 0);
68
-
(308, "ful", "", 0);
69
-
(309, "ness", "", 0)
70
-
]
66
+
let rule_list_3 =
67
+
[
68
+
(301, "icate", "ic", 0);
69
+
(302, "ative", "", 0);
70
+
(303, "alize", "al", 0);
71
+
(304, "iciti", "ic", 0);
72
+
(305, "ical", "ic", 0);
73
+
(308, "ful", "", 0);
74
+
(309, "ness", "", 0);
75
+
]
71
76
72
-
let rule_list_4 = [
73
-
(401, "al", "", 1);
74
-
(402, "ance", "", 1);
75
-
(403, "ence", "", 1);
76
-
(405, "er", "", 1);
77
-
(406, "ic", "", 1);
78
-
(407, "able", "", 1);
79
-
(408, "ible", "", 1);
80
-
(409, "ant", "", 1);
81
-
(410, "ement", "", 1);
82
-
(411, "ment", "", 1);
83
-
(412, "ent", "", 1);
84
-
(423, "sion", "s", 1);
85
-
(424, "tion", "t", 1);
86
-
(415, "ou", "", 1);
87
-
(416, "ism", "", 1);
88
-
(417, "ate", "", 1);
89
-
(418, "iti", "", 1);
90
-
(419, "ous", "", 1);
91
-
(420, "ive", "", 1);
92
-
(421, "ize", "", 1)
93
-
]
77
+
let rule_list_4 =
78
+
[
79
+
(401, "al", "", 1);
80
+
(402, "ance", "", 1);
81
+
(403, "ence", "", 1);
82
+
(405, "er", "", 1);
83
+
(406, "ic", "", 1);
84
+
(407, "able", "", 1);
85
+
(408, "ible", "", 1);
86
+
(409, "ant", "", 1);
87
+
(410, "ement", "", 1);
88
+
(411, "ment", "", 1);
89
+
(412, "ent", "", 1);
90
+
(423, "sion", "s", 1);
91
+
(424, "tion", "t", 1);
92
+
(415, "ou", "", 1);
93
+
(416, "ism", "", 1);
94
+
(417, "ate", "", 1);
95
+
(418, "iti", "", 1);
96
+
(419, "ous", "", 1);
97
+
(420, "ive", "", 1);
98
+
(421, "ize", "", 1);
99
+
]
94
100
95
101
let rule_list_5a = [(501, "e", "", 1); (502, "e", "", -1)]
96
-
97
102
let rule_list_5b = [(503, "ll", "l", 1)]
98
103
99
-
let all_rules = [
100
-
rule_list_1a;
101
-
rule_list_1b; (* rule_list_1b1 is conditionally applied below *)
102
-
rule_list_1c;
103
-
rule_list_2;
104
-
rule_list_3;
105
-
rule_list_4;
106
-
rule_list_5a;
107
-
rule_list_5b
108
-
]
104
+
let all_rules =
105
+
[
106
+
rule_list_1a;
107
+
rule_list_1b;
108
+
(* rule_list_1b1 is conditionally applied below *)
109
+
rule_list_1c;
110
+
rule_list_2;
111
+
rule_list_3;
112
+
rule_list_4;
113
+
rule_list_5a;
114
+
rule_list_5b;
115
+
]
109
116
110
117
(* Returns boolean based on vowel-ness of a character *)
111
-
let is_vowel c =
112
-
match c with 'a' | 'e' | 'i' | 'o' | 'u' -> true | _ -> false
118
+
let is_vowel c = match c with 'a' | 'e' | 'i' | 'o' | 'u' -> true | _ -> false
113
119
114
120
(* Computes a weird word count number based on syllabels and such. *)
115
121
let word_size word =
···
118
124
if idx < wordlen then
119
125
let call = aux (succ idx) in
120
126
match state with
121
-
| 0 ->
122
-
if is_vowel word.[idx] then call count 1 else call count 2
123
-
| 1 ->
124
-
if is_vowel word.[idx] then call count 1 else call (succ count) 2
127
+
| 0 -> if is_vowel word.[idx] then call count 1 else call count 2
128
+
| 1 -> if is_vowel word.[idx] then call count 1 else call (succ count) 2
125
129
| 2 ->
126
130
if is_vowel word.[idx] || word.[idx] = 'y' then call count 1
127
131
else call count 2
128
-
| _ ->
129
-
failwith "Impossible state"
132
+
| _ -> failwith "Impossible state"
130
133
else count
131
134
in
132
135
aux 0 0 0
···
137
140
let vowel_or_y c = is_vowel c || c = 'y' in
138
141
let vowel_or_wxy c = vowel_or_y c || c = 'x' || c = 'w' in
139
142
if len < 3 then false
140
-
else if (not (vowel_or_wxy str.[len - 1]))
143
+
else if
144
+
(not (vowel_or_wxy str.[len - 1]))
141
145
&& vowel_or_y str.[len - 2]
142
-
&& not (is_vowel str.[len - 3]) then true
146
+
&& not (is_vowel str.[len - 3])
147
+
then true
143
148
else false
144
149
145
150
let add_an_e word =
···
158
163
is_vowel str.[0] || aux 1
159
164
160
165
(* Some rules have additional criteria added to them *)
161
-
let rules_criteria = [([106; 107; 123], contains_vowel); ([122], add_an_e); ([502], remove_an_e)]
166
+
let rules_criteria =
167
+
[([106; 107; 123], contains_vowel); ([122], add_an_e); ([502], remove_an_e)]
162
168
163
-
let match_rule word ((num, orig, _, min_root): int * string * string * int) =
169
+
let match_rule word ((num, orig, _, min_root) : int * string * string * int) =
164
170
let orig_len = String.length orig and word_len = String.length word in
165
171
let rec aux_rule word num lst =
166
172
match lst with
167
173
| (rules, fn) :: tl ->
168
174
if List.mem num rules then fn word else aux_rule word num tl
169
-
| [] ->
170
-
true
175
+
| [] -> true
171
176
in
172
177
if word_len > orig_len then
173
178
let word_end = String.sub word (word_len - orig_len) orig_len
174
-
and word_root = String.sub word 0 (word_len - orig_len)
175
-
in
176
-
if word_end = orig
179
+
and word_root = String.sub word 0 (word_len - orig_len) in
180
+
if
181
+
word_end = orig
177
182
&& min_root < word_size word_root
178
-
&& aux_rule word_root num rules_criteria then
179
-
(*print_int num;
180
-
print_string (" ("^word^") "^word_end^" matches "^orig^"\n");*)
183
+
&& aux_rule word_root num rules_criteria
184
+
then
185
+
(*print_int num; print_string (" ("^word^") "^word_end^" matches
186
+
"^orig^"\n");*)
181
187
true
182
188
else false
183
189
else false
184
190
185
-
let apply_rule word ((_, orig, rep, _): int * string * string * int) =
191
+
let apply_rule word ((_, orig, rep, _) : int * string * string * int) =
186
192
let orig_len = String.length orig and word_len = String.length word in
187
193
let orig_word = word
188
-
and new_word = String.sub word 0 (word_len - orig_len) ^ rep
189
-
in
194
+
and new_word = String.sub word 0 (word_len - orig_len) ^ rep in
190
195
(* The new stem must be 2 or more characters in length *)
191
196
if String.length new_word < 2 then orig_word else new_word
192
197
···
197
202
let rule, _, _, _ = hd in
198
203
(rule, apply_rule word hd)
199
204
else replace_end word tl
200
-
| [] ->
201
-
(0, word)
205
+
| [] -> (0, word)
202
206
203
207
let stem in_word =
204
208
let word = String.lowercase_ascii in_word in
205
209
let rec aux aux_word list =
206
210
match list with
207
-
| hd :: tl ->
208
-
(
209
-
match replace_end aux_word hd with
210
-
| 106, out | 107, out ->
211
-
let _, out2 = replace_end out rule_list_1b1 in
212
-
aux out2 tl
213
-
| _, out ->
214
-
aux out tl
215
-
)
216
-
| [] ->
217
-
aux_word
211
+
| hd :: tl -> (
212
+
match replace_end aux_word hd with
213
+
| 106, out | 107, out ->
214
+
let _, out2 = replace_end out rule_list_1b1 in
215
+
aux out2 tl
216
+
| _, out -> aux out tl)
217
+
| [] -> aux_word
218
218
in
219
219
(* This is a really stupid hack. Why do I need it? *)
220
220
(* if 0 = String.compare "'s" (String.sub word (-2) 2) then word *)
···
222
222
aux word all_rules
223
223
224
224
let stem_cmp s1 s2 = stem s1 = stem s2
225
-
226
225
let stem_gt s1 s2 = stem s1 > stem s2
227
-
228
226
let stem_gte s1 s2 = stem s1 >= stem s2
229
-
230
227
let stem_lt s1 s2 = stem s1 < stem s2
231
-
232
228
let stem_lte s1 s2 = stem s1 <= stem s2
+77
-135
lib/search/Tokenizer.ml
+77
-135
lib/search/Tokenizer.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open struct module T = Forester_core.Types end
7
+
open struct
8
+
module T = Forester_core.Types
9
+
end
8
10
9
-
module Set = Set.Make(String)
11
+
module Set = Set.Make (String)
10
12
11
-
type loc =
12
-
| In_frontmatter
13
-
| In_mainmatter
13
+
type loc = In_frontmatter | In_mainmatter
14
14
15
-
let int_of_field_frontmatter
16
-
= function
15
+
let int_of_field_frontmatter = function
17
16
| `uri -> 0
18
17
| `title -> 1
19
18
| `dates -> 2
···
25
24
| `tags -> 8
26
25
| `metas -> 9
27
26
28
-
let int_of_field_article
29
-
= function
27
+
let int_of_field_article = function
30
28
| `frontmatter -> 0
31
29
| `mainmatter -> 1
32
30
| `backmatter -> 2
···
34
32
type token = {v: string; loc: loc}
35
33
36
34
let common_words =
37
-
Set.of_list
38
-
[
39
-
"a";
40
-
"and";
41
-
"be";
42
-
"have";
43
-
"i";
44
-
"in";
45
-
"of";
46
-
"that";
47
-
"the";
48
-
"to";
49
-
]
35
+
Set.of_list ["a"; "and"; "be"; "have"; "i"; "in"; "of"; "that"; "the"; "to"]
50
36
51
37
let tokenize string =
52
38
Str.(split @@ regexp "[^a-zA-Z0-9]+") string
53
-
|> List.filter_map
54
-
(fun s ->
55
-
let lower = String.lowercase_ascii s in
56
-
if not @@ Set.mem lower common_words then
57
-
Some (Stemming.stem lower)
58
-
else
59
-
None
60
-
)
39
+
|> List.filter_map (fun s ->
40
+
let lower = String.lowercase_ascii s in
41
+
if not @@ Set.mem lower common_words then Some (Stemming.stem lower)
42
+
else None)
61
43
62
-
let rec tokenize_content
63
-
: int list -> loc -> T.content -> (int list * string) list
64
-
= fun path loc node ->
44
+
let rec tokenize_content :
45
+
int list -> loc -> T.content -> (int list * string) list =
46
+
fun path loc node ->
65
47
match node with
66
48
| T.Content nodes ->
67
-
List.concat @@
68
-
List.mapi
69
-
(fun i node ->
70
-
match node with
71
-
| T.Text s ->
72
-
List.mapi
73
-
(fun j token -> j :: i :: path, token)
74
-
(tokenize s)
75
-
(* i :: path, token *)
76
-
| T.CDATA s ->
77
-
List.mapi
78
-
(fun j token -> j :: i :: path, token)
79
-
(tokenize s)
80
-
| T.Xml_elt {content; _} ->
81
-
(* TODO: Consider tokenizing xml_qname *)
82
-
tokenize_content
83
-
(i :: path)
84
-
loc
85
-
content
86
-
| T.Section {frontmatter; mainmatter; _} ->
87
-
tokenize_frontmatter
88
-
(int_of_field_article `frontmatter :: path)
89
-
frontmatter @
90
-
tokenize_content path loc mainmatter
91
-
| T.Link {content; _} -> tokenize_content (i :: path) loc content
92
-
| T.KaTeX (_, _) ->
93
-
(* NOTE:
94
-
In order to properly search math, we need to revamp the
95
-
architecture and add more features...*)
96
-
[]
97
-
| T.Transclude _
98
-
| T.Contextual_number _
99
-
| T.Artefact _
100
-
| T.Uri _
101
-
| T.Route_of_uri _
102
-
| T.Datalog_script _
103
-
| T.Results_of_datalog_query _ ->
104
-
[]
105
-
)
106
-
nodes
49
+
List.concat
50
+
@@ List.mapi
51
+
(fun i node ->
52
+
match node with
53
+
| T.Text s ->
54
+
List.mapi (fun j token -> (j :: i :: path, token)) (tokenize s)
55
+
(* i :: path, token *)
56
+
| T.CDATA s ->
57
+
List.mapi (fun j token -> (j :: i :: path, token)) (tokenize s)
58
+
| T.Xml_elt {content; _} ->
59
+
(* TODO: Consider tokenizing xml_qname *)
60
+
tokenize_content (i :: path) loc content
61
+
| T.Section {frontmatter; mainmatter; _} ->
62
+
tokenize_frontmatter
63
+
(int_of_field_article `frontmatter :: path)
64
+
frontmatter
65
+
@ tokenize_content path loc mainmatter
66
+
| T.Link {content; _} -> tokenize_content (i :: path) loc content
67
+
| T.KaTeX (_, _) ->
68
+
(* NOTE: In order to properly search math, we need to revamp the
69
+
architecture and add more features...*)
70
+
[]
71
+
| T.Transclude _ | T.Contextual_number _ | T.Artefact _ | T.Uri _
72
+
| T.Route_of_uri _ | T.Datalog_script _
73
+
| T.Results_of_datalog_query _ ->
74
+
[])
75
+
nodes
107
76
108
-
and tokenize_vertex
109
-
: int list ->
110
-
loc ->
111
-
T.content T.vertex ->
112
-
(int list * string) list
113
-
= fun path loc v ->
77
+
and tokenize_vertex :
78
+
int list -> loc -> T.content T.vertex -> (int list * string) list =
79
+
fun path loc v ->
114
80
match v with
115
81
| T.Uri_vertex _ -> []
116
-
| T.Content_vertex c ->
117
-
tokenize_content path loc c
82
+
| T.Content_vertex c -> tokenize_content path loc c
118
83
119
-
and tokenize_attribution
120
-
: int list ->
121
-
loc ->
122
-
T.content T.attribution ->
123
-
(int list * string) list
124
-
= fun path loc v ->
125
-
match v with
126
-
| T.{vertex; _} ->
127
-
tokenize_vertex path loc vertex
84
+
and tokenize_attribution :
85
+
int list -> loc -> T.content T.attribution -> (int list * string) list =
86
+
fun path loc v ->
87
+
match v with T.{vertex; _} -> tokenize_vertex path loc vertex
128
88
129
-
and tokenize_frontmatter
130
-
: int list ->
131
-
T.content T.frontmatter ->
132
-
(int list * string) list
133
-
= fun path fm ->
89
+
and tokenize_frontmatter :
90
+
int list -> T.content T.frontmatter -> (int list * string) list =
91
+
fun path fm ->
134
92
match fm with
135
-
| {title;
136
-
attributions;
137
-
taxon;
138
-
tags;
139
-
metas;
140
-
_;
141
-
} ->
93
+
| {title; attributions; taxon; tags; metas; _} ->
142
94
List.concat
143
95
[
144
-
Option.value
145
-
~default: []
146
-
(
147
-
Option.map
148
-
(
149
-
tokenize_content
150
-
(int_of_field_frontmatter `title :: path)
151
-
In_frontmatter
152
-
)
153
-
title
154
-
);
155
-
Option.value
156
-
~default: []
157
-
(
158
-
Option.map
159
-
(
160
-
tokenize_content
161
-
(int_of_field_frontmatter `taxon :: path)
162
-
In_frontmatter
163
-
)
164
-
taxon
165
-
);
96
+
Option.value ~default:[]
97
+
(Option.map
98
+
(tokenize_content
99
+
(int_of_field_frontmatter `title :: path)
100
+
In_frontmatter)
101
+
title);
102
+
Option.value ~default:[]
103
+
(Option.map
104
+
(tokenize_content
105
+
(int_of_field_frontmatter `taxon :: path)
106
+
In_frontmatter)
107
+
taxon);
166
108
List.concat_map (tokenize_attribution path In_frontmatter) attributions;
167
109
List.concat_map (tokenize_vertex path In_frontmatter) tags;
168
-
List.concat @@
169
-
List.mapi
170
-
(fun _i (s, c) ->
171
-
(List.mapi (fun i t -> i :: path, t) @@ tokenize s) @
172
-
tokenize_content path In_frontmatter c
173
-
)
174
-
metas;
110
+
List.concat
111
+
@@ List.mapi
112
+
(fun _i (s, c) ->
113
+
(List.mapi (fun i t -> (i :: path, t)) @@ tokenize s)
114
+
@ tokenize_content path In_frontmatter c)
115
+
metas;
175
116
]
176
117
177
-
let tokenize_article : T.content T.article -> (int list * string) list = function
118
+
let tokenize_article : T.content T.article -> (int list * string) list =
119
+
function
178
120
| {frontmatter; mainmatter; _} ->
179
-
tokenize_frontmatter [0] frontmatter @
180
-
tokenize_content [1] In_mainmatter mainmatter
181
-
|> List.map (fun (x, y) -> List.rev x, y)
121
+
tokenize_frontmatter [0] frontmatter
122
+
@ tokenize_content [1] In_mainmatter mainmatter
123
+
|> List.map (fun (x, y) -> (List.rev x, y))
+74
-70
lib/search/test/Test_forester_search.ml
+74
-70
lib/search/test/Test_forester_search.ml
···
6
6
7
7
open Forester_core
8
8
open Forester_search
9
+
9
10
open struct
10
11
module T = Forester_core.Types
11
12
module Trie = Yuujinchou.Trie
12
13
end
13
14
14
15
let doc1 =
15
-
T.{
16
-
frontmatter =
17
-
default_frontmatter
18
-
~uri: (URI.of_string_exn "forest://doc1")
19
-
~title: (T.Content [T.Text "Title of tremendous importance"])
20
-
();
21
-
mainmatter =
22
-
T.Content [T.Text "A donut on a glass plate. Only the donuts."];
23
-
backmatter = T.Content [];
24
-
}
16
+
T.
17
+
{
18
+
frontmatter =
19
+
default_frontmatter
20
+
~uri:(URI.of_string_exn "forest://doc1")
21
+
~title:(T.Content [T.Text "Title of tremendous importance"]) ();
22
+
mainmatter =
23
+
T.Content [T.Text "A donut on a glass plate. Only the donuts."];
24
+
backmatter = T.Content [];
25
+
}
25
26
26
27
let doc2 =
27
-
T.{
28
-
frontmatter = default_frontmatter ~uri: (URI.of_string_exn "forest://doc2") ();
29
-
mainmatter =
30
-
T.Content [T.Text "donut is a donut"];
31
-
backmatter = T.Content [];
32
-
}
28
+
T.
29
+
{
30
+
frontmatter =
31
+
default_frontmatter ~uri:(URI.of_string_exn "forest://doc2") ();
32
+
mainmatter = T.Content [T.Text "donut is a donut"];
33
+
backmatter = T.Content [];
34
+
}
33
35
34
36
let pp_pair pp_fst pp_snd out (x, y) =
35
37
Format.fprintf out "(%a, %a)" pp_fst x pp_snd y
36
38
37
39
let test_context path doc =
38
40
Format.(
39
-
printf
40
-
"word at path %a: %s@."
41
+
printf "word at path %a: %s@."
41
42
(pp_print_list pp_print_int)
42
43
path
43
-
(Context.render_context_article path doc)
44
-
)
44
+
(Context.render_context_article path doc))
45
45
46
46
let test_nth_word () =
47
47
let corpus =
48
-
"Far far away, behind the word mountains, far from the countries Vokalia and Consonantia, there live the blind texts. Separated they live in Bookmarksgrove right at the coast of the Semantics, a large language ocean. A small river named Duden flows by their place and supplies it with the necessary regelialia. It is a paradisematic country, in which roasted parts of sentences fly into your mouth. Even the all-powerful Pointing has no control about the blind texts it is an almost unorthographic life One day however a small line of blind text by the name of Lorem Ipsum decided to leave for the far World of Grammar. The Big Oxmox advised her not to do so, because there were thousands of bad Commas, wild Question Marks and devious Semikoli, but the Little Blind Text didn’t listen. She packed her seven versalia, put her initial into the belt and made herself on the way. When she reached the first hills of the Italic Mountains, she had a last view back on the skyline of her hometown Bookmarksgrove, the headline of Alphabet Village and the subline of her own road, the Line Lane. Pityful a rethoric question ran over her cheek, then"
48
+
"Far far away, behind the word mountains, far from the countries Vokalia \
49
+
and Consonantia, there live the blind texts. Separated they live in \
50
+
Bookmarksgrove right at the coast of the Semantics, a large language \
51
+
ocean. A small river named Duden flows by their place and supplies it \
52
+
with the necessary regelialia. It is a paradisematic country, in which \
53
+
roasted parts of sentences fly into your mouth. Even the all-powerful \
54
+
Pointing has no control about the blind texts it is an almost \
55
+
unorthographic life One day however a small line of blind text by the \
56
+
name of Lorem Ipsum decided to leave for the far World of Grammar. The \
57
+
Big Oxmox advised her not to do so, because there were thousands of bad \
58
+
Commas, wild Question Marks and devious Semikoli, but the Little Blind \
59
+
Text didn’t listen. She packed her seven versalia, put her initial into \
60
+
the belt and made herself on the way. When she reached the first hills of \
61
+
the Italic Mountains, she had a last view back on the skyline of her \
62
+
hometown Bookmarksgrove, the headline of Alphabet Village and the subline \
63
+
of her own road, the Line Lane. Pityful a rethoric question ran over her \
64
+
cheek, then"
49
65
in
50
66
let tokens = Tokenizer.tokenize corpus in
51
67
List.iteri
52
68
(fun i token ->
53
69
Alcotest.(check string)
54
-
"Using get_nth_word and stemming the word should be the same as the nth
55
-
element of tokens. Will be used to render the context of a token."
56
-
(
57
-
Context.get_nth_word i corpus
58
-
|> String.lowercase_ascii
59
-
|> Stemming.stem
60
-
)
61
-
token
62
-
)
70
+
"Using get_nth_word and stemming the word should be the same as the nth\n\
71
+
\ element of tokens. Will be used to render the context of a \
72
+
token."
73
+
(Context.get_nth_word i corpus
74
+
|> String.lowercase_ascii |> Stemming.stem)
75
+
token)
63
76
tokens
64
77
65
78
let test_tokenize_content () =
···
69
82
[
70
83
p
71
84
[
72
-
ol
73
-
[
74
-
li [txt "First item"];
75
-
li [txt "Second item"]
76
-
];
85
+
ol [li [txt "First item"]; li [txt "Second item"]];
77
86
ul
78
87
[
79
88
li [txt "First item in second list"];
80
-
li [txt "Second item in second list"]
89
+
li [txt "Second item in second list"];
81
90
];
82
-
]
91
+
];
83
92
]
84
93
in
85
94
let tokens = Tokenizer.tokenize_content [] In_mainmatter content in
···
99
108
"second";
100
109
"item";
101
110
"second";
102
-
"list"
111
+
"list";
103
112
]
104
113
(List.map render locations)
105
114
···
107
116
let open Forester_frontend.DSL in
108
117
let frontmatter =
109
118
T.default_frontmatter
110
-
~uri: (URI.of_string_exn "forest://test/asdf")
111
-
~source_path: "/foo/bar"
112
-
~taxon: (T.Content [T.Text "Hello"])
113
-
~title: (T.Content [txt "title"; katex Display [txt "a=b"]])
114
-
~attributions: [
115
-
{
116
-
role = T.Author;
117
-
vertex = Uri_vertex (URI.of_string_exn "forest://test/kentookura");
118
-
};
119
-
{
120
-
role = T.Contributor;
121
-
vertex = Uri_vertex (URI.of_string_exn "forest://test/jonmsterling")
122
-
}
123
-
]
119
+
~uri:(URI.of_string_exn "forest://test/asdf")
120
+
~source_path:"/foo/bar" ~taxon:(T.Content [T.Text "Hello"])
121
+
~title:(T.Content [txt "title"; katex Display [txt "a=b"]])
122
+
~attributions:
123
+
[
124
+
{
125
+
role = T.Author;
126
+
vertex = Uri_vertex (URI.of_string_exn "forest://test/kentookura");
127
+
};
128
+
{
129
+
role = T.Contributor;
130
+
vertex = Uri_vertex (URI.of_string_exn "forest://test/jonmsterling");
131
+
};
132
+
]
124
133
()
125
134
in
126
135
let tokens = Tokenizer.tokenize_frontmatter [] frontmatter in
127
136
let locations = List.map (fun (x, _) -> List.rev x) tokens in
128
137
let render path = Context.render_context_frontmatter path frontmatter in
129
138
Alcotest.(check @@ list string)
130
-
""
131
-
["title"; "hello"]
139
+
"" ["title"; "hello"]
132
140
(List.map render locations)
133
141
134
-
let test_ranking () =
135
-
Alcotest.(check string)
136
-
""
137
-
""
138
-
""
142
+
let test_ranking () = Alcotest.(check string) "" "" ""
139
143
140
144
let () =
141
145
let open Alcotest in
142
-
run
143
-
"Test_forester_search"
146
+
run "Test_forester_search"
144
147
[
145
-
"tokenizer",
146
-
[
147
-
test_case "get_nth_word" `Quick test_nth_word;
148
-
test_case "tokenize_content" `Quick test_tokenize_content;
149
-
];
150
-
"context",
151
-
[
152
-
test_case "render_context_frontmatter" `Quick test_render_context_frontmatter;
153
-
];
148
+
( "tokenizer",
149
+
[
150
+
test_case "get_nth_word" `Quick test_nth_word;
151
+
test_case "tokenize_content" `Quick test_tokenize_content;
152
+
] );
153
+
( "context",
154
+
[
155
+
test_case "render_context_frontmatter" `Quick
156
+
test_render_context_frontmatter;
157
+
] );
154
158
]
155
159
156
160
(* let () = *)
+7
-5
lib/server/Headers.ml
+7
-5
lib/server/Headers.ml
···
7
7
open Forester_prelude
8
8
open Forester_core
9
9
10
-
open struct module T = Types end
10
+
open struct
11
+
module T = Types
12
+
end
11
13
12
14
let parse_flag field header =
13
15
match Http.Header.get header field with
···
34
36
header_shown;
35
37
metadata_shown;
36
38
numbered;
37
-
expanded
39
+
expanded;
38
40
}
39
41
40
42
let parse_content_target (header : Http.Header.t) : T.content_target option =
41
43
let open Http in
42
44
match Header.get header "Taxon" with
43
45
| Some _ -> Some T.Taxon
44
-
| None ->
46
+
| None -> (
45
47
match Header.get header "Mainmatter" with
46
48
| Some _ -> Some T.Mainmatter
47
-
| None ->
49
+
| None -> (
48
50
match Header.get header "Full" with
49
51
| Some _ ->
50
52
let@ flags = Option.map @~ parse_section_flags header in
···
52
54
| None ->
53
55
let@ _ = Option.bind @@ Header.get header "Title" in
54
56
let@ flags = Option.map @~ parse_title_flags header in
55
-
T.Title flags
57
+
T.Title flags))
+28
-15
lib/server/Index.ml
+28
-15
lib/server/Index.ml
···
8
8
open HTML
9
9
10
10
let v ?c () =
11
-
html
12
-
[]
11
+
html []
13
12
[
14
-
head
15
-
[]
13
+
head []
16
14
[
17
-
meta [name "viewport"; content "width=device-width";];
18
-
link [rel "stylesheet"; href "/style.css";];
19
-
link [rel "icon"; type_ "image/x-icon"; href "/favicon.ico";];
20
-
script [type_ "module"; src "/min.js";] "";
15
+
meta [name "viewport"; content "width=device-width"];
16
+
link [rel "stylesheet"; href "/style.css"];
17
+
link [rel "icon"; type_ "image/x-icon"; href "/favicon.ico"];
18
+
script [type_ "module"; src "/min.js"] "";
21
19
script [src "/htmx.js"] "";
22
-
link [rel "stylesheet"; href "https://cdn.jsdelivr.net/npm/katex@0.16.21/dist/katex.min.css"; integrity "sha384-zh0CIslj+VczCZtlzBcjt5ppRcsAmDnRem7ESsYwWwg3m/OaJ2l4x7YBZl9Kxxib"; crossorigin `anonymous;];
23
-
script [src "https://cdn.jsdelivr.net/npm/katex@0.16.21/dist/katex.js"; integrity "sha384-CAltQiu9myJj3FAllEacN6FT+rOyXo+hFZKGuR2p4HB8JvJlyUHm31eLfL4eEiJL"; crossorigin `anonymous;] "";
20
+
link
21
+
[
22
+
rel "stylesheet";
23
+
href
24
+
"https://cdn.jsdelivr.net/npm/katex@0.16.21/dist/katex.min.css";
25
+
integrity
26
+
"sha384-zh0CIslj+VczCZtlzBcjt5ppRcsAmDnRem7ESsYwWwg3m/OaJ2l4x7YBZl9Kxxib";
27
+
crossorigin `anonymous;
28
+
];
29
+
script
30
+
[
31
+
src "https://cdn.jsdelivr.net/npm/katex@0.16.21/dist/katex.js";
32
+
integrity
33
+
"sha384-CAltQiu9myJj3FAllEacN6FT+rOyXo+hFZKGuR2p4HB8JvJlyUHm31eLfL4eEiJL";
34
+
crossorigin `anonymous;
35
+
]
36
+
"";
24
37
title [] "";
25
38
];
26
39
body
27
-
[Hx.boost true;]
40
+
[Hx.boost true]
28
41
[
29
42
header [] [];
30
43
div
31
-
[id "grid-wrapper";]
44
+
[id "grid-wrapper"]
32
45
[
33
-
match c with
46
+
(match c with
34
47
| Some stuff -> stuff
35
48
| None ->
36
49
article
···
41
54
Hx.target "this";
42
55
Hx.swap "outerHTML";
43
56
]
44
-
[];
57
+
[]);
45
58
];
46
-
div [id "modal-container";] [];
59
+
div [id "modal-container"] [];
47
60
];
48
61
]
+1
-1
lib/server/Router.ml
+1
-1
lib/server/Router.ml
+196
-213
lib/server/Server.ml
+196
-213
lib/server/Server.ml
···
31
31
let htmx = load_file "htmx.js" in
32
32
let favicon = load_file "favicon.ico" in
33
33
let js_bundle = EP.(load (env#fs / base_dir / "min.js")) in
34
-
let font_dir = EP.(native_exn @@ theme_dir / "fonts") in
35
-
{stylesheet; htmx; js_bundle; font_dir; favicon;}
34
+
let font_dir = EP.(native_exn @@ (theme_dir / "fonts")) in
35
+
{stylesheet; htmx; js_bundle; font_dir; favicon}
36
36
37
37
let lookup_font ~env theme font =
38
38
Eio.Path.(load (env#fs / theme.font_dir / font))
39
39
40
-
let handler
41
-
: env: < fs: [> Eio.Fs.dir_ty] Eio.Path.t; .. > ->
42
-
theme: theme ->
43
-
forest: State.t ->
44
-
Cohttp_eio.Server.conn ->
45
-
Http.Request.t ->
46
-
Cohttp_eio.Body.t ->
47
-
Cohttp_eio.Server.response
48
-
= fun
49
-
~env
50
-
~theme
51
-
~(forest : State.t)
52
-
_socket
53
-
request
54
-
body
55
-
->
40
+
let handler :
41
+
env:< fs : [> Eio.Fs.dir_ty] Eio.Path.t ; .. > ->
42
+
theme:theme ->
43
+
forest:State.t ->
44
+
Cohttp_eio.Server.conn ->
45
+
Http.Request.t ->
46
+
Cohttp_eio.Body.t ->
47
+
Cohttp_eio.Server.response =
48
+
fun ~env ~theme ~(forest : State.t) _socket request body ->
56
49
let resource = Uri.of_string request.resource in
57
50
let path = Uri.path resource in
58
-
match Routes.match' ~target: path Router.routes with
59
-
| Routes.FullMatch r
60
-
| Routes.MatchWithTrailingSlash r ->
61
-
begin
62
-
match r with
63
-
| Font fontname ->
64
-
let body = lookup_font ~env theme fontname in
65
-
let headers =
66
-
let ext = Filename.extension fontname in
67
-
let mimetype =
68
-
match ext with
69
-
| ".ttf" -> "font/ttf"
70
-
| ".woff" -> "font/woff"
71
-
| ".woff2" -> "font/woff2"
72
-
| _ -> assert false
51
+
match Routes.match' ~target:path Router.routes with
52
+
| Routes.FullMatch r | Routes.MatchWithTrailingSlash r -> begin
53
+
match r with
54
+
| Font fontname ->
55
+
let body = lookup_font ~env theme fontname in
56
+
let headers =
57
+
let ext = Filename.extension fontname in
58
+
let mimetype =
59
+
match ext with
60
+
| ".ttf" -> "font/ttf"
61
+
| ".woff" -> "font/woff"
62
+
| ".woff2" -> "font/woff2"
63
+
| _ -> assert false
64
+
in
65
+
Http.Header.of_list [("Content-Type", mimetype)]
66
+
in
67
+
Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body ()
68
+
| Stylesheet ->
69
+
let headers =
70
+
Http.Header.of_list [("Content-Type", "text/css"); ("charset", "utf-8")]
71
+
in
72
+
Cohttp_eio.Server.respond_string ~headers ~status:`OK
73
+
~body:theme.stylesheet ()
74
+
| Js_bundle ->
75
+
let headers =
76
+
Http.Header.of_list [("Content-Type", "application/javascript")]
77
+
in
78
+
Cohttp_eio.Server.respond_string ~headers ~status:`OK
79
+
~body:theme.js_bundle ()
80
+
| Index ->
81
+
let headers = Http.Header.of_list [("Content-Type", "text/html")] in
82
+
Cohttp_eio.Server.respond_string ~headers ~status:`OK
83
+
~body:(Pure_html.to_string (Index.v ()))
84
+
()
85
+
| Favicon ->
86
+
let headers = Http.Header.of_list [("Content-Type", "image/x-icon")] in
87
+
Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body:theme.favicon
88
+
()
89
+
| Tree s ->
90
+
let href = URI_scheme.named_uri ~base:forest.config.url s in
91
+
let request_headers = Http.Request.headers request in
92
+
let is_htmx =
93
+
(*If it is an HTMX request, we just send a fragment. If it is not an
94
+
HTMX request, we need to send the whole page. This happens for example
95
+
when the user opens a link via the URL bar of the browser.
96
+
*)
97
+
Option.is_some @@ Http.Header.get request_headers "Hx-Request"
98
+
in
99
+
begin if is_htmx then begin
100
+
(* We use custom headers to configure the transclusion. *)
101
+
match Headers.parse_content_target request_headers with
102
+
(* If we fail to parse a target, just render the article.*)
103
+
| None -> begin
104
+
match State.get_article href forest with
105
+
| None ->
106
+
(* TODO: Some sort of 404 template *)
107
+
Cohttp_eio.Server.respond_string ~status:`Not_found ~body:"" ()
108
+
| Some content ->
109
+
let response =
110
+
Pure_html.to_string @@ Htmx_client.render_article forest content
111
+
in
112
+
Cohttp_eio.Server.respond_string ~status:`OK ~body:response ()
113
+
end
114
+
| Some target -> (
115
+
match State.get_content_of_transclusion {target; href} forest with
116
+
| None ->
117
+
Cohttp_eio.Server.respond_string ~status:`Not_found ~body:"" ()
118
+
| Some content ->
119
+
(* TODO: Remove any sort of HTML generation from the handler. *)
120
+
let response =
121
+
Pure_html.(
122
+
to_string
123
+
@@ HTML.span [] (Htmx_client.render_content forest content))
124
+
in
125
+
Cohttp_eio.Server.respond_string ~status:`OK ~body:response ())
126
+
end
127
+
else
128
+
match State.get_article href forest with
129
+
| Some article ->
130
+
let content =
131
+
Pure_html.to_string
132
+
@@ Index.v ~c:(Htmx_client.render_article forest article) ()
73
133
in
74
-
Http.Header.of_list ["Content-Type", mimetype]
134
+
let headers = Http.Header.of_list [("Content-Type", "text/html")] in
135
+
Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body:content ()
136
+
| None ->
137
+
Cohttp_eio.Server.respond_string ~status:`Not_found ~body:"" ()
138
+
end
139
+
| Search ->
140
+
if request.meth = `POST then
141
+
let body = Eio.Flow.read_all body in
142
+
let get_param key =
143
+
Option.map (String.concat "")
144
+
@@ Option.map snd
145
+
@@ List.find_opt (fun (s, _) -> s = key) (Uri.query_of_encoded body)
75
146
in
76
-
Cohttp_eio.Server.respond_string ~headers ~status: `OK ~body ()
77
-
| Stylesheet ->
78
-
let headers = Http.Header.of_list ["Content-Type", "text/css"; "charset", "utf-8"] in
79
-
Cohttp_eio.Server.respond_string ~headers ~status: `OK ~body: theme.stylesheet ()
80
-
| Js_bundle ->
81
-
let headers = Http.Header.of_list ["Content-Type", "application/javascript"] in
82
-
Cohttp_eio.Server.respond_string ~headers ~status: `OK ~body: theme.js_bundle ()
83
-
| Index ->
84
-
let headers = Http.Header.of_list ["Content-Type", "text/html"] in
85
-
Cohttp_eio.Server.respond_string ~headers ~status: `OK ~body: (Pure_html.to_string (Index.v ())) ()
86
-
| Favicon ->
87
-
let headers = Http.Header.of_list ["Content-Type", "image/x-icon"] in
88
-
Cohttp_eio.Server.respond_string ~headers ~status: `OK ~body: theme.favicon ()
89
-
| Tree s ->
90
-
let href = URI_scheme.named_uri ~base: forest.config.url s in
91
-
let request_headers = Http.Request.headers request in
92
-
let is_htmx =
93
-
(*If it is an HTMX request, we just send a fragment.
94
-
If it is not an HTMX request, we need to send the whole page. This
95
-
happens for example when the user opens a link via the URL bar of
96
-
the browser.
97
-
*)
98
-
Option.is_some @@ Http.Header.get request_headers "Hx-Request"
147
+
let _search_term = Option.value ~default:"" @@ get_param "search" in
148
+
let search_for = get_param "search-for" in
149
+
let search_results =
150
+
match search_for with
151
+
| None -> []
152
+
| Some "title-text" ->
153
+
(* Forester_search.Index.search *)
154
+
(* forest.search_index *)
155
+
(* search_term *)
156
+
[]
157
+
| Some "full-text" ->
158
+
(* Forester_search.Index.search *)
159
+
(* forest.search_index *)
160
+
(* search_term *)
161
+
[]
162
+
| Some _ -> assert false
99
163
in
100
-
begin
101
-
if is_htmx then
102
-
begin
103
-
(* We use custom headers to configure the transclusion. *)
104
-
match Headers.parse_content_target request_headers with
105
-
(* If we fail to parse a target, just render the article.*)
106
-
| None ->
107
-
begin
108
-
match State.get_article href forest with
109
-
| None ->
110
-
(* TODO: Some sort of 404 template *)
111
-
Cohttp_eio.Server.respond_string ~status: `Not_found ~body: "" ()
112
-
| Some content ->
113
-
let response = Pure_html.to_string @@ Htmx_client.render_article forest content in
114
-
Cohttp_eio.Server.respond_string ~status: `OK ~body: response ()
115
-
end
116
-
| Some target ->
117
-
match State.get_content_of_transclusion {target; href} forest with
118
-
| None -> Cohttp_eio.Server.respond_string ~status: `Not_found ~body: "" ()
119
-
| Some content ->
120
-
(* TODO: Remove any sort of HTML generation from the handler. *)
121
-
let response = Pure_html.(to_string @@ HTML.span [] (Htmx_client.render_content forest content)) in
122
-
Cohttp_eio.Server.respond_string ~status: `OK ~body: response ()
123
-
end
124
-
else
125
-
match State.get_article href forest with
126
-
| Some article ->
127
-
let content = Pure_html.to_string @@ Index.v ~c: (Htmx_client.render_article forest article) () in
128
-
let headers = Http.Header.of_list ["Content-Type", "text/html"] in
129
-
Cohttp_eio.Server.respond_string ~headers ~status: `OK ~body: content ()
130
-
| None -> Cohttp_eio.Server.respond_string ~status: `Not_found ~body: "" ()
131
-
end
132
-
| Search ->
133
-
if request.meth = `POST then
134
-
let body = Eio.Flow.read_all body in
135
-
let get_param key =
136
-
Option.map (String.concat "") @@
137
-
Option.map snd @@
138
-
List.find_opt
139
-
(fun (s, _) ->
140
-
s = key
141
-
)
142
-
(Uri.query_of_encoded body)
143
-
in
144
-
let _search_term = Option.value ~default: "" @@ get_param "search" in
145
-
let search_for = get_param "search-for" in
146
-
let search_results =
147
-
match search_for with
148
-
| None -> []
149
-
| Some "title-text" ->
150
-
(* Forester_search.Index.search *)
151
-
(* forest.search_index *)
152
-
(* search_term *)
153
-
[]
154
-
| Some "full-text" ->
155
-
(* Forester_search.Index.search *)
156
-
(* forest.search_index *)
157
-
(* search_term *)
158
-
[]
159
-
| Some _ -> assert false
160
-
in
161
-
let response
162
-
=
163
-
Search_menu.results
164
-
forest
165
-
(List.map snd search_results)
166
-
in
167
-
Cohttp_eio.Server.respond_string
168
-
~status: `OK
169
-
~body: response
170
-
()
171
-
else
172
-
Cohttp_eio.Server.respond_string ~status: `Method_not_allowed ~body: "" ()
173
-
| Searchmenu ->
174
-
Cohttp_eio.Server.respond_string ~status: `OK ~body: Search_menu.v ()
175
-
| Nil ->
176
-
Cohttp_eio.Server.respond_string ~status: `OK ~body: "" ()
177
-
| Home ->
178
-
begin
179
-
let home = URI_scheme.named_uri ~base: forest.config.url "index" in
180
-
match State.get_article home forest with
181
-
| None ->
182
-
Cohttp_eio.Server.respond_string ~status: `OK ~body: "" ()
183
-
| Some home_tree ->
184
-
let content = Pure_html.to_string @@ Htmx_client.render_article forest home_tree in
185
-
let headers = Http.Header.of_list ["Content-Type", "text/html"] in
186
-
Cohttp_eio.Server.respond_string ~headers ~status: `OK ~body: content ()
187
-
end
188
-
| Query ->
189
-
let q = Uri.get_query_param resource "query" in
190
164
let response =
191
-
q
192
-
|> Option.get
193
-
|> Uri.pct_decode
194
-
|> Repr.of_json_string
195
-
Datalog_expr.(query_t Repr.string (T.vertex_t T.content_t)) |> function
196
-
| Ok _q ->
197
-
Logs.app (fun m -> m "parsed successfully");
198
-
(* let _, _, result = Driver.update (Query q) forest in *)
199
-
begin
200
-
match None with
201
-
(* FIXME :*)
202
-
(* | `Vertex_set(vs : Vertex_set.t) -> Htmx_client.render_query_result forest vs *)
203
-
| Some (`Vertex_set vs) -> Htmx_client.render_query_result forest vs
204
-
| _ -> None
205
-
end
206
-
| Error (`Msg str) ->
207
-
Logs.app (fun m -> m "failed to parse: %s" str);
208
-
(* Pure_html.txt "failed to parse: %s" str *)
209
-
None
165
+
Search_menu.results forest (List.map snd search_results)
210
166
in
211
-
begin
212
-
match response with
213
-
| Some nodes ->
214
-
Cohttp_eio.Server.respond_string
215
-
~status: `OK
216
-
~body: (Format.asprintf "%a" Pure_html.pp nodes)
217
-
()
218
-
| None ->
219
-
(* If result is empty, use
220
-
[hx-retarget](https://htmx.org/reference/#response_headers) to
221
-
hide the entire section. Right now I am just trying to get the
222
-
backmatter to render correctly, I don't know if this is
223
-
compatible with the other use cases of queries. I can think of
224
-
multiple ways to work around this. We could use a separate
225
-
endpoint to get the backmatter, or we could do some more
226
-
HTMXing. I guess the question boils down to which approach is
227
-
more in line with our overarching goal of making forester a
228
-
genuine hypermedia format
229
-
*)
230
-
let headers =
231
-
Http.Header.of_list
232
-
[
233
-
"Hx-Retarget", "closest section.backmatter-section";
234
-
"Hx-Swap", "delete"
235
-
]
236
-
in
237
-
Cohttp_eio.Server.respond_string
238
-
~headers
239
-
~status: `OK
240
-
~body: ""
241
-
()
242
-
end
243
-
| Htmx ->
244
-
let headers = Http.Header.of_list ["Content-Type", "application/javascript"] in
245
-
Cohttp_eio.Server.respond_string ~headers ~status: `OK ~body: theme.htmx ()
167
+
Cohttp_eio.Server.respond_string ~status:`OK ~body:response ()
168
+
else
169
+
Cohttp_eio.Server.respond_string ~status:`Method_not_allowed ~body:"" ()
170
+
| Searchmenu ->
171
+
Cohttp_eio.Server.respond_string ~status:`OK ~body:Search_menu.v ()
172
+
| Nil -> Cohttp_eio.Server.respond_string ~status:`OK ~body:"" ()
173
+
| Home -> begin
174
+
let home = URI_scheme.named_uri ~base:forest.config.url "index" in
175
+
match State.get_article home forest with
176
+
| None -> Cohttp_eio.Server.respond_string ~status:`OK ~body:"" ()
177
+
| Some home_tree ->
178
+
let content =
179
+
Pure_html.to_string @@ Htmx_client.render_article forest home_tree
180
+
in
181
+
let headers = Http.Header.of_list [("Content-Type", "text/html")] in
182
+
Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body:content ()
246
183
end
184
+
| Query ->
185
+
let q = Uri.get_query_param resource "query" in
186
+
let response =
187
+
q |> Option.get |> Uri.pct_decode
188
+
|> Repr.of_json_string
189
+
Datalog_expr.(query_t Repr.string (T.vertex_t T.content_t))
190
+
|> function
191
+
| Ok _q ->
192
+
Logs.app (fun m -> m "parsed successfully");
193
+
(* let _, _, result = Driver.update (Query q) forest in *)
194
+
begin match None with
195
+
(* FIXME :*)
196
+
(* | `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
198
+
| _ -> None
199
+
end
200
+
| Error (`Msg str) ->
201
+
Logs.app (fun m -> m "failed to parse: %s" str);
202
+
(* Pure_html.txt "failed to parse: %s" str *)
203
+
None
204
+
in
205
+
begin match response with
206
+
| Some nodes ->
207
+
Cohttp_eio.Server.respond_string ~status:`OK
208
+
~body:(Format.asprintf "%a" Pure_html.pp nodes)
209
+
()
210
+
| None ->
211
+
(* If result is empty, use
212
+
[hx-retarget](https://htmx.org/reference/#response_headers) to hide
213
+
the entire section. Right now I am just trying to get the backmatter
214
+
to render correctly, I don't know if this is compatible with the
215
+
other use cases of queries. I can think of multiple ways to work
216
+
around this. We could use a separate endpoint to get the backmatter,
217
+
or we could do some more HTMXing. I guess the question boils down to
218
+
which approach is more in line with our overarching goal of making
219
+
forester a genuine hypermedia format
220
+
*)
221
+
let headers =
222
+
Http.Header.of_list
223
+
[
224
+
("Hx-Retarget", "closest section.backmatter-section");
225
+
("Hx-Swap", "delete");
226
+
]
227
+
in
228
+
Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body:"" ()
229
+
end
230
+
| Htmx ->
231
+
let headers =
232
+
Http.Header.of_list [("Content-Type", "application/javascript")]
233
+
in
234
+
Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body:theme.htmx ()
235
+
end
247
236
| Routes.NoMatch ->
248
-
Cohttp_eio.Server.respond_string ~status: `Not_found ~body: "" ()
237
+
Cohttp_eio.Server.respond_string ~status:`Not_found ~body:"" ()
249
238
250
239
let log_warning ex = Logs.warn (fun f -> f "%a" Eio.Exn.pp ex)
251
240
252
241
let run ~env ~port ~forest theme_location =
253
-
let@ sw = Eio.Switch.run ?name: None in
242
+
let@ sw = Eio.Switch.run ?name:None in
254
243
let port = ref port in
255
244
let theme = load_theme ~env theme_location in
256
245
let socket =
257
-
Eio.Net.listen
258
-
env#net
259
-
~sw
260
-
~backlog: 128
261
-
~reuse_addr: true
246
+
Eio.Net.listen env#net ~sw ~backlog:128 ~reuse_addr:true
262
247
(`Tcp (Eio.Net.Ipaddr.V4.loopback, !port))
263
-
and server = Cohttp_eio.Server.make ~callback: (handler ~env ~theme ~forest) ()
248
+
and server =
249
+
Cohttp_eio.Server.make ~callback:(handler ~env ~theme ~forest) ()
264
250
in
265
-
Cohttp_eio.Server.run
266
-
socket
267
-
server
268
-
~on_error: log_warning
251
+
Cohttp_eio.Server.run socket server ~on_error:log_warning
-1
lib/xml_names/Forester_xml_names.ml
-1
lib/xml_names/Forester_xml_names.ml
+2
-2
lib/xml_names/Types.ml
+2
-2
lib/xml_names/Types.ml
+68
-52
lib/xml_names/Xmlns_effect.ml
+68
-52
lib/xml_names/Xmlns_effect.ml
···
5
5
*)
6
6
7
7
open Types
8
-
9
-
module String_map = Map.Make(String)
8
+
module String_map = Map.Make (String)
10
9
11
10
module Xmlns_map = struct
12
11
type t = {
13
12
prefix_to_xmlns: string String_map.t;
14
-
xmlns_to_prefixes: string list String_map.t
13
+
xmlns_to_prefixes: string list String_map.t;
15
14
}
16
15
17
-
let empty = {
18
-
prefix_to_xmlns = String_map.empty;
19
-
xmlns_to_prefixes = String_map.empty
20
-
}
16
+
let empty =
17
+
{prefix_to_xmlns = String_map.empty; xmlns_to_prefixes = String_map.empty}
21
18
22
-
let assoc ~prefix ~xmlns env = {
23
-
prefix_to_xmlns = String_map.add prefix xmlns env.prefix_to_xmlns;
24
-
xmlns_to_prefixes = String_map.add_to_list xmlns prefix env.xmlns_to_prefixes
25
-
}
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
+
}
26
25
end
27
26
28
-
module Make_writer (Elt : sig type t end) = struct
27
+
module Make_writer (Elt : sig
28
+
type t
29
+
end) =
30
+
struct
29
31
type _ Effect.t += Yield : Elt.t -> unit Effect.t
30
32
31
33
let yield x = Effect.perform (Yield x)
···
33
35
let run f =
34
36
let open Effect.Deep in
35
37
try_with
36
-
(fun () -> let r = f () in [], r)
38
+
(fun () ->
39
+
let r = f () in
40
+
([], r))
37
41
()
38
42
{
39
-
effc = fun (type a) (eff : a Effect.t) ->
40
-
match eff with
41
-
| Yield x ->
42
-
Option.some @@ fun (k : (a, _) continuation) ->
43
-
let xs, r = continue k () in
44
-
x :: xs, r
45
-
| _ -> None
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);
46
51
}
47
52
48
53
let register_printer f =
49
54
Printexc.register_printer @@ function
50
-
| Effect.Unhandled (Yield elt) -> f (`Yield elt)
51
-
| _ -> None
55
+
| Effect.Unhandled (Yield elt) -> f (`Yield elt)
56
+
| _ -> None
52
57
53
-
let () = register_printer @@ fun _ -> Some "Unhandled effect; use Make_writer.run"
58
+
let () =
59
+
register_printer @@ fun _ -> Some "Unhandled effect; use Make_writer.run"
54
60
end
55
61
56
62
module Make () = struct
57
-
module E = Algaeff.State.Make(Xmlns_map)
58
-
module Decls = Make_writer(struct type t = xmlns_attr end)
63
+
module E = Algaeff.State.Make (Xmlns_map)
64
+
65
+
module Decls = Make_writer (struct
66
+
type t = xmlns_attr
67
+
end)
59
68
60
69
let find_xmlns_for_prefix prefix =
61
70
let env = E.get () in
62
71
String_map.find_opt prefix env.prefix_to_xmlns
63
72
64
73
let smallest_string strings =
65
-
List.hd @@ List.sort (fun s1 s2 -> compare (String.length s1) (String.length s2)) strings
74
+
List.hd
75
+
@@ List.sort
76
+
(fun s1 s2 -> compare (String.length s1) (String.length s2))
77
+
strings
66
78
67
79
let rec normalise_qname (qname : xml_qname) =
68
80
let scope = E.get () in
69
81
match qname.xmlns with
70
-
| None ->
71
-
begin
72
-
match String_map.find_opt qname.prefix scope.prefix_to_xmlns with
73
-
| None -> qname
74
-
| Some xmlns -> {qname with xmlns = Some xmlns}
75
-
end
76
-
| Some xmlns ->
77
-
begin
78
-
match String_map.find_opt qname.prefix scope.prefix_to_xmlns,
79
-
String_map.find_opt xmlns scope.xmlns_to_prefixes with
80
-
| None, (None | Some []) ->
81
-
E.modify (Xmlns_map.assoc ~prefix: qname.prefix ~xmlns);
82
-
Decls.yield {prefix = qname.prefix; xmlns};
83
-
qname
84
-
| Some xmlns', Some prefixes ->
85
-
if xmlns' = xmlns && List.mem qname.prefix prefixes then
86
-
{qname with prefix = try smallest_string prefixes with _ -> qname.prefix}
87
-
else
88
-
normalise_qname {qname with prefix = qname.prefix ^ "_"}
89
-
| None, Some prefixes ->
90
-
{qname with prefix = try smallest_string prefixes with _ -> qname.prefix}
91
-
| Some _, None ->
92
-
normalise_qname {qname with prefix = qname.prefix ^ "_"}
93
-
end
82
+
| None -> begin
83
+
match String_map.find_opt qname.prefix scope.prefix_to_xmlns with
84
+
| None -> qname
85
+
| Some xmlns -> {qname with xmlns = Some xmlns}
86
+
end
87
+
| Some xmlns -> begin
88
+
match
89
+
( String_map.find_opt qname.prefix scope.prefix_to_xmlns,
90
+
String_map.find_opt xmlns scope.xmlns_to_prefixes )
91
+
with
92
+
| None, (None | Some []) ->
93
+
E.modify (Xmlns_map.assoc ~prefix:qname.prefix ~xmlns);
94
+
Decls.yield {prefix = qname.prefix; xmlns};
95
+
qname
96
+
| Some xmlns', Some prefixes ->
97
+
if xmlns' = xmlns && List.mem qname.prefix prefixes then
98
+
{
99
+
qname with
100
+
prefix = (try smallest_string prefixes with _ -> qname.prefix);
101
+
}
102
+
else normalise_qname {qname with prefix = qname.prefix ^ "_"}
103
+
| None, Some prefixes ->
104
+
{
105
+
qname with
106
+
prefix = (try smallest_string prefixes with _ -> qname.prefix);
107
+
}
108
+
| Some _, None -> normalise_qname {qname with prefix = qname.prefix ^ "_"}
109
+
end
94
110
95
111
let within_scope kont =
96
112
let old_scope = E.get () in
97
113
let added, r = Decls.run kont in
98
114
E.set old_scope;
99
-
added, r
115
+
(added, r)
100
116
101
117
let run ~reserved kont =
102
118
let init =
103
-
let alg env ({prefix; xmlns}: xmlns_attr) =
119
+
let alg env ({prefix; xmlns} : xmlns_attr) =
104
120
Xmlns_map.assoc ~prefix ~xmlns env
105
121
in
106
122
List.fold_left alg Xmlns_map.empty reserved
+1
-2
lib/xml_names/Xmlns_effect.mli
+1
-2
lib/xml_names/Xmlns_effect.mli
···
10
10
val normalise_qname : xml_qname -> xml_qname
11
11
val within_scope : (unit -> 'a) -> xmlns_attr list * 'a
12
12
val find_xmlns_for_prefix : string -> string option
13
-
14
-
val run : reserved: xmlns_attr list -> (unit -> 'a) -> 'a
13
+
val run : reserved:xmlns_attr list -> (unit -> 'a) -> 'a
15
14
end
+26
-44
test/Prelude.ml
+26
-44
test/Prelude.ml
···
8
8
open Forester_core
9
9
open Forester_compiler
10
10
11
-
open struct module L = Lsp.Types end
11
+
open struct
12
+
module L = Lsp.Types
13
+
end
12
14
13
15
let rec strip_syn (syn : Syn.t) : Syn.t =
14
16
let@ Asai.Range.{value; _} = List.map @~ syn in
···
24
26
let lexbuf = Lexing.from_string str in
25
27
Parse.parse lexbuf
26
28
27
-
let parse_string_no_loc str =
28
-
Result.map strip_code @@
29
-
parse_string str
29
+
let parse_string_no_loc str = Result.map strip_code @@ parse_string str
30
30
31
31
let with_open_tmp_dir ~env kont =
32
32
let open Eio in
33
33
let cwd = Eio.Stdenv.cwd env in
34
34
let tmp = "_tmp" in
35
-
Path.mkdirs ~exists_ok: true ~perm: 0o755 Path.(cwd / tmp);
36
-
let tmp_dir =
37
-
Filename.temp_dir
38
-
~temp_dir: tmp
39
-
~perms: 0o755
40
-
""
41
-
""
42
-
in
35
+
Path.mkdirs ~exists_ok:true ~perm:0o755 Path.(cwd / tmp);
36
+
let tmp_dir = Filename.temp_dir ~temp_dir:tmp ~perms:0o755 "" "" in
43
37
Logs.app (fun m -> m "%s" tmp_dir);
44
38
let tmp_path = Eio.Path.(cwd / tmp_dir) in
45
39
let result = kont tmp_path in
46
-
Path.rmtree ~missing_ok: true tmp_path;
40
+
Path.rmtree ~missing_ok:true tmp_path;
47
41
result
48
42
49
43
let with_test_forest ~env ~raw_trees ~(config : Config.t) kont =
···
54
48
(fun dir_name ->
55
49
let dir = EP.(tmp / dir_name) in
56
50
Eio.traceln "mkdir: %s" dir_name;
57
-
EP.(mkdir ~perm: 0o755 dir);
58
-
dir
59
-
)
51
+
EP.(mkdir ~perm:0o755 dir);
52
+
dir)
60
53
config.trees
61
54
in
62
55
let create = `Exclusive 0o644 in
···
64
57
List.iter
65
58
(fun tree ->
66
59
match Filename.dirname tree.path with
67
-
| "." ->
68
-
EP.(
69
-
save
70
-
~create
71
-
(first_tree_dir / tree.path)
72
-
tree.content
73
-
)
60
+
| "." -> EP.(save ~create (first_tree_dir / tree.path) tree.content)
74
61
| dir ->
75
62
Eio.traceln "%s" dir;
76
-
EP.(
77
-
save
78
-
~create
79
-
(tmp / dir / Filename.basename tree.path)
80
-
tree.content
81
-
)
82
-
)
63
+
EP.(save ~create (tmp / dir / Filename.basename tree.path) tree.content))
83
64
raw_trees;
84
65
kont tmp
85
66
···
89
70
nodes = expanded;
90
71
identity = URI uri;
91
72
units = Trie.empty;
92
-
code = {
93
-
nodes = code;
94
-
identity = URI uri;
95
-
origin = Subtree {parent = Anonymous};
96
-
timestamp = None;
97
-
}
73
+
code =
74
+
{
75
+
nodes = code;
76
+
identity = URI uri;
77
+
origin = Subtree {parent = Anonymous};
78
+
timestamp = None;
79
+
};
98
80
}
99
81
100
82
type test_env = {
···
103
85
position: L.Position.t;
104
86
}
105
87
106
-
module Test_env = Algaeff.State.Make(struct type t = test_env end)
88
+
module Test_env = Algaeff.State.Make (struct
89
+
type t = test_env
90
+
end)
107
91
108
92
let find_tree addr =
109
93
let env = Test_env.get () in
110
94
let dirs = env.dirs in
111
-
Eio.Path.native_exn @@
112
-
Option.get @@
113
-
Dir_scanner.find_tree dirs @@
114
-
URI_scheme.named_uri ~base: env.config.url addr
95
+
Eio.Path.native_exn @@ Option.get @@ Dir_scanner.find_tree dirs
96
+
@@ URI_scheme.named_uri ~base:env.config.url addr
115
97
116
98
let find_doc (env : test_env) addr : L.TextDocumentIdentifier.t =
117
99
let path =
118
-
Eio.Path.native_exn @@
119
-
Option.get @@
120
-
Dir_scanner.find_tree env.dirs (URI_scheme.named_uri ~base: env.config.url addr)
100
+
Eio.Path.native_exn @@ Option.get
101
+
@@ Dir_scanner.find_tree env.dirs
102
+
(URI_scheme.named_uri ~base:env.config.url addr)
121
103
in
122
104
{uri = Lsp.Uri.of_path path}
+25
-37
test/Testables.ml
+25
-37
test/Testables.ml
···
8
8
open Forester_compiler
9
9
open Alcotest
10
10
11
-
type 'a bwd = 'a Bwd.bwd =
12
-
| Emp
13
-
| Snoc of 'a bwd * 'a
14
-
[@@deriving show]
15
-
16
-
type backtrace = Asai.Diagnostic.backtrace Bwd.bwd
17
-
[@printer pp_bwd]
11
+
type 'a bwd = 'a Bwd.bwd = Emp | Snoc of 'a bwd * 'a [@@deriving show]
12
+
type backtrace = (Asai.Diagnostic.backtrace Bwd.bwd[@printer pp_bwd])
18
13
19
-
type severity = Asai.Diagnostic.severity =
20
-
| Hint
21
-
| Info
22
-
| Warning
23
-
| Error
24
-
| Bug
14
+
type severity = Asai.Diagnostic.severity = Hint | Info | Warning | Error | Bug
25
15
[@@deriving show]
26
16
27
-
let pp_loctext = fun fmt text -> Format.pp_print_string fmt (Asai.Diagnostic.string_of_text Asai.Range.(text.value))
17
+
let pp_loctext =
18
+
fun fmt text ->
19
+
Format.pp_print_string fmt
20
+
(Asai.Diagnostic.string_of_text Asai.Range.(text.value))
28
21
29
-
type 'a diagnostic =
30
-
'a Asai.Diagnostic.t = {
22
+
type 'a diagnostic = 'a Asai.Diagnostic.t = {
31
23
severity: Asai.Diagnostic.severity; [@printer pp_severity]
32
24
message: 'a;
33
25
explanation: Asai.Diagnostic.loctext; [@printer pp_loctext]
···
36
28
}
37
29
[@@deriving show]
38
30
39
-
let message = testable Reporter.Message.pp (=)
31
+
let message = testable Reporter.Message.pp ( = )
32
+
let delim = testable Forester_core.pp_delim ( = )
33
+
let code = testable Forester_core.Code.pp ( = )
34
+
let code_node = testable Forester_core.Code.pp_node ( = )
35
+
let syn_node = testable Forester_core.Syn.pp_node ( = )
36
+
let syn = testable Syn.pp ( = )
37
+
let eval_result = testable Eval.pp_result ( = )
38
+
let path = testable Trie.pp_path ( = )
39
+
let data = testable Syn.pp_resolver_data ( = )
40
40
41
-
let delim = testable Forester_core.pp_delim (=)
42
-
let code = testable Forester_core.Code.pp (=)
43
-
let code_node = testable Forester_core.Code.pp_node (=)
44
-
let syn_node = testable Forester_core.Syn.pp_node (=)
45
-
let syn = testable Syn.pp (=)
46
-
let eval_result = testable Eval.pp_result (=)
47
-
let path = testable Trie.pp_path (=)
48
-
let data = testable Syn.pp_resolver_data (=)
49
41
let diagnostic =
50
42
let pp = pp_diagnostic Reporter.Message.pp in
51
-
testable pp (=)
43
+
testable pp ( = )
52
44
53
45
let uri = testable URI.pp URI.equal
54
-
55
-
let config = Alcotest.testable Config.pp (=)
46
+
let config = Alcotest.testable Config.pp ( = )
56
47
57
48
let document =
58
49
let pp fmt t = Format.pp_print_string fmt (Lsp.Text_document.text t) in
59
-
testable pp (=)
50
+
testable pp ( = )
60
51
61
-
let tree = testable Code.pp_tree (=)
62
-
63
-
let result = testable Eval.pp_result (=)
64
-
let content = testable Types.pp_content (=)
65
-
66
-
let action = testable Action.pp (=)
67
-
68
-
let completion_type = testable Forester_lsp.Completion.pp_completion (=)
52
+
let tree = testable Code.pp_tree ( = )
53
+
let result = testable Eval.pp_result ( = )
54
+
let content = testable Types.pp_content ( = )
55
+
let action = testable Action.pp ( = )
56
+
let completion_type = testable Forester_lsp.Completion.pp_completion ( = )