forked from
jonmsterling.com/ocaml-forester
ocaml
Adopt Grace
* Asai made the choice to deal with error handling control flow via
effects. Grace only deals with the creation and printing of
diagnostics. For this reason, much of the diff consists of moving from
an effects-based error mechanism to explicitly using the `Result`
type.
For now we use the same error type throughout the codebase. This is
just quickly finish the excision of Asai. In subsequent commits, I
will reexamine the kinds of errors that can arise so that we only
construct diagnostics for errors that the user will face.
I think that much of the code that constructs the diagnostics should
be factored out.
* rename loc to range throughout. Some comments may now contain the
string rangeation...
* refactor Imports to return results
* remove Reporter
* To understand the changes to the parser, refer to this issue:
https://github.com/johnyob/grace/issues/77#issuecomment-4030649630
* This changeset is by no means mergeable, I will still need to review
thoroughly. `failwith "todo"`'s abound.
* This commit contains some janky/untested conversion between Grace and
LSP diagnostics. I don't expect these will remain here for long, since
Grace will hopefully support something like this in the near future.
+1888
-1978
-2
bin/docs/Forester_docs.ml
-2
bin/docs/Forester_docs.ml
···
1
-
open Forester_prelude
2
1
open Forester_core
3
2
open Forester_frontend
4
3
open Forester_compiler
···
14
13
let () =
15
14
Logs.set_reporter (Logs_fmt.reporter ());
16
15
let@ env = Eio_main.run in
17
-
let@ () = Reporter.easy_run in
18
16
let dev = true in
19
17
let config = Config.(default ~url:docs_url) () in
20
18
let init = State.make ~env ~config ~dev ~index () in
+4
-1
bin/forester/dune
+4
-1
bin/forester/dune
+76
-43
bin/forester/main.ml
+76
-43
bin/forester/main.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Forester_prelude
8
7
open Forester_core
9
8
open Forester_frontend
10
9
open Forester_compiler
11
10
open Cmdliner
12
11
module EP = Eio.Path
12
+
open Grace
13
+
open Message
13
14
14
15
let arg_logs =
15
16
let setup_logs style_renderer level =
16
17
Fmt_tty.setup_std_outputs ?style_renderer ();
17
18
Logs.set_level level;
18
19
Logs.set_reporter (Logs_fmt.reporter ());
20
+
Logs_threaded.enable ();
19
21
()
20
22
in
21
23
···
39
41
Format.asprintf "%s" major
40
42
41
43
let build ~env _ config_filename dev no_theme emit_legacy_xml =
42
-
Reporter.easy_run @@ fun () ->
43
44
match Config_parser.parse_forest_config_file config_filename with
44
-
| Error exn -> Logs.err (fun m -> m "%a" Eio.Exn.pp exn)
45
+
| Error exn ->
46
+
Format.printf "%a@."
47
+
Grace_ansi_renderer.(pp_diagnostic ?config:None ?code_to_string:None)
48
+
exn
45
49
| Ok config ->
46
50
let config =
47
51
if dev then
···
63
67
Logs.debug (fun m -> m "Parsed config file %s" config_filename);
64
68
let forest = Driver.batch_run ~env ~dev ~config in
65
69
forest.diagnostics
66
-
|> URI.Tbl.iter (fun _ d -> List.iter Reporter.Tty.display d);
70
+
|> URI.Tbl.iter (fun _ d ->
71
+
List.iter
72
+
(Format.printf "%a@."
73
+
Grace_ansi_renderer.(
74
+
pp_diagnostic ?config:None ?code_to_string:None))
75
+
d);
67
76
if not no_theme then begin
68
-
let@ () = Reporter.trace "when copying theme directory" in
69
77
let theme_dir =
70
78
Option.value
71
79
~default:(List.hd Theme_site.Sites.themes ^ "/default")
72
80
config.theme
73
81
in
74
-
Forester.copy_contents_of_dir ~env ~forest
75
-
@@ Eio_util.path_of_dir ~env theme_dir
82
+
match Eio_util.path_of_dir ~env theme_dir with
83
+
| Ok path -> Forester.copy_contents_of_dir ~env ~forest path
84
+
| Error exn ->
85
+
Format.printf "%a@."
86
+
Grace_ansi_renderer.(pp_diagnostic ?config:None ?code_to_string:None)
87
+
exn
76
88
end;
77
89
Forester.render_forest ~dev ~forest ~emit_legacy_xml;
78
90
Logs.app (fun m -> m "Success!")
79
91
80
92
let new_tree ~env config_filename dest_dir prefix template random =
81
-
let@ () = Reporter.silence in
82
93
match Config_parser.parse_forest_config_file config_filename with
83
-
| Error exn -> Logs.err (fun m -> m "%a" Eio.Exn.pp exn)
84
-
| Ok config ->
94
+
| Error exn ->
95
+
Format.printf "%a@."
96
+
Grace_ansi_renderer.(pp_diagnostic ?config:None ?code_to_string:None)
97
+
exn
98
+
| Ok config -> begin
85
99
let forest = Driver.batch_run ~env ~dev:true ~config in
86
100
let mode = if random then `Random else `Sequential in
87
-
let new_tree =
101
+
match
88
102
Forester.create_tree ~env ~dest_dir ~prefix ~template ~mode ~forest
89
-
in
90
-
Format.printf "%s@." new_tree
103
+
with
104
+
| Ok tree -> Format.printf "%s@." tree
105
+
| Error exn ->
106
+
Format.printf "%a@."
107
+
Grace_ansi_renderer.(pp_diagnostic ?config:None ?code_to_string:None)
108
+
exn
109
+
end
91
110
92
111
let complete ~env config_filename title =
93
-
let@ () = Reporter.silence in
94
112
match Config_parser.parse_forest_config_file config_filename with
95
-
| Error exn -> Logs.err (fun m -> m "%a" Eio.Exn.pp exn)
113
+
| Error exn ->
114
+
Format.printf "%a@."
115
+
Grace_ansi_renderer.(pp_diagnostic ?config:None ?code_to_string:None)
116
+
exn
96
117
| Ok config ->
97
118
let forest = Driver.batch_run ~env ~dev:true ~config in
98
119
let@ uri, title = List.iter @~ Forester.complete ~forest title in
99
120
Format.printf "%s, %s\n" uri title
100
121
101
122
let query_all ~env config_filename =
102
-
let@ () = Reporter.silence in
103
123
match Config_parser.parse_forest_config_file config_filename with
104
-
| Error exn -> Logs.err (fun m -> m "%a" Eio.Exn.pp exn)
124
+
| Error exn ->
125
+
Format.printf "%a@."
126
+
Grace_ansi_renderer.(pp_diagnostic ?config:None ?code_to_string:None)
127
+
exn
105
128
| Ok config ->
106
129
let forest = Driver.batch_run ~env ~config ~dev:true in
107
130
Format.printf "%s" (Forester.json_manifest ~dev:true ~forest)
···
124
147
}
125
148
|}
126
149
150
+
(* This needs to be revamped in face of changes to how themes are handled. *)
127
151
let init ~env dir =
128
152
let default_theme_url =
129
153
"https://git.sr.ht/~jonsterling/forester-base-theme"
···
135
159
| Some d ->
136
160
begin try EP.mkdir ~perm:0o755 EP.(Eio.Stdenv.cwd env / d)
137
161
with _ ->
138
-
Reporter.emit Initialization_warning
139
-
~extra_remarks:
140
-
[Asai.Diagnostic.loctextf "Directory `%s` already exists" d]
162
+
Format.printf "%a@."
163
+
Grace_ansi_renderer.(pp_diagnostic ?config:None ?code_to_string:None)
164
+
@@ Diagnostic.createf Error ~code:Initialization_warning
165
+
"Directory `%s` already exists" d
141
166
end;
142
167
EP.(Eio.Stdenv.cwd env / d)
143
168
in
···
154
179
in
155
180
Eio.Process.run ~cwd proc_mgr cmd
156
181
with exn ->
157
-
Reporter.fatal Configuration_error
158
-
~extra_remarks:
159
-
[
160
-
Asai.Diagnostic.loctextf
161
-
{|
182
+
let _ =
183
+
Diagnostic.createf Error ~code:Configuration_error
184
+
{|
162
185
Failed to set up theme: %a. To perform this step manually, run the commands
163
186
164
187
git init
165
188
git submodule add %s
166
189
git -C theme checkout %s
167
190
|}
168
-
Eio.Exn.pp exn default_theme_url theme_version;
169
-
]
191
+
Eio.Exn.pp exn default_theme_url theme_version
192
+
in
193
+
()
170
194
end;
171
-
["trees"; "assets"] |> List.iter (Eio_util.try_create_dir ~cwd);
172
-
Eio_util.try_create_file ~cwd ~content:default_config_str "forest.toml";
173
-
Eio_util.try_create_file ~cwd ~content:"output/" ".gitignore";
174
-
Eio_util.try_create_file ~cwd ~content:"" "assets/.gitkeep";
175
-
Eio_util.try_create_file ~cwd ~content:index_tree_str "trees/index.tree";
176
-
Reporter.emit Log
177
-
~extra_remarks:
178
-
[
179
-
Asai.Diagnostic.loctextf "%s"
180
-
"Initialized forest, try editing `trees/index.tree` and running \
181
-
`forester build`. Afterwards, you can open `output/index.html` in \
182
-
your browser to view your forest.";
183
-
]
195
+
["trees"; "assets"]
196
+
|> List.iter (Eio_util.try_create_dir ~cwd >>> Result.get_ok);
197
+
Result.get_ok
198
+
@@ Eio_util.try_create_file ~cwd ~content:default_config_str "forest.toml";
199
+
Result.get_ok @@ Eio_util.try_create_file ~cwd ~content:"output/" ".gitignore";
200
+
Result.get_ok @@ Eio_util.try_create_file ~cwd ~content:"" "assets/.gitkeep";
201
+
Result.get_ok
202
+
@@ Eio_util.try_create_file ~cwd ~content:index_tree_str "trees/index.tree";
203
+
let _todo =
204
+
Diagnostic.createf Note ~code:Log
205
+
"Initialized forest, try editing `trees/index.tree` and running \
206
+
`forester build`. Afterwards, you can open `output/index.html` in your \
207
+
browser to view your forest."
208
+
in
209
+
()
184
210
185
211
let arg_config =
186
-
let doc = "A TOML file like $(i,forest.toml)" in
212
+
let doc = "A TOML file like $(i,forest.toml)." in
187
213
Arg.(value & pos 0 file "forest.toml" & info [] ~docv:"FOREST" ~doc)
188
214
189
215
let build_cmd ~env:env_ =
···
296
322
297
323
let lsp ~env _ config =
298
324
match Config_parser.parse_forest_config_file config with
299
-
| Error exn -> Logs.err (fun m -> m "%a" Eio.Exn.pp exn)
325
+
| Error exn ->
326
+
Format.printf "%a@."
327
+
Grace_ansi_renderer.(pp_diagnostic ?config:None ?code_to_string:None)
328
+
exn
300
329
| Ok config -> Forester_lsp.start ~env ~config
301
330
302
331
let lsp_cmd ~env:env_ =
···
373
402
Random.self_init ();
374
403
Printexc.record_backtrace true;
375
404
Logs.set_reporter (Logs_fmt.reporter ());
405
+
Logs.warn (fun m ->
406
+
m
407
+
"You are running a development build of forester. There is ongoing \
408
+
work on a built-in editor. It may do unexpected things to your \
409
+
forest, so make sure it is backed up!@.");
376
410
let@ env = Eio_main.run in
377
-
let@ () = Forester_core.Reporter.easy_run in
378
411
exit @@ Cmd.eval ~catch:false @@ cmd ~env
+1
dune
+1
dune
+3
-3
dune-project
+3
-3
dune-project
+9
-9
flake.lock
+9
-9
flake.lock
···
70
70
},
71
71
"nixpkgs": {
72
72
"locked": {
73
-
"lastModified": 1769170682,
74
-
"narHash": "sha256-oMmN1lVQU0F0W2k6OI3bgdzp2YOHWYUAw79qzDSjenU=",
73
+
"lastModified": 1772542754,
74
+
"narHash": "sha256-WGV2hy+VIeQsYXpsLjdr4GvHv5eECMISX1zKLTedhdg=",
75
75
"owner": "NixOS",
76
76
"repo": "nixpkgs",
77
-
"rev": "c5296fdd05cfa2c187990dd909864da9658df755",
77
+
"rev": "8c809a146a140c5c8806f13399592dbcb1bb5dc4",
78
78
"type": "github"
79
79
},
80
80
"original": {
···
99
99
"opam2json": "opam2json"
100
100
},
101
101
"locked": {
102
-
"lastModified": 1766494091,
103
-
"narHash": "sha256-3e0qNJWebAJadblHfGWyVBphS6tYVnCG8S2DI5Ke4F8=",
102
+
"lastModified": 1771067167,
103
+
"narHash": "sha256-XSw8dQIkdr+6eLvbUHo3cJPtTU7o5SMODz3qlnzmGpQ=",
104
104
"owner": "tweag",
105
105
"repo": "opam-nix",
106
-
"rev": "56f984e6e1b79f561d30a96ca3a5a9e0a1d185d1",
106
+
"rev": "2e20bbbe8130d1880338291446fd4e710a4db9a1",
107
107
"type": "github"
108
108
},
109
109
"original": {
···
131
131
"opam-repository": {
132
132
"flake": false,
133
133
"locked": {
134
-
"lastModified": 1769364207,
135
-
"narHash": "sha256-tw2/fXjOUfiG0njfBKCqp76iU33v08lS2aKWAP/xbKM=",
134
+
"lastModified": 1772577116,
135
+
"narHash": "sha256-2asop4QmRveafi6E4DzzLe9DgwZYmcQc6OBfP2sHFkU=",
136
136
"owner": "ocaml",
137
137
"repo": "opam-repository",
138
-
"rev": "f9f7db30fd6e805d48b947df138d463a5433f4d1",
138
+
"rev": "cbed368dbe42bcb41584964f7e491ddb3d77cc96",
139
139
"type": "github"
140
140
},
141
141
"original": {
+4
-1
forester.opam
+4
-1
forester.opam
···
20
20
"uucp" {>= "15.1.0"}
21
21
"eio_main" {>= "1.1"}
22
22
"ptime" {>= "1.1.0"}
23
-
"asai" {>= "0.3.0"}
24
23
"yuujinchou" {>= "5.2.0"}
25
24
"bwd" {>= "2.3.0"}
26
25
"algaeff" {>= "2.0.0"}
···
44
43
"odoc" {"2.4.4" >= with-doc}
45
44
"alcotest" {with-test}
46
45
"jsont"
46
+
"grace" {>= "0.3"}
47
47
]
48
48
build: [
49
49
["dune" "subst"] {dev}
···
62
62
["dune" "install" "-p" name "--create-install-files" name]
63
63
]
64
64
dev-repo: "git+https://git.sr.ht/~jonsterling/ocaml-forester"
65
+
pin-depends : [
66
+
["grace.dev" "git+https://github.com/kentookura/grace#aa043e9091e2423029ff871ba270840ed9da0369"]
67
+
]
+3
forester.opam.template
+3
forester.opam.template
+1
lib/app/Forester_app.ml
+1
lib/app/Forester_app.ml
+1
-1
lib/compiler/Action.ml
+1
-1
lib/compiler/Action.ml
···
26
26
| Eval of URI.t
27
27
| Query of (string, Vertex.t) Datalog_expr.query
28
28
| Query_results of (Vertex_set.t[@opaque])
29
-
| Report_errors of ((Reporter.Message.t Asai.Diagnostic.t[@opaque]) list * t)
29
+
| Report_errors of ((Message.t Grace.Diagnostic.t[@opaque]) list * t)
30
30
| Run_jobs of Job.job Range.located list
31
31
[@@deriving show]
32
32
+31
-21
lib/compiler/Asset_router.ml
+31
-21
lib/compiler/Asset_router.ml
···
5
5
*)
6
6
7
7
open Forester_core
8
+
open Message
8
9
9
10
let router : (string, URI.t) Hashtbl.t = Hashtbl.create 100
10
11
11
-
let normalize ?loc source_path =
12
-
try Unix.realpath source_path
12
+
let normalize ?range source_path =
13
+
try Ok (Unix.realpath source_path)
13
14
with Unix.Unix_error (e, _, m) ->
14
-
Reporter.fatal ?loc
15
-
(Asset_not_found (Format.asprintf "%s: %s" (Unix.error_message e) m))
15
+
let range = failwith "pass_loc" in
16
+
error
17
+
@@ Diagnostic.createf Error ~code:Asset_not_found "%s: %s"
18
+
(Unix.error_message e) m
16
19
17
20
let install ~(config : Config.t) ~source_path ~content =
18
-
let normalized = normalize source_path in
21
+
let open Result.Syntax in
22
+
let* normalized = normalize source_path in
19
23
match Hashtbl.find_opt router normalized with
20
-
| Some uri -> uri
21
-
| None ->
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
-
let cid_str = Cid.to_string cid in
28
-
let ext = Filename.extension normalized in
29
-
let uri = URI_scheme.named_uri ~base:config.url (cid_str ^ ext) in
30
-
Hashtbl.add router normalized uri;
31
-
uri
24
+
| Some uri -> Ok uri
25
+
| None -> (
26
+
match
27
+
Multihash_digestif.of_cstruct `Sha3_256 (Cstruct.of_string content)
28
+
with
29
+
| Error _ ->
30
+
error
31
+
@@ Diagnostic.createf Error ~code:Internal_error "Asset_router.install"
32
+
| Ok hash ->
33
+
let cid = Cid.v ~version:`Cidv1 ~codec:`Raw ~base:`Base32 ~hash in
34
+
let cid_str = Cid.to_string cid in
35
+
let ext = Filename.extension normalized in
36
+
let uri = URI.named_uri ~base:config.url (cid_str ^ ext) in
37
+
Hashtbl.add router normalized uri;
38
+
ok uri)
32
39
33
-
let uri_of_asset ?loc ~source_path () =
34
-
let normalized = normalize ?loc source_path in
40
+
let uri_of_asset ?range ~source_path () =
41
+
let open Result.Syntax in
42
+
let* normalized = normalize ?range source_path in
35
43
match Hashtbl.find_opt router normalized with
36
-
| Some uri -> uri
37
-
| None -> Reporter.fatal ?loc (Asset_has_no_content_address normalized)
44
+
| Some uri -> ok uri
45
+
| None ->
46
+
let () = failwith "todo: pass loc" in
47
+
error @@ Diagnostic.createf Error ~code:Asset_has_no_content_address ""
+7
-7
lib/compiler/Build_latex.ml
+7
-7
lib/compiler/Build_latex.ml
···
5
5
*)
6
6
7
7
open Forester_core
8
+
open Result.Syntax
9
+
open Message
8
10
9
11
type env = Eio_unix.Stdenv.base
10
12
11
13
let resources_dir cwd = Eio.Path.(cwd / "build" / "resources")
12
14
13
-
let latex_to_svg ~env ?loc source =
15
+
let latex_to_svg ~env ~range source =
14
16
let cwd = Eio.Stdenv.cwd env in
15
17
let hash = Digest.to_hex @@ Digest.string source in
16
18
let name = hash ^ ".svg" in
17
19
let svg_path = Eio.Path.(resources_dir cwd / name) in
18
20
let perm = 0o755 in
19
21
Eio_util.ensure_context_of_path ~perm svg_path;
20
-
try Eio.Path.load svg_path
22
+
try Ok (Eio.Path.load svg_path)
21
23
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
24
+
Logs.info (fun m -> m "Building %s" (Eio.Path.native_exn svg_path));
25
+
let* svg_code = LaTeX_pipeline.latex_to_svg ~env ~range source in
26
26
Eio.Path.save ~create:(`Or_truncate perm) svg_path svg_code;
27
-
svg_code
27
+
Ok svg_code
+7
-1
lib/compiler/Build_latex.mli
+7
-1
lib/compiler/Build_latex.mli
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
+
open Forester_core
8
+
7
9
type env = Eio_unix.Stdenv.base
8
10
9
-
val latex_to_svg : env:env -> ?loc:Asai.Range.t -> string -> string
11
+
val latex_to_svg :
12
+
env:env ->
13
+
range:Grace.Range.t ->
14
+
string ->
15
+
(string, Message.t Grace.Diagnostic.t) result
-1
lib/compiler/Cache.ml
-1
lib/compiler/Cache.ml
+4
-1
lib/compiler/Dir_scanner.ml
+4
-1
lib/compiler/Dir_scanner.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Forester_prelude
8
7
open Forester_core
9
8
module EP = Eio.Path
10
9
···
39
38
match EP.split fp with
40
39
| None -> false
41
40
| Some (_, basename) -> is_tree fp && Filename.chop_extension basename = str
41
+
42
+
let scan_directory path =
43
+
let@ () = S.run in
44
+
process_dir is_tree path
42
45
43
46
let scan_directories dirs =
44
47
let@ () = S.run in
+2
lib/compiler/Dir_scanner.mli
+2
lib/compiler/Dir_scanner.mli
+71
-85
lib/compiler/Driver.ml
+71
-85
lib/compiler/Driver.ml
···
5
5
*)
6
6
7
7
open Forester_core
8
-
open Forester_prelude
9
8
open State.Syntax
9
+
open Result.Syntax
10
+
open Message
10
11
11
12
open struct
12
13
module T = Types
···
15
16
let update (action : Action.t) (forest : State.t) =
16
17
let open Action in
17
18
let forest = State.update_history ~forest action in
19
+
let env = forest.env in
18
20
match action with
19
21
| Quit e -> begin match e with Fail -> exit 1 | Finished -> exit 0 end
20
22
| Query q ->
21
-
let@ () = Reporter.trace "when running query" in
22
23
let r = Forest.run_datalog_query forest.graphs q in
23
24
(Query_results r, forest)
24
25
| Query_results _ -> (Done, forest)
25
26
| Report_errors (_, next_action) -> (next_action, forest)
26
27
| Load_all_configured_dirs ->
27
-
let@ () = Reporter.trace "when loading files from disk" in
28
-
let tree_dirs =
29
-
Eio_util.paths_of_dirs ~env:forest.env forest.config.trees
28
+
let errors, paths = Eio_util.paths_of_dirs ~env forest.config.trees in
29
+
let () =
30
+
let@ tree_dir = List.iter @~ paths in
31
+
assert (Eio.Path.is_directory tree_dir);
32
+
let@ tree_src = Seq.iter @~ Phases.load tree_dir in
33
+
let lsp_uri = Lsp.Text_document.documentUri tree_src in
34
+
let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url lsp_uri in
35
+
URI.Tbl.replace forest.resolver uri (Lsp.Uri.to_path lsp_uri);
36
+
forest.={uri} <- Document tree_src
37
+
(*lsp_documents ;*)
38
+
(*Logs.debug (fun m -> m "loaded %d trees" (Seq.length lsp_documents))*)
30
39
in
31
-
List.iter (fun path -> assert (Eio.Path.is_directory path)) tree_dirs;
32
-
let docs = Phases.load tree_dirs in
33
-
Seq.iter
34
-
(fun doc ->
35
-
let lsp_uri = Lsp.Text_document.documentUri doc in
36
-
let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url lsp_uri in
37
-
URI.Tbl.replace forest.resolver uri (Lsp.Uri.to_path lsp_uri);
38
-
forest.={uri} <- Document doc)
39
-
docs;
40
-
Logs.debug (fun m -> m "loaded %d trees" (Seq.length docs));
41
40
(Parse_all, forest)
42
41
| Parse_all ->
43
-
let@ () = Reporter.trace "when parsing trees" in
44
-
let errors, succeeded = Phases.parse forest in
45
-
List.iter
46
-
(fun (code : Tree.code) ->
47
-
let@ uri = Option.iter @~ Tree.(identity_to_uri code.identity) in
48
-
forest.={uri} <- Parsed code;
49
-
forest.?{uri} <- [])
50
-
succeeded;
42
+
let errors, codes = Phases.parse forest in
43
+
let () =
44
+
let@ code = List.iter @~ codes in
45
+
let@ uri = Option.iter @~ Tree.(identity_to_uri code.identity) in
46
+
forest.={uri} <- Parsed code;
47
+
forest.?{uri} <- []
48
+
in
51
49
if List.length errors = 0 then
52
50
assert (Seq.for_all Tree.is_parsed (URI.Tbl.to_seq_values forest.index));
53
-
List.iter
54
-
(fun diag ->
55
-
let@ uri =
56
-
Option.iter
57
-
@~ Option.map
58
-
(URI_scheme.lsp_uri_to_uri ~base:forest.config.url)
59
-
(Reporter.guess_uri diag)
60
-
in
61
-
forest.?{uri} <- [diag])
62
-
errors;
51
+
let () =
52
+
let@ error = List.iter @~ errors in
53
+
let@ uri =
54
+
Option.iter
55
+
@~ Option.map
56
+
(URI_scheme.lsp_uri_to_uri ~base:forest.config.url)
57
+
(Phases.guess_uri error)
58
+
in
59
+
forest.?{uri} <- [error]
60
+
in
63
61
(Action.report ~errors ~next_action:Build_import_graph, forest)
64
62
| Build_import_graph ->
65
-
let@ () = Reporter.trace "when building import graph" in
66
-
let errors, import_graph = Phases.build_import_graph forest in
63
+
let errors, import_graph = Phases.build_import_graph ~forest in
67
64
Logs.debug (fun m ->
68
65
m "import graph has %d vertices" (Forest_graph.nb_vertex import_graph));
69
66
(Action.report ~errors ~next_action:Expand_all, {forest with import_graph})
70
67
| Expand_all ->
71
-
let@ () = Reporter.tracef "when expanding trees" in
72
68
Logs.debug (fun m -> m "expanding trees");
73
69
let errors = Phases.expand_all forest in
74
70
(Action.report ~errors ~next_action:Eval_all, forest)
75
-
| Expand uri ->
76
-
let@ () = Reporter.tracef "when expanding %a" URI.pp uri in
77
-
begin match Option.bind forest.={uri} Tree.to_code with
71
+
| Expand uri -> begin
72
+
match Option.bind forest.={uri} Tree.to_code with
78
73
| None ->
79
74
( Action.report
80
-
~errors:[Reporter.diagnostic (Resource_not_found uri)]
75
+
~errors:[Diagnostic.createf Error ~code:Resource_not_found ""]
81
76
~next_action:Done,
82
77
forest )
83
78
| Some code ->
84
79
let result, errors = Phases.expand forest code in
85
80
forest.={uri} <- Expanded result;
86
81
(Action.report ~errors ~next_action:(Eval uri), forest)
87
-
end
82
+
end
88
83
| Eval_all ->
89
-
let@ () = Reporter.tracef "when evaluating" in
90
84
Logs.debug (fun m -> m "evaluating");
91
-
let result = Phases.eval forest in
92
-
let jobs, errors =
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)
85
+
let errors, results = Phases.eval forest in
86
+
let jobs =
87
+
let@ Eval.{articles; jobs} = List.concat_map @~ results in
88
+
let () =
89
+
let@ article = List.iter @~ articles in
90
+
State.plant_resource ~forest T.(Article article)
91
+
in
92
+
jobs
102
93
in
103
-
Logs.debug (fun m ->
104
-
m "got %d resources " (Seq.length (State.get_all_resources forest)));
105
94
(Action.report ~errors ~next_action:(Run_jobs jobs), forest)
106
-
| Eval uri ->
107
-
let@ () = Reporter.tracef "when evaluating %a" URI.pp uri in
108
-
let result, _err = Phases.eval_only uri forest in
109
-
(Done, result)
95
+
| Eval uri -> begin
96
+
match Phases.eval_only uri forest with
97
+
| Error error -> (Report_errors ([error], Done), forest)
98
+
| Ok _ -> (Done, forest)
99
+
end
110
100
| Plant_assets ->
111
-
let@ () = Reporter.tracef "when planting assets" in
112
101
(* TODO: We really only need to plant the assets that are referred to (look
113
102
for calls to Asset_router.uri_of_asset).*)
114
-
let paths =
115
-
Dir_scanner.scan_asset_directories
116
-
(Eio_util.paths_of_dirs ~env:forest.env forest.config.assets)
117
-
in
103
+
let errors, paths = Eio_util.paths_of_dirs ~env forest.config.assets in
104
+
let paths = Dir_scanner.scan_asset_directories paths in
118
105
Logs.debug (fun m -> m "planting %i assets" (Seq.length paths));
119
106
let module EP = Eio.Path in
120
107
begin
121
108
let@ path = Eio.Fiber.List.iter ~max_fibers:20 @~ List.of_seq paths in
122
-
let@ () = Reporter.easy_run in
123
109
let content = EP.load path in
124
110
let source_path = EP.native_exn path in
125
-
let uri =
111
+
match
126
112
Asset_router.install ~config:forest.config ~source_path ~content
127
-
in
128
-
Logs.debug (fun m -> m "Installed %s at %a" source_path URI.pp uri);
129
-
State.plant_resource (T.Asset {uri; content}) forest
113
+
with
114
+
| Error _ -> failwith "handle asset router install failure"
115
+
| Ok uri ->
116
+
Logs.debug (fun m -> m "Installed %s at %a" source_path URI.pp uri);
117
+
State.plant_resource ~forest (T.Asset {uri; content})
130
118
end;
131
119
(Done, forest)
132
120
| Plant_foreign ->
133
-
let@ () = Reporter.tracef "when planting foreign forest" in
134
121
Logs.debug (fun m -> m "Planting foreign forests");
135
-
let result, err = Phases.implant_foreign forest in
136
-
(Report_errors (err, Done), result)
122
+
let errors = Phases.implant_foreign ~forest in
123
+
(Report_errors (errors, Done), forest)
137
124
| Run_jobs jobs ->
138
125
Phases.run_jobs forest jobs;
139
126
(Done, forest)
140
127
| Load_tree path ->
141
-
let@ () = Reporter.tracef "when loading %a" Eio.Path.pp path in
142
128
let doc = Imports.load_tree path in
143
129
Logs.debug (fun m -> m "%s" (Lsp.Text_document.text doc));
144
130
let lsp_uri = Lsp.Text_document.documentUri doc in
···
146
132
forest.={uri} <- Document doc;
147
133
(Parse lsp_uri, forest)
148
134
| Parse uri ->
149
-
let@ () = Reporter.tracef "when parsing %s" (Lsp.Uri.to_string uri) in
150
135
Logs.debug (fun m -> m "Reparsing");
151
136
let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url uri in
152
137
begin match Option.bind forest.={uri} Tree.to_doc with
···
163
148
end
164
149
| None -> (
165
150
match Imports.resolve_uri_to_code forest uri with
166
-
| None -> Reporter.fatal (Resource_not_found uri)
167
-
| Some code ->
151
+
| Ok code ->
168
152
Imports.fixup code forest;
169
153
forest.={uri} <- Parsed code;
170
-
(Expand uri, forest))
154
+
(Expand uri, forest)
155
+
| Error errors -> (Report_errors (errors, Expand uri), forest))
171
156
end
172
157
| Done -> (Done, forest)
173
158
174
159
let run_until_done a s : State.t =
175
-
let fatal d =
176
-
Reporter.Tty.display d;
177
-
exit 1
178
-
in
179
-
let emit = Reporter.Tty.display in
180
-
Reporter.run ~emit ~fatal @@ fun () ->
181
160
let rec go action state =
182
161
let new_action, new_state = update action state in
183
162
match action with
···
193
172
194
173
let any_fatal =
195
174
List.fold_left
196
-
Asai.Diagnostic.(fun acc x -> acc || x.severity = Error || x.severity = Bug)
175
+
Grace.Diagnostic.(
176
+
fun acc x -> acc || x.severity = Error || x.severity = Bug)
197
177
false
198
178
199
179
let batch_run ~env ~(config : Config.t) ~dev =
···
209
189
| Report_errors (errors, _) ->
210
190
assert (List.length errors > 0);
211
191
Logs.debug (fun m -> m "got %d errors" (List.length errors));
212
-
List.iter Reporter.Tty.display errors;
192
+
List.iter
193
+
(fun error ->
194
+
Format.printf "%a@."
195
+
Grace_ansi_renderer.(
196
+
pp_diagnostic ?config:None ?code_to_string:None)
197
+
error)
198
+
errors;
213
199
if any_fatal errors then go (Quit Fail) new_state
214
200
else go new_action new_state
215
201
| _ -> go new_action new_state
+36
-31
lib/compiler/Eio_util.ml
+36
-31
lib/compiler/Eio_util.ml
···
5
5
*)
6
6
7
7
open Eio
8
-
open Forester_prelude
9
8
open Forester_core
9
+
open Message
10
10
11
11
let path_of_dir ~env dir =
12
12
try
13
13
let path = Path.(Eio.Stdenv.fs env / Unix.realpath dir) in
14
14
assert (Path.is_directory path);
15
-
path
15
+
Ok path
16
16
with
17
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]
18
+
error
19
+
@@ Diagnostic.createf Error ~code:IO_error "%s: %s" (Unix.error_message e) m
21
20
| Assert_failure (_, _, _) ->
22
-
Reporter.fatal Configuration_error
23
-
~extra_remarks:[Asai.Diagnostic.loctextf "%s is not a directory" dir]
21
+
error
22
+
@@ Diagnostic.createf Error ~code:Configuration_error
23
+
"%s is not a directory" dir
24
24
25
25
let path_of_file ~env file =
26
26
try
27
27
let path = Path.(Eio.Stdenv.fs env / Unix.realpath file) in
28
28
assert (Path.is_file path);
29
-
path
29
+
Ok path
30
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]
31
+
error
32
+
@@ Diagnostic.createf ~code:Configuration_error Error "%s: %s"
33
+
(Unix.error_message e) m
34
+
35
+
let paths_of_dirs ~env =
36
+
List.partition_map
37
+
( path_of_dir ~env >>> function
38
+
| Ok path -> right path
39
+
| Error err -> left err )
34
40
35
-
let paths_of_dirs ~env = List.map (path_of_dir ~env)
36
-
let paths_of_files ~env = List.map (path_of_file ~env)
41
+
let paths_of_files ~env =
42
+
List.partition_map
43
+
( path_of_file ~env >>> function
44
+
| Ok path -> right path
45
+
| Error err -> left err )
37
46
38
47
module NullSink : Flow.Pi.SINK with type t = unit = struct
39
48
type t = unit
···
87
96
let try_create_dir ~cwd dname =
88
97
let ( / ) = Path.( / ) in
89
98
if Eio.Path.is_directory (cwd / dname) then
90
-
Reporter.emit Initialization_warning
91
-
~extra_remarks:[Asai.Diagnostic.loctextf "`%s` already exists" dname]
99
+
error
100
+
@@ Diagnostic.createf Note ~code:Initialization_warning
101
+
"`%s` already exists" dname
92
102
else
93
-
try Eio.Path.mkdir ~perm:0o755 (cwd / dname)
103
+
try ok @@ Eio.Path.mkdir ~perm:0o755 (cwd / dname)
94
104
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
-
]
105
+
error
106
+
@@ Diagnostic.createf Note ~code:Initialization_warning
107
+
"Failed to create directory `%s`: %a" dname Eio.Exn.pp exn
101
108
102
109
let try_create_file ~cwd ?(content = "") fname =
103
110
let ( / ) = Path.( / ) in
104
111
if Eio.Path.is_file (cwd / fname) then
105
-
Forester_core.Reporter.emit Initialization_warning
106
-
~extra_remarks:[Asai.Diagnostic.loctextf "`%s` already exists" fname]
112
+
error
113
+
@@ Diagnostic.createf Error ~code:Initialization_warning
114
+
"`%s` already exists" fname
107
115
else
108
-
try Eio.Path.save ~create:(`Exclusive 0o644) (cwd / fname) content
116
+
try ok @@ Eio.Path.save ~create:(`Exclusive 0o644) (cwd / fname) content
109
117
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
-
]
118
+
error
119
+
@@ Diagnostic.createf Error ~code:Initialization_warning
120
+
"Failed to create file `%s`: %a" fname Eio.Exn.pp exn
116
121
117
122
(* TODO: test this! *)
118
123
let copy_to_dir ~env ~cwd ~source ~dest_dir =
+7
-6
lib/compiler/Eio_util.mli
+7
-6
lib/compiler/Eio_util.mli
···
5
5
*)
6
6
7
7
open Eio
8
+
open Forester_core
8
9
9
10
(* val ( / ) : ([> Fs.dir_ty ] as 'a) Path.t -> string -> 'a Path.t *)
10
11
11
12
val path_of_dir :
12
-
env:< fs : ([> Fs.dir_ty] as 'a) Path.t ; .. > -> string -> 'a Path.t
13
+
env:< fs : ([> Fs.dir_ty] as 'a) Path.t ; .. > -> string -> 'a Path.t res
13
14
14
15
val paths_of_dirs :
15
16
env:< fs : ([> Fs.dir_ty] as 'a) Path.t ; .. > ->
16
17
string list ->
17
-
'a Path.t list
18
+
error list * 'a Path.t list
18
19
19
20
val path_of_file :
20
-
env:< fs : ([> Fs.dir_ty] as 'a) Path.t ; .. > -> string -> 'a Path.t
21
+
env:< fs : ([> Fs.dir_ty] as 'a) Path.t ; .. > -> string -> 'a Path.t res
21
22
22
23
val paths_of_files :
23
24
env:< fs : ([> Fs.dir_ty] as 'a) Path.t ; .. > ->
24
25
string list ->
25
-
'a Path.t list
26
+
error list * 'a Path.t list
26
27
27
28
val null_sink : unit -> Flow.sink_ty Resource.t
28
29
···
44
45
unit
45
46
46
47
val file_exists : [> Fs.dir_ty] Path.t -> bool
47
-
val try_create_dir : cwd:[> Fs.dir_ty] Path.t -> string -> unit
48
+
val try_create_dir : cwd:[> Fs.dir_ty] Path.t -> string -> unit res
48
49
49
50
val try_create_file :
50
-
cwd:[> Fs.dir_ty] Path.t -> ?content:string -> string -> unit
51
+
cwd:[> Fs.dir_ty] Path.t -> ?content:string -> string -> unit res
51
52
52
53
val copy_to_dir :
53
54
env:< process_mgr : [> [> `Generic] Process.mgr_ty] Process.mgr ; .. > ->
+425
-326
lib/compiler/Eval.ml
+425
-326
lib/compiler/Eval.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Forester_prelude
8
7
open Forester_core
8
+
open Message
9
+
open Result.Syntax
9
10
10
11
open struct
11
12
module T = Types
···
16
17
type located = Value.t Range.located
17
18
end
18
19
19
-
let extract_content (node : located) =
20
-
match node.value with
21
-
| Value.Content content -> content
20
+
let empty_label ~range = Diagnostic.Label.createf ~priority:Primary ~range ""
21
+
22
+
let type_error ~expected ~got ~range =
23
+
let got =
24
+
match got with
25
+
| Some got -> Format.asprintf "this value is of type %a" Value.pp got
26
+
| None -> ""
27
+
in
28
+
match range with
29
+
| None -> error @@ Diagnostic.createf Error ~code:Type_error ""
30
+
| Some range ->
31
+
error
32
+
@@ Diagnostic.(
33
+
createf Error ~code:Type_error
34
+
~labels:
35
+
[
36
+
Label.createf ~range ~priority:Primary
37
+
"this value is of type %s, but expected something of type %a"
38
+
got
39
+
(Format.pp_print_list pp_expected_value)
40
+
expected;
41
+
]
42
+
"mismatched type")
43
+
44
+
let type_errorf ~range =
45
+
error
46
+
@@ Diagnostic.(createf Error ~code:Type_error ~labels:[empty_label ~range])
47
+
48
+
let extract_content ({value; range} : located) =
49
+
match value with
50
+
| Value.Content content -> ok content
22
51
| v ->
23
-
Reporter.fatal ?loc:node.loc
24
-
(Type_error {expected = [Content]; got = Some v})
52
+
let expected = [Content] in
53
+
let got = Some v in
54
+
let _ = range in
55
+
type_error ~expected ~got ~range
25
56
26
-
let extract_text_loc (node : located) : string Range.located =
27
-
let content = extract_content node in
57
+
let extract_text_loc ({range; _} as node : located) : string Range.located res =
58
+
let* content = extract_content node in
28
59
let rec loop acc = function
29
60
| [] -> Option.some @@ String.concat "" @@ Bwd.prepend acc []
30
61
| (T.Text txt | T.CDATA txt) :: content -> loop (Bwd.snoc acc txt) content
···
32
63
| _ -> None
33
64
in
34
65
match loop Emp (T.extract_content content) with
35
-
| Some txt -> {value = String.trim txt; loc = node.loc}
66
+
| Some txt -> ok Range.{value = String.trim txt; range = node.range}
36
67
| None ->
37
-
Reporter.fatal ?loc:node.loc (Type_error {expected = [Text]; got = None})
68
+
let expected = [Text] in
69
+
let got = None in
70
+
let _ = range in
71
+
type_error ~expected ~got ~range
38
72
39
-
let extract_text (node : located) : string = (extract_text_loc node).value
73
+
let extract_text (node : located) : string res =
74
+
let* {value; _} = extract_text_loc node in
75
+
ok value
40
76
41
-
let extract_obj_ptr (x : located) =
42
-
match x.value with
43
-
| Obj sym -> sym
44
-
(* TODO: Rephrase, should be something like "this is a thing of type foo,
45
-
cannot access method bar"*)
77
+
let extract_obj_ptr ({value; range} : located) =
78
+
match value with
79
+
| Obj sym -> ok sym
46
80
| other ->
47
-
Reporter.fatal ?loc:x.loc (Type_error {expected = [Obj]; got = Some other})
81
+
let expected = [Obj] in
82
+
let got = Some other in
83
+
type_error ~expected ~got ~range
48
84
49
-
let extract_sym (x : located) =
50
-
match x.value with
51
-
| Sym sym -> sym
85
+
let extract_sym ({value; range} : located) =
86
+
match value with
87
+
| Sym sym -> ok sym
52
88
| other ->
53
-
Reporter.fatal ?loc:x.loc (Type_error {expected = [Sym]; got = Some other})
89
+
let expected = [Sym] in
90
+
let got = Some other in
91
+
type_error ~expected ~got ~range
54
92
55
-
let extract_bool (x : located) =
56
-
match x.value with
57
-
| Content (T.Content [Text "true"]) -> true
58
-
| Content (T.Content [Text "false"]) -> false
93
+
let extract_bool ({value; range} : located) =
94
+
match value with
95
+
| Content (T.Content [Text "true"]) -> ok true
96
+
| Content (T.Content [Text "false"]) -> ok false
59
97
| other ->
60
-
Reporter.fatal ?loc:x.loc (Type_error {expected = [Bool]; got = Some other})
98
+
let expected = [Bool] in
99
+
let got = Some other in
100
+
type_error ~expected ~got ~range
61
101
62
102
let default_backmatter ~(uri : URI.t) : T.content =
63
103
let vtx = T.Uri_vertex uri in
···
83
123
make_section "Contributions" @@ Builtin_queries.contributions_datalog vtx;
84
124
]
85
125
86
-
type result = {
126
+
type eval_result = {
87
127
articles: T.content T.article list;
88
128
jobs: Job.job Range.located list;
89
129
}
···
125
165
Some {node with value = [node]}
126
166
| _ -> None
127
167
128
-
let pop_arg ~env ~loc =
168
+
let pop_arg ~env ~range =
129
169
match pop_arg_opt ~env with
130
-
| Some arg -> arg
131
-
| None -> Reporter.fatal ?loc (Type_error {got = None; expected = [Argument]})
170
+
| Some arg -> ok arg
171
+
| None ->
172
+
let got = None in
173
+
let expected = [Argument] in
174
+
type_error ~got ~expected ~range
132
175
133
176
let initial_eval_env config frontmatter : eval_env =
134
177
{
···
143
186
tape = ref [];
144
187
}
145
188
146
-
let get_current_uri ~env ~loc =
189
+
let get_current_uri ~env ~range =
147
190
match env.frontmatter.contents.uri with
148
-
| Some uri -> uri
191
+
| Some uri -> ok uri
149
192
| None ->
150
-
Reporter.fatal ?loc Internal_error
151
-
~extra_remarks:[Asai.Diagnostic.loctext "No uri for tree"]
193
+
error
194
+
@@ Diagnostic.createf Error ~code:Internal_error
195
+
~labels:
196
+
(Option.fold
197
+
~some:(fun range -> [empty_label ~range])
198
+
~none:[] range)
199
+
"No uri for tree"
152
200
153
-
let get_transclusion_flags ~env ~loc =
201
+
let get_transclusion_flags ~env ~range =
154
202
let get_bool key =
155
-
let@ value = Option.map @~ Symbol_map.find_opt key env.dyn_env in
156
-
extract_bool @@ Range.locate_opt loc value
203
+
let@ value = Option.bind @@ Symbol_map.find_opt key env.dyn_env in
204
+
Result.to_option @@ extract_bool @@ Range.locate_opt range value
157
205
in
158
206
let module S = Expand.Builtins.Transclude in
159
207
let open Option_util in
···
168
216
override (get_bool S.show_metadata_sym) flags.metadata_shown;
169
217
}
170
218
171
-
let resolve_uri ~env ~loc:_ str =
219
+
let resolve_uri ~env ~range str =
172
220
match URI.of_string_exn str with
173
221
| uri -> (
174
222
(* If the URI is just a single component without anything else, we should
175
223
treat it as a link to a local tree. *)
176
224
match (URI.scheme uri, URI.host uri, URI.path_components uri) with
177
-
| None, None, ([] | [_]) ->
178
-
let uri = URI_scheme.named_uri ~base:env.config.url str in
179
-
Result.ok uri
180
-
| _ -> Ok uri
181
-
| exception _ -> Error "Invalid URI")
225
+
| None, None, ([] | [_]) -> ok @@ URI.named_uri ~base:env.config.url str
226
+
| _ -> ok uri
227
+
| exception _ ->
228
+
error
229
+
@@ Diagnostic.createf Error ~code:Invalid_URI
230
+
~labels:
231
+
(Option.fold range
232
+
~some:(fun range -> [empty_label ~range])
233
+
~none:[])
234
+
"Invalid URI: %s" str)
182
235
183
-
let extract_uri (node : located) =
184
-
let text = extract_text node in
185
-
resolve_uri ~loc:node.loc text
236
+
let extract_uri ~env ({range; _} as node : located) =
237
+
let* text = extract_text node in
238
+
resolve_uri ~env ~range text
186
239
187
-
let extract_dx_term (node : located) =
188
-
match node.value with
189
-
| Dx_var name -> Datalog_expr.Var name
190
-
| Dx_const vtx -> Datalog_expr.Const vtx
191
-
(* | other -> Reporter.fatalf Type_error "Expected datalog term" *)
240
+
let extract_dx_term ({value; range} : located) =
241
+
match value with
242
+
| Dx_var name -> ok @@ Datalog_expr.Var name
243
+
| Dx_const vtx -> ok @@ Datalog_expr.Const vtx
192
244
| other ->
193
-
Reporter.fatal ?loc:node.loc
194
-
(Type_error {expected = [Datalog_term]; got = Some other})
245
+
let expected = [Datalog_term] in
246
+
let got = Some other in
247
+
type_error ~got ~expected ~range
195
248
196
-
let extract_dx_prop (node : located) =
197
-
match node.value with
198
-
| Dx_prop prop -> prop
199
-
(* | _ -> Reporter.fatalf Type_error "Expected datalog proposition" *)
249
+
let extract_dx_prop ({value; range} : located) =
250
+
match value with
251
+
| Dx_prop prop -> ok prop
200
252
| other ->
201
-
Reporter.fatal ?loc:node.loc
202
-
(Type_error {expected = [Dx_prop]; got = Some other})
253
+
let expected = [Dx_prop] in
254
+
let got = Some other in
255
+
type_error ~got ~expected ~range
203
256
204
-
let extract_dx_sequent (node : located) =
205
-
match node.value with
206
-
| Dx_sequent sequent -> sequent
257
+
let extract_dx_sequent ({value; range} : located) =
258
+
match value with
259
+
| Dx_sequent sequent -> ok sequent
207
260
| other ->
208
-
Reporter.fatal ?loc:node.loc
209
-
(Type_error {expected = [Dx_sequent]; got = Some other})
261
+
let expected = [Dx_sequent] in
262
+
let got = Some other in
263
+
type_error ~got ~expected ~range
210
264
211
265
let extract_vertex ~env ~type_ (node : located) =
212
266
match type_ with
213
-
| `Content -> Ok (T.Content_vertex (extract_content node))
267
+
| `Content ->
268
+
let* node = extract_content node in
269
+
ok (T.Content_vertex node)
214
270
| `Uri ->
215
271
let@ uri = Result.map @~ extract_uri ~env node in
216
272
T.Uri_vertex uri
···
221
277
222
278
let rec process_tape ~env =
223
279
match pop_node_opt ~env with
224
-
| None -> Value.Content (T.Content [])
280
+
| None -> ok @@ Value.Content (T.Content [])
225
281
| Some node -> eval_node ~env node
226
282
227
283
and eval_tape ~env tape = process_tape ~env:{env with tape = ref tape}
228
284
229
-
and eval_pop_arg ~env ~loc = pop_arg ~env ~loc |> Range.map (eval_tape ~env)
285
+
and eval_pop_arg ~env ~range =
286
+
let* {value = syn; range} = pop_arg ~env ~range in
287
+
let* value = eval_tape ~env syn in
288
+
ok Range.{value; range}
230
289
231
-
and pop_content_arg ~env ~loc = eval_pop_arg ~env ~loc |> extract_content
290
+
and pop_content_arg ~env ~range =
291
+
eval_pop_arg ~env ~range |> Result.bind @~ extract_content
232
292
233
-
and pop_text_arg ~env ~loc = eval_pop_arg ~env ~loc |> extract_text
293
+
and pop_text_arg ~env ~range =
294
+
eval_pop_arg ~env ~range |> Result.bind @~ extract_text
234
295
235
-
and pop_text_arg_loc ~env ~loc = eval_pop_arg ~env ~loc |> extract_text_loc
296
+
and pop_text_arg_loc ~env ~range =
297
+
let* arg = eval_pop_arg ~env ~range in
298
+
extract_text_loc arg
236
299
237
-
and eval_node ~env node : Value.t =
238
-
let loc = node.loc in
239
-
match node.value with
240
-
| Var x -> eval_var ~env ~loc x
241
-
| Text str -> emit_content_node ~env ~loc @@ T.Text str
300
+
and eval_node ~env ({value; range} as node) : Value.t res =
301
+
match value with
302
+
| Var x -> eval_var ~env ~range x
303
+
| Text str -> emit_content_node ~env ~range @@ T.Text str
242
304
| Prim p ->
243
-
let content =
244
-
pop_content_arg ~env ~loc |> T.extract_content |> T.trim_whitespace
305
+
let* content =
306
+
pop_content_arg ~env ~range
307
+
|> Result.map T.extract_content
308
+
|> Result.map T.trim_whitespace
245
309
in
246
-
emit_content_node ~env ~loc @@ T.prim p @@ T.Content content
310
+
emit_content_node ~env ~range @@ T.prim p @@ T.Content content
247
311
| Fun (xs, body) ->
248
-
focus_clo ~env ?loc env.lex_env
312
+
focus_clo ~env ?range env.lex_env
249
313
(List.map (fun (info, x) -> (info, Some x)) xs)
250
314
body
251
315
| Ref -> begin
252
-
match eval_pop_arg ~env ~loc |> extract_uri ~env with
316
+
match eval_pop_arg ~env ~range |> Result.bind @~ extract_uri ~env with
253
317
| Ok href ->
254
318
let content =
255
319
T.Content
···
259
323
T.Contextual_number href;
260
324
]
261
325
in
262
-
emit_content_node ~env ~loc @@ Link {href; content}
326
+
emit_content_node ~env ~range @@ Link {href; content}
263
327
| Error _ ->
264
-
Reporter.fatal ?loc
265
-
(Type_error {got = None; expected = [URI]})
266
-
~extra_remarks:[Asai.Diagnostic.loctextf "Expected valid URI in ref"]
328
+
let got = None in
329
+
let expected = [URI] in
330
+
error
331
+
@@ Diagnostic.createf Error ~code:Type_error "Expected valid URI in ref"
267
332
end
268
333
| Link {title; dest} ->
269
-
let dest = {node with value = dest} |> Range.map (eval_tape ~env) in
270
-
let href =
334
+
let* value = eval_tape ~env dest in
335
+
let dest = {node with value} in
336
+
let* href =
271
337
match extract_uri ~env dest with
272
-
| Ok uri -> uri
273
-
| Error error ->
274
-
Reporter.fatal ?loc
275
-
(Type_error {expected = [URI]; got = None})
276
-
~extra_remarks:[Asai.Diagnostic.loctext error]
277
-
(* "Expected valid URI in link") *)
338
+
| Ok uri -> ok uri
339
+
| Error e ->
340
+
let expected = [URI] in
341
+
let got = None in
342
+
error @@ Diagnostic.createf Error ~code:Type_error ""
278
343
in
279
-
let content =
344
+
let* content =
280
345
match title with
281
346
| None ->
282
-
T.Content
283
-
[T.Transclude {href; target = T.Title {empty_when_untitled = false}}]
347
+
ok
348
+
@@ T.Content
349
+
[
350
+
T.Transclude
351
+
{href; target = T.Title {empty_when_untitled = false}};
352
+
]
284
353
| Some title ->
285
-
{node with value = eval_tape ~env title} |> extract_content
354
+
let* value = eval_tape ~env title in
355
+
{node with value} |> extract_content
286
356
in
287
-
emit_content_node ~env ~loc @@ Link {href; content}
357
+
emit_content_node ~env ~range @@ Link {href; content}
288
358
| Math (mode, body) ->
289
-
let content =
290
-
{node with value = eval_tape ~env:{env with mode = TeX_mode} body}
291
-
|> extract_content
359
+
let* content =
360
+
let* value = eval_tape ~env:{env with mode = TeX_mode} body in
361
+
{node with value} |> extract_content
292
362
in
293
-
emit_content_node ~env ~loc @@ KaTeX (mode, content)
363
+
emit_content_node ~env ~range @@ KaTeX (mode, content)
294
364
| Xml_tag (name, attrs, body) ->
295
-
let rec process : _ list -> _ T.xml_attr list = function
365
+
let rec process : _ list -> T.(content xml_attr) list = function
296
366
| [] -> []
297
367
| (key, v) :: attrs ->
298
-
{T.key; value = extract_content {node with value = eval_tape ~env v}}
368
+
{
369
+
T.key;
370
+
value =
371
+
(Result.get_ok
372
+
(* TODO: handle error *)
373
+
@@
374
+
let* value = eval_tape ~env v in
375
+
extract_content {node with value});
376
+
}
299
377
:: process attrs
300
378
in
301
379
let name =
302
380
T.{prefix = name.prefix; uname = name.uname; xmlns = name.xmlns}
303
381
in
304
-
let content = {node with value = eval_tape ~env body} |> extract_content in
305
-
emit_content_node ~env ~loc
382
+
let* content =
383
+
{node with value = Result.get_ok @@ eval_tape ~env body}
384
+
|> extract_content
385
+
in
386
+
emit_content_node ~env ~range
306
387
@@ T.Xml_elt {name; attrs = process attrs; content}
307
388
| TeX_cs cs ->
308
-
emit_content_node ~env ~loc @@ T.Text (Format.asprintf "%a" pp_tex_cs cs)
389
+
emit_content_node ~env ~range @@ T.Text (Format.asprintf "%a" pp_tex_cs cs)
309
390
| Unresolved_ident (visible, path) ->
310
391
let tex_cs_opt =
311
392
match path with [name] -> TeX_cs.parse name | _ -> None
312
393
in
313
394
begin match (env.mode, tex_cs_opt) with
314
395
| TeX_mode, Some (cs, rest) ->
315
-
emit_content_node ~env ~loc
396
+
emit_content_node ~env ~range
316
397
@@ T.Text (Format.asprintf "%a%s" pp_tex_cs cs rest)
317
398
| _, _ ->
318
-
let extra_remarks = Suggestions.create_suggestions ~visible path in
319
-
Reporter.emit ?loc ~extra_remarks (Unresolved_identifier (visible, path));
320
-
emit_content_node ~env ~loc
399
+
let notes = Suggestions.create_suggestions ~visible path in
400
+
let _ = failwith "todo: pass loc" in
401
+
let _ = failwith "todo: use visible, path" in
402
+
let _ =
403
+
error @@ Diagnostic.createf Error ~notes ~code:Unresolved_identifier ""
404
+
in
405
+
let _ = failwith "todo: use yield" in
406
+
emit_content_node ~env ~range
321
407
@@ T.Text (Format.asprintf "\\%a" Resolver.Scope.pp_path path)
322
408
end
323
409
| Transclude ->
324
-
let flags = get_transclusion_flags ~env ~loc in
325
-
let href_arg = eval_pop_arg ~env ~loc in
326
-
let href =
327
-
match extract_uri ~env href_arg with
328
-
| Ok uri -> uri
329
-
| Error _ ->
330
-
Reporter.fatal ?loc
331
-
(Type_error {got = None; expected = [URI]})
332
-
~extra_remarks:
333
-
[Asai.Diagnostic.loctext "Expected valid URI in transclusion"]
410
+
let flags = get_transclusion_flags ~env ~range in
411
+
let* href_arg = eval_pop_arg ~env ~range in
412
+
let* href =
413
+
Result.map_error (fun err ->
414
+
let got = None in
415
+
let expected = [URI] in
416
+
Diagnostic.createf Error ~code:Type_error
417
+
"Expected valid URI in transclusion")
418
+
@@ extract_uri ~env href_arg
334
419
in
335
-
emit_content_node ~env ~loc @@ T.Transclude {href; target = Full flags}
420
+
emit_content_node ~env ~range @@ T.Transclude {href; target = Full flags}
336
421
| Subtree (addr_opt, nodes) ->
337
-
let flags = get_transclusion_flags ~env ~loc in
422
+
let flags = get_transclusion_flags ~env ~range in
338
423
let uri =
339
424
match addr_opt with
340
-
| Some addr -> Some (URI_scheme.named_uri ~base:env.config.url addr)
425
+
| Some addr -> Some (URI.named_uri ~base:env.config.url addr)
341
426
| None -> None
342
427
in
343
-
let subtree = eval_tree_inner ~env ?uri nodes in
428
+
let* subtree = eval_tree_inner ~env ?uri nodes in
344
429
let frontmatter = env.frontmatter in
345
430
let subtree =
346
431
{
···
353
438
| Some uri ->
354
439
Stack.push subtree env.emitted_trees;
355
440
let transclusion = T.{href = uri; target = Full flags} in
356
-
emit_content_node ~env ~loc @@ Transclude transclusion
441
+
emit_content_node ~env ~range @@ Transclude transclusion
357
442
| None ->
358
-
emit_content_node ~env ~loc
443
+
emit_content_node ~env ~range
359
444
@@ T.Section (T.article_to_section ~flags subtree)
360
445
end
361
446
| Results_of_query ->
362
-
let arg = eval_pop_arg ~env ~loc in
447
+
let* arg = eval_pop_arg ~env ~range in
363
448
begin match arg.value with
364
449
| Value.Dx_query query ->
365
-
emit_content_node ~env ~loc @@ Results_of_datalog_query query
450
+
emit_content_node ~env ~range @@ Results_of_datalog_query query
366
451
| other ->
367
-
Reporter.fatal ?loc:arg.loc
368
-
(Type_error {expected = [Dx_query]; got = Some other})
452
+
let expected = [Dx_query] in
453
+
let got = Some other in
454
+
let loc = arg.range in
455
+
error @@ Diagnostic.createf Error ~code:Type_error ""
369
456
end
370
457
| Syndicate_query_as_json_blob ->
371
-
let name = pop_text_arg ~env ~loc in
372
-
let blob_uri =
373
-
URI_scheme.named_uri ~base:env.config.url @@ name ^ ".json"
374
-
in
375
-
let query_arg = eval_pop_arg ~env ~loc in
458
+
let* name = pop_text_arg ~env ~range in
459
+
let blob_uri = URI.named_uri ~base:env.config.url @@ name ^ ".json" in
460
+
let* query_arg = eval_pop_arg ~env ~range in
376
461
begin match query_arg.value with
377
462
| Dx_query query ->
378
463
let job = Job.Syndicate (Json_blob {blob_uri; query}) in
379
-
Stack.push (Range.locate_opt loc job) env.jobs;
464
+
Stack.push (Range.locate_opt range job) env.jobs;
380
465
process_tape ~env
381
466
| other ->
382
-
Reporter.fatal ?loc:query_arg.loc
383
-
(Type_error {expected = [Dx_query]; got = Some other})
467
+
let expected = [Dx_query] in
468
+
let got = Some other in
469
+
let loc = query_arg.range in
470
+
error @@ Diagnostic.createf Error ~code:Type_error ""
384
471
end
385
472
| Syndicate_current_tree_as_atom_feed ->
386
-
let source_uri = get_current_uri ~env ~loc:node.loc in
473
+
let* source_uri = get_current_uri ~env ~range:node.range in
387
474
let feed_uri = URI.append_path_component source_uri "atom.xml" in
388
475
let job = Job.Syndicate (Atom_feed {source_uri; feed_uri}) in
389
-
Stack.push (Range.locate_opt loc job) env.jobs;
476
+
Stack.push (Range.locate_opt range job) env.jobs;
390
477
process_tape ~env
391
478
| Embed_tex ->
392
-
let preamble, body =
479
+
let* preamble, body =
393
480
let env = {env with mode = TeX_mode} in
394
-
let preamble = pop_content_arg ~env ~loc |> TeX_like.string_of_content in
395
-
let body = pop_content_arg ~env ~loc |> TeX_like.string_of_content in
396
-
(preamble, body)
481
+
let* preamble =
482
+
pop_content_arg ~env ~range |> Result.map TeX_like.string_of_content
483
+
in
484
+
let* body =
485
+
pop_content_arg ~env ~range |> Result.map TeX_like.string_of_content
486
+
in
487
+
ok (preamble, body)
397
488
in
398
489
let source = LaTeX_template.to_string ~preamble ~body in
399
490
let hash = Digest.to_hex @@ Digest.string source in
···
428
519
]
429
520
in
430
521
let artefact = T.{hash; content; sources} in
431
-
Stack.push (Range.locate_opt loc (Job.LaTeX_to_svg job)) env.jobs;
432
-
emit_content_node ~env ~loc @@ T.Artefact artefact
522
+
Stack.push (Range.locate_opt range (Job.LaTeX_to_svg job)) env.jobs;
523
+
emit_content_node ~env ~range @@ T.Artefact artefact
433
524
| Route_asset ->
434
-
let Range.{value = source_path; loc = path_loc} =
435
-
pop_text_arg_loc ~env ~loc
525
+
let* Range.{value = source_path; range = path_range} =
526
+
pop_text_arg_loc ~env ~range
436
527
in
437
-
let uri = Asset_router.uri_of_asset ?loc:path_loc ~source_path () in
438
-
emit_content_nodes ~env ~loc @@ [T.Route_of_uri uri]
528
+
let* uri = Asset_router.uri_of_asset ?range:path_range ~source_path () in
529
+
emit_content_nodes ~env ~range @@ [T.Route_of_uri uri]
439
530
| Object {self; methods} ->
440
531
let table =
441
532
let add (name, body) =
···
446
537
in
447
538
let sym = Symbol.named ["obj"] in
448
539
Symbol_table.replace env.heap sym Value.{prototype = None; methods = table};
449
-
focus ~env ?loc:node.loc @@ Value.Obj sym
540
+
focus ~env ?range:node.range @@ Value.Obj sym
450
541
| Patch {obj; self; super; methods} ->
451
-
let obj_ptr =
452
-
{node with value = obj} |> Range.map (eval_tape ~env) |> extract_obj_ptr
542
+
let* obj_ptr =
543
+
let* value = eval_tape ~env obj in
544
+
extract_obj_ptr {node with value}
453
545
in
454
546
let table =
455
547
let add (name, body) =
···
460
552
let sym = Symbol.named ["obj"] in
461
553
Symbol_table.replace env.heap sym
462
554
Value.{prototype = Some obj_ptr; methods = table};
463
-
focus ~env ?loc:node.loc @@ Value.Obj sym
555
+
focus ~env ?range:node.range @@ Value.Obj sym
464
556
| Group (d, body) ->
465
557
let l, r = delim_to_strings d in
466
-
let content =
467
-
let body = extract_content {node with value = eval_tape ~env body} in
468
-
T.Content ((T.Text l :: T.extract_content body) @ [T.Text r])
558
+
let* content =
559
+
let* value = eval_tape ~env body in
560
+
let* body = extract_content {node with value} in
561
+
ok @@ T.Content ((T.Text l :: T.extract_content body) @ [T.Text r])
469
562
in
470
-
focus ~env ?loc:node.loc @@ Value.Content (T.compress_content content)
563
+
focus ~env ?range:node.range @@ Value.Content (T.compress_content content)
471
564
| Call (obj, method_name) ->
472
-
let sym =
473
-
{node with value = obj} |> Range.map (eval_tape ~env) |> extract_obj_ptr
565
+
let* sym =
566
+
let* value = eval_tape ~env obj in
567
+
extract_obj_ptr {node with value}
474
568
in
475
569
let rec call_method ~env (obj : Value.obj) =
476
570
let proto_val = obj.prototype |> Option.map @@ fun ptr -> Value.Obj ptr in
···
494
588
match obj.prototype with
495
589
| Some proto -> call_method ~env @@ Symbol_table.find env.heap proto
496
590
| None ->
497
-
Reporter.fatal ?loc:node.loc (Unbound_method (method_name, obj)))
591
+
let _ = (method_name, obj) in
592
+
let loc = node.range in
593
+
error @@ Diagnostic.createf Error ~code:Unbound_method "")
498
594
in
499
-
let result = call_method ~env @@ Symbol_table.find env.heap sym in
500
-
focus ~env ?loc:node.loc result
595
+
let* result = call_method ~env @@ Symbol_table.find env.heap sym in
596
+
focus ~env ?range:node.range result
501
597
| Put (k, v, body) ->
502
-
let k =
503
-
{node with value = k} |> Range.map (eval_tape ~env) |> extract_sym
504
-
in
505
-
let body =
598
+
let* value = eval_tape ~env k in
599
+
let* k = extract_sym {node with value} in
600
+
let* symbol = eval_tape ~env v in
601
+
let* body =
506
602
eval_tape
507
-
~env:
508
-
{env with dyn_env = Symbol_map.add k (eval_tape ~env v) env.dyn_env}
603
+
~env:{env with dyn_env = Symbol_map.add k symbol env.dyn_env}
509
604
body
510
605
in
511
-
focus ~env ?loc:node.loc body
606
+
focus ~env ?range:node.range body
512
607
| Default (k, v, body) ->
513
-
let k =
514
-
{node with value = k} |> Range.map (eval_tape ~env) |> extract_sym
608
+
let* k =
609
+
let* value = (eval_tape ~env) k in
610
+
extract_sym {node with value}
515
611
in
516
-
let body =
612
+
let* body =
517
613
let upd flenv =
518
-
if Symbol_map.mem k flenv then flenv
519
-
else Symbol_map.add k (eval_tape ~env v) flenv
614
+
if Symbol_map.mem k flenv then ok flenv
615
+
else
616
+
let* v = eval_tape ~env v in
617
+
ok @@ Symbol_map.add k v flenv
520
618
in
521
-
eval_tape ~env:{env with dyn_env = upd env.dyn_env} body
619
+
let* dyn_env = upd env.dyn_env in
620
+
eval_tape ~env:{env with dyn_env} body
522
621
in
523
-
focus ~env ?loc:node.loc body
622
+
focus ~env ?range:node.range body
524
623
| Get k ->
525
-
let k =
526
-
{node with value = k} |> Range.map (eval_tape ~env) |> extract_sym
624
+
let* k =
625
+
let* value = eval_tape ~env k in
626
+
extract_sym {node with value}
527
627
in
528
628
begin match Symbol_map.find_opt k env.dyn_env with
529
-
| None -> Reporter.fatal ?loc:node.loc (Unbound_fluid_symbol k)
530
-
| Some v -> focus ~env ?loc:node.loc v
629
+
| None ->
630
+
let _ = failwith "use k" in
631
+
let loc = node.range in
632
+
error @@ Diagnostic.createf Error ~code:Unbound_fluid_symbol ""
633
+
| Some v -> focus ~env ?range:node.range v
531
634
end
532
-
| Verbatim str -> emit_content_node ~env ~loc @@ CDATA str
635
+
| Verbatim str -> emit_content_node ~env ~range @@ CDATA str
533
636
| Title ->
534
-
let title = pop_content_arg ~env ~loc in
637
+
let* title = pop_content_arg ~env ~range in
535
638
env.frontmatter := {env.frontmatter.contents with title = Some title};
536
639
process_tape ~env
537
640
| Parent ->
538
-
let parent_arg = eval_pop_arg ~env ~loc in
539
-
let parent =
540
-
match extract_uri ~env parent_arg with
541
-
| Ok uri -> uri
542
-
| Error _ ->
543
-
Reporter.fatal ?loc Invalid_URI
544
-
~extra_remarks:
545
-
[Asai.Diagnostic.loctext "Expected valid URI in parent declaration"]
641
+
let* parent_arg = eval_pop_arg ~env ~range in
642
+
let* parent =
643
+
Result.map_error (fun _ ->
644
+
Diagnostic.createf Error ~code:Invalid_URI
645
+
"Expected valid URI in parent declaration")
646
+
@@ extract_uri ~env parent_arg
546
647
in
547
648
env.frontmatter :=
548
649
{env.frontmatter.contents with designated_parent = Some parent};
549
650
process_tape ~env
550
651
| Meta ->
551
-
let k = pop_text_arg ~env ~loc in
552
-
let v = pop_content_arg ~env ~loc in
652
+
let* k = pop_text_arg ~env ~range in
653
+
let* v = pop_content_arg ~env ~range in
553
654
env.frontmatter :=
554
655
{
555
656
env.frontmatter.contents with
···
557
658
};
558
659
process_tape ~env
559
660
| Attribution (role, type_) ->
560
-
let arg = eval_pop_arg ~env ~loc in
561
-
let vertex =
562
-
match extract_vertex ~env ~type_ arg with
563
-
| Ok vtx -> vtx
564
-
| Error _ ->
565
-
let corrected_attribution_code =
566
-
match role with
567
-
| Author -> "\\author/literal"
568
-
| Contributor -> "\\contributor/literal"
569
-
in
570
-
Reporter.emit ?loc Type_warning
571
-
~extra_remarks:
572
-
[
573
-
Asai.Diagnostic.loctextf
574
-
"Expected valid URI in attribution. Use `%s` instead if you \
575
-
intend an unlinked attribution."
576
-
corrected_attribution_code;
577
-
];
578
-
T.Content_vertex (extract_content arg)
661
+
let* arg = eval_pop_arg ~env ~range in
662
+
let* vertex =
663
+
let _ = failwith "todo" in
664
+
let* content = ok @@ T.Content_vertex (extract_content arg) in
665
+
let@ error = Result.map_error @~ extract_vertex ~env ~type_ arg in
666
+
let corrected_attribution_code =
667
+
match role with
668
+
| Author -> "\\author/literal"
669
+
| Contributor -> "\\contributor/literal"
670
+
in
671
+
Diagnostic.createf Error ~code:Type_warning
672
+
"Expected valid URI in attribution. Use `%s` instead if you intend an \
673
+
unlinked attribution."
674
+
corrected_attribution_code
579
675
in
580
676
let attribution = T.{role; vertex} in
581
677
env.frontmatter :=
···
585
681
};
586
682
process_tape ~env
587
683
| Tag type_ ->
588
-
let arg = eval_pop_arg ~env ~loc in
589
-
let vertex =
590
-
match extract_vertex ~env ~type_ arg with
591
-
| Ok vtx -> vtx
592
-
| Error _ ->
593
-
let corrected = "\\tag/content" in
594
-
Reporter.emit ?loc Type_warning
595
-
~extra_remarks:
596
-
[
597
-
Asai.Diagnostic.loctextf
598
-
"Expected valid URI in tag. Use `%s` instead if you intend an \
599
-
unlinked attribution."
600
-
corrected;
601
-
];
602
-
T.Content_vertex (extract_content arg)
684
+
let* arg = eval_pop_arg ~env ~range in
685
+
let* vertex =
686
+
let _ = failwith "todo" in
687
+
let* content = ok @@ T.Content_vertex (extract_content arg) in
688
+
let@ error = Result.map_error @~ extract_vertex ~env ~type_ arg in
689
+
let corrected = "\\tag/content" in
690
+
let _ = range in
691
+
Diagnostic.createf Error ~code:Type_warning
692
+
"Expected valid URI in tag. Use `%s` instead if you intend an unlinked \
693
+
attribution."
694
+
corrected
603
695
in
604
696
env.frontmatter :=
605
697
{
···
608
700
};
609
701
process_tape ~env
610
702
| Date ->
611
-
let date_str = pop_text_arg ~env ~loc in
703
+
let* date_str = pop_text_arg ~env ~range in
612
704
begin match Human_datetime.parse_string date_str with
613
705
| None ->
614
-
Reporter.fatal ?loc:node.loc Parse_error
615
-
~extra_remarks:
616
-
[Asai.Diagnostic.loctextf "Invalid date string `%s`" date_str]
706
+
let loc = node.range in
707
+
error @@ Diagnostic.createf Error ~code:Parse_error ""
708
+
(*"Invalid date string `%s`" date_str*)
617
709
| Some date ->
618
710
env.frontmatter :=
619
711
{
···
623
715
process_tape ~env
624
716
end
625
717
| Number ->
626
-
let num = pop_text_arg ~env ~loc in
718
+
let* num = pop_text_arg ~env ~range in
627
719
env.frontmatter := {env.frontmatter.contents with number = Some num};
628
720
process_tape ~env
629
721
| Taxon ->
630
-
let taxon = Some (pop_content_arg ~env ~loc) in
631
-
env.frontmatter := {env.frontmatter.contents with taxon};
722
+
let* taxon = pop_content_arg ~env ~range in
723
+
env.frontmatter := {env.frontmatter.contents with taxon = Some taxon};
632
724
process_tape ~env
633
-
| Sym sym -> focus ~env ?loc:node.loc @@ Value.Sym sym
725
+
| Sym sym -> focus ~env ?range:node.range @@ Value.Sym sym
634
726
| Dx_prop (rel, args) ->
635
-
let rel = {node with value = eval_tape ~env rel} |> extract_text in
636
-
let args =
637
-
let@ arg = List.map @~ args in
638
-
{node with value = eval_tape ~env arg} |> extract_dx_term
727
+
let* value = eval_tape ~env rel in
728
+
let* rel = extract_text {node with value} in
729
+
let errors, args =
730
+
let@ arg = List_util.error_partition @~ args in
731
+
let* value = eval_tape ~env arg in
732
+
extract_dx_term {node with value}
639
733
in
640
-
focus ~env ?loc:node.loc @@ Dx_prop {rel; args}
734
+
focus ~env ?range:node.range @@ Dx_prop {rel; args}
641
735
| Dx_sequent (conclusion, premises) ->
642
-
let conclusion =
643
-
{node with value = eval_tape ~env conclusion} |> extract_dx_prop
736
+
let* conclusion =
737
+
let* value = eval_tape ~env conclusion in
738
+
extract_dx_prop {node with value}
644
739
in
645
-
let premises =
646
-
let@ premise = List.map @~ premises in
647
-
{node with value = eval_tape ~env premise} |> extract_dx_prop
740
+
let errors, premises =
741
+
let@ premise = List_util.error_partition @~ premises in
742
+
let* value = eval_tape ~env premise in
743
+
extract_dx_prop {node with value}
648
744
in
649
-
focus ~env ?loc:node.loc @@ Dx_sequent {conclusion; premises}
745
+
focus ~env ?range:node.range @@ Dx_sequent {conclusion; premises}
650
746
| Dx_query (var, positives, negatives) ->
651
-
let positives =
652
-
let@ premise = List.map @~ positives in
653
-
{node with value = eval_tape ~env premise} |> extract_dx_prop
747
+
let errors, positives =
748
+
let@ premise = List_util.error_partition @~ positives in
749
+
let* value = eval_tape ~env premise in
750
+
extract_dx_prop {node with value}
654
751
in
655
-
let negatives =
656
-
let@ premise = List.map @~ negatives in
657
-
{node with value = eval_tape ~env premise} |> extract_dx_prop
752
+
let errors, negatives =
753
+
let@ premise = List_util.error_partition @~ negatives in
754
+
let* value = eval_tape ~env premise in
755
+
extract_dx_prop {node with value}
658
756
in
659
-
focus ~env ?loc:node.loc @@ Dx_query {var; positives; negatives}
660
-
| Dx_var name -> focus ~env ?loc:node.loc @@ Dx_var name
757
+
focus ~env ?range:node.range @@ Dx_query {var; positives; negatives}
758
+
| Dx_var name -> focus ~env ?range:node.range @@ Dx_var name
661
759
| Dx_const (type_, arg) ->
662
-
let arg = {node with value = eval_tape ~env arg} in
663
-
let const =
760
+
let* value = eval_tape ~env arg in
761
+
let arg = {node with value} in
762
+
let* const =
664
763
match type_ with
665
-
| `Content -> T.Content_vertex (extract_content arg)
764
+
| `Content ->
765
+
let* vtx = extract_content arg in
766
+
ok @@ T.Content_vertex vtx
666
767
| `Uri -> begin
667
768
match extract_uri ~env arg with
668
-
| Ok uri -> T.Uri_vertex uri
769
+
| Ok uri -> ok @@ T.Uri_vertex uri
669
770
| Error _ ->
670
-
Reporter.fatal ?loc:node.loc Invalid_URI
671
-
~extra_remarks:
672
-
[
673
-
Asai.Diagnostic.loctext
674
-
"Expected valid URI in datalog constant expression.";
675
-
]
771
+
let loc = range in
772
+
error
773
+
@@ Diagnostic.createf Error ~code:Invalid_URI
774
+
"Expected valid URI in datalog constant expression."
676
775
end
677
776
in
678
-
focus ~env ?loc:node.loc @@ Dx_const const
777
+
focus ~env ?range:node.range @@ Dx_const const
679
778
| Dx_execute ->
680
-
let script = eval_pop_arg ~env ~loc:node.loc |> extract_dx_sequent in
681
-
emit_content_node ~env ~loc:node.loc @@ T.Datalog_script [script]
779
+
let* script =
780
+
eval_pop_arg ~env ~range:node.range |> Result.bind @~ extract_dx_sequent
781
+
in
782
+
emit_content_node ~env ~range:node.range @@ T.Datalog_script [script]
682
783
| Current_tree ->
683
-
emit_content_node ~env ~loc:node.loc
684
-
@@ T.Uri (get_current_uri ~env ~loc:node.loc)
784
+
let* uri = get_current_uri ~env ~range:node.range in
785
+
emit_content_node ~env ~range:node.range @@ T.Uri uri
685
786
686
-
and eval_var ~env ~loc (x : string) =
787
+
and eval_var ~env ~range (x : string) : Value.t res =
687
788
match String_map.find_opt x env.lex_env with
688
-
| Some v -> focus ~env ?loc v
689
-
| None -> Reporter.fatal ?loc (Unbound_variable x)
789
+
| Some v -> focus ~env ?range v
790
+
| None ->
791
+
let unbound_variable = x in
792
+
let loc = range in
793
+
error @@ Diagnostic.createf Error ~code:Unbound_variable ""
690
794
691
-
and focus ~env ?loc = function
692
-
| Clo (rho, xs, body) -> focus_clo ~env ?loc rho xs body
795
+
and focus ~env ?range = function
796
+
| Clo (rho, xs, body) -> focus_clo ~env ?range rho xs body
693
797
| Content content -> begin
694
-
match process_tape ~env with
798
+
let* v = process_tape ~env in
799
+
match v with
695
800
| Content content' ->
696
-
Value.Content (T.concat_compressed_content content content')
697
-
| value -> value
801
+
ok @@ Value.Content (T.concat_compressed_content content content')
802
+
| value -> ok value
698
803
end
699
804
| ( Sym _ | Obj _ | Dx_prop _ | Dx_sequent _ | Dx_query _ | Dx_var _
700
805
| Dx_const _ ) as v -> begin
701
-
match process_tape ~env with
702
-
| Content content when T.strip_whitespace content = T.Content [] -> v
806
+
let* c = process_tape ~env in
807
+
match c with
808
+
| Content content when T.strip_whitespace content = T.Content [] -> ok v
703
809
| v' ->
704
-
Reporter.fatal ?loc
705
-
(Type_error {expected = []; got = None})
706
-
~extra_remarks:
707
-
[
708
-
Asai.Diagnostic.loctextf "Expected solitary node but got %a / %a"
709
-
Value.pp v Value.pp v';
710
-
]
810
+
let expected = [] in
811
+
let got = None in
812
+
let loc = range in
813
+
error
814
+
@@ Diagnostic.createf Error ~code:Type_error
815
+
"Expected solitary node but got %a / %a" Value.pp v Value.pp v'
711
816
end
712
817
713
-
and focus_clo ~env ?loc rho (xs : string option binding list) body =
818
+
and focus_clo ~env ?range rho (xs : string option binding list) body =
714
819
match xs with
715
-
| [] -> focus ~env ?loc @@ eval_tape ~env:{env with lex_env = rho} body
716
-
| (info, y) :: ys -> (
820
+
| [] ->
821
+
Result.bind
822
+
(eval_tape ~env:{env with lex_env = rho} body)
823
+
(focus ~env ?range)
824
+
| (info, y) :: ys -> begin
717
825
match pop_arg_opt ~env with
718
826
| Some arg ->
719
-
let yval =
827
+
let* yval =
720
828
match info with
721
829
| Strict -> eval_tape ~env arg.value
722
-
| Lazy -> Clo (env.lex_env, [(Strict, None)], arg.value)
830
+
| Lazy -> ok @@ Value.Clo (env.lex_env, [(Strict, None)], arg.value)
723
831
in
724
832
let rhoy =
725
833
match y with Some y -> String_map.add y yval rho | None -> rho
726
834
in
727
-
focus_clo ~env ?loc rhoy ys body
835
+
focus_clo ~env ?range rhoy ys body
728
836
| None -> begin
729
-
match process_tape ~env with
837
+
let* c = process_tape ~env in
838
+
match c with
730
839
| Content nodes when T.strip_whitespace nodes = T.Content [] ->
731
-
Clo (rho, xs, body)
840
+
ok @@ Value.Clo (rho, xs, body)
732
841
| _ ->
733
-
Reporter.fatal ?loc Missing_argument
734
-
~extra_remarks:
735
-
[
736
-
Asai.Diagnostic.loctextf "Expected %i additional arguments"
737
-
(List.length xs);
738
-
]
739
-
end)
842
+
let loc = range in
843
+
error
844
+
@@ Diagnostic.createf Error ~code:Missing_argument
845
+
"Expected %i additional arguments" (List.length xs)
846
+
end
847
+
end
740
848
741
-
and emit_content_nodes ~env ~loc content =
742
-
focus ~env ?loc @@ Content (T.Content (T.compress_nodes content))
849
+
and emit_content_nodes ~env ~range content =
850
+
focus ~env ?range @@ Content (T.Content (T.compress_nodes content))
743
851
744
-
and emit_content_node ~env ~loc content = emit_content_nodes ~env ~loc [content]
852
+
and emit_content_node ~env ~range content : _ res =
853
+
emit_content_nodes ~env ~range [content]
745
854
746
855
and eval_tree_inner ~env ?(uri : URI.t option) (syn : Syn.t) :
747
-
T.content T.article =
856
+
T.content T.article res =
748
857
let attribution_is_author attr =
749
858
match T.(attr.role) with T.Author -> true | _ -> false
750
859
in
···
758
867
()
759
868
in
760
869
let env = {env with frontmatter = ref frontmatter} in
761
-
let mainmatter =
762
-
{value = eval_tape ~env syn; loc = None} |> extract_content
870
+
let* mainmatter =
871
+
let* value = eval_tape ~env syn in
872
+
extract_content {value; range = None}
763
873
in
764
874
let frontmatter = env.frontmatter.contents in
765
875
let backmatter =
766
876
match uri with Some uri -> default_backmatter ~uri | None -> Content []
767
877
in
768
-
T.{frontmatter; mainmatter; backmatter}
878
+
ok T.{frontmatter; mainmatter; backmatter}
769
879
770
880
let empty_result = {articles = []; jobs = []}
771
881
772
882
let eval_tree ~(config : Config.t) ~(uri : URI.t) ~(source_path : string option)
773
-
(tree : Syn.t) : result * Reporter.diagnostic list =
774
-
let diagnostics = ref [] in
775
-
let push d = diagnostics := d :: !diagnostics in
776
-
let res =
777
-
Reporter.run
778
-
~fatal:(fun d ->
779
-
push d;
780
-
empty_result)
781
-
~emit:push
782
-
@@ fun () ->
783
-
let fm = T.default_frontmatter ~uri ?source_path () in
784
-
let env = initial_eval_env config (ref fm) in
785
-
let main = eval_tree_inner ~env ~uri tree in
786
-
let side = env.emitted_trees |> Stack.to_seq |> List.of_seq in
787
-
let jobs = env.jobs |> Stack.to_seq |> List.of_seq in
788
-
{articles = main :: side; jobs}
789
-
in
790
-
(res, !diagnostics)
883
+
(tree : Syn.t) : eval_result res =
884
+
let fm = T.default_frontmatter ~uri ?source_path () in
885
+
let env = initial_eval_env config (ref fm) in
886
+
let* main = eval_tree_inner ~env ~uri tree in
887
+
let side = env.emitted_trees |> Stack.to_seq |> List.of_seq in
888
+
let jobs = env.jobs |> Stack.to_seq |> List.of_seq in
889
+
ok {articles = main :: side; jobs}
+2
-2
lib/compiler/Eval.mli
+2
-2
lib/compiler/Eval.mli
···
7
7
open Forester_core
8
8
module T := Types
9
9
10
-
type result = {
10
+
type eval_result = {
11
11
articles: T.content T.article list;
12
12
jobs: Job.job Range.located list;
13
13
}
···
18
18
uri:URI.t ->
19
19
source_path:string option ->
20
20
Syn.t ->
21
-
result * Reporter.diagnostic list
21
+
eval_result res
+91
-91
lib/compiler/Expand.ml
+91
-91
lib/compiler/Expand.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Forester_prelude
8
7
open Forester_core
9
8
open State.Syntax
10
9
module Unit_map = URI.Map
10
+
open Message
11
+
12
+
let emit = Collect_errors.yield
11
13
12
14
open struct
13
15
module R = Resolver
16
+
module T = Types
14
17
module Sc = R.Scope
15
18
end
16
19
···
25
28
end
26
29
27
30
let rec expand_method_calls (base : Syn.t) : Code.t -> Syn.t * Code.t = function
28
-
| {value = Hash_ident x; loc} :: rest ->
29
-
let base = [Range.{value = Syn.Call (base, x); loc}] in
31
+
| {value = Hash_ident x; range} :: rest ->
32
+
let base = [Range.{value = Syn.Call (base, x); range}] in
30
33
expand_method_calls base rest
31
34
| rest -> (base, rest)
32
35
33
36
type 'a Effect.t += Entered_range : Range.t option -> unit Effect.t
34
37
35
-
let entered_range (loc : Range.t option) : unit =
36
-
Effect.perform @@ Entered_range loc
38
+
let entered_range (range : Range.t option) : unit =
39
+
Effect.perform @@ Entered_range range
37
40
38
41
let rec expand_eff ~(forest : State.t) : Code.t -> Syn.t = function
39
42
| [] -> []
40
43
| node :: rest -> begin
41
-
entered_range node.loc;
44
+
entered_range node.range;
42
45
match node.value with
43
46
| Hash_ident x ->
44
47
{node with value = Text ("#" ^ x)} :: expand_eff ~forest rest
···
55
58
expand_eff ~forest rest
56
59
| Group (Squares, x) -> begin
57
60
match x with
58
-
| [{value = Group (Squares, y); loc = yloc}] ->
59
-
entered_range yloc;
61
+
| [{value = Group (Squares, y); range = yrange}] ->
62
+
entered_range yrange;
60
63
let y = expand_eff ~forest y in
61
64
{node with value = Link {dest = y; title = None}}
62
65
:: expand_eff ~forest rest
63
66
| _ ->
64
67
let x = expand_eff ~forest x in
65
68
begin match rest with
66
-
| {value = Group (Parens, y); loc = yloc} :: rest ->
67
-
entered_range yloc;
69
+
| {value = Group (Parens, y); range = yrange} :: rest ->
70
+
entered_range yrange;
68
71
let y = expand_eff ~forest y in
69
72
(* TODO: merge the ranges *)
70
73
{node with value = Link {dest = y; title = Some x}}
···
85
88
let x = expand_eff ~forest x in
86
89
{node with value = Math (m, x)} :: expand_eff ~forest rest
87
90
| Ident path ->
88
-
let out, rest = expand_method_calls (expand_ident node.loc path) rest in
91
+
let out, rest = expand_method_calls (expand_ident node.range path) rest in
89
92
out @ expand_eff ~forest rest
90
93
| Xml_ident (prefix, uname) ->
91
-
let qname = expand_xml_ident node.loc (prefix, uname) in
94
+
let qname = expand_xml_ident node.range (prefix, uname) in
92
95
let attrs, rest = get_xml_attrs ~forest [] rest in
93
96
let arg_opt, rest = get_arg_opt ~forest rest in
94
97
{
···
105
108
| Alloc x ->
106
109
let symbol = Symbol.named x in
107
110
Sc.include_singleton x
108
-
(Term [Range.locate_opt node.loc (Syn.Sym symbol)], node.loc);
111
+
(Term [Range.locate_opt node.range (Syn.Sym symbol)], node.range);
109
112
expand_eff ~forest rest
110
113
| Put (k, v) ->
111
-
let k = expand_ident node.loc k in
114
+
let k = expand_ident node.range k in
112
115
let v = expand_eff ~forest v in
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
116
+
(* TODO: merge rangeations! the resulting rangeation is narrowed to the 'put'
117
+
node, and therefore breaks the nesting of rangeations. That could lead to
115
118
trouble in the future. *)
116
119
[{node with value = Put (k, v, expand_eff ~forest rest)}]
117
120
| Default (k, v) ->
118
-
let k = expand_ident node.loc k in
121
+
let k = expand_ident node.range k in
119
122
let v = expand_eff ~forest v in
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
123
+
(* TODO: merge rangeations! the resulting rangeation is narrowed to the 'put'
124
+
node, and therefore breaks the nesting of rangeations. That could lead to
122
125
trouble in the future. *)
123
126
[{node with value = Default (k, v, expand_eff ~forest rest)}]
124
127
| Get k ->
125
-
let k = expand_ident node.loc k in
128
+
let k = expand_ident node.range k in
126
129
{node with value = Get k} :: expand_eff ~forest rest
127
130
| Dx_var name -> {node with value = Dx_var name} :: expand_eff ~forest rest
128
131
| Dx_const_content x ->
···
144
147
let prems = List.map (expand_eff ~forest) prems in
145
148
{node with value = Dx_sequent (concl, prems)} :: expand_eff ~forest rest
146
149
| Fun (xs, body) ->
147
-
let lam = expand_lambda ~forest node.loc (xs, body) in
150
+
let lam = expand_lambda ~forest node.range (xs, body) in
148
151
lam :: expand_eff ~forest rest
149
152
| Let (x, ys, def) ->
150
-
let lam = expand_lambda ~forest node.loc (ys, def) in
153
+
let lam = expand_lambda ~forest node.range (ys, def) in
151
154
let@ () = Sc.section [] in
152
-
Sc.import_singleton x (Term [lam], node.loc);
155
+
Sc.import_singleton x (Term [lam], node.range);
153
156
expand_eff ~forest rest
154
157
| Def (x, ys, def) ->
155
-
let lam = expand_lambda ~forest node.loc (ys, def) in
156
-
Sc.include_singleton x (Term [lam], node.loc);
158
+
let lam = expand_lambda ~forest node.range (ys, def) in
159
+
Sc.include_singleton x (Term [lam], node.range);
157
160
expand_eff ~forest rest
158
161
| Decl_xmlns (prefix, xmlns) ->
159
162
let path = ["xmlns"; prefix] in
160
-
Sc.include_singleton path (Xmlns {prefix; xmlns}, node.loc);
163
+
Sc.include_singleton path (Xmlns {prefix; xmlns}, node.range);
161
164
expand_eff ~forest rest
162
165
| Object {self; methods} ->
163
166
let methods =
164
167
let@ () = Sc.section [] in
165
168
begin
166
169
let@ self = Option.iter @~ self in
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*)
170
+
let var = Range.{value = Syn.Var self; range = node.range} in
171
+
(* TODO: correct the rangeation *)
172
+
Sc.import_singleton [self] (Term [var], node.range)
173
+
(* TODO: correct the rangeation*)
171
174
end;
172
175
List.map (expand_method ~forest) methods
173
176
in
···
179
182
begin
180
183
let@ self = Option.iter @~ self in
181
184
let self_var = Range.locate_opt None @@ Syn.Var self in
182
-
Sc.import_singleton [self] (Term [self_var], node.loc);
185
+
Sc.import_singleton [self] (Term [self_var], node.range);
183
186
let@ super = Option.iter @~ super in
184
187
let super_var = Range.locate_opt None @@ Syn.Var super in
185
-
Sc.import_singleton [super] (Term [super_var], node.loc)
188
+
Sc.import_singleton [super] (Term [super_var], node.range)
186
189
end;
187
190
List.map (expand_method ~forest) methods
188
191
in
···
192
195
let obj = expand_eff ~forest obj in
193
196
{node with value = Call (obj, meth)} :: expand_eff ~forest rest
194
197
| Import (vis, dep) ->
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
203
-
end;
198
+
let dep_uri = URI.named_uri ~base:forest.config.url dep in
199
+
let _ =
200
+
Result.get_ok
201
+
@@ begin match forest./{dep_uri} with
202
+
| None ->
203
+
let range = node.range in
204
+
let _ = dep_uri in
205
+
error @@ Diagnostic.createf Error ~code:Import_not_found ""
206
+
| Some tree -> begin
207
+
match vis with
208
+
| Public -> ok @@ Sc.include_subtree [] tree
209
+
| Private -> ok @@ Sc.import_subtree [] tree
210
+
end
211
+
end
212
+
in
204
213
expand_eff ~forest rest
205
214
| Comment _ | Error _ ->
206
215
ignore @@ assert false;
···
208
217
end
209
218
210
219
and get_xml_attrs ~forest acc = function
211
-
| {value = Group (Squares, [{value = Text key; loc = loc1}]); _}
212
-
:: {value = Group (Braces, value); loc = loc2}
220
+
| {value = Group (Squares, [{value = Text key; range = range1}]); _}
221
+
:: {value = Group (Braces, value); range = range2}
213
222
:: rest ->
214
-
entered_range loc1;
215
-
entered_range loc2;
223
+
entered_range range1;
224
+
entered_range range2;
216
225
let qname =
217
-
expand_xml_ident loc1 @@ Forester_xml_names.split_xml_qname key
226
+
expand_xml_ident range1 @@ Forester_xml_names.split_xml_qname key
218
227
in
219
228
let value = expand_eff ~forest value in
220
229
get_xml_attrs ~forest (acc @ [(qname, value)]) rest
221
230
| rest -> (acc, rest)
222
231
223
232
and get_arg_opt ~forest : Code.t -> _ = function
224
-
| {value = Group (Braces, arg); loc} :: rest ->
225
-
entered_range loc;
233
+
| {value = Group (Braces, arg); range} :: rest ->
234
+
entered_range range;
226
235
(Some (expand_eff ~forest arg), rest)
227
236
| rest -> (None, rest)
228
237
229
-
and expand_ident loc path =
238
+
and expand_ident range path : Syn.t =
230
239
match Sc.resolve path with
231
240
| None ->
232
241
let visible = Sc.get_visible () in
233
-
[Range.{value = Syn.Unresolved_ident (visible, path); loc}]
242
+
[Range.{value = Syn.Unresolved_ident (visible, path); range}]
234
243
| Some (Term x, _) ->
235
-
let relocate Range.{value; _} = Range.{value; loc} in
244
+
let relocate Range.{value; _} = Range.{value; range} in
236
245
List.map relocate x
237
246
| Some (Xmlns {xmlns; prefix}, _) ->
238
247
let visible = Sc.get_visible () in
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))
248
+
let msg =
249
+
Format.asprintf "path %a resolved to xmlns:%s=\"%s\" instead of term"
250
+
Sc.pp_path path xmlns prefix
251
+
in
252
+
let _ = (visible, path) in
253
+
emit @@ Diagnostic.createf Error ~code:Unresolved_identifier "";
254
+
[]
255
+
(*"%s" msg*)
247
256
(* TODO: This should be perhaps a different error *)
248
257
249
-
and expand_xml_ident loc (prefix, uname) : Types.xml_qname =
258
+
and expand_xml_ident range (prefix, uname) : T.xml_qname =
250
259
match prefix with
251
-
| None -> {xmlns = None; prefix = ""; uname}
260
+
| None -> T.{xmlns = None; prefix = ""; uname}
252
261
| Some prefix -> (
253
262
match Sc.resolve ["xmlns"; prefix] with
254
-
| Some (Xmlns {xmlns; prefix}, _) -> {xmlns = Some xmlns; prefix; uname}
263
+
| Some (Xmlns {xmlns; prefix}, _) -> T.{xmlns = Some xmlns; prefix; uname}
255
264
| _ ->
256
-
Reporter.fatal ?loc (Unresolved_xmlns prefix)
257
-
~extra_remarks:
258
-
[
259
-
Asai.Diagnostic.loctextf "expected path `%s` to resolve to xmlns"
265
+
let _ = prefix in
266
+
let _ = range in
267
+
emit @@ Diagnostic.createf Error ~code:Unresolved_xmlns ~notes:[] "";
268
+
T.{xmlns = None; prefix; uname}
269
+
(*
270
+
Asai.Diagnostic.rangetextf "expected path `%s` to resolve to xmlns"
260
271
prefix;
261
-
Asai.Diagnostic.loctextf
272
+
Asai.Diagnostic.rangetextf
262
273
"You may fix this by defining an XML namespace:@. \
263
274
\\xmlns:%s{...}"
264
275
prefix;
265
-
])
276
+
*)
277
+
)
266
278
267
279
and expand_method ~forest (key, body) = (key, expand_eff ~forest body)
268
280
269
-
and expand_lambda ~forest loc (xs, body) =
281
+
and expand_lambda ~forest range (xs, body) =
270
282
let@ () = Sc.section [] in
271
283
let xs =
272
284
let@ strategy, x = List.map @~ xs in
273
285
let var = Range.locate_opt None @@ Syn.Var x in
274
-
Sc.import_singleton [x] (Term [var], loc);
286
+
Sc.import_singleton [x] (Term [var], range);
275
287
(strategy, x)
276
288
in
277
-
Range.{value = Syn.Fun (xs, expand_eff ~forest body); loc}
289
+
Range.{value = Syn.Fun (xs, expand_eff ~forest body); range}
278
290
279
291
let ignore_entered_range f x =
280
292
let open Effect.Deep in
···
1083
1095
Yuujinchou.Trie.of_seq builtins
1084
1096
1085
1097
let expand_tree_inner ~forest (code : Tree.code) : Tree.syn =
1086
-
let trace k =
1087
-
match identity_to_uri code.identity with
1088
-
| None -> k ()
1089
-
| Some uri ->
1090
-
let@ () = Reporter.tracef "when expanding tree %s" (URI.to_string uri) in
1091
-
k ()
1092
-
in
1093
-
let@ () = trace in
1094
1098
let@ () = Sc.section [] in
1095
1099
let nodes = expand_eff ~forest code.nodes in
1096
1100
let exports = Sc.get_export () in
1097
1101
Tree.{nodes; identity = code.identity; code; units = exports}
1098
1102
1099
-
let expand_tree ~(forest : State.t) (code : Tree.code) :
1100
-
Tree.syn * Reporter.Message.t Asai.Diagnostic.t list =
1101
-
let diagnostics = ref [] in
1102
-
let emit d = diagnostics := d :: !diagnostics in
1103
-
let fatal d =
1104
-
emit d;
1105
-
( Tree.{nodes = []; identity = code.identity; code; units = Trie.empty},
1106
-
!diagnostics )
1103
+
let expand_tree ~(forest : State.t) (code : Tree.code) : Tree.syn * error list =
1104
+
let result = ref None in
1105
+
let errors =
1106
+
let@ () = Collect_errors.run in
1107
+
Sc.run ~init_visible:initial_visible_trie @@ fun () ->
1108
+
let expanded_tree = ignore_entered_range (expand_tree_inner ~forest) code in
1109
+
result := Some expanded_tree
1107
1110
in
1108
-
Reporter.run ~emit ~fatal @@ fun () ->
1109
-
Sc.run ~init_visible:initial_visible_trie @@ fun () ->
1110
-
let expanded_tree = ignore_entered_range (expand_tree_inner ~forest) code in
1111
-
(expanded_tree, !diagnostics)
1111
+
(Option.get !result, List.of_seq errors)
+1
-3
lib/compiler/Expand.mli
+1
-3
lib/compiler/Expand.mli
···
22
22
val expand : forest:State.t -> Code.t -> Syn.t
23
23
24
24
val expand_tree :
25
-
forest:State.t ->
26
-
Tree.code ->
27
-
Tree.syn * Reporter.Message.t Asai.Diagnostic.t list
25
+
forest:State.t -> Tree.code -> Tree.syn * Message.t Grace.Diagnostic.t list
28
26
29
27
type 'a Effect.t += Entered_range : Range.t option -> unit Effect.t
30
28
-3
lib/compiler/Forest.ml
-3
lib/compiler/Forest.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Forester_prelude
8
7
open Forester_core
9
8
10
9
open struct
···
27
26
28
27
let run_datalog_query (graphs : env) (q : (string, Vertex.t) Dx.query) :
29
28
Vertex_set.t =
30
-
let@ () = Reporter.trace "when running query" in
31
-
(* TODO: See above *)
32
29
let () = execute_datalog_script graphs Builtin_relation.axioms in
33
30
let module Graphs = (val graphs) in
34
31
Datalog_eval.run_query Graphs.dl_db q
+39
-31
lib/compiler/Imports.ml
+39
-31
lib/compiler/Imports.ml
···
5
5
*)
6
6
7
7
open Forester_core
8
-
open Forester_prelude
8
+
open Message
9
9
10
10
open struct
11
11
module T = Types
···
15
15
follow: bool;
16
16
forest: State.t; (* We don't touch the import graph in here.*)
17
17
graph: Forest_graph.t;
18
+
mutable errors: error list;
18
19
}
19
20
20
21
let load_tree path =
···
26
27
{textDocument = {languageId = "forester"; text = content; uri; version = 1}}
27
28
28
29
(* Only add edge if both vertices are already present*)
29
-
let add_edge g v w =
30
+
let add_edge g v w : unit res =
30
31
try
31
32
assert (Forest_graph.mem_vertex g v);
32
33
assert (Forest_graph.mem_vertex g w);
33
-
Forest_graph.add_edge g v w
34
+
ok @@ Forest_graph.add_edge g v w
34
35
with exn ->
35
-
Reporter.fatal Internal_error
36
-
~extra_remarks:[Asai.Diagnostic.loctextf "%a" Eio.Exn.pp exn]
36
+
error @@ Diagnostic.createf Error ~code:Internal_error "%a" Eio.Exn.pp exn
37
37
38
-
let resolve_uri_to_code (forest : State.t) (uri : URI.t) : Tree.code option =
39
-
let dirs = Eio_util.paths_of_dirs ~env:forest.env forest.config.trees in
38
+
let resolve_uri_to_code (forest : State.t) (uri : URI.t) :
39
+
(Tree.code, error list) Result.t =
40
+
let errors, dirs =
41
+
Eio_util.paths_of_dirs ~env:forest.env forest.config.trees
42
+
in
40
43
match Forest.find_opt forest.index uri with
41
-
| Some tree -> Tree.to_code tree
44
+
| Some tree ->
45
+
Tree.to_code tree
46
+
|> Option.to_result
47
+
~none:(Diagnostic.createf Error ~code:Internal_error "" :: errors)
42
48
| None -> (
43
49
match URI.Tbl.find_opt forest.resolver uri with
44
50
| Some path ->
45
51
let doc = load_tree Eio.Path.(forest.env#fs / path) in
46
-
Result.to_option @@ Parse.parse_document ~config:forest.config doc
52
+
Result.map_error List.singleton
53
+
@@ Parse.parse_document ~config:forest.config doc
47
54
| None -> (
48
55
match Dir_scanner.find_tree dirs uri with
49
56
| Some path ->
50
57
let native = Eio.Path.native_exn path in
51
58
URI.Tbl.add forest.resolver uri native;
52
59
let doc = load_tree path in
53
-
Result.to_option @@ Parse.parse_document ~config:forest.config doc
54
-
| None -> Reporter.fatal (Resource_not_found uri)))
60
+
Result.map_error List.singleton
61
+
@@ Parse.parse_document ~config:forest.config doc
62
+
| None ->
63
+
let _ = uri in
64
+
error [Diagnostic.createf Error ~code:Resource_not_found ""]))
55
65
56
66
let rec analyse_tree ~env (tree : Tree.code) =
57
67
let@ root = Option.iter @~ identity_to_uri tree.identity in
···
62
72
and analyse_code ~env ~root (code : Code.t) =
63
73
List.iter (analyse_node ~env ~root) code
64
74
65
-
and analyse_node ~env ~root (node : Code.node Asai.Range.located) =
75
+
and analyse_node ~env ~root (node : Code.node Range.located) : unit =
66
76
let config = env.forest.config in
67
77
match node.value with
68
78
| Import (_, dep) ->
69
-
let dep_uri = URI_scheme.named_uri ~base:config.url dep in
79
+
let dep_uri = URI.named_uri ~base:config.url dep in
70
80
let dependency = T.Uri_vertex dep_uri in
71
81
let target = T.Uri_vertex root in
72
82
Forest_graph.add_vertex env.graph dependency;
73
-
(* add_vertex env.forest env.graph tar; *)
74
-
add_edge env.graph dependency target;
83
+
assert (Result.is_ok @@ add_edge env.graph dependency target);
75
84
if env.follow then begin
76
85
match resolve_uri_to_code env.forest dep_uri with
77
-
| None -> Reporter.fatal ?loc:node.loc (Resource_not_found dep_uri)
78
-
| Some code ->
79
-
analyse_tree ~env code;
80
-
assert false
86
+
| Ok code -> analyse_tree ~env code
87
+
| Error error -> env.errors <- List.append error env.errors
81
88
end
82
89
| Subtree (addr, nodes) ->
83
90
let identity =
84
91
match addr with
85
92
| None -> Anonymous
86
-
| Some string -> URI (URI_scheme.named_uri ~base:config.url string)
93
+
| Some string -> URI (URI.named_uri ~base:config.url string)
87
94
in
88
95
analyse_tree ~env
89
96
{identity; origin = Subtree {parent = URI root}; nodes; timestamp = None}
···
120
127
()
121
128
122
129
let dependencies tree forest =
123
-
let env = {forest; follow = true; graph = Forest_graph.create ()} in
130
+
let env =
131
+
{forest; follow = true; graph = Forest_graph.create (); errors = []}
132
+
in
124
133
analyse_tree ~env tree;
125
134
env.graph
126
135
127
136
let fixup (tree : Tree.code) (forest : State.t) =
128
-
let@ () =
129
-
Reporter.tracef "when updating imports for %a" pp_identity tree.identity
130
-
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
···
139
145
@@ Forest_graph.immediate_dependencies graph this_vertex
140
146
in
141
147
let new_deps =
142
-
let env = {forest; follow = false; graph} in
148
+
let env = {forest; follow = false; graph; errors = []} in
143
149
begin
144
150
analyse_tree ~env tree;
145
151
Vertex_set.of_list
···
163
169
let _minimal_dependency_graph : addr:URI.t -> Forest_graph.t =
164
170
fun ~addr ->
165
171
let dep_graph = Forest_graph.create () in
166
-
let rec f v =
172
+
let rec run v =
167
173
Forest_graph.iter_succ
168
174
(fun w ->
169
175
Forest_graph.add_edge dep_graph v w;
170
-
f w)
176
+
run w)
171
177
dep_graph v
172
178
in
173
-
f (T.Uri_vertex addr);
179
+
run (T.Uri_vertex addr);
174
180
dep_graph
175
181
176
182
let build forest =
177
-
let env = {forest; follow = false; graph = Forest_graph.create ()} in
178
-
env.forest |> State.get_all_code |> Seq.iter (analyse_tree ~env);
179
-
env.graph
183
+
let env =
184
+
{forest; follow = false; graph = Forest_graph.create (); errors = []}
185
+
in
186
+
State.get_all_code ~forest:env.forest |> Seq.iter (analyse_tree ~env);
187
+
(env.errors, env.graph)
+9
-3
lib/compiler/Imports.mli
+9
-3
lib/compiler/Imports.mli
···
6
6
7
7
open Forester_core
8
8
9
-
type analysis_env = {follow: bool; forest: State.t; graph: Forest_graph.t}
9
+
type analysis_env = {
10
+
follow: bool;
11
+
forest: State.t;
12
+
graph: Forest_graph.t;
13
+
mutable errors: error list;
14
+
}
10
15
11
16
val load_tree : Eio.Fs.dir_ty Eio.Path.t -> Lsp.Text_document.t
12
-
val build : State.t -> Forest_graph.t
17
+
val build : State.t -> error list * Forest_graph.t
13
18
val dependencies : Tree.code -> State.t -> Forest_graph.t
14
-
val resolve_uri_to_code : State.t -> Forest.key -> Tree.code option
19
+
val resolve_uri_to_code :
20
+
State.t -> Forest.key -> (Tree.code, error list) Result.t
15
21
val fixup : Tree.code -> State.t -> unit
+1
-1
lib/compiler/Job.ml
+1
-1
lib/compiler/Job.ml
···
10
10
type latex_to_svg_job = {hash: string; source: string} [@@deriving show]
11
11
12
12
let uri_for_latex_to_svg_job ~(base : URI.t) (job : latex_to_svg_job) =
13
-
URI_scheme.named_uri ~base @@ job.hash ^ ".svg"
13
+
URI.named_uri ~base @@ job.hash ^ ".svg"
14
14
15
15
type job = LaTeX_to_svg of latex_to_svg_job | Syndicate of content syndication
16
16
[@@deriving show]
+38
-28
lib/compiler/LaTeX_pipeline.ml
+38
-28
lib/compiler/LaTeX_pipeline.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Forester_prelude
8
7
open Forester_core
8
+
open Message
9
+
open Grace
10
+
open Result.Syntax
11
+
9
12
module EP = Eio.Path
10
13
11
14
type env = Eio_unix.Stdenv.base
···
17
20
18
21
(* TODO: When error occurs on stderr, there is nothing informative in the
19
22
diagnostic*)
20
-
let pipe_latex_dvi ~env ~tex_source ?loc kont =
23
+
let pipe_latex_dvi ~env ~tex_source ~range kont =
21
24
let mgr = Eio.Stdenv.process_mgr env in
22
25
let@ tmp = Eio_util.with_open_tmp_dir ~env in
23
26
let tex_fn = "job.tex" in
···
27
30
in
28
31
Eio.Flow.copy tex_source tex_sink
29
32
end;
30
-
begin
33
+
let* () =
31
34
let out_buf = Buffer.create 1000 in
32
35
let stdout = Eio.Flow.buffer_sink out_buf in
33
36
let stderr = Eio_util.null_sink () in
34
37
let cmd = ["latex"; "-halt-on-error"; "-interaction=nonstopmode"; tex_fn] in
35
-
try Eio.Process.run ~cwd:tmp ~stdout ~stderr mgr cmd
38
+
try
39
+
let _ = Eio.Process.run ~cwd:tmp ~stdout ~stderr mgr cmd in
40
+
Ok ()
36
41
with _ ->
37
42
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);
45
-
]
46
-
end;
43
+
let err =
44
+
Diagnostic.createf Error ~code:External_error
45
+
"Encountered fatal LaTeX error: @.@.%s@.@. while running `%s` in \
46
+
directory `%s`."
47
+
formatted_output (String.concat " " cmd) (Eio.Path.native_exn tmp)
48
+
in
49
+
Error err
50
+
in
47
51
EP.with_open_in EP.(tmp / "job.dvi") kont
48
52
49
-
let pipe_dvi_svg ~env ?loc ~dvi_source ~svg_sink () =
53
+
let pipe_dvi_svg ~env ~range ~dvi_source ~svg_sink () =
50
54
let cwd = Eio.Stdenv.cwd env in
51
55
let mgr = Eio.Stdenv.process_mgr env in
52
56
let err_buf = Buffer.create 1000 in
···
63
67
"--stdout";
64
68
]
65
69
in
66
-
try Eio.Process.run ~cwd ~stdin:dvi_source ~stdout:svg_sink ~stderr mgr cmd
70
+
try
71
+
Ok (Eio.Process.run ~cwd ~stdin:dvi_source ~stdout:svg_sink ~stderr mgr cmd)
67
72
with _ ->
68
-
Reporter.fatal External_error
69
-
~extra_remarks:
70
-
[
71
-
Asai.Diagnostic.loctextf ?loc
72
-
"Encountered fatal error running `dvisvgm`: %s"
73
-
(Buffer.contents err_buf);
74
-
]
73
+
let err =
74
+
let message =
75
+
Diagnostic.Message.createf
76
+
"Encountered fatal error running `dvisvgm`: %s"
77
+
(Buffer.contents err_buf)
78
+
in
79
+
Diagnostic.createf Error ~code:External_error
80
+
~labels:[Diagnostic.Label.create ~range ~priority:Primary message]
81
+
""
82
+
in
83
+
Error err
75
84
76
-
let pipe_latex_svg ~env ?loc ~tex_source ~svg_sink () =
77
-
let@ dvi_source = pipe_latex_dvi ~env ~tex_source ?loc in
78
-
pipe_dvi_svg ~env ?loc ~dvi_source ~svg_sink ()
85
+
let pipe_latex_svg ~env ~range ~tex_source ~svg_sink () =
86
+
let@ dvi_source = pipe_latex_dvi ~env ~tex_source ~range in
87
+
pipe_dvi_svg ~env ~range ~dvi_source ~svg_sink ()
79
88
80
-
let latex_to_svg ~env ?loc code =
89
+
let latex_to_svg ~env ~range code =
81
90
let tex_source = Eio.Flow.string_source code in
82
91
let svg_buf = Buffer.create 1000 in
83
92
let svg_sink = Eio.Flow.buffer_sink svg_buf in
84
-
pipe_latex_svg ~env ~tex_source ~svg_sink ?loc ();
85
-
Buffer.contents svg_buf
93
+
match pipe_latex_svg ~env ~tex_source ~svg_sink ~range () with
94
+
| Ok () -> Ok (Buffer.contents svg_buf)
95
+
| Error err -> Error err
+7
-1
lib/compiler/LaTeX_pipeline.mli
+7
-1
lib/compiler/LaTeX_pipeline.mli
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
+
open Forester_core
8
+
7
9
type env = Eio_unix.Stdenv.base
8
10
9
-
val latex_to_svg : env:env -> ?loc:Asai.Range.t -> string -> string
11
+
val latex_to_svg :
12
+
env:env ->
13
+
range:Grace.Range.t ->
14
+
string ->
15
+
(string, Message.t Grace.Diagnostic.t) result
+2
-4
lib/compiler/Parse.ml
+2
-4
lib/compiler/Parse.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Forester_prelude
8
7
open Forester_core
9
8
include Forester_parser.Parse
10
9
···
12
11
let lexbuf = Lexing.from_channel ch in
13
12
if filename = "" then assert false;
14
13
lexbuf.lex_curr_p <- {lexbuf.lex_curr_p with pos_fname = filename};
15
-
parse lexbuf
14
+
parse (`File filename) lexbuf
16
15
17
16
let parse_document ~(config : Config.t) doc =
18
17
let uri = Lsp.Text_document.documentUri doc in
···
20
19
let text = Lsp.Text_document.text doc in
21
20
let lexbuf = Lexing.from_string text in
22
21
lexbuf.lex_curr_p <- {lexbuf.lex_curr_p with pos_fname = path};
23
-
parse lexbuf
22
+
parse (`String {content = text; name = Some path}) lexbuf
24
23
|> Result.map (fun nodes ->
25
24
Tree.
26
25
{
···
31
30
})
32
31
33
32
let parse_file filename =
34
-
let@ () = Reporter.tracef "when parsing file `%s`" filename in
35
33
let ch = open_in filename in
36
34
Fun.protect ~finally:(fun _ -> close_in ch) @@ fun _ ->
37
35
parse_channel filename ch
+2
-3
lib/compiler/Parse.mli
+2
-3
lib/compiler/Parse.mli
···
10
10
val parse_document :
11
11
config:Config.t ->
12
12
Lsp.Text_document.t ->
13
-
(Forester_core.Tree.code, Forester_core.Reporter.diagnostic) result
13
+
(Forester_core.Tree.code, Message.t Grace.Diagnostic.t) result
14
14
15
-
val parse_file :
16
-
string -> (Forester_core.Code.t, Forester_core.Reporter.diagnostic) result
15
+
val parse_file : string -> Forester_core.Code.t res
+95
-91
lib/compiler/Phases.ml
+95
-91
lib/compiler/Phases.ml
···
5
5
*
6
6
*)
7
7
8
-
open Forester_prelude
9
8
open Forester_core
9
+
open Message
10
+
11
+
module EP = Eio.Path
12
+
13
+
open Result.Syntax
10
14
11
15
open struct
12
16
module T = Types
···
14
18
15
19
open State.Syntax
16
20
17
-
let load (tree_dirs : Eio.Fs.dir_ty Eio.Path.t list) =
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
21
+
let guess_uri (d : 'a Diagnostic.t) =
22
+
match d with
23
+
| {labels; _} -> (
24
+
match labels with
25
+
| {range; _} :: _ -> begin
26
+
match Range.source range with
27
+
| `File filename -> Some (Lsp.Uri.of_path filename)
28
+
| `Reader _ -> None
29
+
| `String _ -> None
30
+
end
31
+
| _ -> None)
32
+
33
+
let load (tree_dir : Eio.Fs.dir_ty Eio.Path.t) =
34
+
Dir_scanner.scan_directory tree_dir |> Seq.map Imports.load_tree
21
35
22
36
let parse (forest : State.t) =
23
37
let trees = forest.index |> URI.Tbl.to_seq_values |> List.of_seq in
···
44
58
end;
45
59
forest
46
60
47
-
let build_import_graph (forest : State.t) =
48
-
let@ () = Reporter.trace "when resolving imports" in
49
-
let errors = ref [] in
50
-
let push d = errors := d :: !errors in
51
-
let new_graph =
52
-
Reporter.run ~emit:push ~fatal:(fun d ->
53
-
push d;
54
-
Reporter.Tty.display d;
55
-
forest.import_graph)
56
-
@@ fun () -> Imports.build forest
57
-
in
58
-
(!errors, new_graph)
61
+
let build_import_graph ~(forest : State.t) : _ * _ = Imports.build forest
59
62
60
63
let expand (forest : State.t) = Expand.expand_tree ~forest
61
64
···
81
84
Forest_graph.topo_iter task forest.import_graph;
82
85
!diagnostics
83
86
87
+
open Result.Syntax
88
+
84
89
let run_jobs (forest : State.t) jobs =
85
90
Logs.debug (fun m -> m "Running %d jobs" (List.length jobs));
86
91
(* All resources induced by LaTeX jobs must be planted prior to publication
87
92
export. *)
88
93
let resources_to_plant =
89
-
let@ Range.{value; loc} = Eio.Fiber.List.map ~max_fibers:20 @~ jobs in
90
-
let@ () = Reporter.easy_run in
94
+
let@ Range.{value; range} = Eio.Fiber.List.map ~max_fibers:20 @~ jobs in
95
+
let range = Option.get range in
91
96
match value with
92
97
| Job.LaTeX_to_svg job ->
93
-
let svg = Build_latex.latex_to_svg ~env:forest.env ?loc job.source in
98
+
let* svg = Build_latex.latex_to_svg ~env:forest.env ~range job.source in
94
99
let uri = Job.uri_for_latex_to_svg_job ~base:forest.config.url job in
95
-
T.Asset {uri; content = svg}
96
-
| Job.Syndicate syndication -> T.Syndication syndication
100
+
Ok (T.Asset {uri; content = svg})
101
+
| Job.Syndicate syndication -> Ok (T.Syndication syndication)
97
102
in
98
103
begin
99
104
(* It is probably not save to plant the articles in parallel, so this is
100
105
done sequentially! *)
101
-
let@ resource = List.iter @~ resources_to_plant in
102
-
State.plant_resource resource forest
106
+
let@ result = List.iter @~ resources_to_plant in
107
+
match result with
108
+
| Ok resource -> State.plant_resource ~forest resource
109
+
| Error diagnostic -> (
110
+
match guess_uri diagnostic with
111
+
| None -> ()
112
+
| Some lsp_uri ->
113
+
let uri = Tree.of_lsp_uri ~base:forest.config.url lsp_uri in
114
+
forest.?{uri} <- [diagnostic])
103
115
end
104
116
105
-
let eval (forest : State.t) =
106
-
let result =
107
-
State.get_all_unevaluated forest
108
-
|> Seq.filter Tree.is_expanded
109
-
|> Seq.map (fun tree ->
110
-
let tree = Option.get @@ Tree.to_syn tree in
111
-
match identity_to_uri tree.identity with
112
-
| None ->
113
-
Reporter.fatal Internal_error
114
-
~extra_remarks:
115
-
[Asai.Diagnostic.loctext "can't evaluate a tree with no URI"]
116
-
| Some uri ->
117
-
let source_path =
118
-
if forest.dev then URI.Tbl.find_opt forest.resolver uri else None
119
-
in
120
-
Eval.eval_tree ~config:forest.config ~source_path ~uri tree.nodes)
117
+
let eval (forest : State.t) : error list * Eval.eval_result list =
118
+
let trees =
119
+
List.of_seq
120
+
@@ Seq.filter Tree.is_expanded State.(get_all_unevaluated ~forest)
121
121
in
122
-
result
122
+
let@ tree = List_util.error_partition @~ trees in
123
+
let tree = Option.get @@ Tree.to_syn tree in
124
+
match identity_to_uri tree.identity with
125
+
| None ->
126
+
error
127
+
@@ Grace.Diagnostic.createf Error ~code:Internal_error
128
+
"can't evaluate a tree with no URI"
129
+
| Some uri ->
130
+
let source_path =
131
+
if forest.dev then URI.Tbl.find_opt forest.resolver uri else None
132
+
in
133
+
Eval.eval_tree ~config:forest.config ~source_path ~uri tree.nodes
123
134
124
135
let eval_only (uri : URI.t) (forest : State.t) =
125
136
match forest.={uri} with
126
137
| None -> assert false
127
138
| Some (Document _) -> assert false
128
139
| Some (Parsed _) | Some (Resource _) -> assert false
129
-
| Some (Expanded expanded) ->
140
+
| Some (Expanded expanded) -> (
130
141
let source_path =
131
142
if forest.dev then URI.Tbl.find_opt forest.resolver uri else None
132
143
in
133
-
(* NOTE: Not running jobs. *)
134
-
let Eval.{articles; jobs = _}, diagnostics =
144
+
(* TODO: run jobs. *)
145
+
match
135
146
Eval.eval_tree ~config:forest.config ~source_path ~uri expanded.nodes
136
-
in
137
-
begin
138
-
let@ article = List.iter @~ articles in
139
-
State.plant_resource (Article article) forest
140
-
end;
141
-
(forest, diagnostics)
147
+
with
148
+
| Ok {articles; _} ->
149
+
begin
150
+
let@ article = List.iter @~ articles in
151
+
State.plant_resource ~forest (Article article)
152
+
end;
153
+
ok ()
154
+
| Error e -> error e)
142
155
143
156
let check_status _uri (forest : State.t) =
144
157
match forest with {dependency_cache = _; _} -> (forest, None)
145
158
146
-
let implant_foreign (state : State.t) : State.t * _ =
147
-
begin
148
-
Logs.debug (fun m ->
149
-
m "implanting %i foreign forests" (List.length state.config.foreign));
150
-
let module EP = Eio.Path in
151
-
let@ foreign = List.iter @~ state.config.foreign in
152
-
let path = Eio_util.path_of_file ~env:state.env foreign.path in
153
-
let path_str = EP.native_exn path 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
166
-
match Repr.of_json_string (T.forest_t T.content_t) blob with
167
-
| Ok foreign_forest ->
159
+
let implant ~(forest : State.t) (foreign : Config.foreign) =
160
+
let* path = Eio_util.path_of_file ~env:forest.env foreign.path in
161
+
let path_str = EP.native_exn path in
162
+
let* blob =
163
+
try ok (EP.load path)
164
+
with _ ->
165
+
error
166
+
@@ Grace.Diagnostic.createf Error ~code:IO_error
167
+
"Could not read foreign forest blob at `%s`" path_str
168
+
in
169
+
match Repr.of_json_string (T.forest_t T.content_t) blob with
170
+
| Ok foreign_forest ->
171
+
begin
168
172
let@ r = List.iter @~ foreign_forest in
169
-
State.plant_resource ~route_locally:foreign.route_locally
170
-
~include_in_manifest:foreign.include_in_manifest r state
171
-
| Error (`Msg err) ->
172
-
Reporter.fatal Parse_error
173
-
~extra_remarks:
174
-
[
175
-
Asai.Diagnostic.loctextf "Could not parse foreign forest blob: %s"
176
-
err;
177
-
]
178
-
| exception 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
-
]
186
-
end;
187
-
(state, [])
173
+
State.plant_resource ~forest ~route_locally:foreign.route_locally
174
+
~include_in_manifest:foreign.include_in_manifest r
175
+
end;
176
+
ok ()
177
+
| Error (`Msg err) ->
178
+
error
179
+
@@ Grace.Diagnostic.createf Error ~code:Parse_error
180
+
"Could not parse foreign forest blob: %s" err
181
+
| exception exn ->
182
+
error
183
+
@@ Grace.Diagnostic.createf Error ~code:Parse_error
184
+
"Encountered unknown error while decoding foreign forest blob: %s"
185
+
(Printexc.to_string exn)
186
+
187
+
let implant_foreign ~(forest : State.t) : _ =
188
+
Logs.debug (fun m ->
189
+
m "implanting %i foreign forests" (List.length forest.config.foreign));
190
+
let@ foreign = List.filter_map @~ forest.config.foreign in
191
+
implant ~forest foreign |> function Ok () -> None | Error e -> Some e
+26
-29
lib/compiler/State.ml
+26
-29
lib/compiler/State.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Forester_prelude
8
7
open Forester_core
9
8
open Tree
10
9
open Forester_core
10
+
open Grace
11
+
open Message
11
12
12
13
open struct
13
14
module T = Types
···
20
21
dev: bool;
21
22
config: Config.t;
22
23
index: Tree.t URI.Tbl.t;
23
-
diagnostics: Reporter.Message.t Asai.Diagnostic.t list URI.Tbl.t;
24
+
diagnostics: Message.t Grace.Diagnostic.t list URI.Tbl.t;
24
25
graphs: (module Forest_graphs.S);
25
26
import_graph: Forest_graph.t;
26
27
dependency_cache: Cache.t;
27
28
resolver: string URI.Tbl.t;
28
29
search_index: Forester_search.Index.t;
29
-
usages: (Tree.exports, URI.t Asai.Range.located) Hashtbl.t;
30
+
usages: (Tree.exports, URI.t Forester_core.Range.located) Hashtbl.t;
30
31
history: Action.t list;
31
32
hosts: (string, unit) Hashtbl.t;
32
33
suggestions: URI.t URI.Tbl.t;
···
64
65
match state.={uri} with
65
66
| None -> URI.Tbl.replace state.index uri tree
66
67
| Some existing ->
67
-
let o1 = Tree.origin tree in
68
-
let o2 = Tree.origin existing in
69
-
if o1 <> o2 then begin
70
-
Reporter.emit (Duplicate_tree (o1, o2));
68
+
if Tree.origin tree <> Tree.origin existing then
69
+
let _ = Diagnostic.createf Error ~code:Duplicate_tree "" in
71
70
URI.Tbl.replace state.index uri tree
72
-
end
73
71
else URI.Tbl.replace state.index uri tree
74
72
(* URI.Tbl.replace state.index uri item *)
75
73
···
78
76
Option.bind (URI.Tbl.find_opt state.index uri) Tree.get_units
79
77
80
78
(* updating units*)
81
-
let ( ./{}<- ) state uri units =
82
-
let@ () = Reporter.tracef "when updating units for %a" URI.pp uri in
79
+
let ( ./{}<- ) state uri units : _ result =
83
80
match URI.Tbl.find_opt state.index uri with
84
81
| None ->
85
-
Reporter.fatal Internal_error
86
-
~extra_remarks:
87
-
[Asai.Diagnostic.loctextf "Updating units: %a not found" URI.pp uri]
82
+
error
83
+
@@ Diagnostic.createf Error ~code:`Internal_error
84
+
"Updating units: %a not found" URI.pp uri
88
85
| 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]
86
+
error
87
+
@@ Diagnostic.createf Error ~code:`Internal_error
88
+
"%a has not been expanded yet" URI.pp uri
92
89
| Some (Expanded expanded) ->
93
-
URI.Tbl.replace state.index uri (Expanded {expanded with units})
94
-
| Some (Resource _) -> ()
90
+
ok @@ URI.Tbl.replace state.index uri (Expanded {expanded with units})
91
+
| Some (Resource _) -> Ok ()
95
92
96
93
(* ? for diagnostics*)
97
94
let ( .?{} ) state uri =
···
116
113
let find_opt state uri = URI.Tbl.find_opt state.index uri
117
114
let to_seq state = URI.Tbl.to_seq state.index
118
115
119
-
let get_all_unparsed state =
120
-
state.index |> URI.Tbl.to_seq_values |> Seq.filter is_unparsed
116
+
let get_all_unparsed ~forest =
117
+
forest.index |> URI.Tbl.to_seq_values |> Seq.filter is_unparsed
121
118
122
-
let get_all_code state =
123
-
state.index |> URI.Tbl.to_seq_values |> Seq.filter_map to_code
119
+
let get_all_code ~forest =
120
+
forest.index |> URI.Tbl.to_seq_values |> Seq.filter_map to_code
124
121
125
-
let get_all_unexpanded state =
126
-
state.index |> URI.Tbl.to_seq_values |> Seq.filter is_unexpanded
122
+
let get_all_unexpanded ~forest =
123
+
forest.index |> URI.Tbl.to_seq_values |> Seq.filter is_unexpanded
127
124
128
-
let get_all_expanded state =
129
-
state.index |> URI.Tbl.to_seq_values |> Seq.filter_map to_syn
125
+
let get_all_expanded ~forest =
126
+
forest.index |> URI.Tbl.to_seq_values |> Seq.filter_map to_syn
130
127
131
-
let get_all_unevaluated state =
132
-
state.index |> URI.Tbl.to_seq_values |> Seq.filter is_unevaluated
128
+
let get_all_unevaluated ~forest =
129
+
forest.index |> URI.Tbl.to_seq_values |> Seq.filter is_unevaluated
133
130
134
131
let get_all_articles : t -> T.content T.article Seq.t =
135
132
fun state -> state.index |> URI.Tbl.to_seq_values |> Seq.filter_map to_article
···
258
255
))
259
256
260
257
let plant_resource ?(route_locally = true) ?(include_in_manifest = true)
261
-
resource forest =
258
+
resource ~forest =
262
259
let module Graphs = (val forest.graphs) in
263
260
Forest.analyse_resource forest.graphs resource;
264
261
let@ uri = Option.iter @~ T.uri_for_resource resource in
+12
-34
lib/compiler/Suggestions.ml
+12
-34
lib/compiler/Suggestions.ml
···
5
5
*
6
6
*)
7
7
8
-
open Forester_prelude
9
8
open Forester_core
10
9
11
-
(* TODO: remove this in favor of https://github.com/ocaml/ocaml/pull/13760 *)
12
-
let edit_distance ~cutoff x y =
13
-
let len_x, len_y = (String.length x, String.length y) in
14
-
let grid = Array.make_matrix (len_x + 1) (len_y + 1) 0 in
15
-
for i = 1 to len_x do
16
-
grid.(i).(0) <- i
17
-
done;
18
-
for j = 1 to len_y do
19
-
grid.(0).(j) <- j
20
-
done;
21
-
for j = 1 to len_y do
22
-
for i = 1 to len_x do
23
-
let cost = if x.[i - 1] = y.[j - 1] then 0 else 1 in
24
-
let k = Int.min (grid.(i - 1).(j) + 1) (grid.(i).(j - 1) + 1) in
25
-
grid.(i).(j) <- Int.min k (grid.(i - 1).(j - 1) + cost)
26
-
done
27
-
done;
28
-
let result = grid.(len_x).(len_y) in
29
-
if result > cutoff then None else Some result
30
-
31
-
let suggestions ?prefix ~(cutoff : int) (p : Trie.bwd_path) :
10
+
let suggestions ?prefix ~(limit : int) (p : Trie.bwd_path) :
32
11
('data, 'tag) Trie.t -> ('data, int) Trie.t =
33
12
let compare p d =
34
-
edit_distance ~cutoff
13
+
String.edit_distance ~limit
35
14
(String.concat "" (Bwd.to_list p))
36
15
(String.concat "" (Bwd.to_list d))
37
16
in
38
17
Trie.filter_map ?prefix @@ fun q (data, _) ->
39
-
let@ i = Option.bind @@ compare p q in
40
-
if i > cutoff then None else Some (data, i)
18
+
let i = compare p q in
19
+
if i > limit then None else Some (data, i)
41
20
42
21
let suggestions ~visible path =
43
-
suggestions ~cutoff:2 (Bwd.of_list path) visible
22
+
suggestions ~limit:2 (Bwd.of_list path) visible
44
23
|> Trie.to_seq
45
24
|> Seq.map (fun (path, (data, distance)) -> (path, data, distance))
46
25
|> List.of_seq
47
26
|> List.sort (fun (_, _, a) (_, _, b) -> Int.compare a b)
48
27
49
-
let create_suggestions ~visible path =
28
+
let create_suggestions ~visible path : Diagnostic.Message.t list =
50
29
let suggestions = suggestions ~visible path in
51
30
let extra_remarks =
52
31
if List.length suggestions > 0 then
53
32
let path, data, _ = List.hd suggestions in
54
33
let location_hint =
55
34
match data with
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
-
| _ -> [])
35
+
| Syn.Term ({range = Some range; _} :: _) -> begin
36
+
match Range.source range with
37
+
| `File name | `Reader {name = Some name; _} ->
38
+
[Diagnostic.Message.createf "defined in %s" name]
39
+
| _ -> []
62
40
end
63
41
| _ -> []
64
42
in
65
-
[Asai.Diagnostic.loctextf "Did you mean %a?" Trie.pp_path path]
43
+
[Diagnostic.Message.createf "Did you mean %a?" Trie.pp_path path]
66
44
@ location_hint
67
45
else []
68
46
in
-1
lib/compiler/URI_util.ml
-1
lib/compiler/URI_util.ml
-1
lib/compiler/Xml_forester.ml
-1
lib/compiler/Xml_forester.ml
···
60
60
let tex attrs = f_text_tag ~raw:true "tex" attrs
61
61
let display fmt = string_attr "display" fmt
62
62
let title_ fmt = string_attr "title" fmt
63
-
let ref = f_void_tag "ref"
64
63
let number_ fmt = string_attr "number" fmt
65
64
let img = html_void_tag "img"
66
65
let src fmt = string_attr "src" fmt
-1
lib/compiler/Xml_forester.mli
-1
lib/compiler/Xml_forester.mli
+3
-6
lib/compiler/dune
+3
-6
lib/compiler/dune
···
2
2
;;;
3
3
;;; SPDX-License-Identifier: GPL-3.0-or-later
4
4
5
-
(env
6
-
(dev
7
-
(flags
8
-
(:standard -w -66-32-33-27-26-69-37-34-38))))
9
-
10
5
(library
11
6
(name Forester_compiler)
12
7
(instrumentation
···
21
16
forester.parser
22
17
forester.search
23
18
yuujinchou
24
-
asai
19
+
grace
20
+
grace.ansi_renderer
21
+
grace.std
25
22
ocamlgraph
26
23
pure-html
27
24
str
+3
-9
lib/compiler/test/Test_compiler.ml
+3
-9
lib/compiler/test/Test_compiler.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Forester_prelude
8
7
open Forester_core
9
8
open Forester_compiler
10
9
open Forester_test
···
32
31
let forest, history =
33
32
let@ path = with_test_forest ~raw_trees ~env ~config in
34
33
Sys.chdir (Eio.Path.native_exn path);
35
-
let@ () = Reporter.easy_run in
36
34
let forest = State.make ~env ~config ~dev:false () in
37
35
Driver.run_with_history Load_all_configured_dirs forest
38
36
in
···
50
48
history;
51
49
Alcotest.(check @@ int)
52
50
"no tree is unparsed" 0
53
-
(Seq.length (State.get_all_unparsed forest));
51
+
(Seq.length (State.get_all_unparsed ~forest));
54
52
Alcotest.(check @@ int)
55
53
"no tree is unexpanded" 0
56
-
(Seq.length (State.get_all_unexpanded forest));
54
+
(Seq.length (State.get_all_unexpanded ~forest));
57
55
Alcotest.(check @@ int)
58
56
"no tree is unevaluated" 0
59
-
(Seq.length (State.get_all_unevaluated forest));
57
+
(Seq.length (State.get_all_unevaluated ~forest));
60
58
Alcotest.(check @@ int)
61
59
"has correct number of articles" 8
62
60
(Seq.length (State.get_all_articles forest))
63
61
64
62
let test_includes_paths ~env () =
65
-
let@ () = Reporter.easy_run in
66
63
let config = Config.default () in
67
64
with_test_forest ~raw_trees ~env ~config (fun path ->
68
65
Sys.chdir (Eio.Path.native_exn path);
69
-
let@ () = Reporter.easy_run in
70
66
let forest, history =
71
67
State.make ~env ~config ~dev:true ()
72
68
|> Driver.run_with_history Load_all_configured_dirs
···
107
103
let@ tmp_path = with_test_forest ~raw_trees ~env ~config in
108
104
Logs.app (fun m ->
109
105
m "In temp dir %s" (Unix.realpath @@ Eio.Path.native_exn tmp_path));
110
-
let@ () = Reporter.easy_run in
111
106
let forest =
112
107
State.make ~env ~config ~dev:false ()
113
108
|> Driver.run_until_done Load_all_configured_dirs
···
139
134
(Forest_graph.in_degree reparsed.import_graph vtx > 0)
140
135
141
136
let test_omits_paths ~env () =
142
-
let@ () = Reporter.easy_run in
143
137
let forest = Driver.batch_run ~env ~config ~dev:false in
144
138
let path =
145
139
match forest.@{URI.of_string_exn "http://forest.local/t8/"} with
+13
-26
lib/compiler/test/Test_errors.ml
+13
-26
lib/compiler/test/Test_errors.ml
···
5
5
*)
6
6
7
7
open Forester_core
8
-
open Forester_prelude
9
8
open Forester_compiler
10
9
open Forester_test
11
10
open Testables
12
11
12
+
module type Source = sig
13
+
val v : Grace.Source.t
14
+
end
15
+
16
+
let source str = `String Grace.Source.{name = None; content = str}
17
+
13
18
let parse_string str =
14
19
let lexbuf = Lexing.from_string str in
15
-
let res = Parse.parse lexbuf in
20
+
let source = source str in
21
+
let res = Parse.parse source lexbuf in
16
22
Result.map strip_code res
17
23
18
-
let _test_parse_error_explanation src expect =
19
-
Alcotest.(check @@ result code string)
20
-
"" (Result.Error expect)
21
-
(parse_string src
22
-
|> Result.map_error (fun d ->
23
-
Asai.Diagnostic.string_of_text d.explanation.value))
24
-
25
24
let raw_trees =
26
25
[
27
26
{path = "parse_error.tree"; content = "\\})--aa]jv"};
28
27
{path = "import_error.tree"; content = {|\import{nonexistent}|}};
29
28
]
30
29
31
-
let check_diagnostic expect kont =
32
-
let fatal = fun d -> Alcotest.(check message) "" expect d.message in
33
-
let emit = Fun.const () in
34
-
Reporter.run ~fatal ~emit (fun () ->
35
-
kont ();
36
-
())
37
-
38
30
let () =
39
31
let@ env = Eio_main.run in
40
32
let config = Config.default () in
41
-
let _test () =
33
+
let test () =
42
34
let@ tmp_dir = with_test_forest ~env ~raw_trees ~config in
43
35
Sys.chdir (Eio.Path.native_exn tmp_dir);
44
-
let@ () =
45
-
check_diagnostic (Resource_not_found (URI.of_string_exn "asdf"))
46
-
in
47
-
let@ () = Reporter.easy_run in
48
36
let forest = Driver.batch_run ~env ~config ~dev:false in
49
37
Alcotest.(check @@ list action)
50
38
""
···
62
50
in
63
51
let open Alcotest in
64
52
run "verify error reporting"
65
-
[ (* "parsing", *)
66
-
(* [ *)
67
-
(* test_case "nonexistent tree" `Quick test; *)
68
-
(* ]; *)
53
+
[
54
+
("parsing", [test_case "nonexistent tree" `Quick test]);
69
55
(* "expanding", *)
70
56
(* [ *)
71
57
(* ]; *)
···
73
59
(* [ *)
74
60
(* ]; *)
75
61
(* "driver", *)
76
-
(* []; *) ]
62
+
(* []; *)
63
+
]
+4
-7
lib/compiler/test/Test_expansion.ml
+4
-7
lib/compiler/test/Test_expansion.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Forester_prelude
8
7
open Forester_core
9
8
open Forester_compiler
10
9
open Forester_test
11
10
open Forester_lsp
12
11
open Forester_frontend
13
12
open Testables
13
+
open Result.Syntax
14
14
15
15
open struct
16
16
module T = Types
···
32
32
Expand.expand ~forest code
33
33
34
34
let render ~forest expanded =
35
-
Result.map
36
-
(fun expanded ->
37
-
let Eval.{articles; _}, _ =
35
+
Result.bind expanded (fun expanded ->
36
+
let* Eval.{articles; _} =
38
37
Eval.eval_tree ~config:(Config.default ())
39
38
~uri:(URI.of_string_exn "http://localhost/test")
40
39
~source_path:None expanded
···
59
58
Plain_text_client.string_of_content ~forest T.(article.mainmatter))
60
59
articles
61
60
in
62
-
String.concat "" rendered)
63
-
expanded
61
+
ok @@ String.concat "" rendered)
64
62
65
63
let test_subtree ~env () =
66
-
let@ () = Reporter.easy_run in
67
64
let forest = State.make ~env ~config ~dev:false () in
68
65
let expanded =
69
66
expand ~forest
+1
-3
lib/compiler/test/Test_import_graph.ml
+1
-3
lib/compiler/test/Test_import_graph.ml
···
6
6
7
7
open Forester_core
8
8
open Forester_compiler
9
-
open Forester_prelude
10
9
open Forester_test
11
10
open Testables
12
11
···
15
14
end
16
15
17
16
let config = {(Config.default ()) with trees = ["imports"]}
18
-
let mk_vertex v = T.Uri_vertex (URI_scheme.named_uri ~base:config.url v)
17
+
let mk_vertex v = T.Uri_vertex (URI.named_uri ~base:config.url v)
19
18
let has_edge g v w = Forest_graph.mem_edge g (mk_vertex v) (mk_vertex w)
20
19
21
20
(*
···
61
60
]
62
61
63
62
let test_import_graph ~env () =
64
-
let@ () = Reporter.easy_run in
65
63
let@ tmp_dir = with_test_forest ~env ~config ~raw_trees in
66
64
Sys.chdir (Eio.Path.native_exn tmp_dir);
67
65
let forest, history =
-1
lib/compiler/test/Test_incremental_compilation.ml
-1
lib/compiler/test/Test_incremental_compilation.ml
+2
-1
lib/compiler/test/dune
+2
-1
lib/compiler/test/dune
···
4
4
5
5
(tests
6
6
(names
7
+
Test_errors
7
8
Test_expansion
8
9
Test_compiler
9
10
Test_diagnostic_store
···
13
14
(preprocess
14
15
(pps ppx_deriving.show))
15
16
(libraries
16
-
asai
17
17
eio
18
18
eio_main
19
19
eio.core
···
23
23
fmt
24
24
lsp
25
25
logs
26
+
grace
26
27
logs.fmt
27
28
yuujinchou
28
29
ocamlgraph
+86
lib/core/Code.ml
+86
lib/core/Code.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
+
open Forester_prelude
7
8
open Base
8
9
9
10
open struct
···
137
138
| Decl_xmlns (_, _)
138
139
| Alloc _ | Dx_var _ | Comment _ | Error _ ->
139
140
[]
141
+
142
+
module DSL = struct
143
+
open Range
144
+
let import_private = import_private >>> unloc
145
+
let import_public = import_public >>> unloc
146
+
let inline_math = inline_math >>> unloc
147
+
let display_math = display_math >>> unloc
148
+
let parens = parens >>> unloc
149
+
let squares = squares >>> unloc
150
+
let braces = braces >>> unloc
151
+
let ident i = unloc @@ Ident i
152
+
let hash_ident str = unloc @@ Hash_ident str
153
+
let p content = [ident ["p"]; braces content]
154
+
let ul content = [ident ["ul"]; braces content]
155
+
let li content = [ident ["li"]; braces content]
156
+
let text str = unloc @@ Text str
157
+
let verbatim str = unloc @@ Verbatim str
158
+
let math mode nodes = unloc @@ Math (mode, nodes)
159
+
let ident path = unloc @@ Ident path
160
+
let scope nodes = unloc @@ Scope nodes
161
+
let open_ path = unloc @@ Open path
162
+
let group delim nodes = unloc @@ Group (delim, nodes)
163
+
let def p b t = unloc @@ Def (p, b, t)
164
+
let object_ t = unloc @@ Object t
165
+
end
166
+
167
+
(* Not all nodes need to be documented, such as `Group` *)
168
+
let nodes =
169
+
[
170
+
Text "";
171
+
Verbatim "";
172
+
Math (Inline, []);
173
+
Ident [];
174
+
Hash_ident "";
175
+
Xml_ident (None, "");
176
+
Subtree (None, []);
177
+
Let ([], [], []);
178
+
Open [];
179
+
Scope [];
180
+
Put ([], []);
181
+
Default ([], []);
182
+
Get [];
183
+
Fun ([], []);
184
+
Object {self = None; methods = []};
185
+
Patch {obj = []; self = None; super = None; methods = []};
186
+
Call ([], "");
187
+
Import (Private, "");
188
+
Import (Public, "");
189
+
Def ([], [], []);
190
+
Decl_xmlns ("", "");
191
+
Alloc [];
192
+
Namespace ([], []);
193
+
Comment "";
194
+
]
195
+
196
+
let doc =
197
+
let open DSL in
198
+
List.map
199
+
(function
200
+
| Text _ -> p [text ""]
201
+
| Verbatim _
202
+
| Group (_, _)
203
+
| Math (_, _)
204
+
| Ident _ | Hash_ident _
205
+
| Xml_ident (_, _)
206
+
| Subtree (_, _)
207
+
| Let (_, _, _)
208
+
| Open _ | Scope _
209
+
| Put (_, _)
210
+
| Default (_, _)
211
+
| Get _
212
+
| Fun (_, _)
213
+
| Object _ | Patch _
214
+
| Call (_, _)
215
+
| Import (_, _)
216
+
| Def (_, _, _)
217
+
| Decl_xmlns (_, _)
218
+
| Alloc _
219
+
| Namespace (_, _)
220
+
| Dx_sequent (_, _)
221
+
| Dx_query (_, _, _)
222
+
| Dx_prop (_, _)
223
+
| Dx_var _ | Dx_const_content _ | Dx_const_uri _ | Comment _ | Error _ ->
224
+
[])
225
+
nodes
+25
lib/core/Code.mli
+25
lib/core/Code.mli
···
71
71
val display_math : t -> node
72
72
val map : (t -> t) -> node -> node
73
73
val children : node Range.located -> t
74
+
75
+
module DSL : sig
76
+
val import_private : string -> node Range.located
77
+
val import_public : string -> node Range.located
78
+
val inline_math : t -> node Range.located
79
+
val display_math : t -> node Range.located
80
+
val parens : t -> node Range.located
81
+
val squares : t -> node Range.located
82
+
val braces : t -> node Range.located
83
+
val hash_ident : string -> node Range.located
84
+
val p : t -> node Range.located list
85
+
val ul : t -> node Range.located list
86
+
val li : t -> node Range.located list
87
+
val text : string -> node Range.located
88
+
val verbatim : string -> node Range.located
89
+
val math : Base.math_mode -> t -> node Range.located
90
+
val ident : Trie.path -> node Range.located
91
+
val scope : t -> node Range.located
92
+
val open_ : Trie.path -> node Range.located
93
+
val group : Base.delim -> t -> node Range.located
94
+
95
+
val def : Trie.path -> string Base.binding list -> t -> node Range.located
96
+
97
+
val object_ : t _object -> node Range.located
98
+
end
+5
lib/core/Collect_errors.ml
+5
lib/core/Collect_errors.ml
+1
-1
lib/core/Config.ml
+1
-1
lib/core/Config.ml
+14
lib/core/Error.ml
+14
lib/core/Error.ml
···
1
+
open Forester_prelude
2
+
open Grace
3
+
open Grace_ansi_renderer
4
+
5
+
let print_warning :
6
+
?notes:Diagnostic.Message.t list ->
7
+
?labels:Diagnostic.Label.t list ->
8
+
?code:'code ->
9
+
(error, error) Diagnostic.format ->
10
+
unit =
11
+
fun ?notes ?labels ?code ->
12
+
Diagnostic.createf Warning ?notes ?labels ?code
13
+
>>> Format.printf "%a@."
14
+
(pp_diagnostic ~code_to_string:Message.to_string ?config:None)
+5
-4
lib/core/Forester_core.ml
+5
-4
lib/core/Forester_core.ml
···
9
9
include Base
10
10
(**@closed*)
11
11
12
+
include Forester_prelude
13
+
(**@closed*)
14
+
12
15
module URI = URI
13
16
module URI_scheme = URI_scheme
14
17
module Config = Config
···
22
25
module Vertex_set = Vertex_set
23
26
24
27
(** {1 Error handling}*)
25
-
26
-
(** {2 Compiler diagnostics and other errors.}*)
27
-
28
-
module Reporter = Reporter
29
28
30
29
(** {2 Source locations}
31
30
These are used by compiler diagnostics and the language server.*)
···
60
59
module Resolver = Resolver
61
60
module Code = Code
62
61
module Tree = Tree
62
+
module Collect_errors = Collect_errors
63
+
module Error = Error
+12
-28
lib/core/Range.ml
+12
-28
lib/core/Range.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
include Asai.Range
7
+
include Grace.Range
8
8
9
-
let pp_located pp_arg fmt (x : 'a located) = pp_arg fmt x.value
10
-
let map f node = {node with value = f node.value}
9
+
type t = Grace.Range.t
11
10
12
-
type string_source = Asai.Range.string_source = {
13
-
title: string option;
14
-
content: string;
15
-
}
16
-
[@@deriving repr]
11
+
type 'a located = {value: 'a; range: Grace.Range.t option}
17
12
18
-
type source = [`File of string | `String of string_source] [@@deriving repr]
13
+
let unloc a = {value = a; range = None}
14
+
let get_value {value; _} = value
19
15
20
-
type position = Asai.Range.position = {
21
-
source: source;
22
-
offset: int;
23
-
start_of_line: int;
24
-
line_num: int;
25
-
}
26
-
[@@deriving repr]
16
+
let pp_located pp_arg fmt (x : 'a located) = pp_arg fmt x.value
17
+
let map : type a b. (a -> b) -> a located -> b located =
18
+
fun f node -> {node with value = f node.value}
27
19
28
-
let t : t Repr.t =
29
-
let open Repr in
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
34
-
end
35
-
|~ case1 "Range" (pair position_t position_t) make
36
-
|~ case1 "End_of_file" position_t eof
37
-
|> sealv
20
+
let located_t a = Repr.map a unloc get_value
21
+
let locate_lex ?source (start, end_) a =
22
+
{range = Some (of_lex ?source (start, end_)); value = a}
38
23
39
-
type 'a located = 'a Asai.Range.located = {loc: t option; value: 'a}
40
-
[@@deriving repr]
24
+
let locate_opt range value = {range; value}
-69
lib/core/Reporter.ml
-69
lib/core/Reporter.ml
···
1
-
(*
2
-
* SPDX-FileCopyrightText: 2024 The Forester Project Contributors
3
-
*
4
-
* SPDX-License-Identifier: GPL-3.0-or-later
5
-
*)
6
-
7
-
module R = Resolver
8
-
module Sc = R.Scope
9
-
module Message = Reporter_message
10
-
include Asai.StructuredReporter.Make (Message)
11
-
12
-
type diagnostic = Message.t Asai.Diagnostic.t
13
-
14
-
let log pp s = Logs.info (fun m -> m "%a...@." pp s)
15
-
16
-
let profile msg body =
17
-
let before = Unix.gettimeofday () in
18
-
let result = body () in
19
-
let after = Unix.gettimeofday () in
20
-
emit
21
-
~extra_remarks:[Asai.Diagnostic.loctextf "%s" msg]
22
-
(Profiling (after, before));
23
-
result
24
-
25
-
module Tty = Asai.Tty.Make (Message)
26
-
27
-
let easy_run k =
28
-
let fatal diagnostics =
29
-
Tty.display diagnostics;
30
-
exit 1
31
-
in
32
-
run ~emit:Tty.display ~fatal k
33
-
34
-
let silence k =
35
-
let fatal diagnostics =
36
-
Tty.display diagnostics;
37
-
exit 1
38
-
in
39
-
run ~emit:Tty.display ~fatal k
40
-
41
-
let test_run k =
42
-
let fatal diagnostics =
43
-
Tty.display ~use_color:false ~use_ansi:false diagnostics;
44
-
exit 1
45
-
in
46
-
let emit _diagnostics = () in
47
-
run ~emit ~fatal k
48
-
49
-
(* Reporting diagnostics requires a document URI to publish *)
50
-
let guess_uri (d : diagnostic) =
51
-
match d with
52
-
| {explanation; _} -> (
53
-
match explanation.loc with
54
-
| None -> None
55
-
| Some loc -> (
56
-
match Range.view loc with
57
-
| `End_of_file {source; _} | `Range ({source; _}, _) -> (
58
-
match source with
59
-
| `String _ -> None
60
-
| `File path -> if path <> "" then Some (Lsp.Uri.of_path path) else None
61
-
)))
62
-
63
-
let ignore =
64
-
let emit _ = () in
65
-
let fatal _ =
66
-
fatal Message.Internal_error
67
-
~extra_remarks:[Asai.Diagnostic.loctext "ignoring error"]
68
-
in
69
-
run ~emit ~fatal
-24
lib/core/Reporter.mli
-24
lib/core/Reporter.mli
···
1
-
(*
2
-
* SPDX-FileCopyrightText: 2024 The Forester Project Contributors
3
-
*
4
-
* SPDX-License-Identifier: GPL-3.0-or-later
5
-
*)
6
-
7
-
module Message : module type of Reporter_message
8
-
include module type of Asai.StructuredReporter.Make (Message)
9
-
module Tty : module type of Asai.Tty.Make (Message)
10
-
11
-
type diagnostic = Message.t Asai.Diagnostic.t
12
-
13
-
val log : (Format.formatter -> 'a -> unit) -> 'a -> unit
14
-
val profile : string -> (unit -> 'a) -> 'a
15
-
val easy_run : (unit -> 'a) -> 'a
16
-
val silence : (unit -> 'a) -> 'a
17
-
val test_run : (unit -> 'a) -> 'a
18
-
val guess_uri : diagnostic -> Lsp.Uri.t option
19
-
20
-
val ignore :
21
-
?init_loc:Asai.Range.t ->
22
-
?init_backtrace:Asai.Diagnostic.backtrace ->
23
-
(unit -> 'a) ->
24
-
'a
-248
lib/core/Reporter_message.ml
-248
lib/core/Reporter_message.ml
···
1
-
open Base
2
-
3
-
open struct
4
-
module R = Resolver
5
-
module Sc = R.Scope
6
-
end
7
-
8
-
type expected_value =
9
-
| Content
10
-
| Text
11
-
| Obj
12
-
| Bool
13
-
| Sym
14
-
| Dx_query
15
-
| Dx_sequent
16
-
| Dx_prop
17
-
| Datalog_term
18
-
| Node
19
-
| URI
20
-
| Argument
21
-
[@@deriving show]
22
-
23
-
type t =
24
-
| Import_not_found of URI.t
25
-
| Invalid_URI
26
-
| Asset_has_no_content_address of string
27
-
| Asset_not_found of string
28
-
| Current_tree_has_no_uri
29
-
| Duplicate_tree of origin * origin
30
-
| Parse_error
31
-
| Unbound_method of (string * Value.obj)
32
-
| Type_warning
33
-
| Type_error of {got: Value.t option; expected: expected_value list}
34
-
| Unbound_fluid_symbol of Symbol.t
35
-
| Unbound_variable of string
36
-
| Unresolved_identifier of ((Sc.data, R.P.tag) Trie.t[@opaque]) * Trie.path
37
-
| Unresolved_xmlns of string
38
-
| Reference_error of URI.t
39
-
| Unhandled_case
40
-
| Transclusion_loop
41
-
| Internal_error
42
-
| Configuration_error
43
-
| Initialization_warning
44
-
| Routing_error
45
-
| Profiling of float * float
46
-
| External_error
47
-
| Resource_not_found of URI.t
48
-
| Broken_link of {uri: URI.t; suggestion: URI.t option}
49
-
| IO_error
50
-
| Log
51
-
| Missing_argument
52
-
| Uninterpreted_config_options of string list list
53
-
| Using_default_option of string list
54
-
| Required_config_option of string
55
-
[@@deriving show]
56
-
57
-
let default_severity : t -> Asai.Diagnostic.severity = function
58
-
| Import_not_found _ -> Error
59
-
| Unresolved_identifier _ -> Warning
60
-
| Unresolved_xmlns _ -> Error
61
-
| Invalid_URI -> Error
62
-
| Unbound_method _ -> Error
63
-
| Asset_has_no_content_address _ -> Error
64
-
| Asset_not_found _ -> Error
65
-
| Current_tree_has_no_uri -> Error
66
-
| Reference_error _ -> Error
67
-
| Duplicate_tree _ -> Error
68
-
| Parse_error -> Error
69
-
| Type_error _ -> Error
70
-
| Type_warning -> Warning
71
-
| Unbound_fluid_symbol _ -> Error
72
-
| Unbound_variable _ -> Error
73
-
| Unhandled_case -> Bug
74
-
| Transclusion_loop -> Error
75
-
| Internal_error -> Bug
76
-
| Configuration_error -> Error
77
-
| Initialization_warning -> Warning
78
-
| Routing_error -> Error
79
-
| Profiling _ -> Info
80
-
| External_error -> Error
81
-
| Log -> Info
82
-
| Resource_not_found _ -> Error
83
-
| Broken_link _ -> Warning
84
-
| IO_error -> Error
85
-
| Missing_argument -> Error
86
-
| Uninterpreted_config_options _ -> Warning
87
-
| Using_default_option _ -> Info
88
-
| Required_config_option _ -> Error
89
-
90
-
let short_code : t -> string = function
91
-
| Import_not_found _ -> "import_not_found"
92
-
| Invalid_URI -> "invalid_uri"
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.*)
97
-
| Asset_not_found _ -> "asset_not_found"
98
-
| Current_tree_has_no_uri -> "current_tree_has_no_uri"
99
-
| Duplicate_tree _ -> "duplicate_tree"
100
-
| Parse_error -> "parse_error"
101
-
| Unbound_method _ -> "unbound_method"
102
-
| Type_warning -> "type_warning"
103
-
| Type_error _ -> "type_error"
104
-
| Unbound_fluid_symbol _ -> "unbound_fluid_symbol"
105
-
| Unbound_variable _ -> "Unbound_variable"
106
-
| Unresolved_xmlns _ -> "unresolved_xmlns"
107
-
| Unresolved_identifier _ -> "unresolved_identifier"
108
-
| Reference_error _ -> "reference_error"
109
-
| Unhandled_case -> "unhandled_case"
110
-
| Transclusion_loop -> "transclusion_loop"
111
-
| Internal_error -> "internal_error"
112
-
| Configuration_error -> "configuration_error"
113
-
| Initialization_warning -> "initialization_warning"
114
-
| Routing_error -> "routing_error"
115
-
| Profiling (_, _) -> "profiling"
116
-
| External_error -> "external_error"
117
-
| Resource_not_found _ -> "resource_not_found"
118
-
| Broken_link _ -> "broken_link"
119
-
| IO_error -> "io_error"
120
-
| Log -> "log"
121
-
| Missing_argument -> "missing_argument"
122
-
| Uninterpreted_config_options _ -> "unknown_config_option"
123
-
| Using_default_option _ -> "using_default_option"
124
-
| Required_config_option _ -> "required_config_option"
125
-
126
-
let this_is : Value.t -> string = function
127
-
| Value.Content _ -> "content"
128
-
| Value.Clo (_, _, _) -> "a closure"
129
-
| Value.Dx_prop _ -> "a datalog proposition"
130
-
| Value.Dx_sequent _ -> "a datalog sequent"
131
-
| Value.Dx_query _ -> "a datalog query"
132
-
| Value.Dx_var _ -> "a datalog variable"
133
-
| Value.Dx_const _ -> "a datalog constant"
134
-
| Value.Sym _ -> "a symbol"
135
-
| Value.Obj _ -> "an object"
136
-
137
-
let show_expected_value : expected_value -> string = function
138
-
| Content -> "content"
139
-
| Text -> "text"
140
-
| Obj -> "an object"
141
-
| Bool -> "a boolean"
142
-
| Sym -> "a symbol"
143
-
| Dx_query -> "a datalog query"
144
-
| Dx_sequent -> "a datalog sequent"
145
-
| Dx_prop -> "a datalog proposition"
146
-
| Datalog_term -> "a datalog term"
147
-
| Node -> "a node" (* This might be hard to understand for the end user*)
148
-
| URI -> "a URI"
149
-
| Argument -> "an argument"
150
-
151
-
let default_text : t -> Asai.Diagnostic.text = function
152
-
| Import_not_found uri -> Asai.Diagnostic.textf "%a not found" URI.pp uri
153
-
| Unresolved_xmlns prefix ->
154
-
Asai.Diagnostic.textf "Could not resolve prefix `%s` to XML namespace"
155
-
prefix
156
-
| Unresolved_identifier (_, p) ->
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
196
-
| Asset_not_found msg -> Asai.Diagnostic.text msg
197
-
| Unbound_method (mthd, {prototype = _; methods; _}) ->
198
-
let method_names = List.map fst @@ Value.Method_table.to_list methods in
199
-
Asai.Diagnostic.textf "Unbound method %s. Available methods are:@.%a" mthd
200
-
Format.(pp_print_list (fun ppf s -> fprintf ppf " %s" s))
201
-
method_names
202
-
| Uninterpreted_config_options keys ->
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)
207
-
Format.(
208
-
pp_print_list
209
-
~pp_sep:(fun out () -> fprintf out ", ")
210
-
(fun ppf k ->
211
-
fprintf ppf "%a"
212
-
(pp_print_list
213
-
~pp_sep:(fun out () -> fprintf out ".")
214
-
pp_print_string)
215
-
k))
216
-
keys
217
-
| Using_default_option k ->
218
-
Asai.Diagnostic.textf
219
-
"Configuration option %a is not set. Using default value."
220
-
Format.(
221
-
pp_print_list ~pp_sep:(fun out () -> fprintf out ".") pp_print_string)
222
-
k
223
-
| Required_config_option k ->
224
-
Asai.Diagnostic.textf "Required option %s is not set." k
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
233
-
| Resource_not_found uri ->
234
-
Asai.Diagnostic.textf "Resource not found: %a" URI.pp uri
235
-
| Duplicate_tree (o1, o2) ->
236
-
let show_origin = function
237
-
| Physical doc -> Lsp.(Uri.to_path @@ Text_document.documentUri doc)
238
-
| Subtree {parent} -> Format.asprintf "%a" pp_identity parent
239
-
| Undefined -> "undefined"
240
-
in
241
-
Asai.Diagnostic.textf "%s@ and@ %s@ use@ the@ same@ URI" (show_origin o1)
242
-
(show_origin o2)
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 ->
248
-
Asai.Diagnostic.text ""
+2
-3
lib/core/Resolver.ml
+2
-3
lib/core/Resolver.ml
···
6
6
7
7
module P = struct
8
8
type data = Syn.resolver_data
9
-
type tag = Asai.Range.t option
9
+
type tag = Grace.Range.t option
10
10
type hook = unit (* for modifier hooks; unused here *)
11
11
type context = unit (* for advanced printing and reporting; unused here *)
12
12
end
···
38
38
Format.(
39
39
pp_print_seq
40
40
(pp_print_pair Trie.pp_path
41
-
(pp_print_pair Syn.pp_resolver_data
42
-
(pp_print_option Asai.Range.dump))))
41
+
(pp_print_pair Syn.pp_resolver_data (pp_print_option Grace.Range.pp))))
43
42
end
44
43
45
44
module Lang = Yuujinchou.Language
+9
-6
lib/core/TeX_like.ml
+9
-6
lib/core/TeX_like.ml
···
6
6
*)
7
7
8
8
open Types
9
+
open Grace
9
10
10
11
let rec pp_content fmt = function
11
12
| Content nodes -> List.iter (pp_content_node fmt) nodes
···
17
18
| Xml_elt _ | Transclude _ | Contextual_number _ | Section _ | Link _
18
19
| Artefact _ | Uri _ | Route_of_uri _ | Datalog_script _
19
20
| 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
-
]
21
+
let diagnostic =
22
+
Diagnostic.createf Error ~code:`Internal_error
23
+
"Cannot render this kind of content node as TeX-like string"
24
+
in
25
+
Format.printf "%a@."
26
+
Grace_ansi_renderer.(pp_diagnostic ?config:None ?code_to_string:None)
27
+
diagnostic;
28
+
assert false
26
29
27
30
let string_of_content = Format.asprintf "%a" pp_content
+15
-29
lib/core/Tree.ml
+15
-29
lib/core/Tree.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
+
open Grace
8
+
open Forester_prelude
9
+
7
10
open struct
8
11
module T = Types
9
12
module R = Resolver
10
13
include Base
11
14
end
12
15
13
-
type exports = (R.P.data, Asai.Range.t option) Trie.t
16
+
type exports = (R.P.data, Grace.Range.t option) Trie.t
14
17
15
18
type code = {
16
19
nodes: Code.t;
···
59
62
| Expanded _ -> "expanded"
60
63
| Resource _ -> "resource"
61
64
62
-
(* let get_uri ~base = fun t ->
63
-
let of_lsp_uri doc = Some (URI_scheme.lsp_uri_to_uri ~base (Lsp.Text_document.documentUri doc)) in
64
-
let uri_opt =
65
-
match t with
66
-
| Document doc -> of_lsp_uri doc
67
-
| Resource {tree; _} -> T.uri_for_resource tree
68
-
| Expanded {identity; _}
69
-
| Parsed {identity; _} ->
70
-
identity_to_uri identity
71
-
in
72
-
match uri_opt with
73
-
| Some uri -> uri
74
-
| None -> Reporter.fatal Internal_error ~extra_remarks: [Asai.Diagnostic.loctext "tried to get URI of an anonymous resource"] *)
65
+
let of_lsp_uri ~base uri = URI_scheme.lsp_uri_to_uri ~base uri
75
66
76
67
(* IDK if subtrees should resolve to their parent document*)
77
68
let to_doc : t -> Lsp.Text_document.t option = function
···
155
146
| Resource {resource; _} -> (
156
147
match resource with T.Asset _ -> true | _ -> false)
157
148
158
-
let update_units : t -> exports -> t =
149
+
let update_units : t -> exports -> (t, [`Internal_error] Diagnostic.t) result =
159
150
fun item units ->
160
151
match item with
161
152
| 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
-
]
168
-
| Expanded e -> Expanded {e with units}
153
+
error
154
+
@@ Diagnostic.createf Error ~code:`Internal_error
155
+
"can't update units for this item. It has not been expanded yet"
156
+
| Expanded e -> ok @@ Expanded {e with units}
169
157
| Resource ({expanded; _} as e) -> (
170
158
match expanded with
171
159
| None ->
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}})
160
+
error
161
+
@@ Diagnostic.createf Error ~code:`Internal_error
162
+
"can't update units for this item. It is not a tree."
163
+
| Some expanded ->
164
+
ok @@ Resource {e with expanded = Some {expanded with units}})
+12
lib/core/URI.ml
+12
lib/core/URI.ml
···
88
88
module Map = Map.Make (Basics)
89
89
module Tbl = Hashtbl.Make (Basics)
90
90
include Basics
91
+
92
+
let named_uri ~base name =
93
+
resolve ~base
94
+
@@
95
+
let path = if Filename.extension name = "" then [name; ""] else [name] in
96
+
make ~path ()
97
+
98
+
let last_segment = String.split_on_char '/' >>> List.rev >>> List.hd
99
+
100
+
let of_document ~(base : t) =
101
+
Lsp.Uri.to_path >>> Filename.chop_extension >>> last_segment
102
+
>>> named_uri ~base
+4
lib/core/URI.mli
+4
lib/core/URI.mli
+5
-16
lib/core/URI_scheme.ml
+5
-16
lib/core/URI_scheme.ml
···
6
6
7
7
open Forester_prelude
8
8
9
-
let named_uri ~base name =
10
-
URI.resolve ~base
11
-
@@
12
-
let path = if Filename.extension name = "" then [name; ""] else [name] in
13
-
URI.make ~path ()
14
-
15
-
let last_segment str = str |> String.split_on_char '/' |> List.rev |> List.hd
16
-
17
9
let name (uri : URI.t) : string option =
18
10
uri |> URI.path_components
19
11
|> List.filter (fun x -> not (x = ""))
···
37
29
let@ key = Option.map @~ BaseN.Base36.int_of_string name in
38
30
(None, key)
39
31
40
-
let lsp_uri_to_uri ~(base : URI.t) (uri : Lsp.Uri.t) : URI.t =
41
-
let uri =
42
-
uri |> Lsp.Uri.to_path |> Filename.chop_extension |> last_segment
43
-
|> named_uri ~base
44
-
in
45
-
uri
32
+
let lsp_uri_to_uri ~(base : URI.t) =
33
+
Lsp.Uri.to_path >>> Filename.chop_extension >>> URI.last_segment
34
+
>>> URI.named_uri ~base
46
35
47
-
let path_to_uri ~(base : URI.t) str =
48
-
str |> last_segment |> Filename.chop_extension |> named_uri ~base
36
+
let path_to_uri ~(base : URI.t) =
37
+
URI.last_segment >>> Filename.chop_extension >>> URI.named_uri ~base
-2
lib/core/URI_scheme.mli
-2
lib/core/URI_scheme.mli
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
val named_uri : base:URI.t -> string -> URI.t
8
7
val lsp_uri_to_uri : base:URI.t -> Lsp.Uri.t -> URI.t
9
8
val split_addr : URI.t -> (string option * int) option
10
9
val path_to_uri : base:URI.t -> string -> URI.t
11
-
val last_segment : string -> string
12
10
val name : URI.t -> string option
+6
-2
lib/core/dune
+6
-2
lib/core/dune
+20
-17
lib/frontend/Atom_client.ml
+20
-17
lib/frontend/Atom_client.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Forester_prelude
8
7
open Forester_core
9
8
open Forester_compiler
9
+
open Message
10
10
11
11
open struct
12
12
module T = Types
···
146
146
]
147
147
148
148
let render_feed (forest : State.t) ~(source_uri : URI.t) ~(feed_uri : URI.t) :
149
-
P.node =
149
+
P.node res =
150
150
match State.get_article ~forest source_uri with
151
-
| None -> Reporter.fatal @@ Resource_not_found source_uri
151
+
| None ->
152
+
let _ = source_uri in
153
+
error @@ Diagnostic.createf Error ~code:Resource_not_found ""
152
154
| Some blog ->
153
155
let articles = get_embedded_articles forest blog in
154
156
let all_dates =
···
156
158
article.frontmatter.dates
157
159
in
158
160
let blog_uri_string = URI.to_string source_uri in
159
-
A.feed []
160
-
[
161
-
render_attributions forest blog.frontmatter.uri
162
-
blog.frontmatter.attributions;
163
-
render_updated_date all_dates;
164
-
render_title forest blog.frontmatter;
165
-
A.id [] "%s" blog_uri_string;
166
-
A.link [A.rel "alternate"; A.href "%s" blog_uri_string];
167
-
A.link [A.rel "self"; A.href "%s" @@ URI.to_string feed_uri];
168
-
(A.null
169
-
@@
170
-
let@ article = List.map @~ articles in
171
-
render_entry ~forest ~scope:source_uri article);
172
-
]
161
+
ok
162
+
@@ A.feed []
163
+
[
164
+
render_attributions forest blog.frontmatter.uri
165
+
blog.frontmatter.attributions;
166
+
render_updated_date all_dates;
167
+
render_title forest blog.frontmatter;
168
+
A.id [] "%s" blog_uri_string;
169
+
A.link [A.rel "alternate"; A.href "%s" blog_uri_string];
170
+
A.link [A.rel "self"; A.href "%s" @@ URI.to_string feed_uri];
171
+
(A.null
172
+
@@
173
+
let@ article = List.map @~ articles in
174
+
render_entry ~forest ~scope:source_uri article);
175
+
]
+32
-39
lib/frontend/Config_parser.ml
+32
-39
lib/frontend/Config_parser.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Forester_prelude
8
7
open Forester_core
8
+
open Message
9
+
open Result.Syntax
9
10
10
11
(* type keys = (Toml.Types.Table.key
11
12
[@printer fun fmt key -> fprintf fmt "%s" (Toml.Types.Table.Key.to_string
···
39
40
in
40
41
Key_set.of_list @@ List.map List.rev @@ go [] [] tbl
41
42
42
-
let parse lexbuf filename =
43
-
let@ () = Reporter.easy_run in
43
+
let parse lexbuf filename : Config.t res =
44
44
match Toml.Parser.parse lexbuf filename with
45
45
| `Error (desc, {source; _}) ->
46
-
let@ () = Reporter.tracef "when parsing configuration file" in
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]
46
+
let loc = Range.of_lexbuf ~source:(`File source) lexbuf in
47
+
error @@ Diagnostic.createf Error ~code:Configuration_error "%s" desc
50
48
| `Ok tbl ->
51
49
let open Toml.Lenses in
52
50
let keys = ref (keys tbl) in
53
51
let with_default ~value k lens =
54
52
let open Toml.Lenses in
55
53
match get tbl lens with
56
-
| None ->
57
-
Reporter.emit (Using_default_option k);
58
-
value
54
+
| None -> value
59
55
| Some v ->
60
56
keys := Key_set.remove k !keys;
61
57
v
62
58
in
63
59
let forest = key "forest" |-- table in
64
-
let url =
60
+
let* url =
65
61
let k = ["forest"; "url"] in
66
62
match get tbl (forest |-- key "url" |-- string) with
67
63
| Some url ->
68
64
keys := Key_set.remove k !keys;
69
-
begin try URI.of_string_exn url
65
+
begin try ok @@ URI.of_string_exn url
70
66
with _ ->
71
-
Reporter.fatal Configuration_error
72
-
~extra_remarks:
73
-
[Asai.Diagnostic.loctext "Invalid URL specified in `url` key."]
67
+
error
68
+
@@ Diagnostic.createf Error ~code:Configuration_error
69
+
"Invalid URL specified in `url` key."
74
70
end
75
-
| None ->
76
-
Reporter.emit (Using_default_option k);
77
-
Config.default_url
71
+
| None -> ok Config.default_url
78
72
in
79
73
let default = Config.default ~url () in
80
74
let trees =
···
82
76
with_default ~value:default.trees k
83
77
(forest |-- key "trees" |-- array |-- strings)
84
78
in
85
-
let foreign =
79
+
let errors, foreign =
86
80
let k = ["forest"; "foreign"] in
87
81
match get tbl (forest |-- key "foreign" |-- array |-- tables) with
88
-
| None -> default.foreign
89
-
| Some foreign_tbls ->
82
+
| None -> ([], default.foreign)
83
+
| Some foreign_tbls -> (
90
84
keys := Key_set.remove k !keys;
91
-
let@ foreign_tbl = List.map @~ foreign_tbls in
92
-
let path =
93
-
match get foreign_tbl (key "path" |-- string) with
94
-
| None -> Reporter.fatal (Required_config_option "path")
95
-
| Some path -> path
96
-
in
85
+
let@ foreign_tbl = List_util.error_partition @~ foreign_tbls in
97
86
let route_locally =
98
87
match get foreign_tbl (key "route_locally" |-- bool) with
99
88
| None -> true
···
104
93
| None -> true
105
94
| Some b -> b
106
95
in
107
-
Config.{path; route_locally; include_in_manifest}
96
+
match get foreign_tbl (key "path" |-- string) with
97
+
| None ->
98
+
error
99
+
@@ [Diagnostic.createf Error ~code:Required_config_option "path"]
100
+
| Some path -> ok Config.{path; route_locally; include_in_manifest})
108
101
in
109
102
let assets =
110
103
with_default ~value:default.assets ["forest"; "assets"]
···
112
105
in
113
106
let home =
114
107
let k = ["forest"; "home"] in
115
-
URI_scheme.named_uri ~base:url
108
+
URI.named_uri ~base:url
116
109
@@ with_default ~value:"index" k (forest |-- key "home" |-- string)
117
110
in
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)
124
-
end;
125
111
let theme = get tbl (forest |-- key "theme" |-- string) in
126
-
Config.{url; assets; trees; foreign; home; theme}
112
+
(if not (Key_set.is_empty !keys) then
113
+
let unused_keys =
114
+
!keys |> Key_set.to_list
115
+
|> List.map (List.map Toml.Types.Table.Key.to_string)
116
+
in
117
+
Error.print_warning ~code:Uninterpreted_config_options "");
118
+
ok @@ Config.{url; assets; trees; foreign; home; theme}
127
119
128
120
let parse_forest_config_string str =
129
121
let lexbuf = Lexing.from_string str in
···
136
128
let lexbuf = Lexing.from_channel ch in
137
129
let result = parse lexbuf filename in
138
130
Sys.chdir @@ Filename.dirname filename;
139
-
Ok result
140
-
with exn -> Error exn
131
+
result
132
+
with exn ->
133
+
error @@ Diagnostic.createf Error ~code:IO_error "%a" Eio.Exn.pp exn
+2
-2
lib/frontend/Config_parser.mli
+2
-2
lib/frontend/Config_parser.mli
+3
-27
lib/frontend/DSL.ml
+3
-27
lib/frontend/DSL.ml
···
57
57
let link href content =
58
58
T.Link {href = URI.of_string_exn href; content = T.Content content}
59
59
60
-
module Code = struct
61
-
open Code
62
-
open Asai.Range
63
-
64
-
let import_private = Fun.compose (locate_opt None) @@ Code.import_private
65
-
let import_public = Fun.compose (locate_opt None) @@ Code.import_public
66
-
let inline_math = Fun.compose (locate_opt None) @@ Code.inline_math
67
-
let display_math = Fun.compose (locate_opt None) @@ Code.display_math
68
-
let parens = Fun.compose (locate_opt None) @@ Code.parens
69
-
let squares = Fun.compose (locate_opt None) @@ Code.squares
70
-
let braces = Fun.compose (locate_opt None) @@ Code.braces
71
-
let ident i = locate_opt None @@ Ident i
72
-
let hash_ident str = locate_opt None @@ Hash_ident str
73
-
let ul = ident ["ul"]
74
-
let li = ident ["li"]
75
-
let text str = locate_opt None @@ Text str
76
-
let verbatim str = locate_opt None @@ Verbatim str
77
-
let math mode nodes = locate_opt None @@ Math (mode, nodes)
78
-
let ident path = locate_opt None @@ Ident path
79
-
let scope nodes = locate_opt None @@ Scope nodes
80
-
let open_ path = locate_opt None @@ Open path
81
-
let group delim nodes = locate_opt None @@ Group (delim, nodes)
82
-
let def p b t = locate_opt None @@ Def (p, b, t)
83
-
let object_ t = locate_opt None @@ Code.Object t
84
-
end
85
-
86
60
module Syn = struct
61
+
(*
87
62
open Forester_core.Syn
88
-
open Asai.Range
89
63
90
64
let fun_ b t = locate_opt None @@ Fun (b, t)
91
65
let prim p = locate_opt None @@ Prim p
···
94
68
let squares e = locate_opt None @@ Group (Squares, e)
95
69
let braces e = locate_opt None @@ Group (Braces, e)
96
70
let tex_cs w = locate_opt None @@ TeX_cs (Word w)
71
+
*)
72
+
97
73
end
-1
lib/frontend/Forest_util.ml
-1
lib/frontend/Forest_util.ml
+20
-22
lib/frontend/Forester.ml
+20
-22
lib/frontend/Forester.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Forester_prelude
8
7
open Forester_core
9
8
open Forester_compiler
9
+
open Message
10
+
open Result.Syntax
10
11
11
12
open struct
12
13
module M = URI.Map
···
38
39
let body = Format.asprintf "\\date{%a}\n" Human_datetime.pp now in
39
40
let create = `Exclusive 0o644 in
40
41
(* If no dest_dir is passed, use the config *)
41
-
let dir =
42
+
let* dir =
42
43
match dest_dir with
43
-
| Some dir -> dir
44
+
| Some dir -> ok dir
44
45
| None -> (
45
46
match forest.config.trees with
46
-
| dir :: _ -> dir
47
+
| dir :: _ -> ok dir
47
48
| [] ->
48
-
Reporter.fatal Missing_argument
49
-
~extra_remarks:
50
-
[
51
-
Asai.Diagnostic.loctext
52
-
"Unable to guess destination director for new tree; please \
53
-
supply one.";
54
-
])
49
+
error
50
+
@@ Diagnostic.createf Error ~code:Missing_argument
51
+
"Unable to guess destination director for new tree; please supply \
52
+
one.")
55
53
in
56
54
let path = EP.(env#fs / dir / fname) in
57
55
EP.save ~create path @@ body ^ template_content;
58
-
EP.native_exn path
56
+
ok @@ EP.native_exn path
59
57
60
58
let complete ~(forest : State.t) prefix : (string * string) List.t =
61
59
let config = forest.config in
···
146
144
147
145
let outputs_for_atom_feed_syndication ~(forest : State.t)
148
146
(syndication : T.atom_feed_syndication) =
149
-
let atom_nodes =
147
+
let* atom_nodes =
150
148
Atom_client.render_feed forest ~source_uri:syndication.source_uri
151
149
~feed_uri:syndication.feed_uri
152
150
in
153
151
let atom_content = Format.asprintf "%a" (P.pp_xml ~header:true) atom_nodes in
154
-
[(syndication.feed_uri, atom_content)]
152
+
ok [(syndication.feed_uri, atom_content)]
155
153
156
154
let outputs_for_syndication ~(forest : State.t) = function
157
155
| T.Json_blob syndication ->
158
-
outputs_for_json_blob_syndication ~forest syndication
156
+
ok @@ outputs_for_json_blob_syndication ~forest syndication
159
157
| T.Atom_feed syndication ->
160
158
outputs_for_atom_feed_syndication ~forest syndication
161
159
162
160
let outputs_for_resource ~(forest : State.t) ~emit_legacy_xml
163
161
(evaluated : Tree.evaluated) =
164
-
if not evaluated.route_locally then []
162
+
if not evaluated.route_locally then ok []
165
163
else
166
164
match evaluated.resource with
167
-
| T.Article article -> outputs_for_article ~forest ~emit_legacy_xml article
168
-
| T.Asset asset -> outputs_for_asset asset
165
+
| T.Article article ->
166
+
ok @@ outputs_for_article ~forest ~emit_legacy_xml article
167
+
| T.Asset asset -> ok @@ outputs_for_asset asset
169
168
| T.Syndication syndication -> outputs_for_syndication ~forest syndication
170
169
171
170
let uri_to_local_path ~(forest : State.t) uri =
···
191
190
List.cons [(home_route, home_content)]
192
191
@@
193
192
let@ resource =
194
-
Eio.Fiber.List.map ~max_fibers:40 @~ List.of_seq all_resources
193
+
Eio.Fiber.List.filter_map ~max_fibers:40 @~ List.of_seq all_resources
195
194
in
196
-
let@ () = Reporter.easy_run in
197
-
outputs_for_resource ~forest ~emit_legacy_xml resource
195
+
let _ = failwith "we are dropping all errors here, handle them instead." in
196
+
Result.to_option @@ outputs_for_resource ~forest ~emit_legacy_xml resource
198
197
in
199
198
Logs.debug (fun m -> m "Writing %i files to output" (List.length jobs));
200
199
begin
201
200
(* Note: this part appears to be fast! *)
202
201
let@ items = Eio.Fiber.List.iter ~max_fibers:20 @~ jobs in
203
202
let@ (route : URI.t), content = List.iter @~ items in
204
-
let@ () = Reporter.easy_run in
205
203
let path = EP.(cwd / output_dir_name / uri_to_local_path ~forest route) in
206
204
Eio_util.ensure_context_of_path ~perm:0o755 path;
207
205
EP.save ~create:(`Or_truncate 0o644) path content
+1
-1
lib/frontend/Forester.mli
+1
-1
lib/frontend/Forester.mli
+5
-3
lib/frontend/Html_client.ml
+5
-3
lib/frontend/Html_client.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Forester_prelude
8
7
open Forester_core
9
8
open Forester_compiler
10
9
open Forester_xml_names
10
+
open Message
11
11
open State.Syntax
12
12
open Templates
13
13
open Combinators
···
97
97
let str =
98
98
Format.asprintf "%a" Human_datetime.pp (Human_datetime.drop_time date)
99
99
in
100
-
let uri = URI_scheme.named_uri ~base:env.forest.config.url str in
100
+
let uri = URI.named_uri ~base:env.forest.config.url str in
101
101
match State.get_article ~forest:env.forest uri with
102
102
| None -> None
103
103
| Some _ -> Some (H.href "%s" @@ route ~env uri)
···
202
202
fun ~env -> function
203
203
| Transclusion t -> begin
204
204
match State.get_content_of_transclusion ~forest:env.forest t with
205
-
| None -> Reporter.fatal (Resource_not_found t.href)
205
+
| None ->
206
+
let warning = Diagnostic.createf Warning ~code:Resource_not_found "" in
207
+
H.null []
206
208
| Some content -> H.null @@ render_content ~env content
207
209
end
208
210
| Link link -> render_link ~env link
-1
lib/frontend/Json_manifest_client.ml
-1
lib/frontend/Json_manifest_client.ml
+18
-13
lib/frontend/Legacy_xml_client.ml
+18
-13
lib/frontend/Legacy_xml_client.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Forester_prelude
8
7
open Forester_xml_names
9
8
open Forester_core
10
9
open Forester_compiler
11
10
open State.Syntax
11
+
open Message
12
12
13
13
open struct
14
14
module T = Types
···
50
50
let range ~env =
51
51
let@ uri = Option.bind env.uri in
52
52
let@ path = Option.map @~ State.source_path_of_uri uri env.forest in
53
-
let position =
54
-
Range.{source = `File path; offset = 0; start_of_line = 0; line_num = 0}
55
-
in
56
-
Range.make (position, position)
53
+
Range.initial (`File path)
57
54
58
55
let render_xml_qname qname =
59
56
match qname.prefix with
···
255
252
and render_transclusion ~env (transclusion : T.transclusion) : P.node list =
256
253
match State.get_content_of_transclusion ~forest:env.forest transclusion with
257
254
| None ->
258
-
Reporter.fatal ?loc:(range ~env) (Resource_not_found transclusion.href)
255
+
let loc = range ~env in
256
+
let warning = Diagnostic.createf Warning ~code:Resource_not_found "" in
257
+
[]
259
258
| Some content -> render_content ~env content
260
259
261
260
and render_link ~env (link : T.content T.link) : P.node list =
···
263
262
let attrs =
264
263
match article_opt with
265
264
| None ->
266
-
begin if not env.in_backmatter then
267
-
match State.suggestion_for_uri link.href env.forest with
268
-
| Ok -> ()
269
-
| Not_found {suggestion} ->
270
-
Reporter.emit ?loc:(range ~env)
271
-
@@ Broken_link {uri = link.href; suggestion}
265
+
begin
266
+
Result.get_ok
267
+
@@
268
+
if not env.in_backmatter then
269
+
match State.suggestion_for_uri link.href env.forest with
270
+
| Ok -> ok ()
271
+
| Not_found {suggestion} ->
272
+
let _ = failwith "use suggestion" in
273
+
(*{uri = link.href; suggestion})*)
274
+
(*let loc = ?loc:(range ~env) in*)
275
+
error @@ Diagnostic.createf Error ~code:Broken_link ""
276
+
else ok ()
272
277
end;
273
278
[
274
279
X.href "%s" @@ URI.to_string @@ route env.forest link.href;
···
323
328
let str =
324
329
Format.asprintf "%a" Human_datetime.pp (Human_datetime.drop_time date)
325
330
in
326
-
let uri = URI_scheme.named_uri ~base:config.url str in
331
+
let uri = URI.named_uri ~base:config.url str in
327
332
match State.get_article ~forest:env.forest uri with
328
333
| None -> X.null_
329
334
| Some _ -> X.href "%s" @@ URI.to_string @@ route env.forest uri
+2
-1
lib/frontend/dune
+2
-1
lib/frontend/dune
+21
-21
lib/frontend/test/Test_config.ml
+21
-21
lib/frontend/test/Test_config.ml
···
10
10
open Forester_frontend
11
11
12
12
let test_parsing () =
13
-
Alcotest.(check config)
13
+
Alcotest.(check @@ result config diagnostic)
14
14
"is the same"
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
-
theme = Some "theme";
30
-
}
15
+
(ok
16
+
Config.
17
+
{
18
+
trees = ["trees"];
19
+
assets = [];
20
+
url = URI.of_string_exn "https://www.forester-notes.org/";
21
+
home = URI.of_string_exn "https://www.forester-notes.org/index/";
22
+
foreign =
23
+
[
24
+
{
25
+
path = "foreign/forest.json";
26
+
route_locally = true;
27
+
include_in_manifest = true;
28
+
};
29
+
];
30
+
theme = Some "theme";
31
+
})
31
32
begin
32
-
Forester_core.Reporter.easy_run @@ fun () ->
33
33
Config_parser.parse_forest_config_string
34
34
{|
35
35
[forest]
···
53
53
home = URI.of_string_exn "/index/";
54
54
theme = None;
55
55
}
56
-
( Forester_core.Reporter.easy_run @@ fun () ->
57
-
Config_parser.parse_forest_config_string
58
-
{|
56
+
(Result.get_ok
57
+
@@ Config_parser.parse_forest_config_string
58
+
{|
59
59
[forest]
60
60
trees = ["trees"]
61
61
url = "/"
+2
-4
lib/frontend/test/Test_transclusion.ml
+2
-4
lib/frontend/test/Test_transclusion.ml
···
7
7
(* TODO: should just use cram tests for this instead. *)
8
8
9
9
open Forester_core
10
-
open Forester_prelude
11
10
open Forester_compiler
12
11
open Forester_frontend
13
12
···
17
16
end
18
17
19
18
let config = {(Config.default ()) with trees = ["transclude"]}
20
-
let href = URI_scheme.named_uri ~base:config.url "transcludee"
19
+
let href = URI.named_uri ~base:config.url "transcludee"
21
20
22
21
module Transclusions = struct
23
22
(* It would be cool to use quickcheck here, but no good way to test the result*)
···
30
29
let () =
31
30
let@ env = Eio_main.run in
32
31
Logs.set_level (Some Debug);
33
-
let@ () = Reporter.easy_run in
34
-
let uri = URI_scheme.named_uri ~base:config.url "transcludee" in
32
+
let uri = URI.named_uri ~base:config.url "transcludee" in
35
33
let index = URI.Tbl.create 10 in
36
34
URI.Tbl.add index uri
37
35
@@ Tree.Resource
-1
lib/frontend/test/dune
-1
lib/frontend/test/dune
+42
-37
lib/language_server/Analysis.ml
+42
-37
lib/language_server/Analysis.ml
···
5
5
*
6
6
*)
7
7
8
-
open Forester_prelude
9
8
open Forester_compiler
10
9
open Forester_core
11
10
···
31
30
32
31
(* This function should not descend into the nodes!*)
33
32
let paths : Code.node Range.located -> _ = function
34
-
| {value; loc} -> (
33
+
| {value; range} -> (
35
34
match value with
36
35
| Ident path
37
36
| Open path
···
40
39
| Get path
41
40
| Alloc path
42
41
| Namespace (path, _) ->
43
-
Some ([path], loc)
42
+
Some ([path], range)
44
43
| Def (path, bindings, _) | Let (path, bindings, _) ->
45
-
Some (path :: paths_in_bindings bindings, loc)
44
+
Some (path :: paths_in_bindings bindings, range)
46
45
| Patch {self; _} | Object {self; _} ->
47
-
Option.map (fun x -> ([[x]], loc)) self
48
-
| Fun (bindings, _) -> Some (paths_in_bindings bindings, loc)
46
+
Option.map (fun x -> ([[x]], range)) self
47
+
| Fun (bindings, _) -> Some (paths_in_bindings bindings, range)
49
48
| Subtree _ | Group _ | Scope _ | Math _ | Dx_sequent _ | Dx_const_uri _
50
49
| Dx_const_content _ | Dx_query _ | Dx_prop _ | Text _ | Verbatim _
51
50
| Hash_ident _ | Xml_ident _ | Call _ | Import _ | Decl_xmlns _ | Dx_var _
52
51
| Comment _ | Error _ ->
53
52
None)
54
53
55
-
let extract_addr (node : Code.node Range.located) =
56
-
match node.value with
54
+
let extract_addr ({value; range} : Code.node Range.located) =
55
+
match value with
57
56
| Group (Braces, [{value = Text addr; _}])
58
57
| Group (Parens, [{value = Text addr; _}])
59
58
| Text addr (* SEEEMS DODGY!! *)
60
59
| Import (_, addr) ->
61
-
Some Range.{value = addr; loc = node.loc}
62
-
| Subtree (addr, _) ->
63
-
Option.map (fun s -> Range.{value = s; loc = node.loc}) addr
60
+
Some Range.{value = addr; range}
61
+
| Subtree (addr, _) -> Option.map (fun s -> Range.{value = s; range}) addr
64
62
| _ -> None
65
63
66
64
let rec analyse (node : Code.node Range.located) =
67
65
begin
68
-
let@ {value; loc} = Option.iter @~ extract_addr node in
69
-
S.yield {value = Item.addr value; loc}
66
+
let@ {value; range} = Option.iter @~ extract_addr node in
67
+
S.yield {value = Item.addr value; range}
70
68
end;
71
69
begin
72
-
let@ paths, loc = Option.iter @~ paths node in
70
+
let@ paths, range = Option.iter @~ paths node in
73
71
let@ path = List.iter @~ paths in
74
-
S.yield {value = Item.path path; loc}
72
+
S.yield {value = Item.path path; range}
75
73
end;
76
74
let children = Code.children node in
77
75
List.iter analyse children
···
80
78
let@ () = S.run in
81
79
List.iter analyse nodes
82
80
81
+
let contains ~(position : L.Position.t) (loc : Range.t option) =
82
+
Option.value ~default:false
83
+
@@
84
+
let@ loc = Option.map @~ loc in
85
+
let offset = Grace.Byte_index.of_int position.character in
86
+
let index =
87
+
Grace.Byte_index.(add (of_int position.line) (diff offset initial))
88
+
in
89
+
Range.contains loc index
90
+
91
+
(*
83
92
let contains =
84
93
fun ~(position : Lsp.Types.Position.t) (loc : Range.t option) ->
85
94
let L.Position.{line = cursor_line; character = cursor_character} =
···
87
96
in
88
97
match loc with
89
98
| Some loc -> begin
90
-
match Range.view loc with
91
-
| `Range (start, end_) ->
99
+
match Range.split loc with
100
+
| start, end_ ->
92
101
let start_pos = Lsp_shims.Loc.lsp_pos_of_pos start in
93
102
let end_pos = Lsp_shims.Loc.lsp_pos_of_pos end_ in
94
103
let at_or_after_start =
···
104
113
| _ -> false
105
114
end
106
115
| None -> false
116
+
*)
107
117
108
118
let rec node_at : type a.
109
119
position:L.Position.t ->
···
111
121
a Range.located list ->
112
122
a Range.located option =
113
123
fun ~position ~children code ->
114
-
match List.find_opt (fun Range.{loc; _} -> contains ~position loc) code with
124
+
match
125
+
List.find_opt (fun Range.{range; _} -> contains ~position range) code
126
+
with
115
127
| None -> None
116
128
| Some n -> (
117
129
match (node_at ~position ~children) (children n) with
···
121
133
let get_enclosing_code_group ~position tree =
122
134
let rec go ~position nodes =
123
135
match
124
-
List.find_opt (fun Range.{loc; _} -> contains ~position loc) nodes
136
+
List.find_opt (fun Range.{range; _} -> contains ~position range) nodes
125
137
with
126
138
| None -> None
127
-
| Some n -> (
128
-
match n.value with
139
+
| Some ({value; range} as node) -> (
140
+
match value with
129
141
| Code.Group (delim, t) -> begin
130
142
match go ~position t with
131
-
| None -> Some Asai.Range.{value = (delim, t); loc = n.loc}
143
+
| None -> Some Range.{value = (delim, t); range}
132
144
| Some t -> Some t
133
145
end
134
-
| _ -> (go ~position) (Code.children n))
146
+
| _ -> (go ~position) (Code.children node))
135
147
in
136
148
match Tree.to_code tree with
137
149
| None -> None
···
140
152
let get_enclosing_syn_group ~position tree =
141
153
let rec go ~position nodes =
142
154
match
143
-
List.find_opt (fun Range.{loc; _} -> contains ~position loc) nodes
155
+
List.find_opt (fun Range.{range; _} -> contains ~position range) nodes
144
156
with
145
157
| None -> None
146
-
| Some n -> (
147
-
match n.value with
158
+
| Some ({value; range} as node) -> (
159
+
match value with
148
160
| Syn.Group (delim, children) -> begin
149
161
match go ~position children with
150
-
| None -> Some Asai.Range.{value = (delim, children); loc = n.loc}
162
+
| None -> Some Range.{value = (delim, children); range}
151
163
| Some t -> Some t
152
164
end
153
-
| _ -> go ~position (Syn.children n))
165
+
| _ -> go ~position (Syn.children node))
154
166
in
155
167
match Tree.to_syn tree with
156
168
| None -> None
···
162
174
(tree : Tree.t) =
163
175
match enclosing_group ~position tree with
164
176
| None -> Some position
165
-
| Some {loc; value = _} ->
166
-
let start =
167
-
Option.map (function
168
-
| `Range (start, _) -> start
169
-
| `End_of_file pos -> pos)
170
-
@@ Option.map Range.view loc
171
-
in
172
-
Option.map Lsp_shims.Loc.lsp_pos_of_pos start
177
+
| Some {range; value = _} -> Option.map Lsp_shims.lsp_pos_of_range range
173
178
174
179
let find_with_prev ~position =
175
180
let rec go prev = function
176
181
| [] -> None
177
182
| x :: xs ->
178
-
if contains ~position Asai.Range.(x.loc) then Some (prev, x)
183
+
if contains ~position Range.(x.range) then Some (prev, x)
179
184
else go (Some x) xs
180
185
in
181
186
go None
+3
-3
lib/language_server/Call_hierarchy.ml
+3
-3
lib/language_server/Call_hierarchy.ml
···
82
82
URI_scheme.lsp_uri_to_uri ~base:forest.config.url textDocument.uri
83
83
in
84
84
match Imports.resolve_uri_to_code forest uri with
85
-
| None -> None
86
-
| Some tree ->
85
+
| Error _ -> None
86
+
| Ok tree ->
87
87
let item =
88
88
match Analysis.node_at_code ~position tree.nodes with
89
89
| None -> None
90
-
| Some {loc = _; value} -> (
90
+
| Some {range = _; value} -> (
91
91
match value with
92
92
| Def (_, _, _) | Fun (_, _) -> None
93
93
| Text _ | Verbatim _
+26
-46
lib/language_server/Completion.ml
+26
-46
lib/language_server/Completion.ml
···
5
5
*
6
6
*)
7
7
8
-
open Forester_prelude
9
8
open Forester_core
10
9
open Forester_compiler
11
10
open Forester_frontend
11
+
open Message
12
12
open State.Syntax
13
13
14
14
open struct
15
15
module T = Types
16
16
module L = Lsp.Types
17
+
let ( let* ) = Option.bind
17
18
end
18
19
19
20
type completion = Addrs | New_addr | Assets | Visible | Date [@@deriving show]
···
26
27
27
28
type completion_kind = {
28
29
text: string -> completion option;
29
-
code: Code.node Asai.Range.located Analysis.Context.t -> completion option;
30
-
syn: Syn.node Asai.Range.located Analysis.Context.t -> completion option;
30
+
code: Code.node Range.located Analysis.Context.t -> completion option;
31
+
syn: Syn.node Range.located Analysis.Context.t -> completion option;
31
32
}
32
33
33
34
let subtree_completion : completion_kind =
···
38
39
in
39
40
let code (context : _ Analysis.Context.t) =
40
41
match context with
41
-
| Prev (Asai.Range.{value = Code.Subtree (_, _); _}, _)
42
-
| Prev (_, Asai.Range.{value = Code.Subtree (_, _); _})
42
+
| Prev (Range.{value = Code.Subtree (_, _); _}, _)
43
+
| Prev (_, Range.{value = Code.Subtree (_, _); _})
43
44
| Parent {value = Code.Subtree (_, _); _} ->
44
45
Some New_addr
45
46
| Parent _ | Prev (_, _) | Top _ -> None
···
60
61
in
61
62
let code (context : _ Analysis.Context.t) =
62
63
match context with
63
-
| Prev (Asai.Range.{value = Code.Ident ["route-asset"]; _}, _)
64
-
| Prev (_, Asai.Range.{value = Code.Ident ["route-asset"]; _}) ->
64
+
| Prev (Range.{value = Code.Ident ["route-asset"]; _}, _)
65
+
| Prev (_, Range.{value = Code.Ident ["route-asset"]; _}) ->
65
66
Some Assets
66
67
| Prev _ | Parent _ | Top _ -> None
67
68
in
···
80
81
in
81
82
let code (context : _ Analysis.Context.t) =
82
83
match context with
83
-
| Prev (Asai.Range.{value = Code.Ident ["date"]; _}, _)
84
-
| Prev (_, Asai.Range.{value = Code.Ident ["date"]; _}) ->
84
+
| Prev (Range.{value = Code.Ident ["date"]; _}, _)
85
+
| Prev (_, Range.{value = Code.Ident ["date"]; _}) ->
85
86
Some Date
86
87
| Prev _ | Parent _ | Top _ -> None
87
88
in
···
225
226
226
227
let make
227
228
((path, (data, _)) :
228
-
Yuujinchou.Trie.path * (Resolver.P.data * Asai.Range.t option)) =
229
+
Yuujinchou.Trie.path * (Resolver.P.data * Range.t option)) =
229
230
match data with
230
231
| Term [] -> None
231
232
| Term (node :: _) ->
···
335
336
[L.CompletionItem.create ~label:now_string ~insertText:now_string ()]
336
337
337
338
let compute
338
-
({context; position; textDocument = {uri}; _} : L.CompletionParams.t) =
339
+
({context; position; textDocument = {uri}; _} : L.CompletionParams.t) : _ =
339
340
Logs.debug (fun m ->
340
341
m "when computing completions for %s" (Lsp.Uri.to_string uri));
341
342
let triggerCharacter =
···
347
348
let config = forest.config in
348
349
let base = config.url in
349
350
let uri = URI_scheme.lsp_uri_to_uri ~base uri in
350
-
let tree = forest.={uri} in
351
-
match tree with
352
-
| None ->
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]
362
-
| Some tree ->
363
-
let code = Tree.to_code tree in
364
-
Logs.debug (fun m ->
365
-
m "Received completion request at %s"
366
-
(Yojson.Safe.to_string (L.Position.yojson_of_t position)));
367
-
Logs.debug (fun m -> m "phase is %s" (Tree.show_phase tree));
368
-
let completion_types = completion_types ~position tree in
369
-
Logs.debug (fun m ->
370
-
m "computed completion types: %a"
371
-
(Format.pp_print_list pp_completion)
372
-
(S.to_list completion_types));
373
-
let items =
374
-
let@ completion = List.concat_map @~ S.to_list completion_types in
375
-
match completion with
376
-
| Addrs -> addr_completions ~forest
377
-
| New_addr -> new_addr_completions ~forest
378
-
| Assets -> asset_completions ~config
379
-
| Visible -> visible_completions ~forest ~position code
380
-
| Date -> date_completions ()
381
-
in
382
-
Logs.debug (fun m -> m "items: %d" (List.length items));
383
-
Option.some
384
-
@@ `CompletionList (L.CompletionList.create ~isIncomplete:false ~items ())
351
+
let* tree = forest.={uri} in
352
+
let code = Tree.to_code tree in
353
+
let completion_types = completion_types ~position tree in
354
+
let items =
355
+
let@ completion = List.concat_map @~ S.to_list completion_types in
356
+
match completion with
357
+
| Addrs -> addr_completions ~forest
358
+
| New_addr -> new_addr_completions ~forest
359
+
| Assets -> asset_completions ~config
360
+
| Visible -> visible_completions ~forest ~position code
361
+
| Date -> date_completions ()
362
+
in
363
+
Logs.debug (fun m -> m "items: %d" (List.length items));
364
+
Some (`CompletionList (L.CompletionList.create ~isIncomplete:false ~items ()))
+1
-2
lib/language_server/Definitions.ml
+1
-2
lib/language_server/Definitions.ml
···
5
5
*
6
6
*)
7
7
8
-
open Forester_prelude
9
8
open Forester_core
10
9
open Forester_compiler
11
10
···
25
24
let@ {value = str; _} =
26
25
Option.bind @@ Analysis.addr_at ~position:params.position nodes
27
26
in
28
-
let uri = URI_scheme.named_uri ~base:forest.config.url str in
27
+
let uri = URI.named_uri ~base:forest.config.url str in
29
28
let@ path = Option.map @~ URI.Tbl.find_opt forest.resolver uri in
30
29
let uri = Lsp.Uri.of_path path in
31
30
let range =
-1
lib/language_server/Did_change.ml
-1
lib/language_server/Did_change.ml
-1
lib/language_server/Did_create_files.ml
-1
lib/language_server/Did_create_files.ml
+5
-5
lib/language_server/Document_link.ml
+5
-5
lib/language_server/Document_link.ml
···
5
5
*
6
6
*)
7
7
8
-
open Forester_prelude
9
8
open Forester_core
10
9
open Forester_frontend
11
10
open Forester_compiler
···
32
31
match Option.bind forest.={uri} Tree.to_code with
33
32
| None -> []
34
33
| Some tree -> (
35
-
let@ node = List.filter_map @~ tree.nodes in
36
-
match Range.(node.value) with
34
+
let@ Range.{range; value} = List.filter_map @~ tree.nodes in
35
+
match value with
37
36
| Code.Group (Squares, [{value = Text addr; _}])
38
37
| Code.Group (Parens, [{value = Text addr; _}])
39
38
| Code.Group (Braces, [{value = Text addr; _}]) ->
40
39
(* TODO: Need to analyse syn *)
41
-
let range = Lsp_shims.Loc.lsp_range_of_range node.loc in
42
-
let uri = URI_scheme.named_uri ~base:config.url addr in
40
+
let* range = range in
41
+
let range = Lsp_shims.lsp_range_of_range range in
42
+
let uri = URI.named_uri ~base:config.url addr in
43
43
let* target =
44
44
Option.map Lsp.Uri.of_path @@ URI.Tbl.find_opt forest.resolver uri
45
45
in
+7
-14
lib/language_server/Document_symbols.ml
+7
-14
lib/language_server/Document_symbols.ml
···
5
5
*
6
6
*)
7
7
8
-
open Forester_prelude
9
8
open Forester_core
10
9
open Forester_compiler
11
10
···
13
12
module L = Lsp.Types
14
13
15
14
let pp_path = Resolver.Scope.pp_path
15
+
let ( let* ) = Option.bind
16
16
end
17
17
18
-
let compute (params : L.DocumentSymbolParams.t) =
18
+
let compute (params : L.DocumentSymbolParams.t) :
19
+
[> `DocumentSymbol of L.DocumentSymbol.t list] option =
19
20
let uri = params.textDocument.uri in
20
21
let Lsp_state.{forest; _} = Lsp_state.get () in
21
22
match
22
23
State.get_code forest
23
24
@@ URI_scheme.lsp_uri_to_uri ~base:forest.config.url uri
24
25
with
25
-
| None ->
26
-
URI.Tbl.iter
27
-
(fun uri _ -> Logs.debug (fun m -> m "%a" URI.pp uri))
28
-
forest.index;
29
-
Logs.debug (fun m -> m "%s" (Lsp.Uri.to_string uri));
30
-
Logs.debug (fun m ->
31
-
m "%a" URI.pp (URI_scheme.lsp_uri_to_uri ~base:forest.config.url uri));
32
-
assert false
26
+
| None -> assert false
33
27
| Some {nodes; _} ->
34
-
let symbols =
35
-
let@ {loc; value} = List.filter_map @~ nodes in
28
+
let symbols : L.DocumentSymbol.t list =
29
+
let@ {range; value} = List.filter_map @~ nodes in
36
30
let open Code in
37
-
let range = Lsp_shims.Loc.lsp_range_of_range loc in
31
+
let* range = Option.map Lsp_shims.lsp_range_of_range range in
38
32
let selectionRange = range in
39
33
match value with
40
34
| Subtree (addr, _) ->
41
35
let name = Option.value ~default:"anonymous" addr in
42
-
let range = Lsp_shims.Loc.lsp_range_of_range loc in
43
36
(* TODO: What should the symbol kind of a subtree be? *)
44
37
Option.some
45
38
@@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind:Namespace
+3
-3
lib/language_server/Highlight.ml
+3
-3
lib/language_server/Highlight.ml
···
5
5
*
6
6
*)
7
7
8
-
open Forester_prelude
9
8
open Forester_core
10
9
open Forester_compiler
11
10
···
20
19
URI_scheme.lsp_uri_to_uri ~base:forest.config.url params.textDocument.uri
21
20
in
22
21
let@ tree = Option.map @~ State.get_code forest uri in
23
-
let@ Range.{loc; value} = List.map @~ tree.nodes in
24
-
let range = Lsp_shims.Loc.lsp_range_of_range loc in
22
+
let@ Range.{range; value} = List.filter_map @~ tree.nodes in
23
+
let@ range = Option.map @~ range in
24
+
let range = Lsp_shims.lsp_range_of_range range in
25
25
let kind =
26
26
match value with
27
27
| Code.Text _ | Code.Verbatim _
+7
-7
lib/language_server/Hover.ml
+7
-7
lib/language_server/Hover.ml
···
5
5
*
6
6
*)
7
7
8
-
open Forester_prelude
9
8
open Forester_core
10
9
open Forester_compiler
11
10
open Forester_frontend
12
11
open Forester_search
12
+
open Message
13
13
open State.Syntax
14
14
15
15
open struct
···
30
30
@~
31
31
match forest.={uri} with
32
32
| None ->
33
-
Reporter.fatal Internal_error
34
-
~extra_remarks:
35
-
[Asai.Diagnostic.loctextf "%a is not in the index" URI.pp uri]
33
+
assert false
34
+
(*error
35
+
@@ Diagnostic.createf Error ~code:Internal_error "%a is not in the index"
36
+
URI.pp uri
37
+
*)
36
38
| Some tree -> (
37
39
let* {nodes; _} = Tree.to_code tree in
38
40
let* node = Analysis.node_at_code ~position nodes in
39
41
let tree_under_cursor =
40
42
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
43
+
let uri_under_cursor = URI.named_uri ~base:forest.config.url addr in
44
44
State.get_article ~forest uri_under_cursor
45
45
in
46
46
match tree_under_cursor with
+4
-11
lib/language_server/Inlay_hint.ml
+4
-11
lib/language_server/Inlay_hint.ml
···
5
5
*
6
6
*)
7
7
8
-
open Forester_prelude
9
8
open Forester_core
10
9
open Forester_frontend
11
10
open Forester_compiler
···
25
24
| _ -> (None, Syn.children node)
26
25
27
26
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
27
+
~(pos : Range.t) (addr : string) : L.InlayHint.t option =
28
+
let uri = URI.named_uri ~base:config.url addr in
30
29
let@ {frontmatter; _} = Option.bind @@ State.get_article ~forest uri in
31
30
let@ title = Option.bind frontmatter.title in
32
31
let content = " " ^ Plain_text_client.string_of_content ~forest title in
33
32
Option.some
34
33
@@ L.InlayHint.create
35
-
~position:(Lsp_shims.Loc.lsp_pos_of_pos pos)
34
+
~position:(Lsp_shims.lsp_pos_of_range pos)
36
35
~label:(`String content) ()
37
36
38
-
let pos_of_node (node : 'a Range.located) : Range.position option =
39
-
let@ loc = Option.bind node.loc in
40
-
match Range.view loc with
41
-
| `End_of_file _ -> None
42
-
| `Range (_, pos) -> Some pos
43
-
44
37
let rec extract_inlayable_hints ~(config : Config.t) ~(forest : State.t)
45
38
(nodes : Syn.t) : L.InlayHint.t list =
46
39
let@ node = List.concat_map @~ nodes in
47
40
let addr_opt, rest = consume_addr_for_inlay ~config ~forest node in
48
41
let hint_opt =
49
42
let@ addr = Option.bind addr_opt in
50
-
let@ pos = Option.bind @@ pos_of_node node in
43
+
let@ pos = Option.bind @@ node.range in
51
44
inlay_hint_for_addr ~config ~forest ~pos addr
52
45
in
53
46
let hints = extract_inlayable_hints ~config ~forest rest in
+51
-23
lib/language_server/Lsp_shims.ml
+51
-23
lib/language_server/Lsp_shims.ml
···
9
9
module L = Lsp.Types
10
10
end
11
11
12
-
module Loc = struct
13
-
let lsp_pos_of_pos (pos : Asai.Range.position) =
14
-
L.Position.create ~line:(pos.line_num - 1)
15
-
~character:(pos.offset - pos.start_of_line)
12
+
open Grace
13
+
14
+
let lsp_pos_of_range (range : Range.t) : L.Position.t =
15
+
let source = Grace_source_reader.open_source @@ Range.source range in
16
+
let start, stop = Range.split range in
17
+
let start_line = Grace_source_reader.Line.of_byte_index source start in
18
+
let line = (start_line.idx :> int) in
19
+
let line_start = Grace_source_reader.Line.start start_line in
20
+
let character =
21
+
Grace_source_reader.(slicei source line_start start) |> String.length
22
+
in
23
+
L.Position.create ~line ~character
24
+
25
+
let lsp_range_of_range (range : Range.t) : L.Range.t =
26
+
let source = Grace_source_reader.open_source @@ Range.source range in
27
+
let start, stop = Range.split range in
16
28
17
-
let lsp_range_of_range (r : Asai.Range.t option) =
18
-
match r with
19
-
| Some r ->
20
-
let start, stop =
21
-
match Asai.Range.view r with
22
-
| `Range (start, stop) -> (start, stop)
23
-
| `End_of_file pos -> (pos, pos)
24
-
in
25
-
L.Range.create ~start:(lsp_pos_of_pos start) ~end_:(lsp_pos_of_pos stop)
26
-
| None ->
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
31
-
end
29
+
let start_line = Grace_source_reader.Line.of_byte_index source start in
30
+
let stop_line = Grace_source_reader.Line.of_byte_index source stop in
31
+
32
+
let start =
33
+
let line = (start_line.idx :> int) in
34
+
let line_start = Grace_source_reader.Line.start start_line in
35
+
let character =
36
+
Grace_source_reader.(slicei source line_start start) |> String.length
37
+
in
38
+
L.Position.create ~line ~character
39
+
in
40
+
41
+
let end_ =
42
+
let line = (stop_line.idx :> int) in
43
+
let line_start = Grace_source_reader.Line.start stop_line in
44
+
let character =
45
+
Grace_source_reader.(slicei source line_start stop) |> String.length
46
+
in
47
+
L.Position.create ~line ~character
48
+
in
49
+
50
+
L.Range.create ~start ~end_
51
+
52
+
let location_of_range loc =
53
+
let source = Range.source loc in
54
+
match source with
55
+
| `String _ -> failwith "todo: source of string"
56
+
| `Reader _ -> failwith "todo: source of reader"
57
+
| `File path ->
58
+
let uri = Lsp.Uri.of_path path in
59
+
Option.some @@ L.Location.{range = lsp_range_of_range loc; uri}
32
60
33
61
module Diagnostic = struct
34
-
let lsp_severity_of_severity :
35
-
Asai.Diagnostic.severity -> L.DiagnosticSeverity.t = function
36
-
| Hint -> Hint
37
-
| Info -> Information
62
+
let lsp_severity_of_severity : Diagnostic.Severity.t -> L.DiagnosticSeverity.t
63
+
= function
64
+
| Help -> Hint
65
+
| Note -> Information
38
66
| Warning -> Warning
39
67
| Error -> Error
40
68
| Bug -> Error
+13
-16
lib/language_server/Publish.ml
+13
-16
lib/language_server/Publish.ml
···
5
5
*
6
6
*)
7
7
8
-
open Forester_prelude
9
8
open Forester_core
10
9
open Forester_compiler
11
10
···
16
15
module RPC = Jsonrpc
17
16
end
18
17
19
-
type diagnostic = Reporter.Message.t Asai.Diagnostic.t
20
-
type table = (Lsp.Uri.t, diagnostic list) Hashtbl.t
21
-
22
18
let send packet =
23
19
let server = Lsp_state.get () in
24
20
LspEio.send server.lsp_io packet
25
21
26
-
let render_lsp_related_info (uri : L.DocumentUri.t)
27
-
(message : Asai.Diagnostic.loctext) : L.DiagnosticRelatedInformation.t =
28
-
let range = Lsp_shims.Loc.lsp_range_of_range message.loc in
22
+
let render_lsp_related_info (uri : L.DocumentUri.t) (label : Diagnostic.Label.t)
23
+
: L.DiagnosticRelatedInformation.t =
24
+
let range = Lsp_shims.lsp_range_of_range label.range in
29
25
let location = L.Location.create ~uri ~range in
30
-
let message = Asai.Diagnostic.string_of_text message.value in
26
+
let message = Format.asprintf "%a" Diagnostic.Message.pp label.message in
31
27
L.DiagnosticRelatedInformation.create ~location ~message
32
28
33
-
let render_lsp_diagnostic (uri : L.DocumentUri.t) (diag : diagnostic) :
29
+
let render_lsp_diagnostic (uri : L.DocumentUri.t) (diag : error) :
34
30
Lsp_Diagnostic.t =
35
-
let range = Lsp_shims.Loc.lsp_range_of_range diag.explanation.loc in
31
+
let range = Lsp_shims.lsp_range_of_range @@ (List.hd diag.labels).range in
36
32
let severity =
37
33
Lsp_shims.Diagnostic.lsp_severity_of_severity @@ diag.severity
38
34
in
39
-
let code = `String (Reporter.Message.short_code diag.message) in
35
+
let code =
36
+
`String "todo"
37
+
(*diag.code*)
38
+
in
40
39
let source =
41
40
let Lsp_state.{forest; _} = Lsp_state.get () in
42
41
let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url uri in
···
45
44
in
46
45
Lsp.Text_document.text doc
47
46
in
48
-
let message = Asai.Diagnostic.string_of_text diag.explanation.value in
49
-
let relatedInformation =
50
-
Bwd.to_list @@ Bwd.map (render_lsp_related_info uri) diag.extra_remarks
51
-
in
47
+
let message = Format.asprintf "%a" Diagnostic.Message.pp diag.message in
48
+
let relatedInformation = List.map (render_lsp_related_info uri) diag.labels in
52
49
Lsp_Diagnostic.create ~range ~severity ~code ?source
53
50
~message:(`String message) ~relatedInformation ()
54
51
···
56
53
let msg = Broadcast.to_jsonrpc notif in
57
54
send @@ RPC.Packet.Notification msg
58
55
59
-
let publish (uri : Lsp.Uri.t) (diagnostics : diagnostic list) =
56
+
let publish (uri : Lsp.Uri.t) (diagnostics : error list) =
60
57
let diagnostics = List.map (render_lsp_diagnostic uri) diagnostics in
61
58
let params = L.PublishDiagnosticsParams.create ~uri ~diagnostics () in
62
59
broadcast @@ PublishDiagnostics params
+49
-41
lib/language_server/Semantic_tokens.ml
+49
-41
lib/language_server/Semantic_tokens.ml
···
5
5
*
6
6
*)
7
7
8
-
open Forester_prelude
9
8
open Forester_core
10
9
open Forester_compiler
11
10
···
167
166
:: shift offset tks
168
167
169
168
let tokens (nodes : Code.t) : token list =
170
-
let@ Range.{loc; value} = List.concat_map @~ nodes in
171
-
let L.Range.{start; end_} = Lsp_shims.Loc.lsp_range_of_range loc in
172
-
(* Multiline tokens not supported*)
173
-
if start.line <> end_.line then []
174
-
else
175
-
match value with
176
-
| Code.Ident path -> tokenize_path ~start path
177
-
| Code.Text _ -> []
178
-
| Code.Put (_path, _t) -> []
179
-
(* -> *)
180
-
(* builtin *)
181
-
(* ~start *)
182
-
(* "put" @@ *)
183
-
(* tokenize_path ~start path @ tokens t *)
184
-
| Code.Math (_, _)
185
-
| Code.Verbatim _
186
-
| Code.Import (_, _)
187
-
| Code.Let (_, _, _)
188
-
| Code.Def (_, _, _)
189
-
| Code.Group (_, _)
190
-
| Code.Hash_ident _
191
-
| Code.Xml_ident (_, _)
192
-
| Code.Subtree (_, _)
193
-
| Code.Open _ | Code.Scope _
194
-
| Code.Default (_, _)
195
-
| Code.Get _
196
-
| Code.Fun (_, _)
197
-
| Code.Object _ | Code.Patch _
198
-
| Code.Call (_, _)
199
-
| Code.Decl_xmlns (_, _)
200
-
| Code.Alloc _
201
-
| Code.Dx_sequent (_, _)
202
-
| Code.Dx_query (_, _, _)
203
-
| Code.Dx_prop (_, _)
204
-
| Code.Dx_var _ | Code.Dx_const_content _ | Code.Dx_const_uri _
205
-
| Code.Error _ | Code.Comment _
206
-
| Code.Namespace (_, _) ->
207
-
[]
169
+
let@ Range.{range; value} = List.concat_map @~ nodes in
170
+
let range = Option.map Lsp_shims.lsp_range_of_range range in
171
+
match range with
172
+
| None -> []
173
+
| Some L.Range.{start; end_} -> (
174
+
if
175
+
(* Multiline tokens not supported*)
176
+
start.line <> end_.line
177
+
then []
178
+
else
179
+
match value with
180
+
| Code.Ident path -> tokenize_path ~start path
181
+
| Code.Text _ -> []
182
+
| Code.Put (_path, _t) -> []
183
+
(* -> *)
184
+
(* builtin *)
185
+
(* ~start *)
186
+
(* "put" @@ *)
187
+
(* tokenize_path ~start path @ tokens t *)
188
+
| Code.Math (_, _)
189
+
| Code.Verbatim _
190
+
| Code.Import (_, _)
191
+
| Code.Let (_, _, _)
192
+
| Code.Def (_, _, _)
193
+
| Code.Group (_, _)
194
+
| Code.Hash_ident _
195
+
| Code.Xml_ident (_, _)
196
+
| Code.Subtree (_, _)
197
+
| Code.Open _ | Code.Scope _
198
+
| Code.Default (_, _)
199
+
| Code.Get _
200
+
| Code.Fun (_, _)
201
+
| Code.Object _ | Code.Patch _
202
+
| Code.Call (_, _)
203
+
| Code.Decl_xmlns (_, _)
204
+
| Code.Alloc _
205
+
| Code.Dx_sequent (_, _)
206
+
| Code.Dx_query (_, _, _)
207
+
| Code.Dx_prop (_, _)
208
+
| Code.Dx_var _ | Code.Dx_const_content _ | Code.Dx_const_uri _
209
+
| Code.Error _ | Code.Comment _
210
+
| Code.Namespace (_, _) ->
211
+
[])
208
212
209
213
let process_line_delta (index_of_last_line : int option) (tokens : token list) :
210
214
int * delta_token list =
···
264
268
L.SemanticTokens.t option =
265
269
let Lsp_state.{forest; _} = Lsp_state.get () in
266
270
let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url identifier.uri in
267
-
let@ {nodes; _} = Option.map @~ Imports.resolve_uri_to_code forest uri in
271
+
Result.to_option
272
+
@@
273
+
let@ {nodes; _} = Result.map @~ Imports.resolve_uri_to_code forest uri in
268
274
let tokens = tokens nodes in
269
275
Format.(
270
276
Eio.traceln "%a"
···
280
286
let uri =
281
287
URI_scheme.lsp_uri_to_uri ~base:forest.config.url textDocument.uri
282
288
in
283
-
let@ tree = Option.map @~ Imports.resolve_uri_to_code forest uri in
289
+
Result.to_option
290
+
@@
291
+
let@ tree = Result.map @~ Imports.resolve_uri_to_code forest uri in
284
292
semantic_tokens_delta tree.nodes
285
293
286
294
let on_full_request (params : L.SemanticTokensParams.t) :
+9
-19
lib/language_server/Workspace_symbols.ml
+9
-19
lib/language_server/Workspace_symbols.ml
···
5
5
*
6
6
*)
7
7
8
-
open Forester_prelude
9
8
open Forester_core
10
9
open Forester_compiler
11
10
open Forester_frontend
···
17
16
let ( let* ) = Option.bind
18
17
end
19
18
20
-
let location_of_range loc =
21
-
let* view = Option.map Range.view loc in
22
-
match view with
23
-
| `End_of_file {source; _} | `Range ({source; _}, _) -> (
24
-
match source with
25
-
| `String _ | `File "" -> None
26
-
| `File path ->
27
-
let uri = Lsp.Uri.of_path path in
28
-
Option.some
29
-
@@ L.Location.{range = Lsp_shims.Loc.lsp_range_of_range loc; uri})
30
-
31
19
let exports_to_symbols (exports : Tree.exports) =
32
20
let@ path, (data, range) =
33
21
List.filter_map @~ List.of_seq @@ Trie.to_seq exports
34
22
in
35
-
let@ location = Option.map @~ location_of_range range in
23
+
let* location = Option.bind range Lsp_shims.location_of_range in
36
24
match data with
37
25
| Xmlns _ ->
38
-
L.SymbolInformation.create ~kind:Namespace ~location
39
-
~name:(Format.asprintf "%a" Resolver.Scope.pp_path path)
40
-
()
26
+
Some
27
+
(L.SymbolInformation.create ~kind:Namespace ~location
28
+
~name:(Format.asprintf "%a" Resolver.Scope.pp_path path)
29
+
())
41
30
| Term syn ->
42
31
let kind =
43
32
match (List.hd syn).value with
···
70
59
| Syn.Syndicate_query_as_json_blob | Syn.Current_tree ->
71
60
Constant
72
61
in
73
-
L.SymbolInformation.create ~kind ~location
74
-
~name:(Format.asprintf "%a" Resolver.Scope.pp_path path)
75
-
()
62
+
Some
63
+
(L.SymbolInformation.create ~kind ~location
64
+
~name:(Format.asprintf "%a" Resolver.Scope.pp_path path)
65
+
())
76
66
77
67
let contains_substring_case_insensitive ~pattern text =
78
68
let text = String.lowercase_ascii text
+5
-2
lib/language_server/dune
+5
-2
lib/language_server/dune
···
24
24
forester.frontend
25
25
forester.human_datetime
26
26
lsp
27
-
asai
28
27
eio
29
28
eio.core
30
29
eio.unix
···
34
33
yuujinchou
35
34
fmt
36
35
str
37
-
logs)
36
+
logs
37
+
grace
38
+
grace.std
39
+
grace.ansi_renderer
40
+
grace.source_reader)
38
41
(preprocess
39
42
(pps ppx_deriving.show ppx_repr ppx_yojson_conv)))
+8
-20
lib/parser/Grammar.mly
+8
-20
lib/parser/Grammar.mly
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
+
%parameter<Source : sig
8
+
val v: Grace.Source.t
9
+
end>
10
+
7
11
%{
8
-
open Forester_prelude
9
12
open Forester_core
10
13
%}
11
14
12
-
%token <string option * string> XML_ELT_IDENT
13
-
%token <string> DECL_XMLNS
14
-
%token <string> TEXT VERBATIM
15
-
%token <string> COMMENT
16
-
%token <string> WHITESPACE
17
-
%token <string> IDENT
18
-
19
-
%token <string> HASH_IDENT
20
-
%token IMPORT EXPORT DEF NAMESPACE LET FUN OPEN
21
-
%token OBJECT PATCH CALL
22
-
%token SUBTREE SCOPE PUT GET DEFAULT ALLOC
23
-
%token SLASH LBRACE RBRACE LSQUARE RSQUARE LPAREN RPAREN HASH_LBRACE HASH_HASH_LBRACE TICK AT_SIGN HASH
24
-
%token EOF
25
-
26
-
%token DATALOG
27
-
28
-
%token DX_ENTAILED
29
-
%token <string> DX_VAR
30
15
31
16
%start <Code.t> main
32
17
33
18
%%
34
19
35
20
let locate(p) ==
36
-
| x = p; { Asai.Range.locate_lex $loc x }
21
+
| x = p; {
22
+
let open Source in
23
+
Range.locate_lex ~source:v $loc x
24
+
}
37
25
38
26
let braces(p) == delimited(LBRACE, p, RBRACE)
39
27
let squares(p) == delimited(LSQUARE, p, RSQUARE)
+44
-43
lib/parser/Lexer.mll
+44
-43
lib/parser/Lexer.mll
···
3
3
*
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
+
6
7
{
7
8
open Forester_prelude
8
9
···
36
37
rule token = parse
37
38
| "\\" { push_mode Ident_init; [] }
38
39
| "%" { comment lexbuf }
39
-
| "##{" { [Grammar.HASH_HASH_LBRACE] }
40
-
| "#{" { [Grammar.HASH_LBRACE] }
41
-
| "'" { [Grammar.TICK] }
42
-
| '@' { [Grammar.AT_SIGN] }
43
-
| "-:" { [Grammar.DX_ENTAILED] }
44
-
| "#" { [Grammar.HASH] }
45
-
| '#' (simple_name as name) { [Grammar.HASH_IDENT name] }
46
-
| '?' (simple_name as name) { [Grammar.DX_VAR name] }
47
-
| '{' { [Grammar.LBRACE] }
48
-
| '}' { [Grammar.RBRACE] }
49
-
| '[' { [Grammar.LSQUARE] }
50
-
| ']' { [Grammar.RSQUARE] }
51
-
| '(' { [Grammar.LPAREN] }
52
-
| ')' { [Grammar.RPAREN] }
53
-
| text as str { [Grammar.TEXT str] }
54
-
| wschar+ as str { [Grammar.WHITESPACE str] }
55
-
| newline as str { Lexing.new_line lexbuf; [Grammar.WHITESPACE str] }
56
-
| eof { [Grammar.EOF] }
40
+
| "##{" { [Tokens.HASH_HASH_LBRACE] }
41
+
| "#{" { [Tokens.HASH_LBRACE] }
42
+
| "'" { [Tokens.TICK] }
43
+
| '@' { [Tokens.AT_SIGN] }
44
+
| "-:" { [Tokens.DX_ENTAILED] }
45
+
| "#" { [Tokens.HASH] }
46
+
| '#' (simple_name as name) { [Tokens.HASH_IDENT name] }
47
+
| '?' (simple_name as name) { [Tokens.DX_VAR name] }
48
+
| '{' { [Tokens.LBRACE] }
49
+
| '}' { [Tokens.RBRACE] }
50
+
| '[' { [Tokens.LSQUARE] }
51
+
| ']' { [Tokens.RSQUARE] }
52
+
| '(' { [Tokens.LPAREN] }
53
+
| ')' { [Tokens.RPAREN] }
54
+
| text as str { [Tokens.TEXT str] }
55
+
| wschar+ as str { [Tokens.WHITESPACE str] }
56
+
| newline as str { Lexing.new_line lexbuf; [Tokens.WHITESPACE str] }
57
+
| eof { [Tokens.EOF] }
57
58
| _ { raise_err lexbuf }
58
59
59
60
and ident_init = parse
60
61
| "verb" (verbatim_herald as herald) '|' { drop_mode (); push_verbatim_mode herald; [] }
61
62
| "startverb" { drop_mode (); push_verbatim_mode "\\stopverb"; [] }
62
-
| "scope" { drop_mode (); [Grammar.SCOPE] }
63
-
| "put" { drop_mode (); [Grammar.PUT] }
64
-
| "put?" { drop_mode (); [Grammar.DEFAULT] }
65
-
| "get" { drop_mode (); [Grammar.GET] }
66
-
| "import" { drop_mode (); [Grammar.IMPORT] }
67
-
| "export" { drop_mode (); [Grammar.EXPORT] }
68
-
| "namespace" { drop_mode (); [Grammar.NAMESPACE] }
69
-
| "open" { drop_mode (); [Grammar.OPEN] }
70
-
| "def" { drop_mode (); [Grammar.DEF] }
71
-
| "alloc" { drop_mode (); [Grammar.ALLOC] }
72
-
| "let" { drop_mode (); [Grammar.LET] }
73
-
| "fun" { drop_mode (); [Grammar.FUN] }
74
-
| "subtree" { drop_mode (); [Grammar.SUBTREE] }
75
-
| "object" { drop_mode (); [Grammar.OBJECT] }
76
-
| "patch" { drop_mode (); [Grammar.PATCH] }
77
-
| "call" { drop_mode (); [Grammar.CALL] }
78
-
| "datalog" { drop_mode (); [Grammar.DATALOG] }
63
+
| "scope" { drop_mode (); [Tokens.SCOPE] }
64
+
| "put" { drop_mode (); [Tokens.PUT] }
65
+
| "put?" { drop_mode (); [Tokens.DEFAULT] }
66
+
| "get" { drop_mode (); [Tokens.GET] }
67
+
| "import" { drop_mode (); [Tokens.IMPORT] }
68
+
| "export" { drop_mode (); [Tokens.EXPORT] }
69
+
| "namespace" { drop_mode (); [Tokens.NAMESPACE] }
70
+
| "open" { drop_mode (); [Tokens.OPEN] }
71
+
| "def" { drop_mode (); [Tokens.DEF] }
72
+
| "alloc" { drop_mode (); [Tokens.ALLOC] }
73
+
| "let" { drop_mode (); [Tokens.LET] }
74
+
| "fun" { drop_mode (); [Tokens.FUN] }
75
+
| "subtree" { drop_mode (); [Tokens.SUBTREE] }
76
+
| "object" { drop_mode (); [Tokens.OBJECT] }
77
+
| "patch" { drop_mode (); [Tokens.PATCH] }
78
+
| "call" { drop_mode (); [Tokens.CALL] }
79
+
| "datalog" { drop_mode (); [Tokens.DATALOG] }
79
80
| "<" (xml_base_ident as prefix) ':' (xml_base_ident as uname) ">" { drop_mode (); [XML_ELT_IDENT (Some prefix, uname)] }
80
81
| "<" (xml_base_ident as uname) ">" { drop_mode (); [XML_ELT_IDENT (None, uname)] }
81
82
| "xmlns:" (xml_base_ident as str) { drop_mode (); [DECL_XMLNS str] }
82
-
| "%" { drop_mode (); [Grammar.TEXT "%"] }
83
-
| (simple_name as s) "/" { set_mode Ident_fragments; [Grammar.IDENT s; Grammar.SLASH] }
84
-
| simple_name as s { drop_mode (); [Grammar.IDENT s] }
85
-
| special_name as c { drop_mode (); [Grammar.IDENT (String.make 1 c)] }
83
+
| "%" { drop_mode (); [Tokens.TEXT "%"] }
84
+
| (simple_name as s) "/" { set_mode Ident_fragments; [Tokens.IDENT s; Tokens.SLASH] }
85
+
| simple_name as s { drop_mode (); [Tokens.IDENT s] }
86
+
| special_name as c { drop_mode (); [Tokens.IDENT (String.make 1 c)] }
86
87
| newline { drop_mode (); Lexing.new_line lexbuf; raise_err lexbuf }
87
88
| _ { raise_err lexbuf }
88
89
89
90
and ident_fragments = parse
90
-
| (simple_name as s) "/" { [Grammar.IDENT s; Grammar.SLASH] }
91
-
| simple_name as s { drop_mode (); [Grammar.IDENT s] }
91
+
| (simple_name as s) "/" { [Tokens.IDENT s; Tokens.SLASH] }
92
+
| simple_name as s { drop_mode (); [Tokens.IDENT s] }
92
93
| newline { drop_mode (); Lexing.new_line lexbuf; raise_err lexbuf }
93
94
| _ { raise_err lexbuf }
94
95
95
96
and comment = parse
96
97
| newline_followed_by_ws { Lexing.new_line lexbuf; token lexbuf }
97
-
| eof { [Grammar.EOF] }
98
+
| eof { [Tokens.EOF] }
98
99
| _ { comment lexbuf }
99
100
100
101
and verbatim herald buffer = parse
···
117
118
Buffer.sub buffer 0 offset
118
119
in
119
120
drop_mode ();
120
-
[Grammar.VERBATIM text]
121
+
[Tokens.VERBATIM text]
121
122
else
122
123
[]
123
124
}
+8
-106
lib/parser/Parse.ml
+8
-106
lib/parser/Parse.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Forester_prelude
8
7
open Forester_core
9
8
open Lexing
10
-
module I = Grammar.MenhirInterpreter
9
+
10
+
open Grace
11
11
12
12
let buffer_lexer lexer =
13
13
let buf = ref [] in
···
33
33
| Ident_fragments -> Lexer.ident_fragments lexbuf
34
34
| Verbatim (herald, buffer) -> Lexer.verbatim herald buffer lexbuf
35
35
36
-
let _get_range : I.element option -> (position * position) option =
37
-
fun el ->
38
-
match el with
39
-
| Some (I.Element (_, _, start_pos, end_pos)) -> Some (start_pos, end_pos)
40
-
| None -> None
41
-
42
-
let closed_by c o =
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 ->
49
-
true
50
-
| _ -> false
51
-
52
-
let is_opening_delim = function
53
-
| Grammar.LSQUARE | Grammar.LPAREN | Grammar.LBRACE | Grammar.HASH_LBRACE
54
-
| Grammar.HASH_HASH_LBRACE ->
55
-
true
56
-
| _ -> false
57
-
58
-
let is_closing_delim = function
59
-
| Grammar.RSQUARE | Grammar.RPAREN | Grammar.RBRACE -> true
60
-
| _ -> false
61
-
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
66
-
let delim_stack = Stack.create () in
67
-
let rec run : _ I.checkpoint -> _ -> (Code.t, Reporter.diagnostic) Result.t =
68
-
fun checkpoint supplier ->
69
-
match checkpoint with
70
-
| I.InputNeeded _env ->
71
-
(* If the current token is an opening delimiter, save the token and its
72
-
position on the stack.*)
73
-
let token, _, _ = supplier () in
74
-
let start_position = lexbuf.lex_start_p in
75
-
let end_position = lexbuf.lex_curr_p 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
88
-
run checkpoint supplier
89
-
| I.Shifting ((_, _, _) : Code.t I.env * Code.t I.env * bool) ->
90
-
let checkpoint = I.resume checkpoint ~strategy:`Simplified in
91
-
run checkpoint supplier
92
-
| I.AboutToReduce (_, _) ->
93
-
let checkpoint = I.resume checkpoint ~strategy:`Simplified in
94
-
run checkpoint supplier
95
-
| I.HandlingError _ ->
96
-
if not stop_on_err then
97
-
(* TODO: Don't error out here *)
98
-
Error
99
-
(Asai.Diagnostic.of_text ~loc:(Range.of_lexbuf lexbuf) Error
100
-
Reporter.Message.Parse_error (Asai.Diagnostic.text ""))
101
-
else
102
-
(* let range_of_last_unclosed = *)
103
-
(* Option.map snd @@ Stack.top_opt delim_stack *)
104
-
(* in *)
105
-
let loc = Range.of_lexbuf lexbuf in
106
-
(* let extra_remarks = *)
107
-
(* if Option.is_some range_of_last_unclosed then *)
108
-
(* [ *)
109
-
(* Asai.Diagnostic.loctext *)
110
-
(* ?loc: range_of_last_unclosed *)
111
-
(* "This delimiter is never closed"; *)
112
-
(* ] *)
113
-
(* else [] *)
114
-
(* in *)
115
-
Error
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))))
123
-
| I.Accepted code -> Ok code
124
-
| I.Rejected -> assert false
125
-
in
126
-
let supplier = I.lexer_lexbuf_to_supplier lexer lexbuf in
127
-
try run initial_checkpoint supplier
128
-
with
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)))
36
+
let parse source lexbuf =
37
+
let module Parser = Grammar.Make (struct
38
+
let v = source
39
+
end) in
40
+
try ok @@ Parser.main lexer lexbuf
41
+
with _ -> error @@ Diagnostic.createf Error ""
+1
-2
lib/parser/Parse.mli
+1
-2
lib/parser/Parse.mli
+26
lib/parser/Tokens.mly
+26
lib/parser/Tokens.mly
···
1
+
(*
2
+
* SPDX-FileCopyrightText: 2024 The Forester Project Contributors
3
+
*
4
+
* SPDX-License-Identifier: GPL-3.0-or-later
5
+
*)
6
+
7
+
%token <string option * string> XML_ELT_IDENT
8
+
%token <string> DECL_XMLNS
9
+
%token <string> TEXT VERBATIM
10
+
%token <string> COMMENT
11
+
%token <string> WHITESPACE
12
+
%token <string> IDENT
13
+
14
+
%token <string> HASH_IDENT
15
+
%token IMPORT EXPORT DEF NAMESPACE LET FUN OPEN
16
+
%token OBJECT PATCH CALL
17
+
%token SUBTREE SCOPE PUT GET DEFAULT ALLOC
18
+
%token SLASH LBRACE RBRACE LSQUARE RSQUARE LPAREN RPAREN HASH_LBRACE HASH_HASH_LBRACE TICK AT_SIGN HASH
19
+
%token EOF
20
+
21
+
%token DATALOG
22
+
23
+
%token DX_ENTAILED
24
+
%token <string> DX_VAR
25
+
26
+
%%
+9
-3
lib/parser/dune
+9
-3
lib/parser/dune
···
5
5
(ocamllex Lexer)
6
6
7
7
(menhir
8
-
(modules Grammar)
8
+
(modules Tokens)
9
+
(explain false)
10
+
(flags --only-tokens))
11
+
12
+
(menhir
13
+
(modules Grammar Tokens)
14
+
(merge_into Grammar)
9
15
(explain true)
10
-
(flags --inspection --table --dump))
16
+
(flags --external-tokens Tokens))
11
17
12
18
; The target for saving menhir's stdout to Grammar_messages.ml
13
19
···
25
31
(backend bisect_ppx))
26
32
(preprocess
27
33
(pps ppx_deriving.show ppx_repr))
28
-
(libraries forester.prelude forester.core asai menhirLib)
34
+
(libraries forester.prelude forester.core grace menhirLib)
29
35
(public_name forester.parser))
+1
-1
lib/parser/test/Test_parser.ml
+1
-1
lib/parser/test/Test_parser.ml
+24
lib/prelude/Forester_prelude.ml
+24
lib/prelude/Forester_prelude.ml
···
13
13
module List_util = List_util
14
14
module BaseN = BaseN
15
15
module Compare = Compare
16
+
17
+
(*
18
+
module Seq = struct
19
+
include Seq
20
+
21
+
let error_partition : ('a -> ('b, 'c) Result.t) -> 'a t -> 'b t * 'c t =
22
+
fun f results -> partition_map (f >>> Either.of_result) results
23
+
24
+
let partition_fold_error f xs = error_partition f xs |> Pair.map_snd concat
25
+
end
26
+
*)
27
+
28
+
let error e = Error e
29
+
let ok e = Ok e
30
+
31
+
let right = Either.right
32
+
let left = Either.left
33
+
34
+
module Message = Message
35
+
module Diagnostic = Grace.Diagnostic
36
+
37
+
type message = Message.t
38
+
type error = Message.t Grace.Diagnostic.t
39
+
type 'a res = ('a, error) Result.t
+17
-9
lib/prelude/List_util.ml
+17
-9
lib/prelude/List_util.ml
···
3
3
*
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
+
open Fun_util
6
7
7
-
open Bwd
8
+
let rec prepend_to_all sep = function
9
+
| [] -> []
10
+
| x :: xs -> sep :: x :: prepend_to_all sep xs
8
11
9
-
let nub xs =
10
-
let rec loop acc = function
11
-
| [] -> Bwd.prepend acc []
12
-
| x :: xs ->
13
-
let acc = if Bwd.mem x acc then acc else Bwd.snoc acc x in
14
-
loop acc xs
15
-
in
16
-
loop Bwd.Emp xs
12
+
let intersperse sep = function
13
+
| [] -> []
14
+
| x :: xs -> x :: prepend_to_all sep xs
15
+
16
+
let either_of_result = function Ok v -> Either.Right v | Error err -> Left err
17
+
18
+
let error_partition : type a b err.
19
+
(a -> (b, err) Result.t) -> a list -> err list * b list =
20
+
fun f -> List.partition_map (f >>> either_of_result)
21
+
22
+
let partition_fold_error :
23
+
('a -> ('b list, 'c list) result) -> 'a list -> 'b list * 'b list =
24
+
fun f xs -> error_partition f xs |> Pair.map_snd List.concat
17
25
18
26
let rec prepend_to_all sep = function
19
27
| [] -> []
+119
lib/prelude/Message.ml
+119
lib/prelude/Message.ml
···
1
+
open Grace
2
+
3
+
type expected_value =
4
+
| Content
5
+
| Text
6
+
| Obj
7
+
| Bool
8
+
| Sym
9
+
| Dx_query
10
+
| Dx_sequent
11
+
| Dx_prop
12
+
| Datalog_term
13
+
| Node
14
+
| URI
15
+
| Argument
16
+
[@@deriving show]
17
+
18
+
type t =
19
+
| Import_not_found
20
+
| Invalid_URI
21
+
| Asset_has_no_content_address
22
+
| Asset_not_found
23
+
| Current_tree_has_no_uri
24
+
| Duplicate_tree
25
+
| Parse_error
26
+
| Unbound_method
27
+
| Type_warning
28
+
| Type_error
29
+
| Unbound_fluid_symbol
30
+
| Unbound_variable
31
+
| Unresolved_identifier
32
+
| Unresolved_xmlns
33
+
| Reference_error
34
+
| Unhandled_case
35
+
| Transclusion_loop
36
+
| Internal_error
37
+
| Configuration_error
38
+
| Initialization_warning
39
+
| Routing_error
40
+
| Profiling
41
+
| External_error
42
+
| Resource_not_found
43
+
| Broken_link
44
+
| IO_error
45
+
| Log
46
+
| Missing_argument
47
+
| Uninterpreted_config_options
48
+
| Using_default_option
49
+
| Required_config_option
50
+
[@@deriving show]
51
+
52
+
let default_severity : t -> Diagnostic.Severity.t = function
53
+
| Import_not_found -> Error
54
+
| Unresolved_identifier -> Warning
55
+
| Unresolved_xmlns -> Error
56
+
| Invalid_URI -> Error
57
+
| Unbound_method -> Error
58
+
| Asset_has_no_content_address -> Error
59
+
| Asset_not_found -> Error
60
+
| Current_tree_has_no_uri -> Error
61
+
| Reference_error -> Error
62
+
| Duplicate_tree -> Error
63
+
| Parse_error -> Error
64
+
| Type_error -> Error
65
+
| Type_warning -> Warning
66
+
| Unbound_fluid_symbol -> Error
67
+
| Unbound_variable -> Error
68
+
| Unhandled_case -> Bug
69
+
| Transclusion_loop -> Error
70
+
| Internal_error -> Bug
71
+
| Configuration_error -> Error
72
+
| Initialization_warning -> Warning
73
+
| Routing_error -> Error
74
+
| Profiling -> Note
75
+
| External_error -> Error
76
+
| Log -> Note
77
+
| Resource_not_found -> Error
78
+
| Broken_link -> Warning
79
+
| IO_error -> Error
80
+
| Missing_argument -> Error
81
+
| Uninterpreted_config_options -> Warning
82
+
| Using_default_option -> Note
83
+
| Required_config_option -> Error
84
+
85
+
let to_string : t -> string = function
86
+
| Import_not_found -> "import_not_found"
87
+
| Invalid_URI -> "invalid_uri"
88
+
| Asset_has_no_content_address ->
89
+
"asset_not_found"
90
+
(* This is taken from the original wording
91
+
is very confusing.*)
92
+
| Asset_not_found -> "asset_not_found"
93
+
| Current_tree_has_no_uri -> "current_tree_has_no_uri"
94
+
| Duplicate_tree -> "duplicate_tree"
95
+
| Parse_error -> "parse_error"
96
+
| Unbound_method -> "unbound_method"
97
+
| Type_warning -> "type_warning"
98
+
| Type_error -> "type_error"
99
+
| Unbound_fluid_symbol -> "unbound_fluid_symbol"
100
+
| Unbound_variable -> "Unbound_variable"
101
+
| Unresolved_xmlns -> "unresolved_xmlns"
102
+
| Unresolved_identifier -> "unresolved_identifier"
103
+
| Reference_error -> "reference_error"
104
+
| Unhandled_case -> "unhandled_case"
105
+
| Transclusion_loop -> "transclusion_loop"
106
+
| Internal_error -> "internal_error"
107
+
| Configuration_error -> "configuration_error"
108
+
| Initialization_warning -> "initialization_warning"
109
+
| Routing_error -> "routing_error"
110
+
| Profiling -> "profiling"
111
+
| External_error -> "external_error"
112
+
| Resource_not_found -> "resource_not_found"
113
+
| Broken_link -> "broken_link"
114
+
| IO_error -> "io_error"
115
+
| Log -> "log"
116
+
| Missing_argument -> "missing_argument"
117
+
| Uninterpreted_config_options -> "unknown_config_option"
118
+
| Using_default_option -> "using_default_option"
119
+
| Required_config_option -> "required_config_option"
+2
-2
lib/prelude/dune
+2
-2
lib/prelude/dune
-1
lib/search/Index.ml
-1
lib/search/Index.ml
+3
-14
lib/search/Search_engine.ml
+3
-14
lib/search/Search_engine.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Forester_prelude
8
7
open Forester_core
9
8
open Forester_compiler
10
9
open Forester_search
···
38
37
uris
39
38
40
39
let test_ranked (forest : State.t) =
41
-
let ranked_results =
42
-
Reporter.profile "Ranked search" @@ fun () ->
43
-
ranked_search ~fuzz:2 forest "hyprtext format"
44
-
in
40
+
let ranked_results = ranked_search ~fuzz:2 forest "hyprtext format" in
45
41
Format.printf "got %i ranked results.@." (List.length ranked_results);
46
42
List.iter
47
43
(fun (uri, score) ->
···
52
48
53
49
let test_search (forest : State.t) =
54
50
let s = read_line () in
55
-
let results =
56
-
(* Reporter.profile "Searching" @@ fun () -> *)
57
-
Index.search ~fuzz:1 forest.search_index s
58
-
in
51
+
let results = Index.search ~fuzz:1 forest.search_index s in
59
52
Format.printf "got %i results@." (List.length results)
60
53
61
54
let main ~env () =
···
65
58
let dev = true in
66
59
let forest = Driver.batch_run ~env ~dev ~config in
67
60
let articles = List.of_seq @@ State.get_all_articles forest in
68
-
let index =
69
-
(* Reporter.profile "Building index" @@ fun () -> *)
70
-
Index.create articles
71
-
in
61
+
let index = Index.create articles in
72
62
let size = Obj.reachable_words @@ Obj.repr index in
73
63
Format.printf "index size: %i@." size;
74
64
let forest = {forest with search_index = index} in
···
78
68
79
69
let () =
80
70
let@ env = Eio_main.run in
81
-
let@ () = Forester_core.Reporter.easy_run in
82
71
main ~env ()
-1
lib/search/dune
-1
lib/search/dune
-1
lib/server/Headers.ml
-1
lib/server/Headers.ml
+7
-4
lib/server/Server.ml
+7
-4
lib/server/Server.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Forester_prelude
8
7
open Forester_core
9
8
open Forester_compiler
10
9
open Forester_frontend
···
75
74
respond_string ~headers ~status:`OK ~body ()
76
75
77
76
let tree_handler ~(forest : State.t) ~request_headers uri =
78
-
let href = URI_scheme.named_uri ~base:forest.config.url uri in
77
+
let href = URI.named_uri ~base:forest.config.url uri in
79
78
let htmx = Option.is_some @@ Http.Header.get request_headers "Hx-Request" in
80
79
let env =
81
80
Html_client.
···
193
192
the user enters ~/forest/forest.toml *)
194
193
match Config_parser.parse_forest_config_file filename with
195
194
| Error exn ->
196
-
let error = Format.asprintf "%a" Eio.Exn.pp exn in
195
+
let error =
196
+
Format.asprintf "%a@."
197
+
Grace_ansi_renderer.(
198
+
pp_diagnostic ?config:None ?code_to_string:None)
199
+
exn
200
+
in
197
201
(H.div [] [P.txt "%s" error], `OK)
198
202
| Ok config ->
199
-
let@ () = Reporter.easy_run in
200
203
let f = Driver.batch_run ~env ~config ~dev:true in
201
204
forest := Some f;
202
205
let home =
+2
-1
lib/server/dune
+2
-1
lib/server/dune
+7
-9
test/Prelude.ml
+7
-9
test/Prelude.ml
···
4
4
* SPDX-License-Identifier: GPL-3.0-or-later
5
5
*)
6
6
7
-
open Forester_prelude
8
7
open Forester_core
9
8
open Forester_compiler
10
9
···
13
12
end
14
13
15
14
let rec strip_syn (syn : Syn.t) : Syn.t =
16
-
let@ Asai.Range.{value; _} = List.map @~ syn in
17
-
Asai.Range.{value = Syn.map strip_syn value; loc = None}
15
+
let@ {value; _} = List.map @~ syn in
16
+
Range.{value = Syn.map strip_syn value; range = None}
18
17
19
18
let rec strip_code (code : Code.t) : Code.t =
20
-
let@ Asai.Range.{value; _} = List.map @~ code in
21
-
Asai.Range.{value = Code.map strip_code value; loc = None}
19
+
let@ Range.{value; _} = List.map @~ code in
20
+
Range.{value = Code.map strip_code value; range = None}
22
21
23
22
type raw_tree = {path: string; content: string}
24
23
25
24
let parse_string str =
26
25
let lexbuf = Lexing.from_string str in
27
-
Parse.parse lexbuf
26
+
Parse.parse (`String {content = str; name = None}) lexbuf
28
27
29
28
let parse_string_no_loc str = Result.map strip_code @@ parse_string str
30
29
···
88
87
let find_tree ~env addr =
89
88
let dirs = env.dirs in
90
89
Eio.Path.native_exn @@ Option.get @@ Dir_scanner.find_tree dirs
91
-
@@ URI_scheme.named_uri ~base:env.config.url addr
90
+
@@ URI.named_uri ~base:env.config.url addr
92
91
93
92
let find_doc (env : test_env) addr : L.TextDocumentIdentifier.t =
94
93
let path =
95
94
Eio.Path.native_exn @@ Option.get
96
-
@@ Dir_scanner.find_tree env.dirs
97
-
(URI_scheme.named_uri ~base:env.config.url addr)
95
+
@@ Dir_scanner.find_tree env.dirs (URI.named_uri ~base:env.config.url addr)
98
96
in
99
97
{uri = Lsp.Uri.of_path path}
+13
-25
test/Testables.ml
+13
-25
test/Testables.ml
···
8
8
open Forester_compiler
9
9
open Alcotest
10
10
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])
13
-
14
-
type severity = Asai.Diagnostic.severity = Hint | Info | Warning | Error | Bug
15
-
[@@deriving show]
16
-
17
-
let pp_loctext =
18
-
fun fmt text ->
19
-
Format.pp_print_string fmt
20
-
(Asai.Diagnostic.string_of_text Asai.Range.(text.value))
21
-
22
-
type 'a diagnostic = 'a Asai.Diagnostic.t = {
23
-
severity: Asai.Diagnostic.severity; [@printer pp_severity]
24
-
message: 'a;
25
-
explanation: Asai.Diagnostic.loctext; [@printer pp_loctext]
26
-
backtrace: Asai.Diagnostic.backtrace; [@printer pp_bwd pp_loctext]
27
-
extra_remarks: Asai.Diagnostic.loctext Bwd.bwd; [@printer pp_bwd pp_loctext]
28
-
}
11
+
type severity = Grace.Diagnostic.Severity.t =
12
+
| Help
13
+
| Note
14
+
| Warning
15
+
| Error
16
+
| Bug
29
17
[@@deriving show]
30
18
31
-
let message = testable Reporter.Message.pp ( = )
19
+
let message = testable Message.pp ( = )
32
20
let delim = testable Forester_core.pp_delim ( = )
33
21
let code = testable Forester_core.Code.pp ( = )
34
22
let code_node = testable Forester_core.Code.pp_node ( = )
35
23
let syn_node = testable Forester_core.Syn.pp_node ( = )
36
24
let syn = testable Syn.pp ( = )
37
-
let eval_result = testable Eval.pp_result ( = )
25
+
let eval_result = testable Eval.pp_eval_result ( = )
38
26
let path = testable Trie.pp_path ( = )
39
27
let data = testable Syn.pp_resolver_data ( = )
40
-
41
-
let diagnostic =
42
-
let pp = pp_diagnostic Reporter.Message.pp in
43
-
testable pp ( = )
28
+
let diagnostic : Message.t Grace.Diagnostic.t testable =
29
+
testable
30
+
Grace_ansi_renderer.(
31
+
pp_diagnostic ?config:None ~code_to_string:Message.to_string)
32
+
( = )
44
33
45
34
let uri = testable URI.pp URI.equal
46
35
let config = Alcotest.testable Config.pp ( = )
···
50
39
testable pp ( = )
51
40
52
41
let tree = testable Code.pp_tree ( = )
53
-
let result = testable Eval.pp_result ( = )
54
42
let content = testable Types.pp_content ( = )
55
43
let action = testable Action.pp ( = )
56
44
let completion_type = testable Forester_lsp.Completion.pp_completion ( = )