ocaml
0
fork

Configure Feed

Select the types of activity you want to include in your feed.

The Big topiary=>ocamlformat switch

Topiary has been getting less and less reliable at properly formatting,
and simultaneously it appears that ocamlformat has become much more
reliable than it was when I last evaluated it.

For this reason, I have decided to switch formatters for Forester.

+5810 -5706
-14
.nova/Tasks/Format File.json
··· 1 - { 2 - "actions" : { 3 - "run" : { 4 - "enabled" : true, 5 - "script" : "#!\/bin\/sh\ntopiary format $1" 6 - } 7 - }, 8 - "arguments" : [ 9 - "${File}" 10 - ], 11 - "environment" : { 12 - "TOPIARY_LANGUAGE_DIR" : "topiary" 13 - } 14 - }
-8
.nova/Tasks/Format Repo.json
··· 1 - { 2 - "actions" : { 3 - "run" : { 4 - "enabled" : true, 5 - "path" : "format.sh" 6 - } 7 - } 8 - }
+10
.ocamlformat
··· 1 + version=0.28.1 2 + profile=conventional 3 + 4 + exp-grouping=preserve 5 + cases-exp-indent=2 6 + space-around-records=false 7 + space-around-lists=false 8 + space-around-variants=false 9 + space-around-arrays=false 10 + field-space=tight-decl
+7 -5
README.md
··· 28 28 <~jonsterling/forester-devel@lists.sr.ht>. General discussion can be mailed to 29 29 <~jonsterling/forester-discuss@lists.sr.ht>. 30 30 31 - When you prepare patches, please try to match the surrounding coding style to 32 - the best of your ability (and do not use `ocamlformat`); patches will not be 33 - rejected on grounds of poor formatting but they may be reformatted before being 34 - applied. If you install [Topiary](https://topiary.tweag.io), you can format the 35 - entire project using `./format.sh`. 31 + When you prepare patches, please be sure that all code is formatted as follows: 32 + 33 + dune build @fmt 34 + dune promote 35 + 36 + Patches will not be rejected on grounds of poor formatting but they may be 37 + reformatted before being applied. 36 38 37 39 [Join us on IRC](irc://irc.libera.chat/#forester) 38 40
-6
REUSE.toml
··· 11 11 SPDX-License-Identifier = "GPL-3.0-or-later" 12 12 13 13 [[annotations]] 14 - path = ["topiary/*"] 15 - precedence = "override" 16 - SPDX-FileCopyrightText = "2024 Tweag I/O Limited" 17 - SPDX-License-Identifier = "MIT" 18 - 19 - [[annotations]] 20 14 path = [".envrc", ".nova/**/*", ".vscode/**/*", "flake.lock", "flake.nix"] 21 15 precedence = "override" 22 16 SPDX-FileCopyrightText = "2024 The Forester Project Contributors"
+32 -49
bin/forester/App.ml
··· 7 7 open Brr 8 8 9 9 let htmx = Jv.get Jv.global "htmx" 10 - 11 10 let ajax o = Jv.call o "ajax" 12 11 let on_load o = Jv.call o "onLoad" 13 - 14 12 let katex = Jv.get Jv.global "katex" 15 13 16 14 type _katex_config = { ··· 26 24 maxExpand: Jv.t; 27 25 strict: Jv.t; 28 26 trust: Jv.t; (* Boolean or function*) 29 - globalGroup: Jv.t 27 + globalGroup: Jv.t; 30 28 } 31 29 32 - let trust_config = 33 - Jv.obj 34 - [| 35 - "trust", 36 - Jv.of_bool true 37 - |] 38 - 30 + let trust_config = Jv.obj [|("trust", Jv.of_bool true)|] 39 31 let render o = Jv.call o "render" 40 32 41 33 let () = 42 - ignore @@ 43 - on_load 44 - htmx 45 - [| 46 - let f = fun root -> 47 - El.fold_find_by_selector 48 - ~root 49 - (fun elt _ -> 50 - ignore @@ 51 - render 52 - katex 53 - [| 54 - Jv.get (El.to_jv elt) "textContent"; 55 - El.to_jv elt; 56 - trust_config; 57 - |] 58 - ) 59 - (Jstr.v ".math") 60 - () 61 - in 62 - Jv.repr f 63 - |] 34 + ignore 35 + @@ on_load htmx 36 + [| 37 + (let f = 38 + fun root -> 39 + El.fold_find_by_selector ~root 40 + (fun elt _ -> 41 + ignore 42 + @@ render katex 43 + [| 44 + Jv.get (El.to_jv elt) "textContent"; 45 + El.to_jv elt; 46 + trust_config; 47 + |]) 48 + (Jstr.v ".math") () 49 + in 50 + Jv.repr f); 51 + |] 64 52 65 53 (* let () = ignore @@ Jv.call htmx "logAll" [||] *) 66 54 67 55 let () = 68 - ignore @@ 69 - Ev.listen 70 - Ev.keydown 71 - (fun e -> 72 - let ev = Ev.as_type e in 73 - Ev.( 74 - if Keyboard.ctrl_key ev && Keyboard.key ev = Jstr.v "k" then 75 - begin 76 - Console.log ["hello"]; 77 - prevent_default e; 78 - ignore @@ 79 - ajax 80 - htmx 56 + ignore 57 + @@ Ev.listen Ev.keydown 58 + (fun e -> 59 + let ev = Ev.as_type e in 60 + Ev.( 61 + if Keyboard.ctrl_key ev && Keyboard.key ev = Jstr.v "k" then begin 62 + Console.log ["hello"]; 63 + prevent_default e; 64 + ignore 65 + @@ ajax htmx 81 66 [| 82 67 Jv.of_string "GET"; 83 68 Jv.of_string "/searchmenu"; 84 69 Jv.of_string "#modal-container"; 85 70 |] 86 - end 87 - ) 88 - ) 89 - (Document.as_target G.document) 71 + end)) 72 + (Document.as_target G.document)
+1 -1
bin/forester/dune
··· 44 44 eio_main 45 45 fmt 46 46 fmt.cli 47 - fmt.tty)) 47 + fmt.tty))
+118 -118
bin/forester/main.ml
··· 9 9 open Forester_frontend 10 10 open Forester_compiler 11 11 open Cmdliner 12 - 13 12 module EP = Eio.Path 14 13 15 14 let setup_logs style_renderer level = ··· 20 19 21 20 let verbosity = 22 21 let env = Cmd.Env.info "PART_LOGS" in 23 - Logs_cli.level ~env ~docs: Manpage.s_common_options () 22 + Logs_cli.level ~env ~docs:Manpage.s_common_options () 24 23 25 24 let renderer = 26 25 let env = Cmd.Env.info "PART_FMT" in 27 - Fmt_cli.style_renderer ~docs: Manpage.s_common_options ~env () 26 + Fmt_cli.style_renderer ~docs:Manpage.s_common_options ~env () 28 27 29 28 let arg_logs = Term.(const setup_logs $ renderer $ verbosity) 30 29 ··· 43 42 let forest = Driver.batch_run ~env ~dev ~config in 44 43 forest.diagnostics 45 44 |> URI.Tbl.iter (fun _ d -> List.iter Reporter.Tty.display d); 46 - begin 47 - if not no_theme then 48 - let@ () = Reporter.trace "when copying theme directory" in 49 - Forester.copy_contents_of_dir ~env ~forest @@ Eio_util.path_of_dir ~env "theme" 45 + begin if not no_theme then 46 + let@ () = Reporter.trace "when copying theme directory" in 47 + Forester.copy_contents_of_dir ~env ~forest 48 + @@ Eio_util.path_of_dir ~env "theme" 50 49 end; 51 50 Forester.render_forest ~dev ~forest; 52 51 Logs.app (fun m -> m "Success!") ··· 54 53 let new_tree ~env config_filename dest_dir prefix template random = 55 54 let@ () = Reporter.silence in 56 55 let config = Config_parser.parse_forest_config_file config_filename in 57 - let forest = Driver.batch_run ~env ~dev: true ~config in 56 + let forest = Driver.batch_run ~env ~dev:true ~config in 58 57 let mode = if random then `Random else `Sequential in 59 - let new_tree = Forester.create_tree ~env ~dest_dir ~prefix ~template ~mode ~forest in 58 + let new_tree = 59 + Forester.create_tree ~env ~dest_dir ~prefix ~template ~mode ~forest 60 + in 60 61 Format.printf "%s" new_tree 61 62 62 63 let complete ~env config_filename title = 63 64 let@ () = Reporter.silence in 64 65 let config = Config_parser.parse_forest_config_file config_filename in 65 - let forest = Driver.batch_run ~env ~dev: true ~config in 66 + let forest = Driver.batch_run ~env ~dev:true ~config in 66 67 let@ uri, title = List.iter @~ Forester.complete ~forest title in 67 68 Format.printf "%s, %s\n" uri title 68 69 69 70 let query_all ~env config_filename = 70 71 let@ () = Reporter.silence in 71 72 let config = Config_parser.parse_forest_config_file config_filename in 72 - let forest = Driver.batch_run ~env ~config ~dev: true in 73 - Format.printf "%s" (Forester.json_manifest ~dev: true ~forest) 73 + let forest = Driver.batch_run ~env ~config ~dev:true in 74 + Format.printf "%s" (Forester.json_manifest ~dev:true ~forest) 74 75 75 76 let default_config_str = 76 77 {|[forest] ··· 91 92 |} 92 93 93 94 let init ~env dir = 94 - let default_theme_url = "https://git.sr.ht/~jonsterling/forester-base-theme" in 95 + let default_theme_url = 96 + "https://git.sr.ht/~jonsterling/forester-base-theme" 97 + in 95 98 let theme_version = "5.0" in 96 99 let cwd = 97 100 match dir with 98 101 | None -> Eio.Stdenv.cwd env 99 102 | Some d -> 100 - begin 101 - try 102 - EP.mkdir ~perm: 0o755 EP.(Eio.Stdenv.cwd env / d) 103 - with 104 - | _ -> 105 - Reporter.emit Initialization_warning ~extra_remarks: [Asai.Diagnostic.loctextf "Directory `%s` already exists" d] 103 + begin try EP.mkdir ~perm:0o755 EP.(Eio.Stdenv.cwd env / d) 104 + with _ -> 105 + Reporter.emit Initialization_warning 106 + ~extra_remarks: 107 + [Asai.Diagnostic.loctextf "Directory `%s` already exists" d] 106 108 end; 107 - EP.((Eio.Stdenv.cwd env) / d) 109 + EP.(Eio.Stdenv.cwd env / d) 108 110 in 109 - begin 110 - try 111 - let proc_mgr = Eio.Stdenv.process_mgr env in 112 - let@ cmd = 113 - List.iter @~ 114 - [ 115 - ["git"; "init"; "--quiet"]; 116 - ["git"; "branch"; "-m"; "main"]; 117 - ["git"; "submodule"; "add"; default_theme_url; "theme"]; 118 - ["git"; "-C"; "theme"; "checkout"; theme_version]; 119 - ] 120 - in 121 - Eio.Process.run ~cwd proc_mgr cmd 122 - with 123 - | exn -> 124 - Reporter.fatal 125 - Configuration_error 126 - ~extra_remarks: [ 127 - Asai.Diagnostic.loctextf 128 - {| 111 + begin try 112 + let proc_mgr = Eio.Stdenv.process_mgr env in 113 + let@ cmd = 114 + List.iter 115 + @~ [ 116 + ["git"; "init"; "--quiet"]; 117 + ["git"; "branch"; "-m"; "main"]; 118 + ["git"; "submodule"; "add"; default_theme_url; "theme"]; 119 + ["git"; "-C"; "theme"; "checkout"; theme_version]; 120 + ] 121 + in 122 + Eio.Process.run ~cwd proc_mgr cmd 123 + with exn -> 124 + Reporter.fatal Configuration_error 125 + ~extra_remarks: 126 + [ 127 + Asai.Diagnostic.loctextf 128 + {| 129 129 Failed to set up theme: %a. To perform this step manually, run the commands 130 130 131 131 git init 132 132 git submodule add %s 133 133 git -C theme checkout %s 134 134 |} 135 - Eio.Exn.pp 136 - exn 137 - default_theme_url 138 - theme_version 139 - ] 135 + Eio.Exn.pp exn default_theme_url theme_version; 136 + ] 140 137 end; 141 138 ["trees"; "assets"] |> List.iter (Eio_util.try_create_dir ~cwd); 142 - Eio_util.try_create_file ~cwd ~content: default_config_str "forest.toml"; 143 - Eio_util.try_create_file ~cwd ~content: "output/" ".gitignore"; 144 - Eio_util.try_create_file ~cwd ~content: "" "assets/.gitkeep"; 145 - Eio_util.try_create_file ~cwd ~content: index_tree_str "trees/index.tree"; 146 - Reporter.emit Log ~extra_remarks: [Asai.Diagnostic.loctextf "%s" "Initialized forest, try editing `trees/index.tree` and running `forester build`. Afterwards, you can open `output/index.html` in your browser to view your forest."] 139 + Eio_util.try_create_file ~cwd ~content:default_config_str "forest.toml"; 140 + Eio_util.try_create_file ~cwd ~content:"output/" ".gitignore"; 141 + Eio_util.try_create_file ~cwd ~content:"" "assets/.gitkeep"; 142 + Eio_util.try_create_file ~cwd ~content:index_tree_str "trees/index.tree"; 143 + Reporter.emit Log 144 + ~extra_remarks: 145 + [ 146 + Asai.Diagnostic.loctextf "%s" 147 + "Initialized forest, try editing `trees/index.tree` and running \ 148 + `forester build`. Afterwards, you can open `output/index.html` in \ 149 + your browser to view your forest."; 150 + ] 147 151 148 152 let arg_config = 149 153 let doc = "A TOML file like $(i,forest.toml)" in 150 - Arg.(value & pos 0 file "forest.toml" & info [] ~docv: "FOREST" ~doc) 154 + Arg.(value & pos 0 file "forest.toml" & info [] ~docv:"FOREST" ~doc) 151 155 152 156 let build_cmd ~env = 153 157 let arg_dev = 154 - let doc = "Run forester in development mode; this will attach source file locations to the generated json." in 158 + let doc = 159 + "Run forester in development mode; this will attach source file \ 160 + locations to the generated json." 161 + in 155 162 Arg.value @@ Arg.flag @@ Arg.info ["dev"] ~doc 156 163 in 157 164 let arg_no_theme = ··· 159 166 Arg.value @@ Arg.flag @@ Arg.info ["no-theme"] ~doc 160 167 in 161 168 let doc = "Build the forest" in 162 - let man = [ 163 - `S Manpage.s_description; 164 - `P "The $(tname) command builds a hypertext $(b,forest) from trees stored in each $(i,INPUT_DIR) or any of its subdirectories; tree files are expected to be of the form $(i,addr.tree) where $(i,addr) is the address of the tree. Note that the physical location of a tree is not taken into account, and two trees with the same address are not permitted."; 165 - ] 169 + let man = 170 + [ 171 + `S Manpage.s_description; 172 + `P 173 + "The $(tname) command builds a hypertext $(b,forest) from trees stored \ 174 + in each $(i,INPUT_DIR) or any of its subdirectories; tree files are \ 175 + expected to be of the form $(i,addr.tree) where $(i,addr) is the \ 176 + address of the tree. Note that the physical location of a tree is not \ 177 + taken into account, and two trees with the same address are not \ 178 + permitted."; 179 + ] 166 180 in 167 181 let info = Cmd.info "build" ~version ~doc ~man in 168 - Cmd.v 169 - info 170 - Term.( 171 - const (build ~env) 172 - $ arg_logs 173 - $ arg_config 174 - $ arg_dev 175 - $ arg_no_theme 176 - ) 182 + Cmd.v info 183 + Term.(const (build ~env) $ arg_logs $ arg_config $ arg_dev $ arg_no_theme) 177 184 178 185 let new_tree_cmd ~env = 179 186 let arg_prefix = 180 187 let doc = "The namespace prefix for the created tree." in 181 - Arg.value @@ 182 - Arg.opt (Arg.some Arg.string) None @@ 183 - Arg.info ["prefix"] ~docv: "XXX" ~doc 188 + Arg.value 189 + @@ Arg.opt (Arg.some Arg.string) None 190 + @@ Arg.info ["prefix"] ~docv:"XXX" ~doc 184 191 in 185 192 let arg_template = 186 193 let doc = "The tree to use as a template" in 187 - Arg.value @@ 188 - Arg.opt (Arg.some Arg.string) None @@ 189 - Arg.info ["template"] ~docv: "XXX" ~doc 194 + Arg.value 195 + @@ Arg.opt (Arg.some Arg.string) None 196 + @@ Arg.info ["template"] ~docv:"XXX" ~doc 190 197 in 191 - let arg_dest_dir 192 - : string option Term.t 193 - = 198 + let arg_dest_dir : string option Term.t = 194 199 let doc = "The directory in which to deposit created tree." in 195 - Arg.value @@ 196 - Arg.opt (Arg.some Arg.dir) None @@ 197 - Arg.info ["dest"] ~docv: "DEST" ~doc 200 + Arg.value 201 + @@ Arg.opt (Arg.some Arg.dir) None 202 + @@ Arg.info ["dest"] ~docv:"DEST" ~doc 198 203 in 199 204 let arg_random = 200 - let doc = "True if the new tree should have id assigned randomly rather than sequentially" in 205 + let doc = 206 + "True if the new tree should have id assigned randomly rather than \ 207 + sequentially" 208 + in 201 209 Arg.value @@ Arg.flag @@ Arg.info ["random"] ~doc 202 210 in 203 211 let doc = "Create a new tree." in 204 212 let info = Cmd.info "new" ~version ~doc in 205 - Cmd.v 206 - info 213 + Cmd.v info 207 214 Term.( 208 215 const (new_tree ~env) 209 - $ arg_config 210 - $ arg_dest_dir 211 - $ arg_prefix 212 - $ arg_template 213 - $ arg_random 214 - ) 216 + $ arg_config $ arg_dest_dir $ arg_prefix $ arg_template $ arg_random) 215 217 216 218 let complete_cmd ~env = 217 219 let arg_title = 218 220 let doc = "The tree title prefix to complete." in 219 - Arg.value @@ 220 - Arg.opt Arg.string "" @@ 221 - Arg.info ["title"] ~docv: "title" ~doc 221 + Arg.value @@ Arg.opt Arg.string "" @@ Arg.info ["title"] ~docv:"title" ~doc 222 222 in 223 223 let doc = "Complete a tree title." in 224 224 let info = Cmd.info "complete" ~version ~doc in ··· 237 237 let init_cmd ~env = 238 238 let arg_dir = 239 239 let doc = "The directory in which to initialize the forest" in 240 - Arg.value @@ Arg.opt (Arg.some Arg.string) None @@ Arg.info ["dir"] ~docv: "DIR" ~doc 240 + Arg.value 241 + @@ Arg.opt (Arg.some Arg.string) None 242 + @@ Arg.info ["dir"] ~docv:"DIR" ~doc 241 243 in 242 244 let doc = "Initialize a new forest" in 243 - let man = [ 244 - `S Manpage.s_description; 245 - `P "The $(tname) command initializes a $(b,forest) in the current directory. This involves initialising a git repository, setting up a git submodule for the theme, creating an assets and trees directory, as well as a config file." 246 - ] 245 + let man = 246 + [ 247 + `S Manpage.s_description; 248 + `P 249 + "The $(tname) command initializes a $(b,forest) in the current \ 250 + directory. This involves initialising a git repository, setting up a \ 251 + git submodule for the theme, creating an assets and trees directory, \ 252 + as well as a config file."; 253 + ] 247 254 in 248 255 let info = Cmd.info "init" ~version ~doc ~man in 249 256 Cmd.v info Term.(const (init ~env) $ arg_dir) 250 257 251 258 let lsp ~env _ config = 252 259 let config = Config_parser.parse_forest_config_file config in 253 - Forester_lsp.start 254 - ~env 255 - ~config 260 + Forester_lsp.start ~env ~config 256 261 257 262 let lsp_cmd ~env = 258 - let man = [ 259 - `S Manpage.s_description; 260 - `P "The $(tname) command starts the forester language server."; 261 - ] 263 + let man = 264 + [ 265 + `S Manpage.s_description; 266 + `P "The $(tname) command starts the forester language server."; 267 + ] 262 268 in 263 269 let doc = "Start the LSP" in 264 270 let info = Cmd.info "lsp" ~version ~doc ~man in 265 - Cmd.v 266 - info 267 - Term.( 268 - const (lsp ~env) 269 - $ arg_logs 270 - $ arg_config 271 - ) 271 + Cmd.v info Term.(const (lsp ~env) $ arg_logs $ arg_config) 272 272 273 273 let cmd ~env = 274 274 let doc = "a tool for tending mathematical forests" in 275 - let man = [ 276 - `S Manpage.s_bugs; 277 - `P "Email bug reports to <~jonsterling/forester-discuss@lists.sr.ht>."; 278 - `S Manpage.s_authors; 279 - `P "Jonathan Sterling" 280 - ] 275 + let man = 276 + [ 277 + `S Manpage.s_bugs; 278 + `P "Email bug reports to <~jonsterling/forester-discuss@lists.sr.ht>."; 279 + `S Manpage.s_authors; 280 + `P "Jonathan Sterling"; 281 + ] 281 282 in 282 283 let info = Cmd.info "forester" ~version ~doc ~man in 283 - Cmd.group 284 - info 284 + Cmd.group info 285 285 [ 286 286 build_cmd ~env; 287 287 new_tree_cmd ~env; 288 288 complete_cmd ~env; 289 289 init_cmd ~env; 290 290 query_cmd ~env; 291 - lsp_cmd ~env 291 + lsp_cmd ~env; 292 292 ] 293 293 294 294 let () = ··· 297 297 Logs.set_reporter (Logs_fmt.reporter ()); 298 298 let@ env = Eio_main.run in 299 299 let@ () = Forester_core.Reporter.easy_run in 300 - exit @@ Cmd.eval ~catch: false @@ cmd ~env 300 + exit @@ Cmd.eval ~catch:false @@ cmd ~env
+2 -2
docs/dune
··· 3 3 ;;; SPDX-License-Identifier: GPL-3.0-or-later 4 4 5 5 (documentation 6 - (package forester) 7 - (mld_files index developing)) 6 + (package forester) 7 + (mld_files index developing))
+2 -1
dune
··· 4 4 5 5 (env 6 6 (static 7 - (link_flags (-ccopt -static)))) 7 + (link_flags 8 + (-ccopt -static))))
-2
flake.nix
··· 101 101 legacyPackages = scopes.scope'; 102 102 packages.default = scopesStatic.main; 103 103 devShells.default = pkgs.mkShell { 104 - TOPIARY_LANGUAGE_DIR = "topiary"; 105 104 inputsFrom = [ scopes.main ]; 106 105 107 106 buildInputs = ··· 109 108 devPackages 110 109 ++ [ 111 110 tex 112 - topiary 113 111 reuse 114 112 watchexec 115 113 ];
-10
format.sh
··· 1 - #!/usr/bin/env sh 2 - 3 - # SPDX-FileCopyrightText: 2024 The Forester Project Contributors 4 - # 5 - # SPDX-License-Identifier: GPL-3.0-or-later 6 - 7 - topiary format -s bin/**/*.ml 8 - topiary format -s lib/**/*.mli 9 - topiary format -s lib/**/*.ml 10 - topiary format -s test/*.ml
+8 -9
lib/compiler/Action.ml
··· 6 6 7 7 open Forester_core 8 8 9 - type exit = 10 - Fail | Finished 11 - [@@deriving show] 9 + type exit = Fail | Finished [@@deriving show] 12 10 13 11 type t = 14 12 | Quit of exit ··· 20 18 | Parse_all 21 19 | Expand_all 22 20 | Eval_all 23 - | Load_tree of (Eio.Fs.dir_ty Eio.Path.t [@printer Eio.Path.pp]) 24 - | Parse of (Lsp.Uri.t [@printer fun fmt uri -> fprintf fmt "%s" (Lsp.Uri.to_string uri)]) 21 + | Load_tree of (Eio.Fs.dir_ty Eio.Path.t[@printer Eio.Path.pp]) 22 + | Parse of 23 + (Lsp.Uri.t 24 + [@printer fun fmt uri -> fprintf fmt "%s" (Lsp.Uri.to_string uri)]) 25 25 | Expand of URI.t 26 26 | Eval of URI.t 27 27 | Query of (string, Vertex.t) Datalog_expr.query 28 - | Query_results of (Vertex_set.t [@opaque]) 29 - | Report_errors of ((Reporter.Message.t Asai.Diagnostic.t [@opaque]) list * t) 28 + | Query_results of (Vertex_set.t[@opaque]) 29 + | Report_errors of ((Reporter.Message.t Asai.Diagnostic.t[@opaque]) list * t) 30 30 | Run_jobs of Job.job Range.located list 31 31 [@@deriving show] 32 32 33 33 let report ~next_action ~errors = 34 - if List.length errors > 0 then 35 - Report_errors (errors, next_action) 34 + if List.length errors > 0 then Report_errors (errors, next_action) 36 35 else next_action
+11 -12
lib/compiler/Asset_router.ml
··· 9 9 let router : (string, URI.t) Hashtbl.t = Hashtbl.create 100 10 10 11 11 let normalize ?loc source_path = 12 - try 13 - Unix.realpath source_path 14 - with 15 - | Unix.Unix_error (e, _, m) -> 16 - Reporter.fatal 17 - ?loc 18 - (Asset_not_found (Format.asprintf "%s: %s" (Unix.error_message e) m)) 12 + try Unix.realpath source_path 13 + with Unix.Unix_error (e, _, m) -> 14 + Reporter.fatal ?loc 15 + (Asset_not_found (Format.asprintf "%s: %s" (Unix.error_message e) m)) 19 16 20 17 let install ~(config : Config.t) ~source_path ~content = 21 18 let normalized = normalize source_path in 22 19 match Hashtbl.find_opt router normalized with 23 20 | Some uri -> uri 24 21 | None -> 25 - let hash = Result.get_ok @@ Multihash_digestif.of_cstruct `Sha3_256 (Cstruct.of_string content) in 26 - let cid = Cid.v ~version: `Cidv1 ~codec: `Raw ~base: `Base32 ~hash in 22 + let hash = 23 + Result.get_ok 24 + @@ Multihash_digestif.of_cstruct `Sha3_256 (Cstruct.of_string content) 25 + in 26 + let cid = Cid.v ~version:`Cidv1 ~codec:`Raw ~base:`Base32 ~hash in 27 27 let cid_str = Cid.to_string cid in 28 28 let ext = Filename.extension normalized in 29 - let uri = URI_scheme.named_uri ~base: config.url (cid_str ^ ext) in 29 + let uri = URI_scheme.named_uri ~base:config.url (cid_str ^ ext) in 30 30 Hashtbl.add router normalized uri; 31 31 uri 32 32 ··· 34 34 let normalized = normalize ?loc source_path in 35 35 match Hashtbl.find_opt router normalized with 36 36 | Some uri -> uri 37 - | None -> 38 - Reporter.fatal ?loc (Asset_has_no_content_address normalized) 37 + | None -> Reporter.fatal ?loc (Asset_has_no_content_address normalized)
+8 -8
lib/compiler/Build_latex.ml
··· 17 17 let svg_path = Eio.Path.(resources_dir cwd / name) in 18 18 let perm = 0o755 in 19 19 Eio_util.ensure_context_of_path ~perm svg_path; 20 - try 21 - Eio.Path.load svg_path 22 - with 23 - | Eio.Io (Eio.Fs.E (Eio.Fs.Not_found _), _) -> 24 - Reporter.emit Log ~extra_remarks: [Asai.Diagnostic.loctextf "Building %s" (Eio.Path.native_exn svg_path)]; 25 - let svg_code = LaTeX_pipeline.latex_to_svg ~env ?loc source in 26 - Eio.Path.save ~create: (`Or_truncate perm) svg_path svg_code; 27 - svg_code 20 + try Eio.Path.load svg_path 21 + with Eio.Io (Eio.Fs.E (Eio.Fs.Not_found _), _) -> 22 + Reporter.emit Log 23 + ~extra_remarks: 24 + [Asai.Diagnostic.loctextf "Building %s" (Eio.Path.native_exn svg_path)]; 25 + let svg_code = LaTeX_pipeline.latex_to_svg ~env ?loc source in 26 + Eio.Path.save ~create:(`Or_truncate perm) svg_path svg_code; 27 + svg_code
+1 -5
lib/compiler/Build_latex.mli
··· 6 6 7 7 type env = Eio_unix.Stdenv.base 8 8 9 - val latex_to_svg : 10 - env: env -> 11 - ?loc: Asai.Range.t -> 12 - string -> 13 - string 9 + val latex_to_svg : env:env -> ?loc:Asai.Range.t -> string -> string
+55 -64
lib/compiler/Cache.ml
··· 6 6 7 7 open Forester_prelude 8 8 open Forester_core 9 - open struct module T = Types end 9 + 10 + open struct 11 + module T = Types 12 + end 10 13 11 14 (*Inspired by 12 - https://rustc-dev-guide.rust-lang.org/queries/incremental-compilation-in-detail.html 15 + https://rustc-dev-guide.rust-lang.org/queries/incremental-compilation-in-detail.html 13 16 *) 14 17 15 18 module Item = struct 16 19 type color = Red | Green | Unknown 20 + type meta = {timestamp: float option; color: color} 17 21 18 - type meta = { 19 - timestamp: float option; 20 - color: color; 21 - } 22 - 23 - type t = (* Key *) 24 - | Tree of URI.t 25 - | Path of Trie.path 26 - | Asset of string 22 + type t = 23 + (* Key *) 24 + | Tree of URI.t 25 + | Path of Trie.path 26 + | Asset of string 27 27 28 28 (* TODO: Hand-roll these for performance? *) 29 29 let compare = compare 30 30 let hash = Hashtbl.hash 31 - let equal = (=) 31 + let equal = ( = ) 32 32 33 - let check_timestamp 34 - = fun path timestamp -> 33 + let check_timestamp = 34 + fun path timestamp -> 35 35 match timestamp with 36 36 | Some timestamp -> 37 - let last_modified = Eio.Path.(stat ~follow: true @@ path).mtime in 38 - if last_modified > timestamp then 39 - Red 40 - else Green 37 + let last_modified = Eio.Path.(stat ~follow:true @@ path).mtime in 38 + if last_modified > timestamp then Red else Green 41 39 | _ -> Red 42 40 end 43 41 44 42 (* The core datastructure here is a {graph; hashtbl} 45 43 We shadow many functions from both datastructures. 46 - *) 44 + *) 47 45 48 - module Dependency_tbl = Hashtbl.Make(Item) 46 + module Dependency_tbl = Hashtbl.Make (Item) 49 47 50 48 module Dependecy_graph : sig 51 - type t 52 - type vertex = Item.t 53 - val add_vertex : t -> vertex -> t 49 + type t 50 + type vertex = Item.t 54 51 55 - val create : ?size: int -> unit -> t 56 - val pred : t -> vertex -> vertex list 57 - val empty : unit -> t 58 - end 59 - = struct 60 - module G = Graph.Imperative.Digraph.ConcreteBidirectional(Item) 52 + val add_vertex : t -> vertex -> t 53 + val create : ?size:int -> unit -> t 54 + val pred : t -> vertex -> vertex list 55 + val empty : unit -> t 56 + end = struct 57 + module G = Graph.Imperative.Digraph.ConcreteBidirectional (Item) 58 + 61 59 type t = G.t 62 60 type vertex = Item.t 61 + 63 62 let create = G.create 64 63 let pred = G.pred 65 - let add_vertex g v = G.add_vertex g v; g 66 - let empty = G.create ?size: None 64 + 65 + let add_vertex g v = 66 + G.add_vertex g v; 67 + g 68 + 69 + let empty = G.create ?size:None 67 70 end 68 71 69 72 type t = { ··· 72 75 db: Datalog_engine.db; 73 76 } 74 77 75 - let empty = { 76 - tbl = Dependency_tbl.create 1000; 77 - graph = Dependecy_graph.create (); 78 - db = Datalog_engine.db_create (); 79 - } 78 + let empty = 79 + { 80 + tbl = Dependency_tbl.create 1000; 81 + graph = Dependecy_graph.create (); 82 + db = Datalog_engine.db_create (); 83 + } 80 84 81 85 let find_opt t uri = Dependency_tbl.find_opt t.tbl uri 82 86 ··· 86 90 87 91 let pred t v = Dependecy_graph.pred t.graph v 88 92 89 - let get_changed_paths ~(config : Config.t) (cache : t) (dirs : Eio.Fs.dir_ty Eio.Path.t List.t) : Eio.Fs.dir_ty Eio.Path.t Seq.t = 93 + let get_changed_paths ~(config : Config.t) (cache : t) 94 + (dirs : Eio.Fs.dir_ty Eio.Path.t List.t) : Eio.Fs.dir_ty Eio.Path.t Seq.t = 90 95 let@ path = Seq.filter_map @~ Dir_scanner.scan_directories dirs in 91 96 let path_str = Eio.Path.native_exn path in 92 - let uri = URI_scheme.path_to_uri ~base: config.url path_str in 93 - let last_modified = Eio.Path.(stat ~follow: true path).mtime in 97 + let uri = URI_scheme.path_to_uri ~base:config.url path_str in 98 + let last_modified = Eio.Path.(stat ~follow:true path).mtime in 94 99 (* "flipped" bind, by default returns the current path. IDK, I am being lazy. *) 95 - let (let*) o f = match o with None -> Some path | Some v -> f v in 100 + let ( let* ) o f = match o with None -> Some path | Some v -> f v in 96 101 let* {timestamp; _} = Dependency_tbl.find_opt cache.tbl (Tree uri) in 97 102 let* last_seen = timestamp in 98 - if last_modified > last_seen then 99 - Some path 100 - else 101 - None 103 + if last_modified > last_seen then Some path else None 102 104 103 105 let rec try_mark_green t node = 104 106 let exception Done of bool in ··· 106 108 let@ v = List.filter_map @~ pred t node in 107 109 match Dependency_tbl.find_opt t.tbl v with 108 110 | None -> None 109 - | Some c -> 110 - Some (v, c) 111 + | Some c -> Some (v, c) 111 112 in 112 113 let result = 113 114 try ··· 117 118 | Red -> raise (Done false) 118 119 | Green -> true && acc 119 120 | Unknown -> 120 - if try_mark_green t dep then true && acc 121 - else raise (Done false) 122 - ) 123 - dependencies 124 - true 125 - with 126 - | Done b -> b 121 + if try_mark_green t dep then true && acc else raise (Done false)) 122 + dependencies true 123 + with Done b -> b 127 124 in 128 125 if result then 129 - Dependency_tbl.replace 130 - t.tbl 131 - node 132 - { 133 - color = Green; 134 - timestamp = Some (Unix.time ()) 135 - } 136 - else 137 - assert false; 126 + Dependency_tbl.replace t.tbl node 127 + {color = Green; timestamp = Some (Unix.time ())} 128 + else assert false; 138 129 result 139 130 140 131 let marshal filename (v : t) = 141 132 let oc = open_out_bin filename in 142 133 Fun.protect 143 - ~finally: (fun () -> close_out oc) 134 + ~finally:(fun () -> close_out oc) 144 135 (fun () -> Marshal.to_channel oc v []) 145 136 146 137 let unmarshal filename : t = 147 138 let ic = open_in_bin filename in 148 139 Fun.protect 149 - ~finally: (fun () -> close_in ic) 140 + ~finally:(fun () -> close_in ic) 150 141 (fun () -> Marshal.from_channel ic)
+13 -16
lib/compiler/Dir_scanner.ml
··· 6 6 7 7 open Forester_prelude 8 8 open Forester_core 9 - 10 9 module EP = Eio.Path 11 - module S = Algaeff.Sequencer.Make(struct type t = Eio.Fs.dir_ty EP.t end) 10 + 11 + module S = Algaeff.Sequencer.Make (struct 12 + type t = Eio.Fs.dir_ty EP.t 13 + end) 12 14 13 15 let rec process_file condition fp = 14 - if EP.is_directory fp then 15 - process_dir condition fp 16 - else if condition fp then 17 - S.yield fp 16 + if EP.is_directory fp then process_dir condition fp 17 + else if condition fp then S.yield fp 18 18 19 19 and process_dir condition dir = 20 20 assert (not @@ Filename.is_relative @@ EP.native_exn dir); 21 21 try 22 22 let@ fp = List.iter @~ EP.read_dir dir in 23 23 process_file condition EP.(dir / fp) 24 - with 25 - | Eio.Io (Eio.Fs.E (Permission_denied _), _) -> () 24 + with Eio.Io (Eio.Fs.E (Permission_denied _), _) -> () 26 25 27 26 let is_tree fp = 28 27 match EP.split fp with 29 28 | None -> false 30 29 | Some (_, basename) -> 31 - Filename.extension basename = ".tree" && not @@ String.starts_with ~prefix: "." basename 30 + Filename.extension basename = ".tree" 31 + && (not @@ String.starts_with ~prefix:"." basename) 32 32 33 33 let is_not_hidden fp = 34 34 match EP.split fp with 35 35 | None -> false 36 - | Some (_, basename) -> 37 - not @@ String.starts_with ~prefix: "." basename 36 + | Some (_, basename) -> not @@ String.starts_with ~prefix:"." basename 38 37 39 38 let matching_basename str fp = 40 39 match EP.split fp with 41 40 | None -> false 42 - | Some (_, basename) -> 43 - is_tree fp 44 - && Filename.chop_extension basename = str 41 + | Some (_, basename) -> is_tree fp && Filename.chop_extension basename = str 45 42 46 43 let scan_directories dirs = 47 44 let@ () = S.run in ··· 68 65 if Filename.is_relative native then raise (Is_relative native); 69 66 Some first_match 70 67 with 71 - | Is_relative _ -> assert false 72 - | Failure _ -> None 68 + | Is_relative _ -> assert false 69 + | Failure _ -> None
+8 -3
lib/compiler/Dir_scanner.mli
··· 6 6 7 7 open Forester_core 8 8 9 - val scan_directories : Eio.Fs.dir_ty Eio.Path.t list -> Eio.Fs.dir_ty Eio.Path.t Seq.t 10 - val scan_asset_directories : Eio.Fs.dir_ty Eio.Path.t list -> Eio.Fs.dir_ty Eio.Path.t Seq.t 11 - val find_tree : Eio.Fs.dir_ty Eio.Path.t list -> URI.t -> Eio.Fs.dir_ty Eio.Path.t option 9 + val scan_directories : 10 + Eio.Fs.dir_ty Eio.Path.t list -> Eio.Fs.dir_ty Eio.Path.t Seq.t 11 + 12 + val scan_asset_directories : 13 + Eio.Fs.dir_ty Eio.Path.t list -> Eio.Fs.dir_ty Eio.Path.t Seq.t 14 + 15 + val find_tree : 16 + Eio.Fs.dir_ty Eio.Path.t list -> URI.t -> Eio.Fs.dir_ty Eio.Path.t option
+101 -119
lib/compiler/Driver.ml
··· 8 8 open Forester_prelude 9 9 open State.Syntax 10 10 11 - open struct module T = Types end 11 + open struct 12 + module T = Types 13 + end 12 14 13 15 let update (action : Action.t) (forest : State.t) = 14 16 let open Action in 15 17 let forest = State.update_history forest action in 16 18 match action with 17 - | Quit e -> 18 - begin 19 - match e with 20 - | Fail -> exit 1 21 - | Finished -> exit 0 22 - end 19 + | Quit e -> begin match e with Fail -> exit 1 | Finished -> exit 0 end 23 20 | Query q -> 24 21 let@ () = Reporter.trace "when running query" in 25 22 let r = Forest.run_datalog_query forest.graphs q in 26 - Query_results r, forest 27 - | Query_results _ -> Done, forest 28 - | Report_errors (_, next_action) -> next_action, forest 23 + (Query_results r, forest) 24 + | Query_results _ -> (Done, forest) 25 + | Report_errors (_, next_action) -> (next_action, forest) 29 26 | Load_all_configured_dirs -> 30 27 let@ () = Reporter.trace "when loading files from disk" in 31 - let tree_dirs = Eio_util.paths_of_dirs ~env: forest.env forest.config.trees in 28 + let tree_dirs = 29 + Eio_util.paths_of_dirs ~env:forest.env forest.config.trees 30 + in 32 31 List.iter (fun path -> assert (Eio.Path.is_directory path)) tree_dirs; 33 32 let docs = Phases.load tree_dirs in 34 33 Seq.iter 35 34 (fun doc -> 36 35 let lsp_uri = Lsp.Text_document.documentUri doc in 37 - let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url lsp_uri in 36 + let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url lsp_uri in 38 37 URI.Tbl.replace forest.resolver uri (Lsp.Uri.to_path lsp_uri); 39 - forest.={uri} <- Document doc 40 - ) 38 + forest.={uri} <- Document doc) 41 39 docs; 42 40 Logs.debug (fun m -> m "loaded %d trees" (Seq.length docs)); 43 - Parse_all, forest 41 + (Parse_all, forest) 44 42 | Parse_all -> 45 43 let@ () = Reporter.trace "when parsing trees" in 46 44 let errors, succeeded = Phases.parse forest in ··· 48 46 (fun (code : Tree.code) -> 49 47 let@ uri = Option.iter @~ Tree.(identity_to_uri code.identity) in 50 48 forest.={uri} <- Parsed code; 51 - forest.?{uri} <- [] 52 - ) 49 + forest.?{uri} <- []) 53 50 succeeded; 54 - if (List.length errors = 0) then 55 - assert ( 56 - Seq.for_all 57 - Tree.is_parsed 58 - (URI.Tbl.to_seq_values forest.index) 59 - ); 51 + if List.length errors = 0 then 52 + assert (Seq.for_all Tree.is_parsed (URI.Tbl.to_seq_values forest.index)); 60 53 List.iter 61 54 (fun diag -> 62 55 let@ uri = 63 - Option.iter @~ Option.map (URI_scheme.lsp_uri_to_uri ~base: forest.config.url) (Reporter.guess_uri diag) 56 + Option.iter 57 + @~ Option.map 58 + (URI_scheme.lsp_uri_to_uri ~base:forest.config.url) 59 + (Reporter.guess_uri diag) 64 60 in 65 - forest.?{uri} <- [diag] 66 - ) 61 + forest.?{uri} <- [diag]) 67 62 errors; 68 - Action.report ~errors ~next_action: Build_import_graph, forest 63 + (Action.report ~errors ~next_action:Build_import_graph, forest) 69 64 | Build_import_graph -> 70 65 let@ () = Reporter.trace "when building import graph" in 71 66 let errors, import_graph = Phases.build_import_graph forest in 72 - Logs.debug (fun m -> m "import graph has %d vertices" (Forest_graph.nb_vertex import_graph)); 73 - Action.report ~errors ~next_action: Expand_all, {forest with import_graph} 67 + Logs.debug (fun m -> 68 + m "import graph has %d vertices" (Forest_graph.nb_vertex import_graph)); 69 + (Action.report ~errors ~next_action:Expand_all, {forest with import_graph}) 74 70 | Expand_all -> 75 71 let@ () = Reporter.tracef "when expanding trees" in 76 72 Logs.debug (fun m -> m "expanding trees"); 77 73 let errors = Phases.expand_all forest in 78 - Action.report ~errors ~next_action: Eval_all, forest 74 + (Action.report ~errors ~next_action:Eval_all, forest) 79 75 | Expand uri -> 80 76 let@ () = Reporter.tracef "when expanding %a" URI.pp uri in 81 - begin 82 - match Option.bind forest.={uri} Tree.to_code with 83 - | None -> 84 - Action.report ~errors: [Reporter.diagnostic (Resource_not_found uri)] ~next_action: Done, forest 85 - | Some code -> 86 - let result, errors = Phases.expand forest code in 87 - forest.={uri} <- Expanded result; 88 - Action.report ~errors ~next_action: (Eval uri), forest 77 + begin match Option.bind forest.={uri} Tree.to_code with 78 + | None -> 79 + ( Action.report 80 + ~errors:[Reporter.diagnostic (Resource_not_found uri)] 81 + ~next_action:Done, 82 + forest ) 83 + | Some code -> 84 + let result, errors = Phases.expand forest code in 85 + forest.={uri} <- Expanded result; 86 + (Action.report ~errors ~next_action:(Eval uri), forest) 89 87 end 90 88 | Eval_all -> 91 89 let@ () = Reporter.tracef "when evaluating" in 92 90 Logs.debug (fun m -> m "evaluating"); 93 91 let result = Phases.eval forest in 94 92 let jobs, errors = 95 - result 96 - |> List.of_seq 97 - |> List.map 98 - (fun (Eval.{articles; jobs}, diagnostics) -> 99 - begin 100 - let@ article = List.iter @~ articles in 101 - State.plant_resource (T.Article article) forest 102 - end; 103 - jobs, diagnostics 104 - ) 105 - |> List.split |> fun (j, e) -> List.concat j, List.concat e 93 + result |> List.of_seq 94 + |> List.map (fun (Eval.{articles; jobs}, diagnostics) -> 95 + begin 96 + let@ article = List.iter @~ articles in 97 + State.plant_resource (T.Article article) forest 98 + end; 99 + (jobs, diagnostics)) 100 + |> List.split 101 + |> fun (j, e) -> (List.concat j, List.concat e) 106 102 in 107 - Logs.debug (fun m -> m "got %d resources " (Seq.length (State.get_all_resources forest))); 108 - Action.report ~errors ~next_action: (Run_jobs jobs), forest 103 + Logs.debug (fun m -> 104 + m "got %d resources " (Seq.length (State.get_all_resources forest))); 105 + (Action.report ~errors ~next_action:(Run_jobs jobs), forest) 109 106 | Eval uri -> 110 107 let@ () = Reporter.tracef "when evaluating %a" URI.pp uri in 111 108 let result, _err = Phases.eval_only uri forest in 112 - Done, result 109 + (Done, result) 113 110 | Plant_assets -> 114 111 let@ () = Reporter.tracef "when planting assets" in 115 - (* TODO: We really only need to plant the assets that are referred to (look for calls to Asset_router.uri_of_asset).*) 112 + (* TODO: We really only need to plant the assets that are referred to (look 113 + for calls to Asset_router.uri_of_asset).*) 116 114 let paths = 117 115 Dir_scanner.scan_asset_directories 118 - (Eio_util.paths_of_dirs ~env: forest.env forest.config.assets) 116 + (Eio_util.paths_of_dirs ~env:forest.env forest.config.assets) 119 117 in 120 118 Logs.debug (fun m -> m "planting %i assets" (Seq.length paths)); 121 119 let module EP = Eio.Path in 122 120 begin 123 - let@ path = Eio.Fiber.List.iter ~max_fibers: 20 @~ List.of_seq paths in 121 + let@ path = Eio.Fiber.List.iter ~max_fibers:20 @~ List.of_seq paths in 124 122 let@ () = Reporter.easy_run in 125 123 let content = EP.load path in 126 124 let source_path = EP.native_exn path in 127 - let uri = Asset_router.install ~config: forest.config ~source_path ~content in 125 + let uri = 126 + Asset_router.install ~config:forest.config ~source_path ~content 127 + in 128 128 Logs.debug (fun m -> m "Installed %s at %a" source_path URI.pp uri); 129 129 State.plant_resource (T.Asset {uri; content}) forest 130 130 end; 131 - Done, forest 131 + (Done, forest) 132 132 | Plant_foreign -> 133 133 let@ () = Reporter.tracef "when planting foreign forest" in 134 134 Logs.debug (fun m -> m "Planting foreign forests"); 135 135 let result, err = Phases.implant_foreign forest in 136 - Report_errors (err, Done), result 136 + (Report_errors (err, Done), result) 137 137 | Run_jobs jobs -> 138 138 Phases.run_jobs forest jobs; 139 - Done, forest 139 + (Done, forest) 140 140 | Load_tree path -> 141 141 let@ () = Reporter.tracef "when loading %a" Eio.Path.pp path in 142 142 let doc = Imports.load_tree path in 143 143 Logs.debug (fun m -> m "%s" (Lsp.Text_document.text doc)); 144 144 let lsp_uri = Lsp.Text_document.documentUri doc in 145 - let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url lsp_uri in 145 + let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url lsp_uri in 146 146 forest.={uri} <- Document doc; 147 - Parse lsp_uri, forest 147 + (Parse lsp_uri, forest) 148 148 | Parse uri -> 149 149 let@ () = Reporter.tracef "when parsing %s" (Lsp.Uri.to_string uri) in 150 150 Logs.debug (fun m -> m "Reparsing"); 151 - let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url uri in 152 - begin 153 - match Option.bind forest.={uri} Tree.to_doc with 154 - | Some doc -> 155 - begin 156 - match Parse.parse_document ~config: forest.config doc with 157 - | Ok code -> 158 - forest.={uri} <- Parsed code; 159 - forest.?{uri} <- []; 160 - Imports.fixup code forest; 161 - Expand uri, forest 162 - | Error diagnostic -> 163 - forest.?{uri} <- [diagnostic]; 164 - (Report_errors ([diagnostic], Done)), forest 165 - end 166 - | None -> 167 - match Imports.resolve_uri_to_code forest uri with 168 - | None -> Reporter.fatal (Resource_not_found uri) 169 - | Some code -> 170 - Imports.fixup code forest; 171 - forest.={uri} <- Parsed code; 172 - Expand uri, forest 151 + let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url uri in 152 + begin match Option.bind forest.={uri} Tree.to_doc with 153 + | Some doc -> begin 154 + match Parse.parse_document ~config:forest.config doc with 155 + | Ok code -> 156 + forest.={uri} <- Parsed code; 157 + forest.?{uri} <- []; 158 + Imports.fixup code forest; 159 + (Expand uri, forest) 160 + | Error diagnostic -> 161 + forest.?{uri} <- [diagnostic]; 162 + (Report_errors ([diagnostic], Done), forest) 173 163 end 174 - | Done -> 175 - Done, forest 164 + | None -> ( 165 + match Imports.resolve_uri_to_code forest uri with 166 + | None -> Reporter.fatal (Resource_not_found uri) 167 + | Some code -> 168 + Imports.fixup code forest; 169 + forest.={uri} <- Parsed code; 170 + (Expand uri, forest)) 171 + end 172 + | Done -> (Done, forest) 176 173 177 174 let run_until_done a s : State.t = 178 175 let fatal d = ··· 187 184 | Quit Fail -> exit 1 188 185 | Quit Finished -> exit 0 189 186 | Done -> new_state 190 - | _ -> 191 - go new_action new_state 187 + | _ -> go new_action new_state 192 188 in 193 189 go a s 194 190 ··· 197 193 198 194 let any_fatal = 199 195 List.fold_left 200 - Asai.Diagnostic.( 201 - fun acc x -> 202 - acc 203 - || x.severity = Error 204 - || x.severity = Bug 205 - ) 196 + Asai.Diagnostic.(fun acc x -> acc || x.severity = Error || x.severity = Bug) 206 197 false 207 198 208 199 let batch_run ~env ~(config : Config.t) ~dev = 209 200 let init = 210 - State.make ~env ~config ~dev () 211 - |> plant_assets 212 - |> implant_foreign 201 + State.make ~env ~config ~dev () |> plant_assets |> implant_foreign 213 202 in 214 203 let rec go action state = 215 204 let new_action, new_state = update action state in ··· 221 210 assert (List.length errors > 0); 222 211 Logs.debug (fun m -> m "got %d errors" (List.length errors)); 223 212 List.iter Reporter.Tty.display errors; 224 - if any_fatal errors then 225 - go (Quit Fail) new_state 213 + if any_fatal errors then go (Quit Fail) new_state 226 214 else go new_action new_state 227 - | _ -> 228 - go new_action new_state 215 + | _ -> go new_action new_state 229 216 in 230 217 go Load_all_configured_dirs init 231 218 232 219 let language_server ~env ~config = 233 - let init = State.make ~env ~config ~dev: true () in 220 + let init = State.make ~env ~config ~dev:true () in 234 221 let rec go action state = 235 222 let new_action, new_state = update action state in 236 223 match action with 237 224 | Quit Fail -> exit 1 238 225 | Quit Finished -> exit 0 239 226 | Done -> new_state 240 - | _ -> 241 - go new_action new_state 227 + | _ -> go new_action new_state 242 228 in 243 229 let _, state = update Plant_assets init in 244 230 (* TODO: this ought to implant the foreign trees as well *) ··· 251 237 match update action state with 252 238 | new_action, new_state -> 253 239 if action = Done then new_state 254 - else 255 - begin 256 - go new_action new_state 257 - end 240 + else begin 241 + go new_action new_state 242 + end 258 243 in 259 244 let forest = go a s in 260 - forest, List.rev !history 245 + (forest, List.rev !history) 261 246 262 247 let collect_emitted_errors a s = 263 248 let errors = ref [] in 264 249 let rec go action state = 265 250 match update action state with 266 - | new_action, new_state -> 251 + | new_action, new_state -> ( 267 252 match action with 268 253 | Done -> new_state 269 - | Report_errors (errs, _) -> 270 - begin 271 - errors := errs @ !errors; 272 - go new_action new_state 273 - end 274 - | _ -> 254 + | Report_errors (errs, _) -> begin 255 + errors := errs @ !errors; 275 256 go new_action new_state 257 + end 258 + | _ -> go new_action new_state) 276 259 in 277 260 let forest = go a s in 278 - forest, List.rev !errors 261 + (forest, List.rev !errors) 279 262 280 - let rec force 281 - : Action.t list -> State.t -> State.t 282 - = fun msgs state -> 263 + let rec force : Action.t list -> State.t -> State.t = 264 + fun msgs state -> 283 265 match msgs with 284 266 | [] -> state 285 267 | msg :: remaining ->
+54 -59
lib/compiler/Eio_util.ml
··· 10 10 11 11 let path_of_dir ~env dir = 12 12 try 13 - let path = Path.(Eio.Stdenv.fs env / (Unix.realpath dir)) in 13 + let path = Path.(Eio.Stdenv.fs env / Unix.realpath dir) in 14 14 assert (Path.is_directory path); 15 15 path 16 16 with 17 - | Unix.Unix_error (e, _, m) -> 18 - Reporter.fatal 19 - IO_error 20 - ~extra_remarks: [ 21 - Asai.Diagnostic.loctextf "%s: %s" (Unix.error_message e) m 22 - ] 23 - | Assert_failure (_, _, _) -> 24 - Reporter.fatal 25 - Configuration_error 26 - ~extra_remarks: [Asai.Diagnostic.loctextf "%s is not a directory" dir] 17 + | Unix.Unix_error (e, _, m) -> 18 + Reporter.fatal IO_error 19 + ~extra_remarks: 20 + [Asai.Diagnostic.loctextf "%s: %s" (Unix.error_message e) m] 21 + | Assert_failure (_, _, _) -> 22 + Reporter.fatal Configuration_error 23 + ~extra_remarks:[Asai.Diagnostic.loctextf "%s is not a directory" dir] 27 24 28 25 let path_of_file ~env file = 29 26 try 30 - let path = Path.(Eio.Stdenv.fs env / (Unix.realpath file)) in 27 + let path = Path.(Eio.Stdenv.fs env / Unix.realpath file) in 31 28 assert (Path.is_file path); 32 29 path 33 - with 34 - | Unix.Unix_error (e, _, m) -> 35 - Reporter.fatal Configuration_error ~extra_remarks: [Asai.Diagnostic.loctextf "%s: %s" (Unix.error_message e) m] 30 + with Unix.Unix_error (e, _, m) -> 31 + Reporter.fatal Configuration_error 32 + ~extra_remarks: 33 + [Asai.Diagnostic.loctextf "%s: %s" (Unix.error_message e) m] 36 34 37 - let paths_of_dirs ~env = 38 - List.map (path_of_dir ~env) 39 - 40 - let paths_of_files ~env = 41 - List.map (path_of_file ~env) 35 + let paths_of_dirs ~env = List.map (path_of_dir ~env) 36 + let paths_of_files ~env = List.map (path_of_file ~env) 42 37 43 38 module NullSink : Flow.Pi.SINK with type t = unit = struct 44 39 type t = unit 40 + 45 41 let single_write _ _ = 0 46 - let copy _ ~src: _ = () 42 + let copy _ ~src:_ = () 47 43 end 48 44 49 45 let null_sink () : Flow.sink_ty Resource.t = ··· 52 48 53 49 let ensure_context_of_path ~perm (path : _ Path.t) = 54 50 let@ path', _ = Option.iter @~ Path.split path in 55 - Path.mkdirs ~exists_ok: true ~perm path' 51 + Path.mkdirs ~exists_ok:true ~perm path' 56 52 57 53 let ensure_remove_file path = 58 - try 59 - Eio.Path.unlink path 60 - with 61 - | Eio.Exn.Io (Eio.Fs.E (Eio.Fs.Not_found _), _) -> () 54 + try Eio.Path.unlink path 55 + with Eio.Exn.Io (Eio.Fs.E (Eio.Fs.Not_found _), _) -> () 62 56 63 57 let with_open_tmp_dir ~env kont = 64 58 let dir_name = string_of_int @@ Oo.id (object end) in 65 59 let cwd = Eio.Stdenv.cwd env in 66 60 let tmp = "_tmp" in 67 61 let tmp_path = Eio.Path.(cwd / tmp / dir_name) in 68 - Path.mkdirs ~exists_ok: true ~perm: 0o755 tmp_path; 62 + Path.mkdirs ~exists_ok:true ~perm:0o755 tmp_path; 69 63 let@ p = Eio.Path.with_open_dir tmp_path in 70 64 let result = kont p in 71 - Path.rmtree ~missing_ok: true tmp_path; 65 + Path.rmtree ~missing_ok:true tmp_path; 72 66 result 73 67 74 68 let run_process ?(quiet = false) ~env ~cwd cmd = ··· 77 71 let errbuf = Buffer.create 100 in 78 72 let errsink = Eio.Flow.buffer_sink errbuf in 79 73 let outsink = Eio.Flow.buffer_sink outbuf in 80 - if not quiet then 81 - Eio.traceln "Running %s" (String.concat " " cmd); 82 - try 83 - Eio.Process.run ~cwd ~stdout: outsink ~stderr: errsink mgr cmd 84 - with 85 - | exn -> 86 - Eio.traceln "Error: %s" (Buffer.contents errbuf); 87 - Eio.traceln "Output: %s" (Buffer.contents outbuf); 88 - raise exn 74 + if not quiet then Eio.traceln "Running %s" (String.concat " " cmd); 75 + try Eio.Process.run ~cwd ~stdout:outsink ~stderr:errsink mgr cmd 76 + with exn -> 77 + Eio.traceln "Error: %s" (Buffer.contents errbuf); 78 + Eio.traceln "Output: %s" (Buffer.contents outbuf); 79 + raise exn 89 80 90 81 let file_exists path = 91 82 try 92 83 let@ _ = Eio.Path.with_open_in path in 93 84 true 94 - with 95 - | Eio.Io (Eio.Fs.E (Eio.Fs.Not_found _), _) -> false 85 + with Eio.Io (Eio.Fs.E (Eio.Fs.Not_found _), _) -> false 96 86 97 87 let try_create_dir ~cwd dname = 98 - let (/) = Path.(/) in 88 + let ( / ) = Path.( / ) in 99 89 if Eio.Path.is_directory (cwd / dname) then 100 - Reporter.emit 101 - Initialization_warning 102 - ~extra_remarks: [Asai.Diagnostic.loctextf "`%s` already exists" dname] 90 + Reporter.emit Initialization_warning 91 + ~extra_remarks:[Asai.Diagnostic.loctextf "`%s` already exists" dname] 103 92 else 104 - try 105 - Eio.Path.mkdir ~perm: 0o755 (cwd / dname) 106 - with 107 - | exn -> 108 - Forester_core.Reporter.emit Initialization_warning ~extra_remarks: [Asai.Diagnostic.loctextf "Failed to create directory `%s`: %a" dname Eio.Exn.pp exn] 93 + try Eio.Path.mkdir ~perm:0o755 (cwd / dname) 94 + with exn -> 95 + Forester_core.Reporter.emit Initialization_warning 96 + ~extra_remarks: 97 + [ 98 + Asai.Diagnostic.loctextf "Failed to create directory `%s`: %a" dname 99 + Eio.Exn.pp exn; 100 + ] 109 101 110 102 let try_create_file ~cwd ?(content = "") fname = 111 - let (/) = Path.(/) in 103 + let ( / ) = Path.( / ) in 112 104 if Eio.Path.is_file (cwd / fname) then 113 - Forester_core.Reporter.emit Initialization_warning ~extra_remarks: [Asai.Diagnostic.loctextf "`%s` already exists" fname] 105 + Forester_core.Reporter.emit Initialization_warning 106 + ~extra_remarks:[Asai.Diagnostic.loctextf "`%s` already exists" fname] 114 107 else 115 - try 116 - Eio.Path.save ~create: (`Exclusive 0o644) (cwd / fname) content 117 - with 118 - | exn -> 119 - Forester_core.Reporter.emit Initialization_warning ~extra_remarks: [Asai.Diagnostic.loctextf "Failed to create file `%s`: %a" fname Eio.Exn.pp exn] 108 + try Eio.Path.save ~create:(`Exclusive 0o644) (cwd / fname) content 109 + with exn -> 110 + Forester_core.Reporter.emit Initialization_warning 111 + ~extra_remarks: 112 + [ 113 + Asai.Diagnostic.loctextf "Failed to create file `%s`: %a" fname 114 + Eio.Exn.pp exn; 115 + ] 120 116 121 117 (* TODO: test this! *) 122 118 let copy_to_dir ~env ~cwd ~source ~dest_dir = 123 119 let path = Path.(cwd / dest_dir) in 124 - Path.mkdirs ~exists_ok: true ~perm: 0o755 path; 120 + Path.mkdirs ~exists_ok:true ~perm:0o755 path; 125 121 if Sys.unix then 126 - run_process ~quiet: true ~env ~cwd ["cp"; "-R"; source; dest_dir] 127 - else 128 - run_process ~quiet: true ~env ~cwd ["xcopy"; source; dest_dir ^ "/"] 122 + run_process ~quiet:true ~env ~cwd ["cp"; "-R"; source; dest_dir] 123 + else run_process ~quiet:true ~env ~cwd ["xcopy"; source; dest_dir ^ "/"]
+16 -25
lib/compiler/Eio_util.mli
··· 9 9 (* val ( / ) : ([> Fs.dir_ty ] as 'a) Path.t -> string -> 'a Path.t *) 10 10 11 11 val path_of_dir : 12 - env: < fs: ([> Fs.dir_ty] as 'a) Path.t; .. > -> 13 - string -> 14 - 'a Path.t 12 + env:< fs : ([> Fs.dir_ty] as 'a) Path.t ; .. > -> string -> 'a Path.t 15 13 16 14 val paths_of_dirs : 17 - env: < fs: ([> Fs.dir_ty] as 'a) Path.t; .. > -> 15 + env:< fs : ([> Fs.dir_ty] as 'a) Path.t ; .. > -> 18 16 string list -> 19 17 'a Path.t list 20 18 21 19 val path_of_file : 22 - env: < fs: ([> Fs.dir_ty] as 'a) Path.t; .. > -> 23 - string -> 24 - 'a Path.t 20 + env:< fs : ([> Fs.dir_ty] as 'a) Path.t ; .. > -> string -> 'a Path.t 25 21 26 22 val paths_of_files : 27 - env: < fs: ([> Fs.dir_ty] as 'a) Path.t; .. > -> 23 + env:< fs : ([> Fs.dir_ty] as 'a) Path.t ; .. > -> 28 24 string list -> 29 25 'a Path.t list 30 26 31 27 val null_sink : unit -> Flow.sink_ty Resource.t 32 28 33 29 val ensure_context_of_path : 34 - perm: File.Unix_perm.t -> [> Fs.dir_ty] Path.t -> unit 30 + perm:File.Unix_perm.t -> [> Fs.dir_ty] Path.t -> unit 35 31 36 32 val ensure_remove_file : [> Fs.dir_ty] Path.t -> unit 37 33 38 34 val with_open_tmp_dir : 39 - env: < cwd: [> Fs.dir_ty] Path.t; .. > -> 40 - ([< `Close | `Dir>`Dir] Path.t -> 'a) -> 35 + env:< cwd : [> Fs.dir_ty] Path.t ; .. > -> 36 + ([< `Close | `Dir > `Dir] Path.t -> 'a) -> 41 37 'a 42 38 43 39 val run_process : 44 - ?quiet: bool -> 45 - env: 46 - < process_mgr: [> [> `Generic] Process.mgr_ty] Process.mgr; 47 - .. > -> 48 - cwd: [> Fs.dir_ty] Path.t -> 40 + ?quiet:bool -> 41 + env:< process_mgr : [> [> `Generic] Process.mgr_ty] Process.mgr ; .. > -> 42 + cwd:[> Fs.dir_ty] Path.t -> 49 43 string list -> 50 44 unit 51 45 52 46 val file_exists : [> Fs.dir_ty] Path.t -> bool 53 - 54 - val try_create_dir : cwd: [> Fs.dir_ty] Path.t -> string -> unit 47 + val try_create_dir : cwd:[> Fs.dir_ty] Path.t -> string -> unit 55 48 56 49 val try_create_file : 57 - cwd: [> Fs.dir_ty] Path.t -> ?content: string -> string -> unit 50 + cwd:[> Fs.dir_ty] Path.t -> ?content:string -> string -> unit 58 51 59 52 val copy_to_dir : 60 - env: 61 - < process_mgr: [> [> `Generic] Process.mgr_ty] Process.mgr; 62 - .. > -> 63 - cwd: [> Fs.dir_ty] Path.t -> 64 - source: string -> 65 - dest_dir: string -> 53 + env:< process_mgr : [> [> `Generic] Process.mgr_ty] Process.mgr ; .. > -> 54 + cwd:[> Fs.dir_ty] Path.t -> 55 + source:string -> 56 + dest_dir:string -> 66 57 unit
+351 -276
lib/compiler/Eval.ml
··· 11 11 module T = Types 12 12 module String_map = Value.String_map 13 13 module Symbol_map = Value.Symbol_map 14 + 14 15 type located = Value.t Range.located 15 16 end 16 17 17 18 let extract_content (node : located) = 18 19 match node.value with 19 20 | Value.Content content -> content 20 - | v -> Reporter.fatal ?loc: node.loc (Type_error {expected = [Content]; got = Some v}) 21 + | v -> 22 + Reporter.fatal ?loc:node.loc 23 + (Type_error {expected = [Content]; got = Some v}) 21 24 22 25 let extract_text_loc (node : located) : string Range.located = 23 26 let content = extract_content node in ··· 29 32 in 30 33 match loop Emp (T.extract_content content) with 31 34 | Some txt -> {value = String.trim txt; loc = node.loc} 32 - | None -> Reporter.fatal ?loc: node.loc (Type_error {expected = [Text]; got = None}) 35 + | None -> 36 + Reporter.fatal ?loc:node.loc (Type_error {expected = [Text]; got = None}) 33 37 34 38 let extract_text (node : located) : string = (extract_text_loc node).value 35 39 36 40 let extract_obj_ptr (x : located) = 37 41 match x.value with 38 42 | Obj sym -> sym 39 - (* TODO: Rephrase, should be something like "this is a thing of type foo, cannot access method bar"*) 40 - | other -> Reporter.fatal ?loc: x.loc (Type_error {expected = [Obj]; got = Some other}) 43 + (* TODO: Rephrase, should be something like "this is a thing of type foo, 44 + cannot access method bar"*) 45 + | other -> 46 + Reporter.fatal ?loc:x.loc (Type_error {expected = [Obj]; got = Some other}) 41 47 42 48 let extract_sym (x : located) = 43 49 match x.value with 44 50 | Sym sym -> sym 45 - | other -> Reporter.fatal ?loc: x.loc (Type_error {expected = [Sym]; got = Some other}) 51 + | other -> 52 + Reporter.fatal ?loc:x.loc (Type_error {expected = [Sym]; got = Some other}) 46 53 47 54 let extract_bool (x : located) = 48 55 match x.value with 49 56 | Content (T.Content [Text "true"]) -> true 50 57 | Content (T.Content [Text "false"]) -> false 51 - | other -> Reporter.fatal ?loc: x.loc (Type_error {expected = [Bool]; got = Some other}) 58 + | other -> 59 + Reporter.fatal ?loc:x.loc (Type_error {expected = [Bool]; got = Some other}) 52 60 53 61 let default_backmatter ~(uri : URI.t) : T.content = 54 62 let vtx = T.Uri_vertex uri in 55 63 let make_section title query = 56 64 let section = 57 - let frontmatter = T.default_frontmatter ~title: (T.Content [T.Text title]) () in 65 + let frontmatter = 66 + T.default_frontmatter ~title:(T.Content [T.Text title]) () 67 + in 58 68 let mainmatter = T.Content [T.Results_of_datalog_query query] in 59 - let flags = {T.default_section_flags with hidden_when_empty = Some true} in 69 + let flags = 70 + {T.default_section_flags with hidden_when_empty = Some true} 71 + in 60 72 T.{frontmatter; mainmatter; flags} 61 73 in 62 74 T.Section section ··· 67 79 make_section "Context" @@ Builtin_queries.context_datalog vtx; 68 80 make_section "Backlinks" @@ Builtin_queries.backlinks_datalog vtx; 69 81 make_section "Related" @@ Builtin_queries.related_datalog vtx; 70 - make_section "Contributions" @@ Builtin_queries.contributions_datalog vtx 82 + make_section "Contributions" @@ Builtin_queries.contributions_datalog vtx; 71 83 ] 72 84 73 - type result = {articles: T.content T.article list; jobs: Job.job Range.located list} [@@deriving show] 85 + type result = { 86 + articles: T.content T.article list; 87 + jobs: Job.job Range.located list; 88 + } 89 + [@@deriving show] 74 90 75 91 module Tape = Tape_effect.Make () 76 - module Lex_env = Algaeff.Reader.Make(struct type t = Value.t String_map.t end) 77 - module Dyn_env = Algaeff.Reader.Make(struct type t = Value.t Symbol_map.t end) 78 - module Config_env = Algaeff.Reader.Make(struct type t = Config.t end) 79 - module Heap = Algaeff.State.Make(struct type t = Value.obj Symbol_map.t end) 80 - module Emitted_trees = Algaeff.State.Make(struct type t = T.content T.article list end) 81 - module Jobs = Algaeff.State.Make(struct type t = Job.job Range.located list end) 82 - module Frontmatter = Algaeff.State.Make(struct type t = T.content T.frontmatter end) 83 - module Mode_env = Algaeff.Reader.Make(struct type t = eval_mode end) 92 + 93 + module Lex_env = Algaeff.Reader.Make (struct 94 + type t = Value.t String_map.t 95 + end) 96 + 97 + module Dyn_env = Algaeff.Reader.Make (struct 98 + type t = Value.t Symbol_map.t 99 + end) 100 + 101 + module Config_env = Algaeff.Reader.Make (struct 102 + type t = Config.t 103 + end) 104 + 105 + module Heap = Algaeff.State.Make (struct 106 + type t = Value.obj Symbol_map.t 107 + end) 108 + 109 + module Emitted_trees = Algaeff.State.Make (struct 110 + type t = T.content T.article list 111 + end) 112 + 113 + module Jobs = Algaeff.State.Make (struct 114 + type t = Job.job Range.located list 115 + end) 116 + 117 + module Frontmatter = Algaeff.State.Make (struct 118 + type t = T.content T.frontmatter 119 + end) 120 + 121 + module Mode_env = Algaeff.Reader.Make (struct 122 + type t = eval_mode 123 + end) 84 124 85 125 let get_current_uri ~loc = 86 126 match (Frontmatter.get ()).uri with 87 127 | Some uri -> uri 88 - | None -> Reporter.fatal ?loc Internal_error ~extra_remarks: [Asai.Diagnostic.loctext "No uri for tree"] 128 + | None -> 129 + Reporter.fatal ?loc Internal_error 130 + ~extra_remarks:[Asai.Diagnostic.loctext "No uri for tree"] 89 131 90 132 let get_transclusion_flags ~loc = 91 133 let dynenv = Dyn_env.read () in ··· 96 138 let module S = Expand.Builtins.Transclude in 97 139 let open Option_util in 98 140 let flags = T.default_section_flags in 99 - {flags with 141 + { 142 + flags with 100 143 expanded = override (get_bool S.expanded_sym) flags.expanded; 101 144 header_shown = override (get_bool S.show_heading_sym) flags.header_shown; 102 145 included_in_toc = override (get_bool S.toc_sym) flags.included_in_toc; 103 146 numbered = override (get_bool S.numbered_sym) flags.numbered; 104 - metadata_shown = override (get_bool S.show_metadata_sym) flags.metadata_shown; 147 + metadata_shown = 148 + override (get_bool S.show_metadata_sym) flags.metadata_shown; 105 149 } 106 150 107 - let resolve_uri ~loc: _ str = 151 + let resolve_uri ~loc:_ str = 108 152 match URI.of_string_exn str with 109 - | uri -> 110 - (* If the URI is just a single component without anything else, we should treat it as a link to a local tree. *) 111 - match URI.scheme uri, URI.host uri, URI.path_components uri with 153 + | uri -> ( 154 + (* If the URI is just a single component without anything else, we should 155 + treat it as a link to a local tree. *) 156 + match (URI.scheme uri, URI.host uri, URI.path_components uri) with 112 157 | None, None, ([] | [_]) -> 113 158 let config = Config_env.read () in 114 - let uri = URI_scheme.named_uri ~base: config.url str in 159 + let uri = URI_scheme.named_uri ~base:config.url str in 115 160 Result.ok uri 116 161 | _ -> Ok uri 117 - | exception _ -> Error "Invalid URI" 162 + | exception _ -> Error "Invalid URI") 118 163 119 164 let extract_uri (node : located) = 120 165 let text = extract_text node in 121 - resolve_uri ~loc: node.loc text 166 + resolve_uri ~loc:node.loc text 122 167 123 168 let extract_dx_term (node : located) = 124 169 match node.value with 125 170 | Dx_var name -> Datalog_expr.Var name 126 171 | Dx_const vtx -> Datalog_expr.Const vtx 127 172 (* | other -> Reporter.fatalf Type_error "Expected datalog term" *) 128 - | other -> Reporter.fatal ?loc: node.loc (Type_error {expected = [Datalog_term]; got = Some other}) 173 + | other -> 174 + Reporter.fatal ?loc:node.loc 175 + (Type_error {expected = [Datalog_term]; got = Some other}) 129 176 130 177 let extract_dx_prop (node : located) = 131 178 match node.value with 132 179 | Dx_prop prop -> prop 133 180 (* | _ -> Reporter.fatalf Type_error "Expected datalog proposition" *) 134 - | other -> Reporter.fatal ?loc: node.loc (Type_error {expected = [Dx_prop]; got = Some other}) 181 + | other -> 182 + Reporter.fatal ?loc:node.loc 183 + (Type_error {expected = [Dx_prop]; got = Some other}) 135 184 136 185 let extract_dx_sequent (node : located) = 137 186 match node.value with 138 187 | Dx_sequent sequent -> sequent 139 - | other -> Reporter.fatal ?loc: node.loc (Type_error {expected = [Dx_sequent]; got = Some other}) 188 + | other -> 189 + Reporter.fatal ?loc:node.loc 190 + (Type_error {expected = [Dx_sequent]; got = Some other}) 140 191 141 192 let extract_vertex ~type_ (node : located) = 142 193 match type_ with 143 - | `Content -> 144 - Ok (T.Content_vertex (extract_content node)) 194 + | `Content -> Ok (T.Content_vertex (extract_content node)) 145 195 | `Uri -> 146 196 let@ uri = Result.map @~ extract_uri node in 147 197 T.Uri_vertex uri ··· 155 205 | None -> Value.Content (T.Content []) 156 206 | Some node -> eval_node node 157 207 158 - and eval_tape tape = 159 - Tape.run ~tape process_tape 160 - 161 - and eval_pop_arg ~loc = 162 - Tape.pop_arg ~loc 163 - |> Range.map eval_tape 164 - 165 - and pop_content_arg ~loc = 166 - eval_pop_arg ~loc 167 - |> extract_content 168 - 169 - and pop_text_arg ~loc = 170 - eval_pop_arg ~loc 171 - |> extract_text 172 - 173 - and pop_text_arg_loc ~loc = 174 - eval_pop_arg ~loc 175 - |> extract_text_loc 208 + and eval_tape tape = Tape.run ~tape process_tape 209 + and eval_pop_arg ~loc = Tape.pop_arg ~loc |> Range.map eval_tape 210 + and pop_content_arg ~loc = eval_pop_arg ~loc |> extract_content 211 + and pop_text_arg ~loc = eval_pop_arg ~loc |> extract_text 212 + and pop_text_arg_loc ~loc = eval_pop_arg ~loc |> extract_text_loc 176 213 177 214 and eval_node node : Value.t = 178 215 let loc = node.loc in 179 216 match node.value with 180 - | Var x -> 181 - eval_var ~loc x 182 - | Text str -> 183 - emit_content_node ~loc @@ T.Text str 217 + | Var x -> eval_var ~loc x 218 + | Text str -> emit_content_node ~loc @@ T.Text str 184 219 | Prim p -> 185 - let content = pop_content_arg ~loc |> T.extract_content |> T.trim_whitespace in 220 + let content = 221 + pop_content_arg ~loc |> T.extract_content |> T.trim_whitespace 222 + in 186 223 emit_content_node ~loc @@ T.prim p @@ T.Content content 187 224 | Fun (xs, body) -> 188 225 let env = Lex_env.read () in 189 - focus_clo ?loc env (List.map (fun (info, x) -> info, Some x) xs) body 190 - | Ref -> 191 - begin 192 - match eval_pop_arg ~loc |> extract_uri with 193 - | Ok href -> 194 - let content = 195 - T.Content 196 - [ 197 - T.Transclude {href; target = T.Taxon}; 198 - T.Text " "; 199 - T.Contextual_number href 200 - ] 201 - in 202 - emit_content_node ~loc @@ Link {href; content} 203 - | Error _ -> 204 - Reporter.fatal 205 - ?loc 206 - (Type_error {got = None; expected = [URI]}) 207 - ~extra_remarks: [Asai.Diagnostic.loctextf "Expected valid URI in ref"] 208 - end 226 + focus_clo ?loc env (List.map (fun (info, x) -> (info, Some x)) xs) body 227 + | Ref -> begin 228 + match eval_pop_arg ~loc |> extract_uri with 229 + | Ok href -> 230 + let content = 231 + T.Content 232 + [ 233 + T.Transclude {href; target = T.Taxon}; 234 + T.Text " "; 235 + T.Contextual_number href; 236 + ] 237 + in 238 + emit_content_node ~loc @@ Link {href; content} 239 + | Error _ -> 240 + Reporter.fatal ?loc 241 + (Type_error {got = None; expected = [URI]}) 242 + ~extra_remarks:[Asai.Diagnostic.loctextf "Expected valid URI in ref"] 243 + end 209 244 | Link {title; dest} -> 210 245 let dest = {node with value = dest} |> Range.map eval_tape in 211 246 let href = 212 247 match extract_uri dest with 213 248 | Ok uri -> uri 214 249 | Error error -> 215 - Reporter.fatal 216 - ?loc 250 + Reporter.fatal ?loc 217 251 (Type_error {expected = [URI]; got = None}) 218 - ~extra_remarks: [Asai.Diagnostic.loctext error] 219 - (* "Expected valid URI in link") *) 252 + ~extra_remarks:[Asai.Diagnostic.loctext error] 253 + (* "Expected valid URI in link") *) 220 254 in 221 255 let content = 222 256 match title with 223 - | None -> T.Content [T.Transclude {href; target = T.Title {empty_when_untitled = false}}] 257 + | None -> 258 + T.Content 259 + [T.Transclude {href; target = T.Title {empty_when_untitled = false}}] 224 260 | Some title -> {node with value = eval_tape title} |> extract_content 225 261 in 226 262 emit_content_node ~loc @@ Link {href; content} 227 263 | Math (mode, body) -> 228 264 let content = 229 - let@ () = Mode_env.run ~env: TeX_mode in 265 + let@ () = Mode_env.run ~env:TeX_mode in 230 266 {node with value = eval_tape body} |> extract_content 231 267 in 232 268 emit_content_node ~loc @@ KaTeX (mode, content) ··· 234 270 let rec process : _ list -> _ T.xml_attr list = function 235 271 | [] -> [] 236 272 | (key, v) :: attrs -> 237 - {T.key; value = extract_content {node with value = eval_tape v}} :: process attrs 273 + {T.key; value = extract_content {node with value = eval_tape v}} 274 + :: process attrs 238 275 in 239 - let name = T.{prefix = name.prefix; uname = name.uname; xmlns = name.xmlns} in 276 + let name = 277 + T.{prefix = name.prefix; uname = name.uname; xmlns = name.xmlns} 278 + in 240 279 let content = {node with value = eval_tape body} |> extract_content in 241 280 emit_content_node ~loc @@ T.Xml_elt {name; attrs = process attrs; content} 242 281 | TeX_cs cs -> 243 282 emit_content_node ~loc @@ T.Text (Format.asprintf "%a" pp_tex_cs cs) 244 283 | Unresolved_ident (visible, path) -> 245 284 let tex_cs_opt = 246 - match path with 247 - | [name] -> TeX_cs.parse name 248 - | _ -> None 285 + match path with [name] -> TeX_cs.parse name | _ -> None 249 286 in 250 - begin 251 - match Mode_env.read (), tex_cs_opt with 252 - | TeX_mode, Some (cs, rest) -> 253 - emit_content_node ~loc @@ T.Text (Format.asprintf "%a%s" pp_tex_cs cs rest) 254 - | _, _ -> 255 - let extra_remarks = Suggestions.create_suggestions ~visible path in 256 - Reporter.emit ?loc ~extra_remarks (Unresolved_identifier (visible, path)); 257 - emit_content_node ~loc @@ T.Text (Format.asprintf "\\%a" Resolver.Scope.pp_path path) 287 + begin match (Mode_env.read (), tex_cs_opt) with 288 + | TeX_mode, Some (cs, rest) -> 289 + emit_content_node ~loc 290 + @@ T.Text (Format.asprintf "%a%s" pp_tex_cs cs rest) 291 + | _, _ -> 292 + let extra_remarks = Suggestions.create_suggestions ~visible path in 293 + Reporter.emit ?loc ~extra_remarks (Unresolved_identifier (visible, path)); 294 + emit_content_node ~loc 295 + @@ T.Text (Format.asprintf "\\%a" Resolver.Scope.pp_path path) 258 296 end 259 297 | Transclude -> 260 298 let flags = get_transclusion_flags ~loc in ··· 263 301 match extract_uri href_arg with 264 302 | Ok uri -> uri 265 303 | Error _ -> 266 - Reporter.fatal ?loc (Type_error {got = None; expected = [URI]}) ~extra_remarks: [Asai.Diagnostic.loctext "Expected valid URI in transclusion"] 304 + Reporter.fatal ?loc 305 + (Type_error {got = None; expected = [URI]}) 306 + ~extra_remarks: 307 + [Asai.Diagnostic.loctext "Expected valid URI in transclusion"] 267 308 in 268 309 emit_content_node ~loc @@ T.Transclude {href; target = Full flags} 269 310 | Subtree (addr_opt, nodes) -> ··· 271 312 let config = Config_env.read () in 272 313 let uri = 273 314 match addr_opt with 274 - | Some addr -> Some (URI_scheme.named_uri ~base: config.url addr) 315 + | Some addr -> Some (URI_scheme.named_uri ~base:config.url addr) 275 316 | None -> None 276 317 in 277 318 let subtree = eval_tree_inner ?uri nodes in 278 319 let frontmatter = Frontmatter.get () in 279 - let subtree = {subtree with frontmatter = {subtree.frontmatter with uri; designated_parent = frontmatter.uri}} in 280 - begin 281 - match uri with 282 - | Some uri -> 283 - Emitted_trees.modify @@ List.cons subtree; 284 - let transclusion = T.{href = uri; target = Full flags} in 285 - emit_content_node ~loc @@ Transclude transclusion 286 - | None -> 287 - emit_content_node ~loc @@ T.Section (T.article_to_section ~flags subtree) 320 + let subtree = 321 + { 322 + subtree with 323 + frontmatter = 324 + {subtree.frontmatter with uri; designated_parent = frontmatter.uri}; 325 + } 326 + in 327 + begin match uri with 328 + | Some uri -> 329 + Emitted_trees.modify @@ List.cons subtree; 330 + let transclusion = T.{href = uri; target = Full flags} in 331 + emit_content_node ~loc @@ Transclude transclusion 332 + | None -> 333 + emit_content_node ~loc @@ T.Section (T.article_to_section ~flags subtree) 288 334 end 289 335 | Results_of_query -> 290 336 let arg = eval_pop_arg ~loc in 291 - begin 292 - match arg.value with 293 - | Value.Dx_query query -> 294 - emit_content_node ~loc @@ Results_of_datalog_query query 295 - | other -> Reporter.fatal ?loc: arg.loc (Type_error {expected = [Dx_query]; got = Some other}) 337 + begin match arg.value with 338 + | Value.Dx_query query -> 339 + emit_content_node ~loc @@ Results_of_datalog_query query 340 + | other -> 341 + Reporter.fatal ?loc:arg.loc 342 + (Type_error {expected = [Dx_query]; got = Some other}) 296 343 end 297 344 | Syndicate_query_as_json_blob -> 298 345 let name = pop_text_arg ~loc in 299 346 let config = Config_env.read () in 300 - let blob_uri = URI_scheme.named_uri ~base: config.url @@ name ^ ".json" in 347 + let blob_uri = URI_scheme.named_uri ~base:config.url @@ name ^ ".json" in 301 348 let query_arg = eval_pop_arg ~loc in 302 - begin 303 - match query_arg.value with 304 - | Dx_query query -> 305 - let job = Job.Syndicate (Json_blob {blob_uri; query}) in 306 - Jobs.modify @@ List.cons @@ Range.locate_opt loc job; 307 - process_tape () 308 - | other -> Reporter.fatal ?loc: query_arg.loc (Type_error {expected = [Dx_query]; got = Some other}) 349 + begin match query_arg.value with 350 + | Dx_query query -> 351 + let job = Job.Syndicate (Json_blob {blob_uri; query}) in 352 + Jobs.modify @@ List.cons @@ Range.locate_opt loc job; 353 + process_tape () 354 + | other -> 355 + Reporter.fatal ?loc:query_arg.loc 356 + (Type_error {expected = [Dx_query]; got = Some other}) 309 357 end 310 358 | Syndicate_current_tree_as_atom_feed -> 311 - let source_uri = get_current_uri ~loc: node.loc in 359 + let source_uri = get_current_uri ~loc:node.loc in 312 360 let feed_uri = 313 - let components = URI.append_path_component (URI.path_components source_uri) "atom.xml" in 361 + let components = 362 + URI.append_path_component (URI.path_components source_uri) "atom.xml" 363 + in 314 364 URI.with_path_components components source_uri 315 365 in 316 366 let job = Job.Syndicate (Atom_feed {source_uri; feed_uri}) in ··· 319 369 | Embed_tex -> 320 370 let config = Config_env.read () in 321 371 let preamble, body = 322 - let@ () = Mode_env.run ~env: TeX_mode in 372 + let@ () = Mode_env.run ~env:TeX_mode in 323 373 let preamble = pop_content_arg ~loc |> TeX_like.string_of_content in 324 374 let body = pop_content_arg ~loc |> TeX_like.string_of_content in 325 - preamble, body 375 + (preamble, body) 326 376 in 327 377 let source = LaTeX_template.to_string ~preamble ~body in 328 378 let hash = Digest.to_hex @@ Digest.string source in 329 379 let job = Job.{hash; source} in 330 - let uri = Job.uri_for_latex_to_svg_job ~base: config.url job in 380 + let uri = Job.uri_for_latex_to_svg_job ~base:config.url job in 331 381 let content = 332 382 T.Content 333 383 [ 334 384 T.Xml_elt 335 385 { 336 386 content = T.Content []; 337 - name = {uname = "img"; prefix = "html"; xmlns = Some "http://www.w3.org/1999/xhtml"}; 338 - attrs = [ 387 + name = 339 388 { 340 - key = {uname = "src"; prefix = ""; xmlns = None}; 341 - value = T.Content [T.Route_of_uri uri] 342 - } 343 - ] 344 - } 389 + uname = "img"; 390 + prefix = "html"; 391 + xmlns = Some "http://www.w3.org/1999/xhtml"; 392 + }; 393 + attrs = 394 + [ 395 + { 396 + key = {uname = "src"; prefix = ""; xmlns = None}; 397 + value = T.Content [T.Route_of_uri uri]; 398 + }; 399 + ]; 400 + }; 345 401 ] 346 402 in 347 - let sources = [ 348 - T.{type_ = "latex"; part = "preamble"; source = preamble}; 349 - T.{type_ = "latex"; part = "body"; source = body} 350 - ] 403 + let sources = 404 + [ 405 + T.{type_ = "latex"; part = "preamble"; source = preamble}; 406 + T.{type_ = "latex"; part = "body"; source = body}; 407 + ] 351 408 in 352 409 let artefact = T.{hash; content; sources} in 353 410 Jobs.modify (List.cons (Range.locate_opt loc (Job.LaTeX_to_svg job))); 354 411 emit_content_node ~loc @@ T.Artefact artefact 355 412 | Route_asset -> 356 413 let Range.{value = source_path; loc = path_loc} = pop_text_arg_loc ~loc in 357 - let uri = Asset_router.uri_of_asset ?loc: path_loc ~source_path () in 414 + let uri = Asset_router.uri_of_asset ?loc:path_loc ~source_path () in 358 415 emit_content_nodes ~loc @@ [T.Route_of_uri uri] 359 416 | Object {self; methods} -> 360 417 let table = ··· 366 423 in 367 424 let sym = Symbol.named ["obj"] in 368 425 Heap.modify @@ Symbol_map.add sym Value.{prototype = None; methods = table}; 369 - focus ?loc: node.loc @@ Value.Obj sym 426 + focus ?loc:node.loc @@ Value.Obj sym 370 427 | Patch {obj; self; super; methods} -> 371 - let obj_ptr = {node with value = obj} |> Range.map eval_tape |> extract_obj_ptr in 428 + let obj_ptr = 429 + {node with value = obj} |> Range.map eval_tape |> extract_obj_ptr 430 + in 372 431 let table = 373 432 let env = Lex_env.read () in 374 433 let add (name, body) = 375 - Value.Method_table.add 376 - name 377 - Value.{body; self; super; env} 434 + Value.Method_table.add name Value.{body; self; super; env} 378 435 in 379 436 List.fold_right add methods Value.Method_table.empty 380 437 in 381 438 let sym = Symbol.named ["obj"] in 382 - Heap.modify @@ Symbol_map.add sym Value.{prototype = Some obj_ptr; methods = table}; 383 - focus ?loc: node.loc @@ Value.Obj sym 439 + Heap.modify 440 + @@ Symbol_map.add sym Value.{prototype = Some obj_ptr; methods = table}; 441 + focus ?loc:node.loc @@ Value.Obj sym 384 442 | Group (d, body) -> 385 443 let l, r = delim_to_strings d in 386 444 let content = 387 445 let body = extract_content {node with value = eval_tape body} in 388 - T.Content (T.Text l :: T.extract_content body @ [T.Text r]) 446 + T.Content ((T.Text l :: T.extract_content body) @ [T.Text r]) 389 447 in 390 - focus ?loc: node.loc @@ Value.Content (T.compress_content content) 448 + focus ?loc:node.loc @@ Value.Content (T.compress_content content) 391 449 | Call (obj, method_name) -> 392 - let sym = {node with value = obj} |> Range.map eval_tape |> extract_obj_ptr in 450 + let sym = 451 + {node with value = obj} |> Range.map eval_tape |> extract_obj_ptr 452 + in 393 453 let rec call_method (obj : Value.obj) = 394 454 let proto_val = obj.prototype |> Option.map @@ fun ptr -> Value.Obj ptr in 395 455 match Value.Method_table.find_opt method_name obj.methods with ··· 402 462 in 403 463 match proto_val with 404 464 | None -> env 405 - | Some proto_val -> 465 + | Some proto_val -> ( 406 466 match mthd.super with 407 467 | None -> env 408 - | Some super -> String_map.add super proto_val env 468 + | Some super -> String_map.add super proto_val env) 409 469 in 410 470 let@ () = Lex_env.run ~env in 411 471 eval_tape mthd.body 412 - | None -> 472 + | None -> ( 413 473 match obj.prototype with 414 - | Some proto -> 415 - call_method @@ Symbol_map.find proto @@ Heap.get () 474 + | Some proto -> call_method @@ Symbol_map.find proto @@ Heap.get () 416 475 | None -> 417 - Reporter.fatal 418 - ?loc: node.loc 419 - (Unbound_method (method_name, obj)) 476 + Reporter.fatal ?loc:node.loc (Unbound_method (method_name, obj))) 420 477 in 421 478 let result = call_method @@ Symbol_map.find sym @@ Heap.get () in 422 - focus ?loc: node.loc result 479 + focus ?loc:node.loc result 423 480 | Put (k, v, body) -> 424 481 let k = {node with value = k} |> Range.map eval_tape |> extract_sym in 425 482 let body = 426 483 let@ () = Dyn_env.scope (Symbol_map.add k (eval_tape v)) in 427 484 eval_tape body 428 485 in 429 - focus ?loc: node.loc body 486 + focus ?loc:node.loc body 430 487 | Default (k, v, body) -> 431 488 let k = {node with value = k} |> Range.map eval_tape |> extract_sym in 432 489 let body = 433 - let upd flenv = if Symbol_map.mem k flenv then flenv else Symbol_map.add k (eval_tape v) flenv in 490 + let upd flenv = 491 + if Symbol_map.mem k flenv then flenv 492 + else Symbol_map.add k (eval_tape v) flenv 493 + in 434 494 let@ () = Dyn_env.scope upd in 435 495 eval_tape body 436 496 in 437 - focus ?loc: node.loc body 497 + focus ?loc:node.loc body 438 498 | Get k -> 439 499 let k = {node with value = k} |> Range.map eval_tape |> extract_sym in 440 500 let env = Dyn_env.read () in 441 - begin 442 - match Symbol_map.find_opt k env with 443 - | None -> 444 - Reporter.fatal 445 - ?loc: node.loc 446 - (Unbound_fluid_symbol k) 447 - | Some v -> focus ?loc: node.loc v 501 + begin match Symbol_map.find_opt k env with 502 + | None -> Reporter.fatal ?loc:node.loc (Unbound_fluid_symbol k) 503 + | Some v -> focus ?loc:node.loc v 448 504 end 449 - | Verbatim str -> 450 - emit_content_node ~loc @@ CDATA str 505 + | Verbatim str -> emit_content_node ~loc @@ CDATA str 451 506 | Title -> 452 507 let title = pop_content_arg ~loc in 453 508 Frontmatter.modify (fun fm -> {fm with title = Some title}); ··· 457 512 let parent = 458 513 match extract_uri parent_arg with 459 514 | Ok uri -> uri 460 - | Error _ -> Reporter.fatal ?loc Invalid_URI ~extra_remarks: [Asai.Diagnostic.loctext "Expected valid URI in parent declaration"] 515 + | Error _ -> 516 + Reporter.fatal ?loc Invalid_URI 517 + ~extra_remarks: 518 + [Asai.Diagnostic.loctext "Expected valid URI in parent declaration"] 461 519 in 462 520 Frontmatter.modify (fun fm -> {fm with designated_parent = Some parent}); 463 521 process_tape () 464 522 | Meta -> 465 523 let k = pop_text_arg ~loc in 466 524 let v = pop_content_arg ~loc in 467 - Frontmatter.modify (fun fm -> {fm with metas = fm.metas @ [k, v]}); 525 + Frontmatter.modify (fun fm -> {fm with metas = fm.metas @ [(k, v)]}); 468 526 process_tape () 469 527 | Attribution (role, type_) -> 470 528 let arg = eval_pop_arg ~loc in ··· 477 535 | Author -> "\\author/literal" 478 536 | Contributor -> "\\contributor/literal" 479 537 in 480 - Reporter.emit 481 - ?loc 482 - Type_warning 483 - ~extra_remarks: [Asai.Diagnostic.loctextf "Expected valid URI in attribution. Use `%s` instead if you intend an unlinked attribution." corrected_attribution_code]; 538 + Reporter.emit ?loc Type_warning 539 + ~extra_remarks: 540 + [ 541 + Asai.Diagnostic.loctextf 542 + "Expected valid URI in attribution. Use `%s` instead if you \ 543 + intend an unlinked attribution." 544 + corrected_attribution_code; 545 + ]; 484 546 T.Content_vertex (extract_content arg) 485 547 in 486 548 let attribution = T.{role; vertex} in 487 - Frontmatter.modify (fun fm -> {fm with attributions = fm.attributions @ [attribution]}); 549 + Frontmatter.modify (fun fm -> 550 + {fm with attributions = fm.attributions @ [attribution]}); 488 551 process_tape () 489 552 | Tag type_ -> 490 553 let arg = eval_pop_arg ~loc in ··· 493 556 | Ok vtx -> vtx 494 557 | Error _ -> 495 558 let corrected = "\\tag/content" in 496 - Reporter.emit ?loc Type_warning ~extra_remarks: [Asai.Diagnostic.loctextf "Expected valid URI in tag. Use `%s` instead if you intend an unlinked attribution." corrected]; 559 + Reporter.emit ?loc Type_warning 560 + ~extra_remarks: 561 + [ 562 + Asai.Diagnostic.loctextf 563 + "Expected valid URI in tag. Use `%s` instead if you intend an \ 564 + unlinked attribution." 565 + corrected; 566 + ]; 497 567 T.Content_vertex (extract_content arg) 498 568 in 499 569 Frontmatter.modify (fun fm -> {fm with tags = fm.tags @ [vertex]}); 500 570 process_tape () 501 571 | Date -> 502 572 let date_str = pop_text_arg ~loc in 503 - begin 504 - match Human_datetime.parse_string date_str with 505 - | None -> 506 - Reporter.fatal ?loc: node.loc Parse_error ~extra_remarks: [Asai.Diagnostic.loctextf "Invalid date string `%s`" date_str] 507 - | Some date -> 508 - Frontmatter.modify (fun fm -> {fm with dates = fm.dates @ [date]}); 509 - process_tape () 573 + begin match Human_datetime.parse_string date_str with 574 + | None -> 575 + Reporter.fatal ?loc:node.loc Parse_error 576 + ~extra_remarks: 577 + [Asai.Diagnostic.loctextf "Invalid date string `%s`" date_str] 578 + | Some date -> 579 + Frontmatter.modify (fun fm -> {fm with dates = fm.dates @ [date]}); 580 + process_tape () 510 581 end 511 582 | Number -> 512 583 let num = pop_text_arg ~loc in ··· 516 587 let taxon = Some (pop_content_arg ~loc) in 517 588 Frontmatter.modify (fun fm -> {fm with taxon}); 518 589 process_tape () 519 - | Sym sym -> 520 - focus ?loc: node.loc @@ Value.Sym sym 590 + | Sym sym -> focus ?loc:node.loc @@ Value.Sym sym 521 591 | Dx_prop (rel, args) -> 522 592 let rel = {node with value = eval_tape rel} |> extract_text in 523 593 let args = 524 594 let@ arg = List.map @~ args in 525 595 {node with value = eval_tape arg} |> extract_dx_term 526 596 in 527 - focus ?loc: node.loc @@ Dx_prop {rel; args} 597 + focus ?loc:node.loc @@ Dx_prop {rel; args} 528 598 | Dx_sequent (conclusion, premises) -> 529 - let conclusion = {node with value = eval_tape conclusion} |> extract_dx_prop in 599 + let conclusion = 600 + {node with value = eval_tape conclusion} |> extract_dx_prop 601 + in 530 602 let premises = 531 603 let@ premise = List.map @~ premises in 532 604 {node with value = eval_tape premise} |> extract_dx_prop 533 605 in 534 - focus ?loc: node.loc @@ Dx_sequent {conclusion; premises} 606 + focus ?loc:node.loc @@ Dx_sequent {conclusion; premises} 535 607 | Dx_query (var, positives, negatives) -> 536 608 let positives = 537 609 let@ premise = List.map @~ positives in ··· 541 613 let@ premise = List.map @~ negatives in 542 614 {node with value = eval_tape premise} |> extract_dx_prop 543 615 in 544 - focus ?loc: node.loc @@ Dx_query {var; positives; negatives} 545 - | Dx_var name -> 546 - focus ?loc: node.loc @@ Dx_var name 616 + focus ?loc:node.loc @@ Dx_query {var; positives; negatives} 617 + | Dx_var name -> focus ?loc:node.loc @@ Dx_var name 547 618 | Dx_const (type_, arg) -> 548 619 let arg = {node with value = eval_tape arg} in 549 620 let const = 550 621 match type_ with 551 622 | `Content -> T.Content_vertex (extract_content arg) 552 - | `Uri -> 553 - begin 554 - match extract_uri arg with 555 - | Ok uri -> T.Uri_vertex uri 556 - | Error _ -> 557 - Reporter.fatal ?loc: node.loc Invalid_URI ~extra_remarks: [Asai.Diagnostic.loctext "Expected valid URI in datalog constant expression."] 558 - end 623 + | `Uri -> begin 624 + match extract_uri arg with 625 + | Ok uri -> T.Uri_vertex uri 626 + | Error _ -> 627 + Reporter.fatal ?loc:node.loc Invalid_URI 628 + ~extra_remarks: 629 + [ 630 + Asai.Diagnostic.loctext 631 + "Expected valid URI in datalog constant expression."; 632 + ] 633 + end 559 634 in 560 - focus ?loc: node.loc @@ Dx_const const 635 + focus ?loc:node.loc @@ Dx_const const 561 636 | Dx_execute -> 562 - let script = eval_pop_arg ~loc: node.loc |> extract_dx_sequent in 563 - emit_content_node ~loc: node.loc @@ T.Datalog_script [script] 637 + let script = eval_pop_arg ~loc:node.loc |> extract_dx_sequent in 638 + emit_content_node ~loc:node.loc @@ T.Datalog_script [script] 564 639 | Current_tree -> 565 - emit_content_node ~loc: node.loc @@ T.Uri (get_current_uri ~loc: node.loc) 640 + emit_content_node ~loc:node.loc @@ T.Uri (get_current_uri ~loc:node.loc) 566 641 567 642 and eval_var ~loc (x : string) = 568 643 let env = Lex_env.read () in 569 644 match String_map.find_opt x env with 570 645 | Some v -> focus ?loc v 571 - | None -> 572 - Reporter.fatal 573 - ?loc 574 - (Unbound_variable x) 646 + | None -> Reporter.fatal ?loc (Unbound_variable x) 575 647 576 648 and focus ?loc = function 577 - | Clo (rho, xs, body) -> 578 - focus_clo ?loc rho xs body 579 - | Content content -> 580 - begin 581 - match process_tape () with 582 - | Content content' -> Value.Content (T.concat_compressed_content content content') 583 - | value -> value 584 - end 585 - | Sym _ | Obj _ | Dx_prop _ | Dx_sequent _ | Dx_query _ | Dx_var _ | Dx_const _ as v -> 586 - begin 587 - match process_tape () with 588 - | Content content when T.strip_whitespace content = T.Content [] -> v 589 - | v' -> 590 - Reporter.fatal 591 - ?loc 592 - (Type_error {expected = []; got = None}) 593 - ~extra_remarks: [Asai.Diagnostic.loctextf "Expected solitary node but got %a / %a" Value.pp v Value.pp v'] 594 - end 649 + | Clo (rho, xs, body) -> focus_clo ?loc rho xs body 650 + | Content content -> begin 651 + match process_tape () with 652 + | Content content' -> 653 + Value.Content (T.concat_compressed_content content content') 654 + | value -> value 655 + end 656 + | ( Sym _ | Obj _ | Dx_prop _ | Dx_sequent _ | Dx_query _ | Dx_var _ 657 + | Dx_const _ ) as v -> begin 658 + match process_tape () with 659 + | Content content when T.strip_whitespace content = T.Content [] -> v 660 + | v' -> 661 + Reporter.fatal ?loc 662 + (Type_error {expected = []; got = None}) 663 + ~extra_remarks: 664 + [ 665 + Asai.Diagnostic.loctextf "Expected solitary node but got %a / %a" 666 + Value.pp v Value.pp v'; 667 + ] 668 + end 595 669 596 670 and focus_clo ?loc rho (xs : string option binding list) body = 597 671 match xs with 598 672 | [] -> 599 - focus ?loc @@ 600 - let@ () = Lex_env.run ~env: rho in 601 - eval_tape body 602 - | (info, y) :: ys -> 673 + focus ?loc 674 + @@ 675 + let@ () = Lex_env.run ~env:rho in 676 + eval_tape body 677 + | (info, y) :: ys -> ( 603 678 match Tape.pop_arg_opt () with 604 679 | Some arg -> 605 680 let yval = ··· 607 682 | Strict -> eval_tape arg.value 608 683 | Lazy -> Clo (Lex_env.read (), [(Strict, None)], arg.value) 609 684 in 610 - let rhoy = match y with Some y -> String_map.add y yval rho | None -> rho in 685 + let rhoy = 686 + match y with Some y -> String_map.add y yval rho | None -> rho 687 + in 611 688 focus_clo ?loc rhoy ys body 612 - | None -> 613 - begin 614 - match process_tape () with 615 - | Content nodes when T.strip_whitespace nodes = T.Content [] -> Clo (rho, xs, body) 616 - | _ -> Reporter.fatal ?loc Missing_argument ~extra_remarks: [Asai.Diagnostic.loctextf "Expected %i additional arguments" (List.length xs)] 617 - end 689 + | None -> begin 690 + match process_tape () with 691 + | Content nodes when T.strip_whitespace nodes = T.Content [] -> 692 + Clo (rho, xs, body) 693 + | _ -> 694 + Reporter.fatal ?loc Missing_argument 695 + ~extra_remarks: 696 + [ 697 + Asai.Diagnostic.loctextf "Expected %i additional arguments" 698 + (List.length xs); 699 + ] 700 + end) 618 701 619 702 and emit_content_nodes ~loc content = 620 703 focus ?loc @@ Content (T.Content (T.compress_nodes content)) 621 704 622 - and emit_content_node ~loc content = 623 - emit_content_nodes ~loc [content] 705 + and emit_content_node ~loc content = emit_content_nodes ~loc [content] 624 706 625 707 and eval_tree_inner ?(uri : URI.t option) (syn : Syn.t) : T.content T.article = 626 708 let attribution_is_author attr = 627 - match T.(attr.role) with 628 - | T.Author -> true 629 - | _ -> false 709 + match T.(attr.role) with T.Author -> true | _ -> false 630 710 in 631 711 let outer_frontmatter = Frontmatter.get () in 632 - let attributions = List.filter attribution_is_author outer_frontmatter.attributions in 712 + let attributions = 713 + List.filter attribution_is_author outer_frontmatter.attributions 714 + in 633 715 let frontmatter = 634 - T.default_frontmatter 635 - ?uri 636 - ~attributions 637 - ?source_path: outer_frontmatter.source_path 638 - ~dates: outer_frontmatter.dates 716 + T.default_frontmatter ?uri ~attributions 717 + ?source_path:outer_frontmatter.source_path ~dates:outer_frontmatter.dates 639 718 () 640 719 in 641 - let@ () = Frontmatter.run ~init: frontmatter in 720 + let@ () = Frontmatter.run ~init:frontmatter in 642 721 let mainmatter = {value = eval_tape syn; loc = None} |> extract_content in 643 722 let frontmatter = Frontmatter.get () in 644 - let backmatter = match uri with Some uri -> default_backmatter ~uri | None -> Content [] in 645 - T.{frontmatter; mainmatter; backmatter = backmatter} 723 + let backmatter = 724 + match uri with Some uri -> default_backmatter ~uri | None -> Content [] 725 + in 726 + T.{frontmatter; mainmatter; backmatter} 646 727 647 - let empty_result = { 648 - articles = []; 649 - jobs = [] 650 - } 728 + let empty_result = {articles = []; jobs = []} 651 729 652 - let eval_tree 653 - ~(config : Config.t) 654 - ~(uri : URI.t) 655 - ~(source_path : string option) 656 - (tree : Syn.t) 657 - : result * Reporter.diagnostic list 658 - = 730 + let eval_tree ~(config : Config.t) ~(uri : URI.t) ~(source_path : string option) 731 + (tree : Syn.t) : result * Reporter.diagnostic list = 659 732 let diagnostics = ref [] in 660 733 let push d = diagnostics := d :: !diagnostics in 661 734 let res = 662 735 Reporter.run 663 - ~fatal: (fun d -> push d; empty_result) 664 - ~emit: push 665 - @@ fun () -> 666 - let fm = T.default_frontmatter ~uri ?source_path () in 667 - let@ () = Mode_env.run ~env: Text_mode in 668 - let@ () = Frontmatter.run ~init: fm in 669 - let@ () = Emitted_trees.run ~init: [] in 670 - let@ () = Jobs.run ~init: [] in 671 - let@ () = Heap.run ~init: Symbol_map.empty in 672 - let@ () = Lex_env.run ~env: String_map.empty in 673 - let@ () = Dyn_env.run ~env: Symbol_map.empty in 674 - let@ () = Config_env.run ~env: config in 675 - let main = eval_tree_inner ~uri tree in 676 - let side = Emitted_trees.get () in 677 - let jobs = Jobs.get () in 678 - {articles = main :: side; jobs} 736 + ~fatal:(fun d -> 737 + push d; 738 + empty_result) 739 + ~emit:push 740 + @@ fun () -> 741 + let fm = T.default_frontmatter ~uri ?source_path () in 742 + let@ () = Mode_env.run ~env:Text_mode in 743 + let@ () = Frontmatter.run ~init:fm in 744 + let@ () = Emitted_trees.run ~init:[] in 745 + let@ () = Jobs.run ~init:[] in 746 + let@ () = Heap.run ~init:Symbol_map.empty in 747 + let@ () = Lex_env.run ~env:String_map.empty in 748 + let@ () = Dyn_env.run ~env:Symbol_map.empty in 749 + let@ () = Config_env.run ~env:config in 750 + let main = eval_tree_inner ~uri tree in 751 + let side = Emitted_trees.get () in 752 + let jobs = Jobs.get () in 753 + {articles = main :: side; jobs} 679 754 in 680 - res, !diagnostics 755 + (res, !diagnostics)
+4 -4
lib/compiler/Eval.mli
··· 9 9 10 10 type result = { 11 11 articles: T.content T.article list; 12 - jobs: Job.job Range.located list 12 + jobs: Job.job Range.located list; 13 13 } 14 14 [@@deriving show] 15 15 16 16 val eval_tree : 17 - config: Config.t -> 18 - uri: URI.t -> 19 - source_path: string option -> 17 + config:Config.t -> 18 + uri:URI.t -> 19 + source_path:string option -> 20 20 Syn.t -> 21 21 result * Reporter.diagnostic list
+866 -175
lib/compiler/Expand.ml
··· 7 7 open Forester_prelude 8 8 open Forester_core 9 9 open State.Syntax 10 - 11 10 module Unit_map = URI.Map 12 11 13 12 open struct ··· 29 28 | {value = Hash_ident x; loc} :: rest -> 30 29 let base = [Range.{value = Syn.Call (base, x); loc}] in 31 30 expand_method_calls base rest 32 - | rest -> base, rest 31 + | rest -> (base, rest) 33 32 34 33 type 'a Effect.t += Entered_range : Range.t option -> unit Effect.t 35 34 ··· 38 37 39 38 let rec expand_eff ~(forest : State.t) : Code.t -> Syn.t = function 40 39 | [] -> [] 41 - | node :: rest -> 40 + | node :: rest -> begin 42 41 entered_range node.loc; 43 42 match node.value with 44 43 | Hash_ident x -> 45 44 {node with value = Text ("#" ^ x)} :: expand_eff ~forest rest 46 - | Text x -> 47 - {node with value = Text x} :: expand_eff ~forest rest 48 - | Verbatim x -> 49 - {node with value = Verbatim x} :: expand_eff ~forest rest 45 + | Text x -> {node with value = Text x} :: expand_eff ~forest rest 46 + | Verbatim x -> {node with value = Verbatim x} :: expand_eff ~forest rest 50 47 | Namespace (path, body) -> 51 48 let result = 52 49 let@ () = Sc.section path in ··· 54 51 in 55 52 result @ expand_eff ~forest rest 56 53 | Open path -> 57 - Sc.modify_visible @@ 58 - R.Lang.union 59 - [ 60 - R.Lang.all; 61 - R.Lang.renaming path [] 62 - ]; 54 + Sc.modify_visible @@ R.Lang.union [R.Lang.all; R.Lang.renaming path []]; 63 55 expand_eff ~forest rest 64 - | Group (Squares, x) -> 65 - begin 66 - match x with 67 - | [{value = Group (Squares, y); loc = yloc}] -> 56 + | Group (Squares, x) -> begin 57 + match x with 58 + | [{value = Group (Squares, y); loc = yloc}] -> 59 + entered_range yloc; 60 + let y = expand_eff ~forest y in 61 + {node with value = Link {dest = y; title = None}} 62 + :: expand_eff ~forest rest 63 + | _ -> 64 + let x = expand_eff ~forest x in 65 + begin match rest with 66 + | {value = Group (Parens, y); loc = yloc} :: rest -> 68 67 entered_range yloc; 69 68 let y = expand_eff ~forest y in 70 - {node with value = Link {dest = y; title = None}} :: expand_eff ~forest rest 71 - | _ -> 72 - let x = expand_eff ~forest x in 73 - begin 74 - match rest with 75 - | {value = Group (Parens, y); loc = yloc} :: rest -> 76 - entered_range yloc; 77 - let y = expand_eff ~forest y in 78 - (* TODO: merge the ranges *) 79 - {node with value = Link {dest = y; title = Some x}} :: expand_eff ~forest rest 80 - | _ -> {node with value = Group (Squares, x)} :: expand_eff ~forest rest 81 - end 82 - end 69 + (* TODO: merge the ranges *) 70 + {node with value = Link {dest = y; title = Some x}} 71 + :: expand_eff ~forest rest 72 + | _ -> {node with value = Group (Squares, x)} :: expand_eff ~forest rest 73 + end 74 + end 83 75 | Group (d, x) -> 84 76 let x = expand_eff ~forest x in 85 77 {node with value = Group (d, x)} :: expand_eff ~forest rest ··· 99 91 let qname = expand_xml_ident node.loc (prefix, uname) in 100 92 let attrs, rest = get_xml_attrs ~forest [] rest in 101 93 let arg_opt, rest = get_arg_opt ~forest rest in 102 - {node with value = Xml_tag (qname, attrs, Option.value ~default: [] arg_opt)} :: expand_eff ~forest rest 94 + { 95 + node with 96 + value = Xml_tag (qname, attrs, Option.value ~default:[] arg_opt); 97 + } 98 + :: expand_eff ~forest rest 103 99 | Scope body -> 104 100 let body = 105 101 let@ () = Sc.section [] in ··· 108 104 body @ expand_eff ~forest rest 109 105 | Alloc x -> 110 106 let symbol = Symbol.named x in 111 - Sc.include_singleton x (Term [Range.locate_opt node.loc (Syn.Sym symbol)], node.loc); 107 + Sc.include_singleton x 108 + (Term [Range.locate_opt node.loc (Syn.Sym symbol)], node.loc); 112 109 expand_eff ~forest rest 113 110 | Put (k, v) -> 114 111 let k = expand_ident node.loc k in 115 112 let v = expand_eff ~forest v in 116 - (* TODO: merge locations! the resulting location is narrowed to the 'put' node, and therefore breaks the nesting of locations. That could lead to trouble in the future. *) 113 + (* TODO: merge locations! the resulting location is narrowed to the 'put' 114 + node, and therefore breaks the nesting of locations. That could lead to 115 + trouble in the future. *) 117 116 [{node with value = Put (k, v, expand_eff ~forest rest)}] 118 117 | Default (k, v) -> 119 118 let k = expand_ident node.loc k in 120 119 let v = expand_eff ~forest v in 121 - (* TODO: merge locations! the resulting location is narrowed to the 'put' node, and therefore breaks the nesting of locations. That could lead to trouble in the future. *) 120 + (* TODO: merge locations! the resulting location is narrowed to the 'put' 121 + node, and therefore breaks the nesting of locations. That could lead to 122 + trouble in the future. *) 122 123 [{node with value = Default (k, v, expand_eff ~forest rest)}] 123 124 | Get k -> 124 125 let k = expand_ident node.loc k in 125 126 {node with value = Get k} :: expand_eff ~forest rest 126 - | Dx_var name -> 127 - {node with value = Dx_var name} :: expand_eff ~forest rest 127 + | Dx_var name -> {node with value = Dx_var name} :: expand_eff ~forest rest 128 128 | Dx_const_content x -> 129 129 let x = expand_eff ~forest x in 130 130 {node with value = Dx_const (`Content, x)} :: expand_eff ~forest rest ··· 164 164 let@ () = Sc.section [] in 165 165 begin 166 166 let@ self = Option.iter @~ self in 167 - let var = Range.{value = Syn.Var self; loc = node.loc} in (* TODO: correct the location *) 168 - Sc.import_singleton [self] (Term [var], node.loc) (* TODO: correct the location*) 167 + let var = Range.{value = Syn.Var self; loc = node.loc} in 168 + (* TODO: correct the location *) 169 + Sc.import_singleton [self] (Term [var], node.loc) 170 + (* TODO: correct the location*) 169 171 end; 170 172 List.map (expand_method ~forest) methods 171 173 in ··· 190 192 let obj = expand_eff ~forest obj in 191 193 {node with value = Call (obj, meth)} :: expand_eff ~forest rest 192 194 | Import (vis, dep) -> 193 - let dep_uri = URI_scheme.named_uri ~base: forest.config.url dep in 194 - begin 195 - match forest./{dep_uri} with 196 - | None -> 197 - Reporter.emit ?loc: node.loc (Import_not_found dep_uri) 198 - | Some tree -> 199 - begin 200 - match vis with 201 - | Public -> Sc.include_subtree [] tree 202 - | Private -> Sc.import_subtree [] tree 203 - end 195 + let dep_uri = URI_scheme.named_uri ~base:forest.config.url dep in 196 + begin match forest./{dep_uri} with 197 + | None -> Reporter.emit ?loc:node.loc (Import_not_found dep_uri) 198 + | Some tree -> begin 199 + match vis with 200 + | Public -> Sc.include_subtree [] tree 201 + | Private -> Sc.import_subtree [] tree 202 + end 204 203 end; 205 204 expand_eff ~forest rest 206 205 | Comment _ | Error _ -> 207 206 ignore @@ assert false; 208 207 expand_eff ~forest rest 208 + end 209 209 210 210 and get_xml_attrs ~forest acc = function 211 - | {value = Group (Squares, [{value = Text key; loc = loc1}]); _} :: {value = Group (Braces, value); loc = loc2} :: rest -> 211 + | {value = Group (Squares, [{value = Text key; loc = loc1}]); _} 212 + :: {value = Group (Braces, value); loc = loc2} 213 + :: rest -> 212 214 entered_range loc1; 213 215 entered_range loc2; 214 - let qname = expand_xml_ident loc1 @@ Forester_xml_names.split_xml_qname key in 216 + let qname = 217 + expand_xml_ident loc1 @@ Forester_xml_names.split_xml_qname key 218 + in 215 219 let value = expand_eff ~forest value in 216 - get_xml_attrs ~forest (acc @ [qname, value]) rest 217 - | rest -> acc, rest 220 + get_xml_attrs ~forest (acc @ [(qname, value)]) rest 221 + | rest -> (acc, rest) 218 222 219 223 and get_arg_opt ~forest : Code.t -> _ = function 220 224 | {value = Group (Braces, arg); loc} :: rest -> 221 225 entered_range loc; 222 - Some (expand_eff ~forest arg), rest 223 - | rest -> None, rest 226 + (Some (expand_eff ~forest arg), rest) 227 + | rest -> (None, rest) 224 228 225 229 and expand_ident loc path = 226 230 match Sc.resolve path with ··· 232 236 List.map relocate x 233 237 | Some (Xmlns {xmlns; prefix}, _) -> 234 238 let visible = Sc.get_visible () in 235 - Reporter.fatal 236 - ?loc 237 - ~extra_remarks: [ 238 - Asai.Diagnostic.loctextf 239 - "path %a resolved to xmlns:%s=\"%s\" instead of term" 240 - Sc.pp_path 241 - path 242 - xmlns 243 - prefix 244 - ] 245 - (Unresolved_identifier (visible, path)) (* TODO: This should be perhaps a different error *) 239 + Reporter.fatal ?loc 240 + ~extra_remarks: 241 + [ 242 + Asai.Diagnostic.loctextf 243 + "path %a resolved to xmlns:%s=\"%s\" instead of term" Sc.pp_path 244 + path xmlns prefix; 245 + ] 246 + (Unresolved_identifier (visible, path)) 247 + (* TODO: This should be perhaps a different error *) 246 248 247 249 and expand_xml_ident loc (prefix, uname) : Types.xml_qname = 248 250 match prefix with 249 251 | None -> {xmlns = None; prefix = ""; uname} 250 - | Some prefix -> 252 + | Some prefix -> ( 251 253 match Sc.resolve ["xmlns"; prefix] with 252 - | Some (Xmlns {xmlns; prefix}, _) -> 253 - {xmlns = Some xmlns; prefix = prefix; uname} 254 + | Some (Xmlns {xmlns; prefix}, _) -> {xmlns = Some xmlns; prefix; uname} 254 255 | _ -> 255 - Reporter.fatal 256 - ?loc 257 - (Unresolved_xmlns prefix) 258 - ~extra_remarks: [ 259 - Asai.Diagnostic.loctextf 260 - "expected path `%s` to resolve to xmlns" 261 - prefix; 262 - Asai.Diagnostic.loctextf "You may fix this by defining an XML namespace:@. \\xmlns:%s{...}" prefix; 263 - ] 256 + Reporter.fatal ?loc (Unresolved_xmlns prefix) 257 + ~extra_remarks: 258 + [ 259 + Asai.Diagnostic.loctextf "expected path `%s` to resolve to xmlns" 260 + prefix; 261 + Asai.Diagnostic.loctextf 262 + "You may fix this by defining an XML namespace:@. \ 263 + \\xmlns:%s{...}" 264 + prefix; 265 + ]) 264 266 265 - and expand_method ~forest (key, body) = 266 - key, expand_eff ~forest body 267 + and expand_method ~forest (key, body) = (key, expand_eff ~forest body) 267 268 268 269 and expand_lambda ~forest loc (xs, body) = 269 270 let@ () = Sc.section [] in ··· 271 272 let@ strategy, x = List.map @~ xs in 272 273 let var = Range.locate_opt None @@ Syn.Var x in 273 274 Sc.import_singleton [x] (Term [var], loc); 274 - strategy, x 275 + (strategy, x) 275 276 in 276 277 Range.{value = Syn.Fun (xs, expand_eff ~forest body); loc} 277 278 278 279 let ignore_entered_range f x = 279 280 let open Effect.Deep in 280 - try_with 281 - f 282 - x 281 + try_with f x 283 282 { 284 - effc = fun (type a) (eff : a Effect.t) -> 285 - match eff with 286 - | Entered_range _ -> 287 - Option.some @@ fun (k : (a, _) continuation) -> 288 - continue k () 289 - | _ -> None 283 + effc = 284 + (fun (type a) (eff : a Effect.t) -> 285 + match eff with 286 + | Entered_range _ -> 287 + Option.some @@ fun (k : (a, _) continuation) -> continue k () 288 + | _ -> None); 290 289 } 291 290 292 291 let expand ~forest (xs : Code.t) : Syn.t = ··· 294 293 295 294 (* Feel free to extend this *) 296 295 let tex_builtin_words = 297 - List.to_seq ["left"; "right"; "big"; "bigr"; "Big"; "Bigr"; "bigg"; "biggr"; "Bigg"; "Biggr"; "bigl"; "Bigl"; "biggl"; "Biggl"; "mathrlap"; "mathllap"; "mathclap"; "rlap"; "llap"; "ulap"; "dlap"; "infty"; "infinity"; "lbrace"; "rbrace"; "llbracket"; "rrbracket"; "lvert"; "lVert"; "rvert"; "rVert"; "vert"; "Vert"; "setminus"; "backslash"; "smallsetminus"; "sslash"; "lfloor"; "lceil"; "lmoustache"; "lang"; "langle"; "llangle"; "rfloor"; "rceil"; "rmoustache"; "rang"; "rangle"; "rrangle"; "uparrow"; "downarrow"; "updownarrow"; "prime"; "alpha"; "beta"; "gamma"; "delta"; "zeta"; "eta"; "theta"; "iota"; "kappa"; "lambda"; "mu"; "nu"; "xi"; "pi"; "rho"; "sigma"; "tau"; "upsilon"; "chi"; "psi"; "omega"; "backepsilon"; "varkappa"; "varpi"; "varrho"; "varsigma"; "vartheta"; "varepsilon"; "phi"; "varphi"; "arccos"; "arcsin"; "arctan"; "arg"; "cos"; "cosh"; "cot"; "coth"; "csc"; "deg"; "dim"; "exp"; "hom"; "ker"; "lg"; "ln"; "log"; "sec"; "sin"; "sinh"; "tan"; "tanh"; "det"; "gcd"; "inf"; "lim"; "liminf"; "limsup"; "max"; "min"; "Pr"; "sup"; "omicron"; "epsilon"; "cdot"; "Alpha"; "Beta"; "Delta"; "Gamma"; "digamma"; "Lambda"; "Pi"; "Phi"; "Psi"; "Sigma"; "Theta"; "Xi"; "Zeta"; "Eta"; "Iota"; "Kappa"; "Mu"; "Nu"; "Rho"; "Tau"; "mho"; "Omega"; "Upsilon"; "Upsi"; "iff"; "Longleftrightarrow"; "Leftrightarrow"; "impliedby"; "Leftarrow"; "implies"; "Rightarrow"; "hookleftarrow"; "embedsin"; "hookrightarrow"; "longleftarrow"; "longrightarrow"; "leftarrow"; "to"; "rightarrow"; "leftrightarrow"; "mapsto"; "map"; "nearrow"; "nearr"; "nwarrow"; "nwarr"; "searrow"; "searr"; "swarrow"; "swarr"; "neArrow"; "neArr"; "nwArrow"; "nwArr"; "seArrow"; "seArr"; "swArrow"; "swArr"; "darr"; "Downarrow"; "uparr"; "Uparrow"; "downuparrow"; "duparr"; "updarr"; "Updownarrow"; "leftsquigarrow"; "rightsquigarrow"; "dashleftarrow"; "dashrightarrow"; "curvearrowbotright"; "righttoleftarrow"; "lefttorightarrow"; "leftrightsquigarrow"; "upuparrows"; "rightleftarrows"; "rightrightarrows"; "curvearrowleft"; "curvearrowright"; "downdownarrows"; "leftarrowtail"; "rightarrowtail"; "leftleftarrows"; "leftrightarrows"; "Lleftarrow"; "Rrightarrow"; "looparrowleft"; "looparrowright"; "Lsh"; "Rsh"; "circlearrowleft"; "circlearrowright"; "twoheadleftarrow"; "twoheadrightarrow"; "nLeftarrow"; "nleftarrow"; "nLeftrightarrow"; "nleftrightarrow"; "nRightarrow"; "nrightarrow"; "rightharpoonup"; "rightharpoondown"; "leftharpoonup"; "leftharpoondown"; "downharpoonleft"; "downharpoonright"; "leftrightharpoons"; "rightleftharpoons"; "upharpoonleft"; "upharpoonright"; "xrightarrow"; "xleftarrow"; "xleftrightarrow"; "xLeftarrow"; "xRightarrow"; "xLeftrightarrow"; "xleftrightharpoons"; "xrightleftharpoons"; "xhookleftarrow"; "xhookrightarrow"; "xmapsto"; "dots"; "ldots"; "cdots"; "ddots"; "udots"; "vdots"; "colon"; "cup"; "union"; "bigcup"; "Union"; "&Union;"; "cap"; "intersection"; "bigcap"; "Intersection"; "in"; "coloneqq"; "Coloneqq"; "coloneq"; "Coloneq"; "eqqcolon"; "Eqqcolon"; "eqcolon"; "Eqcolon"; "colonapprox"; "Colonapprox"; "colonsim"; "Colonsim"; "dblcolon"; "ast"; "Cap"; "Cup"; "circledast"; "circledcirc"; "curlyvee"; "curlywedge"; "divideontimes"; "dotplus"; "leftthreetimes"; "rightthreetimes"; "veebar"; "gt"; "lt"; "approxeq"; "backsim"; "backsimeq"; "barwedge"; "doublebarwedge"; "subset"; "subseteq"; "subseteqq"; "subsetneq"; "subsetneqq"; "varsubsetneq"; "varsubsetneqq"; "prec"; "parallel"; "nparallel"; "shortparallel"; "nshortparallel"; "perp"; "eqslantgtr"; "eqslantless"; "gg"; "ggg"; "geq"; "geqq"; "geqslant"; "gneq"; "gneqq"; "gnapprox"; "gnsim"; "gtrapprox"; "ge"; "le"; "leq"; "leqq"; "leqslant"; "lessapprox"; "lessdot"; "lesseqgtr"; "lesseqqgtr"; "lessgtr"; "lneq"; "lneqq"; "lnsim"; "lvertneqq"; "gtrsim"; "gtrdot"; "gtreqless"; "gtreqqless"; "gtrless"; "gvertneqq"; "lesssim"; "lnapprox"; "nsubset"; "nsubseteq"; "nsubseteqq"; "notin"; "ni"; "notni"; "nmid"; "nshortmid"; "preceq"; "npreceq"; "ll"; "ngeq"; "ngeqq"; "ngeqslant"; "nleq"; "nleqq"; "nleqslant"; "nless"; "supset"; "supseteq"; "supseteqq"; "supsetneq"; "supsetneqq"; "varsupsetneq"; "varsupsetneqq"; "approx"; "asymp"; "bowtie"; "dashv"; "Vdash"; "vDash"; "VDash"; "vdash"; "Vvdash"; "models"; "sim"; "simeq"; "nsim"; "smile"; "triangle"; "triangledown"; "triangleleft"; "cong"; "succ"; "nsucc"; "ngtr"; "nsupset"; "nsupseteq"; "propto"; "equiv"; "nequiv"; "frown"; "triangleright"; "ncong"; "succeq"; "succapprox"; "succnapprox"; "succcurlyeq"; "succsim"; "succnsim"; "nsucceq"; "nvDash"; "nvdash"; "nVDash"; "amalg"; "pm"; "mp"; "bigcirc"; "wr"; "odot"; "uplus"; "clubsuit"; "spadesuit"; "Diamond"; "diamond"; "sqcup"; "sqcap"; "sqsubset"; "sqsubseteq"; "sqsupset"; "sqsupseteq"; "Subset"; "Supset"; "ltimes"; "div"; "rtimes"; "bot"; "therefore"; "thickapprox"; "thicksim"; "varpropto"; "varnothing"; "flat"; "vee"; "because"; "between"; "Bumpeq"; "bumpeq"; "circeq"; "curlyeqprec"; "curlyeqsucc"; "doteq"; "doteqdot"; "eqcirc"; "fallingdotseq"; "multimap"; "pitchfork"; "precapprox"; "precnapprox"; "preccurlyeq"; "precsim"; "precnsim"; "risingdotseq"; "sharp"; "bullet"; "nexists"; "dagger"; "ddagger"; "not"; "top"; "natural"; "angle"; "measuredangle"; "backprime"; "bigstar"; "blacklozenge"; "lozenge"; "blacksquare"; "blacktriangle"; "blacktriangleleft"; "blacktriangleright"; "blacktriangledown"; "ntriangleleft"; "ntriangleright"; "ntrianglelefteq"; "ntrianglerighteq"; "trianglelefteq"; "trianglerighteq"; "triangleq"; "vartriangleleft"; "vartriangleright"; "forall"; "bigtriangleup"; "bigtriangledown"; "nprec"; "aleph"; "beth"; "eth"; "ell"; "hbar"; "Im"; "imath"; "jmath"; "wp"; "Re"; "Perp"; "Vbar"; "boxdot"; "Box"; "square"; "emptyset"; "empty"; "exists"; "circ"; "rhd"; "lhd"; "lll"; "unrhd"; "unlhd"; "Del"; "nabla"; "sphericalangle"; "heartsuit"; "diamondsuit"; "partial"; "qed"; "mod"; "pmod"; "bottom"; "neg"; "neq"; "ne"; "shortmid"; "mid"; "int"; "integral"; "iint"; "doubleintegral"; "iiint"; "tripleintegral"; "iiiint"; "quadrupleintegral"; "oint"; "conint"; "contourintegral"; "times"; "star"; "circleddash"; "odash"; "intercal"; "smallfrown"; "smallsmile"; "boxminus"; "minusb"; "boxplus"; "plusb"; "boxtimes"; "timesb"; "sum"; "prod"; "product"; "coprod"; "coproduct"; "otimes"; "Otimes"; "bigotimes"; "ominus"; "oslash"; "oplus"; "Oplus"; "bigoplus"; "bigodot"; "bigsqcup"; "bigsqcap"; "biginterleave"; "biguplus"; "wedge"; "Wedge"; "bigwedge"; "Vee"; "bigvee"; "invamp"; "parr"; "frac"; "tfrac"; "binom"; "tbinom"; "tensor"; "multiscripts"; "overbrace"; "underbrace"; "underline"; "bar"; "overline"; "closure"; "widebar"; "vec"; "widevec"; "overrightarrow"; "overleftarrow"; "overleftrightarrow"; "underrightarrow"; "underleftarrow"; "underleftrightarrow"; "dot"; "ddot"; "dddot"; "ddddot"; "tilde"; "widetilde"; "check"; "widecheck"; "hat"; "widehat"; "underset"; "stackrel"; "overset"; "over"; "atop"; "underoverset"; "sqrt"; "root"; "space"; "text"; "statusline"; "tooltip"; "toggle"; "begintoggle"; "endtoggle"; "mathraisebox"; "fghilight"; "fghighlight"; "bghilight"; "bghighlight"; "color"; "bgcolor"; "displaystyle"; "textstyle"; "textsize"; "scriptsize"; "scriptscriptsize"; "mathit"; "mathsf"; "mathtt"; "boldsymbol"; "mathbf"; "mathrm"; "mathbb"; "mathfrak"; "mathfr"; "slash"; "boxed"; "mathcal"; "mathscr"; "begin"; "end"; "substack"; "array"; "arrayopts"; "colalign"; "collayout"; "rowalign"; "align"; "equalrows"; "equalcols"; "rowlines"; "collines"; "frame"; "padding"; "rowopts"; "cellopts"; "rowspan"; "colspan"; "thinspace"; "medspace"; "thickspace"; "quad"; "qquad"; "negspace"; "negthinspace"; "negmedspace"; "negthickspace"; "phantom"; "operatorname"; "mathop"; "mathbin"; "mathrel"; "includegraphics"; "lparen"; "rparen"; "land"; "lor"; "middle"; "mathpunct"; "mathord"] 296 + List.to_seq 297 + [ 298 + "left"; 299 + "right"; 300 + "big"; 301 + "bigr"; 302 + "Big"; 303 + "Bigr"; 304 + "bigg"; 305 + "biggr"; 306 + "Bigg"; 307 + "Biggr"; 308 + "bigl"; 309 + "Bigl"; 310 + "biggl"; 311 + "Biggl"; 312 + "mathrlap"; 313 + "mathllap"; 314 + "mathclap"; 315 + "rlap"; 316 + "llap"; 317 + "ulap"; 318 + "dlap"; 319 + "infty"; 320 + "infinity"; 321 + "lbrace"; 322 + "rbrace"; 323 + "llbracket"; 324 + "rrbracket"; 325 + "lvert"; 326 + "lVert"; 327 + "rvert"; 328 + "rVert"; 329 + "vert"; 330 + "Vert"; 331 + "setminus"; 332 + "backslash"; 333 + "smallsetminus"; 334 + "sslash"; 335 + "lfloor"; 336 + "lceil"; 337 + "lmoustache"; 338 + "lang"; 339 + "langle"; 340 + "llangle"; 341 + "rfloor"; 342 + "rceil"; 343 + "rmoustache"; 344 + "rang"; 345 + "rangle"; 346 + "rrangle"; 347 + "uparrow"; 348 + "downarrow"; 349 + "updownarrow"; 350 + "prime"; 351 + "alpha"; 352 + "beta"; 353 + "gamma"; 354 + "delta"; 355 + "zeta"; 356 + "eta"; 357 + "theta"; 358 + "iota"; 359 + "kappa"; 360 + "lambda"; 361 + "mu"; 362 + "nu"; 363 + "xi"; 364 + "pi"; 365 + "rho"; 366 + "sigma"; 367 + "tau"; 368 + "upsilon"; 369 + "chi"; 370 + "psi"; 371 + "omega"; 372 + "backepsilon"; 373 + "varkappa"; 374 + "varpi"; 375 + "varrho"; 376 + "varsigma"; 377 + "vartheta"; 378 + "varepsilon"; 379 + "phi"; 380 + "varphi"; 381 + "arccos"; 382 + "arcsin"; 383 + "arctan"; 384 + "arg"; 385 + "cos"; 386 + "cosh"; 387 + "cot"; 388 + "coth"; 389 + "csc"; 390 + "deg"; 391 + "dim"; 392 + "exp"; 393 + "hom"; 394 + "ker"; 395 + "lg"; 396 + "ln"; 397 + "log"; 398 + "sec"; 399 + "sin"; 400 + "sinh"; 401 + "tan"; 402 + "tanh"; 403 + "det"; 404 + "gcd"; 405 + "inf"; 406 + "lim"; 407 + "liminf"; 408 + "limsup"; 409 + "max"; 410 + "min"; 411 + "Pr"; 412 + "sup"; 413 + "omicron"; 414 + "epsilon"; 415 + "cdot"; 416 + "Alpha"; 417 + "Beta"; 418 + "Delta"; 419 + "Gamma"; 420 + "digamma"; 421 + "Lambda"; 422 + "Pi"; 423 + "Phi"; 424 + "Psi"; 425 + "Sigma"; 426 + "Theta"; 427 + "Xi"; 428 + "Zeta"; 429 + "Eta"; 430 + "Iota"; 431 + "Kappa"; 432 + "Mu"; 433 + "Nu"; 434 + "Rho"; 435 + "Tau"; 436 + "mho"; 437 + "Omega"; 438 + "Upsilon"; 439 + "Upsi"; 440 + "iff"; 441 + "Longleftrightarrow"; 442 + "Leftrightarrow"; 443 + "impliedby"; 444 + "Leftarrow"; 445 + "implies"; 446 + "Rightarrow"; 447 + "hookleftarrow"; 448 + "embedsin"; 449 + "hookrightarrow"; 450 + "longleftarrow"; 451 + "longrightarrow"; 452 + "leftarrow"; 453 + "to"; 454 + "rightarrow"; 455 + "leftrightarrow"; 456 + "mapsto"; 457 + "map"; 458 + "nearrow"; 459 + "nearr"; 460 + "nwarrow"; 461 + "nwarr"; 462 + "searrow"; 463 + "searr"; 464 + "swarrow"; 465 + "swarr"; 466 + "neArrow"; 467 + "neArr"; 468 + "nwArrow"; 469 + "nwArr"; 470 + "seArrow"; 471 + "seArr"; 472 + "swArrow"; 473 + "swArr"; 474 + "darr"; 475 + "Downarrow"; 476 + "uparr"; 477 + "Uparrow"; 478 + "downuparrow"; 479 + "duparr"; 480 + "updarr"; 481 + "Updownarrow"; 482 + "leftsquigarrow"; 483 + "rightsquigarrow"; 484 + "dashleftarrow"; 485 + "dashrightarrow"; 486 + "curvearrowbotright"; 487 + "righttoleftarrow"; 488 + "lefttorightarrow"; 489 + "leftrightsquigarrow"; 490 + "upuparrows"; 491 + "rightleftarrows"; 492 + "rightrightarrows"; 493 + "curvearrowleft"; 494 + "curvearrowright"; 495 + "downdownarrows"; 496 + "leftarrowtail"; 497 + "rightarrowtail"; 498 + "leftleftarrows"; 499 + "leftrightarrows"; 500 + "Lleftarrow"; 501 + "Rrightarrow"; 502 + "looparrowleft"; 503 + "looparrowright"; 504 + "Lsh"; 505 + "Rsh"; 506 + "circlearrowleft"; 507 + "circlearrowright"; 508 + "twoheadleftarrow"; 509 + "twoheadrightarrow"; 510 + "nLeftarrow"; 511 + "nleftarrow"; 512 + "nLeftrightarrow"; 513 + "nleftrightarrow"; 514 + "nRightarrow"; 515 + "nrightarrow"; 516 + "rightharpoonup"; 517 + "rightharpoondown"; 518 + "leftharpoonup"; 519 + "leftharpoondown"; 520 + "downharpoonleft"; 521 + "downharpoonright"; 522 + "leftrightharpoons"; 523 + "rightleftharpoons"; 524 + "upharpoonleft"; 525 + "upharpoonright"; 526 + "xrightarrow"; 527 + "xleftarrow"; 528 + "xleftrightarrow"; 529 + "xLeftarrow"; 530 + "xRightarrow"; 531 + "xLeftrightarrow"; 532 + "xleftrightharpoons"; 533 + "xrightleftharpoons"; 534 + "xhookleftarrow"; 535 + "xhookrightarrow"; 536 + "xmapsto"; 537 + "dots"; 538 + "ldots"; 539 + "cdots"; 540 + "ddots"; 541 + "udots"; 542 + "vdots"; 543 + "colon"; 544 + "cup"; 545 + "union"; 546 + "bigcup"; 547 + "Union"; 548 + "&Union;"; 549 + "cap"; 550 + "intersection"; 551 + "bigcap"; 552 + "Intersection"; 553 + "in"; 554 + "coloneqq"; 555 + "Coloneqq"; 556 + "coloneq"; 557 + "Coloneq"; 558 + "eqqcolon"; 559 + "Eqqcolon"; 560 + "eqcolon"; 561 + "Eqcolon"; 562 + "colonapprox"; 563 + "Colonapprox"; 564 + "colonsim"; 565 + "Colonsim"; 566 + "dblcolon"; 567 + "ast"; 568 + "Cap"; 569 + "Cup"; 570 + "circledast"; 571 + "circledcirc"; 572 + "curlyvee"; 573 + "curlywedge"; 574 + "divideontimes"; 575 + "dotplus"; 576 + "leftthreetimes"; 577 + "rightthreetimes"; 578 + "veebar"; 579 + "gt"; 580 + "lt"; 581 + "approxeq"; 582 + "backsim"; 583 + "backsimeq"; 584 + "barwedge"; 585 + "doublebarwedge"; 586 + "subset"; 587 + "subseteq"; 588 + "subseteqq"; 589 + "subsetneq"; 590 + "subsetneqq"; 591 + "varsubsetneq"; 592 + "varsubsetneqq"; 593 + "prec"; 594 + "parallel"; 595 + "nparallel"; 596 + "shortparallel"; 597 + "nshortparallel"; 598 + "perp"; 599 + "eqslantgtr"; 600 + "eqslantless"; 601 + "gg"; 602 + "ggg"; 603 + "geq"; 604 + "geqq"; 605 + "geqslant"; 606 + "gneq"; 607 + "gneqq"; 608 + "gnapprox"; 609 + "gnsim"; 610 + "gtrapprox"; 611 + "ge"; 612 + "le"; 613 + "leq"; 614 + "leqq"; 615 + "leqslant"; 616 + "lessapprox"; 617 + "lessdot"; 618 + "lesseqgtr"; 619 + "lesseqqgtr"; 620 + "lessgtr"; 621 + "lneq"; 622 + "lneqq"; 623 + "lnsim"; 624 + "lvertneqq"; 625 + "gtrsim"; 626 + "gtrdot"; 627 + "gtreqless"; 628 + "gtreqqless"; 629 + "gtrless"; 630 + "gvertneqq"; 631 + "lesssim"; 632 + "lnapprox"; 633 + "nsubset"; 634 + "nsubseteq"; 635 + "nsubseteqq"; 636 + "notin"; 637 + "ni"; 638 + "notni"; 639 + "nmid"; 640 + "nshortmid"; 641 + "preceq"; 642 + "npreceq"; 643 + "ll"; 644 + "ngeq"; 645 + "ngeqq"; 646 + "ngeqslant"; 647 + "nleq"; 648 + "nleqq"; 649 + "nleqslant"; 650 + "nless"; 651 + "supset"; 652 + "supseteq"; 653 + "supseteqq"; 654 + "supsetneq"; 655 + "supsetneqq"; 656 + "varsupsetneq"; 657 + "varsupsetneqq"; 658 + "approx"; 659 + "asymp"; 660 + "bowtie"; 661 + "dashv"; 662 + "Vdash"; 663 + "vDash"; 664 + "VDash"; 665 + "vdash"; 666 + "Vvdash"; 667 + "models"; 668 + "sim"; 669 + "simeq"; 670 + "nsim"; 671 + "smile"; 672 + "triangle"; 673 + "triangledown"; 674 + "triangleleft"; 675 + "cong"; 676 + "succ"; 677 + "nsucc"; 678 + "ngtr"; 679 + "nsupset"; 680 + "nsupseteq"; 681 + "propto"; 682 + "equiv"; 683 + "nequiv"; 684 + "frown"; 685 + "triangleright"; 686 + "ncong"; 687 + "succeq"; 688 + "succapprox"; 689 + "succnapprox"; 690 + "succcurlyeq"; 691 + "succsim"; 692 + "succnsim"; 693 + "nsucceq"; 694 + "nvDash"; 695 + "nvdash"; 696 + "nVDash"; 697 + "amalg"; 698 + "pm"; 699 + "mp"; 700 + "bigcirc"; 701 + "wr"; 702 + "odot"; 703 + "uplus"; 704 + "clubsuit"; 705 + "spadesuit"; 706 + "Diamond"; 707 + "diamond"; 708 + "sqcup"; 709 + "sqcap"; 710 + "sqsubset"; 711 + "sqsubseteq"; 712 + "sqsupset"; 713 + "sqsupseteq"; 714 + "Subset"; 715 + "Supset"; 716 + "ltimes"; 717 + "div"; 718 + "rtimes"; 719 + "bot"; 720 + "therefore"; 721 + "thickapprox"; 722 + "thicksim"; 723 + "varpropto"; 724 + "varnothing"; 725 + "flat"; 726 + "vee"; 727 + "because"; 728 + "between"; 729 + "Bumpeq"; 730 + "bumpeq"; 731 + "circeq"; 732 + "curlyeqprec"; 733 + "curlyeqsucc"; 734 + "doteq"; 735 + "doteqdot"; 736 + "eqcirc"; 737 + "fallingdotseq"; 738 + "multimap"; 739 + "pitchfork"; 740 + "precapprox"; 741 + "precnapprox"; 742 + "preccurlyeq"; 743 + "precsim"; 744 + "precnsim"; 745 + "risingdotseq"; 746 + "sharp"; 747 + "bullet"; 748 + "nexists"; 749 + "dagger"; 750 + "ddagger"; 751 + "not"; 752 + "top"; 753 + "natural"; 754 + "angle"; 755 + "measuredangle"; 756 + "backprime"; 757 + "bigstar"; 758 + "blacklozenge"; 759 + "lozenge"; 760 + "blacksquare"; 761 + "blacktriangle"; 762 + "blacktriangleleft"; 763 + "blacktriangleright"; 764 + "blacktriangledown"; 765 + "ntriangleleft"; 766 + "ntriangleright"; 767 + "ntrianglelefteq"; 768 + "ntrianglerighteq"; 769 + "trianglelefteq"; 770 + "trianglerighteq"; 771 + "triangleq"; 772 + "vartriangleleft"; 773 + "vartriangleright"; 774 + "forall"; 775 + "bigtriangleup"; 776 + "bigtriangledown"; 777 + "nprec"; 778 + "aleph"; 779 + "beth"; 780 + "eth"; 781 + "ell"; 782 + "hbar"; 783 + "Im"; 784 + "imath"; 785 + "jmath"; 786 + "wp"; 787 + "Re"; 788 + "Perp"; 789 + "Vbar"; 790 + "boxdot"; 791 + "Box"; 792 + "square"; 793 + "emptyset"; 794 + "empty"; 795 + "exists"; 796 + "circ"; 797 + "rhd"; 798 + "lhd"; 799 + "lll"; 800 + "unrhd"; 801 + "unlhd"; 802 + "Del"; 803 + "nabla"; 804 + "sphericalangle"; 805 + "heartsuit"; 806 + "diamondsuit"; 807 + "partial"; 808 + "qed"; 809 + "mod"; 810 + "pmod"; 811 + "bottom"; 812 + "neg"; 813 + "neq"; 814 + "ne"; 815 + "shortmid"; 816 + "mid"; 817 + "int"; 818 + "integral"; 819 + "iint"; 820 + "doubleintegral"; 821 + "iiint"; 822 + "tripleintegral"; 823 + "iiiint"; 824 + "quadrupleintegral"; 825 + "oint"; 826 + "conint"; 827 + "contourintegral"; 828 + "times"; 829 + "star"; 830 + "circleddash"; 831 + "odash"; 832 + "intercal"; 833 + "smallfrown"; 834 + "smallsmile"; 835 + "boxminus"; 836 + "minusb"; 837 + "boxplus"; 838 + "plusb"; 839 + "boxtimes"; 840 + "timesb"; 841 + "sum"; 842 + "prod"; 843 + "product"; 844 + "coprod"; 845 + "coproduct"; 846 + "otimes"; 847 + "Otimes"; 848 + "bigotimes"; 849 + "ominus"; 850 + "oslash"; 851 + "oplus"; 852 + "Oplus"; 853 + "bigoplus"; 854 + "bigodot"; 855 + "bigsqcup"; 856 + "bigsqcap"; 857 + "biginterleave"; 858 + "biguplus"; 859 + "wedge"; 860 + "Wedge"; 861 + "bigwedge"; 862 + "Vee"; 863 + "bigvee"; 864 + "invamp"; 865 + "parr"; 866 + "frac"; 867 + "tfrac"; 868 + "binom"; 869 + "tbinom"; 870 + "tensor"; 871 + "multiscripts"; 872 + "overbrace"; 873 + "underbrace"; 874 + "underline"; 875 + "bar"; 876 + "overline"; 877 + "closure"; 878 + "widebar"; 879 + "vec"; 880 + "widevec"; 881 + "overrightarrow"; 882 + "overleftarrow"; 883 + "overleftrightarrow"; 884 + "underrightarrow"; 885 + "underleftarrow"; 886 + "underleftrightarrow"; 887 + "dot"; 888 + "ddot"; 889 + "dddot"; 890 + "ddddot"; 891 + "tilde"; 892 + "widetilde"; 893 + "check"; 894 + "widecheck"; 895 + "hat"; 896 + "widehat"; 897 + "underset"; 898 + "stackrel"; 899 + "overset"; 900 + "over"; 901 + "atop"; 902 + "underoverset"; 903 + "sqrt"; 904 + "root"; 905 + "space"; 906 + "text"; 907 + "statusline"; 908 + "tooltip"; 909 + "toggle"; 910 + "begintoggle"; 911 + "endtoggle"; 912 + "mathraisebox"; 913 + "fghilight"; 914 + "fghighlight"; 915 + "bghilight"; 916 + "bghighlight"; 917 + "color"; 918 + "bgcolor"; 919 + "displaystyle"; 920 + "textstyle"; 921 + "textsize"; 922 + "scriptsize"; 923 + "scriptscriptsize"; 924 + "mathit"; 925 + "mathsf"; 926 + "mathtt"; 927 + "boldsymbol"; 928 + "mathbf"; 929 + "mathrm"; 930 + "mathbb"; 931 + "mathfrak"; 932 + "mathfr"; 933 + "slash"; 934 + "boxed"; 935 + "mathcal"; 936 + "mathscr"; 937 + "begin"; 938 + "end"; 939 + "substack"; 940 + "array"; 941 + "arrayopts"; 942 + "colalign"; 943 + "collayout"; 944 + "rowalign"; 945 + "align"; 946 + "equalrows"; 947 + "equalcols"; 948 + "rowlines"; 949 + "collines"; 950 + "frame"; 951 + "padding"; 952 + "rowopts"; 953 + "cellopts"; 954 + "rowspan"; 955 + "colspan"; 956 + "thinspace"; 957 + "medspace"; 958 + "thickspace"; 959 + "quad"; 960 + "qquad"; 961 + "negspace"; 962 + "negthinspace"; 963 + "negmedspace"; 964 + "negthickspace"; 965 + "phantom"; 966 + "operatorname"; 967 + "mathop"; 968 + "mathbin"; 969 + "mathrel"; 970 + "includegraphics"; 971 + "lparen"; 972 + "rparen"; 973 + "land"; 974 + "lor"; 975 + "middle"; 976 + "mathpunct"; 977 + "mathord"; 978 + ] 298 979 |> Seq.map @@ fun word -> 299 - let path = [word] in 300 - let node = Syn.TeX_cs (TeX_cs.Word word) in 301 - path, (Syn.Term [Range.locate_opt None node], None) 980 + let path = [word] in 981 + let node = Syn.TeX_cs (TeX_cs.Word word) in 982 + (path, (Syn.Term [Range.locate_opt None node], None)) 302 983 303 984 (* Feel free to extend this *) 304 985 let tex_builtin_symbols = 305 986 List.to_seq ['_'; ','; ';'] 306 987 |> Seq.map @@ fun c -> 307 - let path = [String_util.implode [c]] in 308 - let node = Syn.TeX_cs (TeX_cs.Symbol c) in 309 - path, (Syn.Term [Range.locate_opt None node], None) 988 + let path = [String_util.implode [c]] in 989 + let node = Syn.TeX_cs (TeX_cs.Symbol c) in 990 + (path, (Syn.Term [Range.locate_opt None node], None)) 310 991 311 992 let builtin_xml_namespaces = 312 993 List.to_seq 313 994 [ 314 - "html", "http://www.w3.org/1999/xhtml"; 315 - "mml", "http://www.w3.org/1998/Math/MathML" 995 + ("html", "http://www.w3.org/1999/xhtml"); 996 + ("mml", "http://www.w3.org/1998/Math/MathML"); 316 997 ] 317 998 |> Seq.map @@ fun (prefix, xmlns) -> 318 - ["xmlns"; prefix], (Syn.Xmlns {prefix; xmlns}, None) 999 + (["xmlns"; prefix], (Syn.Xmlns {prefix; xmlns}, None)) 319 1000 320 1001 let builtins = 321 - Seq.concat @@ 322 - List.to_seq 323 - [ 324 - builtin_xml_namespaces; 325 - tex_builtin_words; 326 - tex_builtin_symbols; 327 - begin 328 - let open Builtins.Transclude in 329 - List.to_seq [expanded_sym; show_heading_sym; toc_sym; numbered_sym; show_metadata_sym] 330 - |> Seq.map @@ fun sym -> 331 - Symbol.name sym, (Syn.Term [Range.locate_opt None (Syn.Sym sym)], None) 332 - end; 333 - begin 334 - List.to_seq 335 - [ 336 - ["p"], Syn.Prim `P; 337 - ["em"], Syn.Prim `Em; 338 - ["strong"], Syn.Prim `Strong; 339 - ["li"], Syn.Prim `Li; 340 - ["ol"], Syn.Prim `Ol; 341 - ["ul"], Syn.Prim `Ul; 342 - ["code"], Syn.Prim `Code; 343 - ["blockquote"], Syn.Prim `Blockquote; 344 - ["pre"], Syn.Prim `Pre; 345 - ["figure"], Syn.Prim `Figure; 346 - ["figcaption"], Syn.Prim `Figcaption; 347 - ["transclude"], Syn.Transclude; 348 - ["tex"], Syn.Embed_tex; 349 - ["ref"], Syn.Ref; 350 - ["title"], Syn.Title; 351 - ["taxon"], Syn.Taxon; 352 - ["date"], Syn.Date; 353 - ["meta"], Syn.Meta; 354 - ["author"], Syn.Attribution (Author, `Uri); 355 - ["author"; "literal"], Syn.Attribution (Author, `Content); 356 - ["contributor"], Syn.Attribution (Contributor, `Uri); 357 - ["contributor"; "literal"], Syn.Attribution (Contributor, `Content); 358 - ["parent"], Syn.Parent; 359 - ["number"], Syn.Number; 360 - ["tag"], Syn.Tag `Content; 361 - ["query"], Syn.Results_of_query; 362 - ["rel"; "has-tag"], Syn.Text Builtin_relation.has_tag; 363 - ["rel"; "has-taxon"], Syn.Text Builtin_relation.has_taxon; 364 - ["rel"; "has-author"], Syn.Text Builtin_relation.has_author; 365 - ["rel"; "has-direct-contributor"], Syn.Text Builtin_relation.has_direct_contributor; 366 - ["rel"; "transcludes"], Syn.Text Builtin_relation.transcludes; 367 - ["rel"; "transcludes"; "transitive-closure"], Syn.Text Builtin_relation.transcludes_tc; 368 - ["rel"; "transcludes"; "reflexive-transitive-closure"], Syn.Text Builtin_relation.transcludes_rtc; 369 - ["rel"; "links-to"], Syn.Text Builtin_relation.links_to; 370 - ["rel"; "is-reference"], Syn.Text Builtin_relation.is_reference; 371 - ["rel"; "is-person"], Syn.Text Builtin_relation.is_person; 372 - ["rel"; "is-node"], Syn.Text Builtin_relation.is_node; 373 - ["rel"; "is-article"], Syn.Text Builtin_relation.is_article; 374 - ["rel"; "is-asset"], Syn.Text Builtin_relation.is_asset; 375 - ["rel"; "in-host"], Syn.Text Builtin_relation.in_host; 376 - ["execute"], Syn.Dx_execute; 377 - ["route-asset"], Syn.Route_asset; 378 - ["syndicate-query-as-json-blob"], Syn.Syndicate_query_as_json_blob; 379 - ["syndicate-current-tree-as-atom-feed"], Syn.Syndicate_current_tree_as_atom_feed; 380 - ["current-tree"], Syn.Current_tree; 381 - ] 382 - |> Seq.map @@ fun (path, node) -> 383 - path, (Syn.Term [Range.locate_opt None node], None) 384 - end 385 - ] 1002 + Seq.concat 1003 + @@ List.to_seq 1004 + [ 1005 + builtin_xml_namespaces; 1006 + tex_builtin_words; 1007 + tex_builtin_symbols; 1008 + begin 1009 + let open Builtins.Transclude in 1010 + List.to_seq 1011 + [ 1012 + expanded_sym; 1013 + show_heading_sym; 1014 + toc_sym; 1015 + numbered_sym; 1016 + show_metadata_sym; 1017 + ] 1018 + |> Seq.map @@ fun sym -> 1019 + ( Symbol.name sym, 1020 + (Syn.Term [Range.locate_opt None (Syn.Sym sym)], None) ) 1021 + end; 1022 + begin 1023 + List.to_seq 1024 + [ 1025 + (["p"], Syn.Prim `P); 1026 + (["em"], Syn.Prim `Em); 1027 + (["strong"], Syn.Prim `Strong); 1028 + (["li"], Syn.Prim `Li); 1029 + (["ol"], Syn.Prim `Ol); 1030 + (["ul"], Syn.Prim `Ul); 1031 + (["code"], Syn.Prim `Code); 1032 + (["blockquote"], Syn.Prim `Blockquote); 1033 + (["pre"], Syn.Prim `Pre); 1034 + (["figure"], Syn.Prim `Figure); 1035 + (["figcaption"], Syn.Prim `Figcaption); 1036 + (["transclude"], Syn.Transclude); 1037 + (["tex"], Syn.Embed_tex); 1038 + (["ref"], Syn.Ref); 1039 + (["title"], Syn.Title); 1040 + (["taxon"], Syn.Taxon); 1041 + (["date"], Syn.Date); 1042 + (["meta"], Syn.Meta); 1043 + (["author"], Syn.Attribution (Author, `Uri)); 1044 + (["author"; "literal"], Syn.Attribution (Author, `Content)); 1045 + (["contributor"], Syn.Attribution (Contributor, `Uri)); 1046 + ( ["contributor"; "literal"], 1047 + Syn.Attribution (Contributor, `Content) ); 1048 + (["parent"], Syn.Parent); 1049 + (["number"], Syn.Number); 1050 + (["tag"], Syn.Tag `Content); 1051 + (["query"], Syn.Results_of_query); 1052 + (["rel"; "has-tag"], Syn.Text Builtin_relation.has_tag); 1053 + (["rel"; "has-taxon"], Syn.Text Builtin_relation.has_taxon); 1054 + (["rel"; "has-author"], Syn.Text Builtin_relation.has_author); 1055 + ( ["rel"; "has-direct-contributor"], 1056 + Syn.Text Builtin_relation.has_direct_contributor ); 1057 + (["rel"; "transcludes"], Syn.Text Builtin_relation.transcludes); 1058 + ( ["rel"; "transcludes"; "transitive-closure"], 1059 + Syn.Text Builtin_relation.transcludes_tc ); 1060 + ( ["rel"; "transcludes"; "reflexive-transitive-closure"], 1061 + Syn.Text Builtin_relation.transcludes_rtc ); 1062 + (["rel"; "links-to"], Syn.Text Builtin_relation.links_to); 1063 + (["rel"; "is-reference"], Syn.Text Builtin_relation.is_reference); 1064 + (["rel"; "is-person"], Syn.Text Builtin_relation.is_person); 1065 + (["rel"; "is-node"], Syn.Text Builtin_relation.is_node); 1066 + (["rel"; "is-article"], Syn.Text Builtin_relation.is_article); 1067 + (["rel"; "is-asset"], Syn.Text Builtin_relation.is_asset); 1068 + (["rel"; "in-host"], Syn.Text Builtin_relation.in_host); 1069 + (["execute"], Syn.Dx_execute); 1070 + (["route-asset"], Syn.Route_asset); 1071 + ( ["syndicate-query-as-json-blob"], 1072 + Syn.Syndicate_query_as_json_blob ); 1073 + ( ["syndicate-current-tree-as-atom-feed"], 1074 + Syn.Syndicate_current_tree_as_atom_feed ); 1075 + (["current-tree"], Syn.Current_tree); 1076 + ] 1077 + |> Seq.map @@ fun (path, node) -> 1078 + (path, (Syn.Term [Range.locate_opt None node], None)) 1079 + end; 1080 + ] 386 1081 387 1082 let initial_visible_trie : (Syn.resolver_data, Range.t option) Trie.t = 388 1083 Yuujinchou.Trie.of_seq builtins ··· 401 1096 let exports = Sc.get_export () in 402 1097 Tree.{nodes; identity = code.identity; code; units = exports} 403 1098 404 - let expand_tree ~(forest : State.t) (code : Tree.code) : Tree.syn * Reporter.Message.t Asai.Diagnostic.t list = 1099 + let expand_tree ~(forest : State.t) (code : Tree.code) : 1100 + Tree.syn * Reporter.Message.t Asai.Diagnostic.t list = 405 1101 let diagnostics = ref [] in 406 1102 let emit d = diagnostics := d :: !diagnostics in 407 1103 let fatal d = 408 1104 emit d; 409 - Tree.{ 410 - nodes = []; 411 - identity = code.identity; 412 - code = code; 413 - units = Trie.empty; 414 - }, 415 - !diagnostics 1105 + ( Tree.{nodes = []; identity = code.identity; code; units = Trie.empty}, 1106 + !diagnostics ) 416 1107 in 417 1108 Reporter.run ~emit ~fatal @@ fun () -> 418 - Sc.run ~init_visible: initial_visible_trie @@ fun () -> 1109 + Sc.run ~init_visible:initial_visible_trie @@ fun () -> 419 1110 let expanded_tree = ignore_entered_range (expand_tree_inner ~forest) code in 420 - expanded_tree, !diagnostics 1111 + (expanded_tree, !diagnostics)
+10 -8
lib/compiler/Expand.mli
··· 5 5 *) 6 6 7 7 open Forester_core 8 - 9 8 module Unit_map = URI.Map 10 9 11 10 val initial_visible_trie : (Syn.resolver_data, Range.t option) Trie.t 12 11 13 - module Builtins : 14 - sig 15 - module Transclude : 16 - sig 12 + module Builtins : sig 13 + module Transclude : sig 17 14 val expanded_sym : Symbol.t 18 15 val show_heading_sym : Symbol.t 19 16 val show_metadata_sym : Symbol.t ··· 22 19 end 23 20 end 24 21 25 - val expand : forest: State.t -> Code.t -> Syn.t 26 - val expand_tree : forest: State.t -> Tree.code -> Tree.syn * Reporter.Message.t Asai.Diagnostic.t list 22 + val expand : forest:State.t -> Code.t -> Syn.t 23 + 24 + val expand_tree : 25 + forest:State.t -> 26 + Tree.code -> 27 + Tree.syn * Reporter.Message.t Asai.Diagnostic.t list 27 28 28 29 type 'a Effect.t += Entered_range : Range.t option -> unit Effect.t 29 - val expand_eff : forest: State.t -> Code.t -> Syn.t 30 + 31 + val expand_eff : forest:State.t -> Code.t -> Syn.t
+33 -26
lib/compiler/Forest.ml
··· 25 25 (* TODO: Why is this not run at the top level? *) 26 26 (* let () = execute_datalog_script Builtin_relation.axioms *) 27 27 28 - let run_datalog_query (graphs : env) (q : (string, Vertex.t) Dx.query) : Vertex_set.t = 28 + let run_datalog_query (graphs : env) (q : (string, Vertex.t) Dx.query) : 29 + Vertex_set.t = 29 30 let@ () = Reporter.trace "when running query" in 30 31 (* TODO: See above *) 31 32 let () = execute_datalog_script graphs Builtin_relation.axioms in ··· 50 51 in 51 52 execute_datalog_script graphs [{conclusion; premises}] 52 53 53 - let rec analyse_content_node graphs (scope : URI.t) (node : 'a T.content_node) : unit = 54 + let rec analyse_content_node graphs (scope : URI.t) (node : 'a T.content_node) : 55 + unit = 54 56 match node with 55 - | Text _ | CDATA _ | Route_of_uri _ | Uri _ | Results_of_datalog_query _ | Contextual_number _ -> () 56 - | Transclude transclusion -> 57 - analyse_transclusion graphs scope transclusion 57 + | Text _ | CDATA _ | Route_of_uri _ | Uri _ | Results_of_datalog_query _ 58 + | Contextual_number _ -> 59 + () 60 + | Transclude transclusion -> analyse_transclusion graphs scope transclusion 58 61 | Xml_elt elt -> 59 62 begin 60 63 let@ attr = List.iter @~ elt.attrs in 61 64 analyse_content graphs scope attr.value 62 65 end; 63 66 analyse_content graphs scope elt.content 64 - | Section section -> 65 - analyse_section graphs scope section 67 + | Section section -> analyse_section graphs scope section 66 68 | Link link -> 67 - add_edge graphs Builtin_relation.links_to ~source: (Uri_vertex scope) ~target: (Uri_vertex link.href); 69 + add_edge graphs Builtin_relation.links_to ~source:(Uri_vertex scope) 70 + ~target:(Uri_vertex link.href); 68 71 analyse_content graphs scope link.content 69 - | KaTeX (_, content) -> 70 - analyse_content graphs scope content 71 - | Artefact artefact -> 72 - analyse_artefact graphs scope artefact 73 - | Datalog_script script -> 74 - execute_datalog_script graphs script 72 + | KaTeX (_, content) -> analyse_content graphs scope content 73 + | Artefact artefact -> analyse_artefact graphs scope artefact 74 + | Datalog_script script -> execute_datalog_script graphs script 75 75 76 76 and analyse_artefact graphs scope artefact = 77 77 analyse_content graphs scope artefact.content 78 78 79 - and analyse_transclusion graphs (scope : URI.t) (transclusion : T.transclusion) : unit = 79 + and analyse_transclusion graphs (scope : URI.t) (transclusion : T.transclusion) 80 + : unit = 80 81 match transclusion.target with 81 82 | Full _ | Mainmatter -> 82 - add_edge graphs Builtin_relation.transcludes ~source: (Uri_vertex scope) ~target: (Uri_vertex transclusion.href) 83 + add_edge graphs Builtin_relation.transcludes ~source:(Uri_vertex scope) 84 + ~target:(Uri_vertex transclusion.href) 83 85 | Title _ | Taxon -> () 84 86 85 - and analyse_content (graphs : env) (scope : URI.t) (content : T.content) : unit = 87 + and analyse_content (graphs : env) (scope : URI.t) (content : T.content) : unit 88 + = 86 89 T.extract_content content |> List.iter @@ analyse_content_node graphs scope 87 90 88 91 and analyse_attribution graphs (scope : URI.t) (attr : _ T.attribution) = ··· 91 94 | Author -> Builtin_relation.has_author 92 95 | Contributor -> Builtin_relation.has_direct_contributor 93 96 in 94 - add_edge graphs rel ~source: (Uri_vertex scope) ~target: attr.vertex; 97 + add_edge graphs rel ~source:(Uri_vertex scope) ~target:attr.vertex; 95 98 analyse_vertex graphs scope attr.vertex 96 99 97 100 and analyse_vertex graphs scope vtx = ··· 101 104 102 105 and analyse_tag graphs (scope : URI.t) (tag : _ T.vertex) = 103 106 analyse_vertex graphs scope tag; 104 - add_edge graphs Builtin_relation.has_tag ~source: (Uri_vertex scope) ~target: tag 107 + add_edge graphs Builtin_relation.has_tag ~source:(Uri_vertex scope) 108 + ~target:tag 105 109 106 110 and analyse_taxon graphs (scope : URI.t) (taxon_opt : T.content option) = 107 111 let@ taxon = Option.iter @~ taxon_opt in 108 112 analyse_content graphs scope taxon; 109 - add_edge graphs Builtin_relation.has_taxon ~source: (Uri_vertex scope) ~target: (Content_vertex taxon) 113 + add_edge graphs Builtin_relation.has_taxon ~source:(Uri_vertex scope) 114 + ~target:(Content_vertex taxon) 110 115 111 116 and analyse_attributions graphs (scope : URI.t) = 112 117 List.iter @@ analyse_attribution graphs scope 113 118 114 - and analyse_tags graphs (scope : URI.t) = 115 - List.iter @@ analyse_tag graphs scope 119 + and analyse_tags graphs (scope : URI.t) = List.iter @@ analyse_tag graphs scope 116 120 117 - and analyse_frontmatter graphs (scope : URI.t) (fm : T.content T.frontmatter) : unit = 121 + and analyse_frontmatter graphs (scope : URI.t) (fm : T.content T.frontmatter) : 122 + unit = 118 123 Option.iter (analyse_content graphs scope) fm.title; 119 124 analyse_taxon graphs scope fm.taxon; 120 125 analyse_attributions graphs scope fm.attributions; ··· 127 132 and analyse_meta graphs (scope : URI.t) (_, content) : unit = 128 133 analyse_content graphs scope content 129 134 130 - and analyse_section graphs (scope : URI.t) (section : T.content T.section) : unit = 135 + and analyse_section graphs (scope : URI.t) (section : T.content T.section) : 136 + unit = 131 137 begin 132 138 let@ target = Option.iter @~ section.frontmatter.uri in 133 - add_edge graphs Builtin_relation.transcludes ~source: (Uri_vertex scope) ~target: (Uri_vertex target) 139 + add_edge graphs Builtin_relation.transcludes ~source:(Uri_vertex scope) 140 + ~target:(Uri_vertex target) 134 141 end; 135 - let scope = Option.value ~default: scope section.frontmatter.uri in 142 + let scope = Option.value ~default:scope section.frontmatter.uri in 136 143 analyse_frontmatter graphs scope section.frontmatter; 137 144 analyse_content graphs scope section.mainmatter 138 145
+18 -7
lib/compiler/Forest.mli
··· 5 5 *) 6 6 7 7 open Forester_core 8 - 9 8 include module type of URI.Tbl 10 9 11 10 (**/**) 11 + 12 12 module T := Types 13 13 module Dx := Datalog_expr 14 14 15 - val execute_datalog_script : (module Forest_graphs.S) -> (string, Vertex.t) Dx.sequent list -> unit 15 + val execute_datalog_script : 16 + (module Forest_graphs.S) -> (string, Vertex.t) Dx.sequent list -> unit 17 + 16 18 (**/**) 17 19 18 20 val analyse_resource : (module Forest_graphs.S) -> T.content T.resource -> unit 19 - (** [analyse_resource graphs resource] traverses {{!Forester_core.Types.resource}[resource]}, recording facts about it in {{!Forester_core.Forest_graphs.S}[graphs]}. 21 + (** [analyse_resource graphs resource] traverses 22 + {{!Forester_core.Types.resource}[resource]}, recording facts about it in 23 + {{!Forester_core.Forest_graphs.S}[graphs]}. 20 24 21 - - When encountering a {{!Forester_core.Types.Link}[Link]}, it adds an edge to the {{!Forester_core.Builtin_relation.links_to}[links_to]} relation in {{!Forester_core.Forest_graphs.S}[graphs]}. 25 + - When encountering a {{!Forester_core.Types.Link}[Link]}, it adds an edge 26 + to the {{!Forester_core.Builtin_relation.links_to}[links_to]} relation in 27 + {{!Forester_core.Forest_graphs.S}[graphs]}. 22 28 23 - - When encountering a {{!Forester_core.Types.Transclude}[Transclude]}, it adds an edge to the {{!Forester_core.Builtin_relation.transcludes}[transcludes]} relation in {{!Forester_core.Forest_graphs.S}[graphs]}. 29 + - When encountering a {{!Forester_core.Types.Transclude}[Transclude]}, it 30 + adds an edge to the 31 + {{!Forester_core.Builtin_relation.transcludes}[transcludes]} relation in 32 + {{!Forester_core.Forest_graphs.S}[graphs]}. 24 33 25 - - When encountering a {{!Forester_core.Types.Datalog_script}[Datalog_script script]}, it runs the script and records the results in {{!Forester_core.Forest_graphs.S}[graphs]}. 26 - *) 34 + - When encountering a 35 + {{!Forester_core.Types.Datalog_script}[Datalog_script script]}, it runs 36 + the script and records the results in 37 + {{!Forester_core.Forest_graphs.S}[graphs]}. *) 27 38 28 39 val run_datalog_query : 29 40 (module Forest_graphs.S) ->
+17 -10
lib/compiler/Forester_compiler.ml
··· 6 6 7 7 (** The forester compiler*) 8 8 9 - (** {1 Base types }*) 9 + (** {1 Base types}*) 10 10 11 11 module Xml_forester = Xml_forester 12 12 (** Definition of the forester XML schema. This is the compilation target.*) ··· 15 15 16 16 (** {2 Parsing} 17 17 18 - The lexer and parser are implemented with {{: https://ocaml.org/manual/5.3/lexyacc.html} ocamllex} and {{: https://gallium.inria.fr/~fpottier/menhir/} menhir}*) 18 + The lexer and parser are implemented with 19 + {{:https://ocaml.org/manual/5.3/lexyacc.html} ocamllex} and 20 + {{:https://gallium.inria.fr/~fpottier/menhir/} menhir}*) 19 21 20 22 module Parse = Parse 21 23 22 24 module Imports = Imports 23 - (** Create {{!Forester_core.Forest_graph.t}import and dependency graphs}. 24 - *) 25 + (** Create {{!Forester_core.Forest_graph.t}import and dependency graphs}. *) 25 26 26 27 module Expand = Expand 27 - (** Transform {!Code.tree}s into {!Syn.tree}s by {{!Forester_core.Forest_graph.topo_fold}folding} over the {{!Forester_core.Forest_graph}import graph.}*) 28 + (** Transform {!Code.tree}s into {!Syn.tree}s by 29 + {{!Forester_core.Forest_graph.topo_fold}folding} over the 30 + {{!Forester_core.Forest_graph}import graph.}*) 28 31 29 32 module Eval = Eval 30 33 (** Transform {!Syn.tree}s into {{!Forester_core.Types.article}[articles]}.*) 31 34 32 35 (** {1 High-level architecture} 33 36 34 - The compiler needs to support both batch-style and incremental compilation. To this end, we define a {{!State.t}state type} and {{!Phases}transition functions} that act on this state. 37 + The compiler needs to support both batch-style and incremental compilation. 38 + To this end, we define a {{!State.t}state type} and 39 + {{!Phases}transition functions} that act on this state. 35 40 36 - In the future, we want to record more knowledge in {{!field:State.graphs}[graphs]} of the {{!State.t}state} and derive the information we need for the language server via the query system. 37 - 38 - *) 41 + In the future, we want to record more knowledge in 42 + {{!field:State.graphs}[graphs]} of the {{!State.t}state} and derive the 43 + information we need for the language server via the query system. *) 39 44 40 45 module Forest = Forest 41 46 (** Augmented hash table used throughout compilation phases.*) ··· 45 50 module Phases = Phases 46 51 module Driver = Driver 47 52 module Asset_router = Asset_router 48 - 49 53 module URI_util = URI_util 50 54 51 55 (** {1 IO}*) ··· 55 59 module Build_latex = Build_latex 56 60 module LaTeX_pipeline = LaTeX_pipeline 57 61 module LaTeX_template = LaTeX_template 62 + 58 63 module Job = Job 59 64 (** Definition of LaTeX jobs*) 60 65 61 66 (**/**) 67 + 62 68 module Eio_util = Eio_util 63 69 module Export_for_test = Export_for_test 64 70 module Cache = Cache 65 71 module Dir_scanner = Dir_scanner 72 + 66 73 (**/**)
+77 -63
lib/compiler/Imports.ml
··· 6 6 7 7 open Forester_core 8 8 open Forester_prelude 9 - open struct module T = Types end 9 + 10 + open struct 11 + module T = Types 12 + end 10 13 11 14 type analysis_env = { 12 15 follow: bool; ··· 19 22 let path_str = Eio.Path.native_exn path in 20 23 assert (not @@ Filename.is_relative path_str); 21 24 let uri = Lsp.Uri.of_path path_str in 22 - Lsp.Text_document.make 23 - ~position_encoding: `UTF8 24 - { 25 - textDocument = { 26 - languageId = "forester"; 27 - text = content; 28 - uri; 29 - version = 1 30 - } 31 - } 25 + Lsp.Text_document.make ~position_encoding:`UTF8 26 + {textDocument = {languageId = "forester"; text = content; uri; version = 1}} 32 27 33 28 (* Only add edge if both vertices are already present*) 34 29 let add_edge g v w = ··· 36 31 assert (Forest_graph.mem_vertex g v); 37 32 assert (Forest_graph.mem_vertex g w); 38 33 Forest_graph.add_edge g v w 39 - with 40 - | exn -> Reporter.fatal Internal_error ~extra_remarks: [Asai.Diagnostic.loctextf "%a" Eio.Exn.pp exn] 34 + with exn -> 35 + Reporter.fatal Internal_error 36 + ~extra_remarks:[Asai.Diagnostic.loctextf "%a" Eio.Exn.pp exn] 41 37 42 - module Analysis_env = Algaeff.Reader.Make(struct type t = analysis_env end) 38 + module Analysis_env = Algaeff.Reader.Make (struct 39 + type t = analysis_env 40 + end) 43 41 44 - let resolve_uri_to_code 45 - (forest : State.t) 46 - (uri : URI.t) 47 - : Tree.code option 48 - = 49 - let dirs = Eio_util.paths_of_dirs ~env: forest.env forest.config.trees in 42 + let resolve_uri_to_code (forest : State.t) (uri : URI.t) : Tree.code option = 43 + let dirs = Eio_util.paths_of_dirs ~env:forest.env forest.config.trees in 50 44 match Forest.find_opt forest.index uri with 51 45 | Some tree -> Tree.to_code tree 52 - | None -> 46 + | None -> ( 53 47 match URI.Tbl.find_opt forest.resolver uri with 54 48 | Some path -> 55 49 let doc = load_tree Eio.Path.(forest.env#fs / path) in 56 - Result.to_option @@ 57 - Parse.parse_document ~config: forest.config doc 58 - | None -> 50 + Result.to_option @@ Parse.parse_document ~config:forest.config doc 51 + | None -> ( 59 52 match Dir_scanner.find_tree dirs uri with 60 53 | Some path -> 61 54 let native = Eio.Path.native_exn path in 62 55 URI.Tbl.add forest.resolver uri native; 63 56 let doc = load_tree path in 64 - Result.to_option @@ 65 - Parse.parse_document ~config: forest.config doc 66 - | None -> 67 - Reporter.fatal (Resource_not_found uri) 57 + Result.to_option @@ Parse.parse_document ~config:forest.config doc 58 + | None -> Reporter.fatal (Resource_not_found uri))) 68 59 69 60 let rec analyse_tree (tree : Tree.code) = 70 61 let env = Analysis_env.read () in 71 62 let@ root = Option.iter @~ identity_to_uri tree.identity in 72 63 let code = tree.nodes in 73 64 Forest_graph.add_vertex env.graph (T.Uri_vertex root); 74 - analyse_code ~root code; 65 + analyse_code ~root code 75 66 76 - and analyse_code ~root (code : Code.t) = 77 - List.iter (analyse_node ~root) code 67 + and analyse_code ~root (code : Code.t) = List.iter (analyse_node ~root) code 78 68 79 69 and analyse_node ~root (node : Code.node Asai.Range.located) = 80 70 let env = Analysis_env.read () in 81 71 let config = env.forest.config in 82 72 match node.value with 83 73 | Import (_, dep) -> 84 - let dep_uri = URI_scheme.named_uri ~base: config.url dep in 74 + let dep_uri = URI_scheme.named_uri ~base:config.url dep in 85 75 let dependency = T.Uri_vertex dep_uri in 86 76 let target = T.Uri_vertex root in 87 77 Forest_graph.add_vertex env.graph dependency; 88 78 (* add_vertex env.forest env.graph tar; *) 89 79 add_edge env.graph dependency target; 90 - if env.follow then 91 - begin 92 - match resolve_uri_to_code env.forest dep_uri with 93 - | None -> Reporter.fatal ?loc: node.loc (Resource_not_found dep_uri) 94 - | Some code -> 95 - analyse_tree code; 96 - assert false 97 - end 80 + if env.follow then begin 81 + match resolve_uri_to_code env.forest dep_uri with 82 + | None -> Reporter.fatal ?loc:node.loc (Resource_not_found dep_uri) 83 + | Some code -> 84 + analyse_tree code; 85 + assert false 86 + end 98 87 | Subtree (addr, nodes) -> 99 88 let identity = 100 89 match addr with 101 90 | None -> Anonymous 102 - | Some string -> 103 - URI (URI_scheme.named_uri ~base: config.url string) 91 + | Some string -> URI (URI_scheme.named_uri ~base:config.url string) 104 92 in 105 93 analyse_tree 106 - {identity; origin = Subtree {parent = URI root}; nodes; timestamp = None;} 107 - | Scope code | Namespace (_, code) | Group (_, code) | Math (_, code) | Let (_, _, code) | Fun (_, code) | Def (_, _, code) -> 94 + {identity; origin = Subtree {parent = URI root}; nodes; timestamp = None} 95 + | Scope code 96 + | Namespace (_, code) 97 + | Group (_, code) 98 + | Math (_, code) 99 + | Let (_, _, code) 100 + | Fun (_, code) 101 + | Def (_, _, code) -> 108 102 analyse_code ~root code 109 103 | Object {methods; _} | Patch {methods; _} -> 110 104 let@ _, code = List.iter @~ methods in ··· 118 112 | Dx_query (_, positives, negatives) -> 119 113 List.iter (analyse_code ~root) positives; 120 114 List.iter (analyse_code ~root) negatives 121 - | Text _ | Hash_ident _ | Xml_ident (_, _) | Verbatim _ | Ident _ | Open _ | Put (_, _) | Default (_, _) | Get _ | Decl_xmlns (_, _) | Call (_, _) | Alloc _ | Dx_var _ | Dx_const_content _ | Dx_const_uri _ | Comment _ | Error _ -> () 115 + | Text _ | Hash_ident _ 116 + | Xml_ident (_, _) 117 + | Verbatim _ | Ident _ | Open _ 118 + | Put (_, _) 119 + | Default (_, _) 120 + | Get _ 121 + | Decl_xmlns (_, _) 122 + | Call (_, _) 123 + | Alloc _ | Dx_var _ | Dx_const_content _ | Dx_const_uri _ | Comment _ 124 + | Error _ -> 125 + () 122 126 123 127 let dependencies tree forest = 124 128 let env = {forest; follow = true; graph = Forest_graph.create ()} in ··· 127 131 env.graph 128 132 129 133 let fixup (tree : Tree.code) (forest : State.t) = 130 - let@ () = Reporter.tracef "when updating imports for %a" pp_identity tree.identity in 134 + let@ () = 135 + Reporter.tracef "when updating imports for %a" pp_identity tree.identity 136 + in 131 137 Logs.debug (fun m -> m "updating imports for %a" pp_identity tree.identity); 132 138 let graph = forest.import_graph in 133 139 match tree.identity with 134 140 | Anonymous -> assert false 135 141 | URI uri -> 136 142 let this_vertex = T.Uri_vertex uri in 137 - let old_deps = Vertex_set.of_list @@ Forest_graph.immediate_dependencies graph this_vertex in 143 + let old_deps = 144 + Vertex_set.of_list 145 + @@ Forest_graph.immediate_dependencies graph this_vertex 146 + in 138 147 let new_deps = 139 - let env = {forest; follow = false; graph;} in 148 + let env = {forest; follow = false; graph} in 140 149 let@ () = Analysis_env.run ~env in 141 150 begin 142 151 analyse_tree tree; 143 - Vertex_set.of_list @@ Forest_graph.immediate_dependencies env.graph this_vertex 144 - end; 152 + Vertex_set.of_list 153 + @@ Forest_graph.immediate_dependencies env.graph this_vertex 154 + end 145 155 in 146 156 let unchanged_deps = Vertex_set.inter new_deps old_deps in 147 157 let added_deps = Vertex_set.diff new_deps unchanged_deps in 148 158 let removed_deps = Vertex_set.diff old_deps unchanged_deps in 149 - Logs.debug (fun m -> m "added %d dependencies" (Vertex_set.cardinal added_deps)); 150 - Logs.debug (fun m -> m "removed %d dependencies" (Vertex_set.cardinal removed_deps)); 151 - Vertex_set.iter (fun v -> Forest_graph.remove_edge graph v this_vertex) removed_deps; 152 - Vertex_set.iter (fun v -> Forest_graph.add_edge graph v this_vertex) added_deps 159 + Logs.debug (fun m -> 160 + m "added %d dependencies" (Vertex_set.cardinal added_deps)); 161 + Logs.debug (fun m -> 162 + m "removed %d dependencies" (Vertex_set.cardinal removed_deps)); 163 + Vertex_set.iter 164 + (fun v -> Forest_graph.remove_edge graph v this_vertex) 165 + removed_deps; 166 + Vertex_set.iter 167 + (fun v -> Forest_graph.add_edge graph v this_vertex) 168 + added_deps 153 169 154 - let _minimal_dependency_graph 155 - : addr: URI.t -> Forest_graph.t 156 - = fun ~addr -> 170 + let _minimal_dependency_graph : addr:URI.t -> Forest_graph.t = 171 + fun ~addr -> 157 172 let dep_graph = Forest_graph.create () in 158 173 let rec f v = 159 174 Forest_graph.iter_succ 160 - (fun w -> Forest_graph.add_edge dep_graph v w; f w) 161 - dep_graph 162 - v 175 + (fun w -> 176 + Forest_graph.add_edge dep_graph v w; 177 + f w) 178 + dep_graph v 163 179 in 164 180 f (T.Uri_vertex addr); 165 181 dep_graph ··· 167 183 let build forest = 168 184 let env = {forest; follow = false; graph = Forest_graph.create ()} in 169 185 let@ () = Analysis_env.run ~env in 170 - env.forest 171 - |> State.get_all_code 172 - |> Seq.iter analyse_tree; 186 + env.forest |> State.get_all_code |> Seq.iter analyse_tree; 173 187 env.graph
+1 -5
lib/compiler/Imports.mli
··· 6 6 7 7 open Forester_core 8 8 9 - type analysis_env = { 10 - follow: bool; 11 - forest: State.t; 12 - graph: Forest_graph.t; 13 - } 9 + type analysis_env = {follow: bool; forest: State.t; graph: Forest_graph.t} 14 10 15 11 val load_tree : Eio.Fs.dir_ty Eio.Path.t -> Lsp.Text_document.t 16 12 val build : State.t -> Forest_graph.t
+2 -8
lib/compiler/Job.ml
··· 7 7 open Forester_core 8 8 open Types 9 9 10 - type latex_to_svg_job = { 11 - hash: string; 12 - source: string; 13 - } 14 - [@@deriving show] 10 + type latex_to_svg_job = {hash: string; source: string} [@@deriving show] 15 11 16 12 let uri_for_latex_to_svg_job ~(base : URI.t) (job : latex_to_svg_job) = 17 13 URI_scheme.named_uri ~base @@ job.hash ^ ".svg" 18 14 19 - type job = 20 - | LaTeX_to_svg of latex_to_svg_job 21 - | Syndicate of content syndication 15 + type job = LaTeX_to_svg of latex_to_svg_job | Syndicate of content syndication 22 16 [@@deriving show]
+35 -30
lib/compiler/LaTeX_pipeline.ml
··· 6 6 7 7 open Forester_prelude 8 8 open Forester_core 9 - 10 9 module EP = Eio.Path 11 10 12 11 type env = Eio_unix.Stdenv.base 13 12 14 13 let indent_string string = 15 - string 16 - |> String.split_on_char '\n' 14 + string |> String.split_on_char '\n' 17 15 |> List.map (Format.sprintf "\t%s") 18 16 |> String.concat "\n" 19 17 20 - (* TODO: When error occurs on stderr, there is nothing informative in the diagnostic*) 18 + (* TODO: When error occurs on stderr, there is nothing informative in the 19 + diagnostic*) 21 20 let pipe_latex_dvi ~env ~tex_source ?loc kont = 22 21 let mgr = Eio.Stdenv.process_mgr env in 23 22 let@ tmp = Eio_util.with_open_tmp_dir ~env in 24 23 let tex_fn = "job.tex" in 25 24 begin 26 - let@ tex_sink = EP.with_open_out ~create: (`Or_truncate 0o644) EP.(tmp / tex_fn) in 25 + let@ tex_sink = 26 + EP.with_open_out ~create:(`Or_truncate 0o644) EP.(tmp / tex_fn) 27 + in 27 28 Eio.Flow.copy tex_source tex_sink 28 29 end; 29 30 begin ··· 31 32 let stdout = Eio.Flow.buffer_sink out_buf in 32 33 let stderr = Eio_util.null_sink () in 33 34 let cmd = ["latex"; "-halt-on-error"; "-interaction=nonstopmode"; tex_fn] in 34 - try 35 - Eio.Process.run ~cwd: tmp ~stdout ~stderr mgr cmd 36 - with 37 - | _ -> 38 - let formatted_output = Buffer.contents out_buf |> indent_string in 39 - Reporter.fatal 40 - External_error 41 - ~extra_remarks: [ 42 - Asai.Diagnostic.loctextf 43 - ?loc 44 - "Encountered fatal LaTeX error: @.@.%s@.@. while running `%s` in directory `%s`." 45 - formatted_output 46 - (String.concat " " cmd) 47 - (Eio.Path.native_exn tmp) 35 + try Eio.Process.run ~cwd:tmp ~stdout ~stderr mgr cmd 36 + with _ -> 37 + let formatted_output = Buffer.contents out_buf |> indent_string in 38 + Reporter.fatal External_error 39 + ~extra_remarks: 40 + [ 41 + Asai.Diagnostic.loctextf ?loc 42 + "Encountered fatal LaTeX error: @.@.%s@.@. while running `%s` in \ 43 + directory `%s`." 44 + formatted_output (String.concat " " cmd) (Eio.Path.native_exn tmp); 48 45 ] 49 46 end; 50 47 EP.with_open_in EP.(tmp / "job.dvi") kont ··· 54 51 let mgr = Eio.Stdenv.process_mgr env in 55 52 let err_buf = Buffer.create 1000 in 56 53 let stderr = Eio.Flow.buffer_sink err_buf in 57 - let cmd = ["dvisvgm"; "--exact"; "--clipjoin"; "--font-format=woff"; "--bbox=papersize"; "--zoom=1.5"; "--stdin"; "--stdout"] in 58 - try 59 - Eio.Process.run ~cwd ~stdin: dvi_source ~stdout: svg_sink ~stderr mgr cmd 60 - with 61 - | _ -> 62 - Reporter.fatal 63 - External_error 64 - ~extra_remarks: [ 65 - Asai.Diagnostic.loctextf 66 - ?loc 54 + let cmd = 55 + [ 56 + "dvisvgm"; 57 + "--exact"; 58 + "--clipjoin"; 59 + "--font-format=woff"; 60 + "--bbox=papersize"; 61 + "--zoom=1.5"; 62 + "--stdin"; 63 + "--stdout"; 64 + ] 65 + in 66 + try Eio.Process.run ~cwd ~stdin:dvi_source ~stdout:svg_sink ~stderr mgr cmd 67 + with _ -> 68 + Reporter.fatal External_error 69 + ~extra_remarks: 70 + [ 71 + Asai.Diagnostic.loctextf ?loc 67 72 "Encountered fatal error running `dvisvgm`: %s" 68 - (Buffer.contents err_buf) 73 + (Buffer.contents err_buf); 69 74 ] 70 75 71 76 let pipe_latex_svg ~env ?loc ~tex_source ~svg_sink () =
+1 -1
lib/compiler/LaTeX_pipeline.mli
··· 6 6 7 7 type env = Eio_unix.Stdenv.base 8 8 9 - val latex_to_svg : env: env -> ?loc: Asai.Range.t -> string -> string 9 + val latex_to_svg : env:env -> ?loc:Asai.Range.t -> string -> string
+2 -2
lib/compiler/LaTeX_template.mli
··· 4 4 * SPDX-License-Identifier: GPL-3.0-or-later 5 5 *) 6 6 7 - val pp : Format.formatter -> preamble: string -> body: string -> unit 8 - val to_string : preamble: string -> body: string -> string 7 + val pp : Format.formatter -> preamble:string -> body:string -> unit 8 + val to_string : preamble:string -> body:string -> string
+8 -9
lib/compiler/Parse.ml
··· 6 6 7 7 open Forester_prelude 8 8 open Forester_core 9 - 10 9 include Forester_parser.Parse 11 10 12 11 let parse_channel filename ch = ··· 23 22 lexbuf.lex_curr_p <- {lexbuf.lex_curr_p with pos_fname = path}; 24 23 parse lexbuf 25 24 |> Result.map (fun nodes -> 26 - Tree.{ 27 - nodes; 28 - origin = Physical doc; 29 - identity = URI (URI_scheme.path_to_uri ~base: config.url path); 30 - timestamp = Some (Unix.time ()); 31 - } 32 - ) 25 + Tree. 26 + { 27 + nodes; 28 + origin = Physical doc; 29 + identity = URI (URI_scheme.path_to_uri ~base:config.url path); 30 + timestamp = Some (Unix.time ()); 31 + }) 33 32 34 33 let parse_file filename = 35 34 let@ () = Reporter.tracef "when parsing file `%s`" filename in 36 35 let ch = open_in filename in 37 - Fun.protect ~finally: (fun _ -> close_in ch) @@ fun _ -> 36 + Fun.protect ~finally:(fun _ -> close_in ch) @@ fun _ -> 38 37 parse_channel filename ch
+2 -3
lib/compiler/Parse.mli
··· 8 8 include module type of Forester_parser.Parse 9 9 10 10 val parse_document : 11 - config: Config.t -> 11 + config:Config.t -> 12 12 Lsp.Text_document.t -> 13 13 (Forester_core.Tree.code, Forester_core.Reporter.diagnostic) result 14 14 15 15 val parse_file : 16 - string -> 17 - (Forester_core.Code.t, Forester_core.Reporter.diagnostic) result 16 + string -> (Forester_core.Code.t, Forester_core.Reporter.diagnostic) result
+76 -72
lib/compiler/Phases.ml
··· 8 8 open Forester_prelude 9 9 open Forester_core 10 10 11 - open struct module T = Types end 11 + open struct 12 + module T = Types 13 + end 12 14 13 15 open State.Syntax 14 16 15 17 let load (tree_dirs : Eio.Fs.dir_ty Eio.Path.t list) = 16 - Logs.debug (fun m -> m "loading trees from %i directories" (List.length tree_dirs)); 17 - Dir_scanner.scan_directories tree_dirs 18 - |> Seq.map Imports.load_tree 18 + Logs.debug (fun m -> 19 + m "loading trees from %i directories" (List.length tree_dirs)); 20 + Dir_scanner.scan_directories tree_dirs |> Seq.map Imports.load_tree 19 21 20 22 let parse (forest : State.t) = 21 23 let trees = forest.index |> URI.Tbl.to_seq_values |> List.of_seq in 22 24 let results = 23 25 let@ tree = List.filter_map @~ trees in 24 26 match tree with 25 - | Document doc -> Some (Parse.parse_document ~config: forest.config doc) 26 - | Parsed _ 27 - | Expanded _ 28 - | Resource _ -> 29 - None 27 + | Document doc -> Some (Parse.parse_document ~config:forest.config doc) 28 + | Parsed _ | Expanded _ | Resource _ -> None 30 29 in 31 30 let@ result = List.partition_map @~ results in 32 - match result with 33 - | Ok t -> Right t 34 - | Error d -> Left d 31 + match result with Ok t -> Right t | Error d -> Left d 35 32 36 33 let reparse (doc : Lsp.Text_document.t) (forest : State.t) = 37 34 Logs.debug (fun m -> m "reparsing"); 38 - let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url @@ Lsp.Text_document.documentUri doc in 39 - begin 40 - match Parse.parse_document ~config: forest.config doc with 41 - | Ok code -> 42 - forest.={uri} <- Parsed code; 43 - Imports.fixup code forest 44 - | Error d -> 45 - forest.?{uri} <- [d] 35 + let uri = 36 + URI_scheme.lsp_uri_to_uri ~base:forest.config.url 37 + @@ Lsp.Text_document.documentUri doc 38 + in 39 + begin match Parse.parse_document ~config:forest.config doc with 40 + | Ok code -> 41 + forest.={uri} <- Parsed code; 42 + Imports.fixup code forest 43 + | Error d -> forest.?{uri} <- [d] 46 44 end; 47 45 forest 48 46 ··· 51 49 let errors = ref [] in 52 50 let push d = errors := d :: !errors in 53 51 let new_graph = 54 - Reporter.run 55 - ~emit: push 56 - ~fatal: (fun d -> 52 + Reporter.run ~emit:push ~fatal:(fun d -> 57 53 push d; 58 54 Reporter.Tty.display d; 59 - forest.import_graph 60 - ) 61 - @@ fun () -> 62 - Imports.build forest 55 + forest.import_graph) 56 + @@ fun () -> Imports.build forest 63 57 in 64 - !errors, new_graph 58 + (!errors, new_graph) 65 59 66 - let expand (forest : State.t) = 67 - Expand.expand_tree ~forest 60 + let expand (forest : State.t) = Expand.expand_tree ~forest 68 61 69 62 let expand_all (forest : State.t) = 70 63 let diagnostics = ref [] in 71 64 let task vertex = 72 65 match vertex with 73 66 | T.Content_vertex _ -> assert false 74 - | T.Uri_vertex uri -> 67 + | T.Uri_vertex uri -> ( 75 68 match forest.={uri} with 76 - | None -> 77 - () 78 - | Some tree -> 69 + | None -> () 70 + | Some tree -> ( 79 71 match Tree.to_code tree with 80 72 | Some tree -> 81 73 let expanded, errors = Expand.expand_tree ~forest tree in ··· 84 76 forest.?{uri} <- errors 85 77 | None -> 86 78 Logs.debug (fun m -> m "expanding: no source code for %a" URI.pp uri); 87 - assert false; 79 + assert false)) 88 80 in 89 81 Forest_graph.topo_iter task forest.import_graph; 90 82 !diagnostics 91 83 92 84 let run_jobs (forest : State.t) jobs = 93 85 Logs.debug (fun m -> m "Running %d jobs" (List.length jobs)); 94 - (* All resources induced by LaTeX jobs must be planted prior to publication export. *) 86 + (* All resources induced by LaTeX jobs must be planted prior to publication 87 + export. *) 95 88 let resources_to_plant = 96 - let@ Range.{value; loc} = Eio.Fiber.List.map ~max_fibers: 20 @~ jobs in 89 + let@ Range.{value; loc} = Eio.Fiber.List.map ~max_fibers:20 @~ jobs in 97 90 let@ () = Reporter.easy_run in 98 91 match value with 99 92 | Job.LaTeX_to_svg job -> 100 - let svg = Build_latex.latex_to_svg ~env: forest.env ?loc job.source in 101 - let uri = Job.uri_for_latex_to_svg_job ~base: forest.config.url job in 93 + let svg = Build_latex.latex_to_svg ~env:forest.env ?loc job.source in 94 + let uri = Job.uri_for_latex_to_svg_job ~base:forest.config.url job in 102 95 T.Asset {uri; content = svg} 103 - | Job.Syndicate syndication -> 104 - T.Syndication syndication 96 + | Job.Syndicate syndication -> T.Syndication syndication 105 97 in 106 98 begin 107 - (* It is probably not save to plant the articles in parallel, so this is done sequentially! *) 99 + (* It is probably not save to plant the articles in parallel, so this is 100 + done sequentially! *) 108 101 let@ resource = List.iter @~ resources_to_plant in 109 102 State.plant_resource resource forest 110 103 end ··· 116 109 |> Seq.map (fun tree -> 117 110 let tree = Option.get @@ Tree.to_syn tree in 118 111 match identity_to_uri tree.identity with 119 - | None -> Reporter.fatal Internal_error ~extra_remarks: [Asai.Diagnostic.loctext "can't evaluate a tree with no URI"] 112 + | None -> 113 + Reporter.fatal Internal_error 114 + ~extra_remarks: 115 + [Asai.Diagnostic.loctext "can't evaluate a tree with no URI"] 120 116 | Some uri -> 121 117 let source_path = 122 - if forest.dev then 123 - URI.Tbl.find_opt forest.resolver uri 124 - else None 118 + if forest.dev then URI.Tbl.find_opt forest.resolver uri else None 125 119 in 126 - Eval.eval_tree 127 - ~config: forest.config 128 - ~source_path 129 - ~uri 130 - tree.nodes 131 - ) 120 + Eval.eval_tree ~config:forest.config ~source_path ~uri tree.nodes) 132 121 in 133 122 result 134 123 ··· 139 128 | Some (Parsed _) | Some (Resource _) -> assert false 140 129 | Some (Expanded expanded) -> 141 130 let source_path = 142 - if forest.dev then 143 - URI.Tbl.find_opt forest.resolver uri 144 - else None 131 + if forest.dev then URI.Tbl.find_opt forest.resolver uri else None 145 132 in 146 133 (* NOTE: Not running jobs. *) 147 134 let Eval.{articles; jobs = _}, diagnostics = 148 - Eval.eval_tree 149 - ~config: forest.config 150 - ~source_path 151 - ~uri 152 - expanded.nodes 135 + Eval.eval_tree ~config:forest.config ~source_path ~uri expanded.nodes 153 136 in 154 137 begin 155 138 let@ article = List.iter @~ articles in 156 139 State.plant_resource (Article article) forest 157 140 end; 158 - forest, diagnostics 141 + (forest, diagnostics) 159 142 160 143 let check_status _uri (forest : State.t) = 161 - match forest with 162 - | {dependency_cache = _; _} -> 163 - forest, None 144 + match forest with {dependency_cache = _; _} -> (forest, None) 164 145 165 146 let implant_foreign (state : State.t) : State.t * _ = 166 147 begin 167 - Logs.debug (fun m -> m "implanting %i foreign forests" (List.length state.config.foreign)); 148 + Logs.debug (fun m -> 149 + m "implanting %i foreign forests" (List.length state.config.foreign)); 168 150 let module EP = Eio.Path in 169 151 let@ foreign = List.iter @~ state.config.foreign in 170 - let path = Eio_util.path_of_file ~env: state.env foreign.path in 152 + let path = Eio_util.path_of_file ~env:state.env foreign.path in 171 153 let path_str = EP.native_exn path in 172 - Reporter.log Format.pp_print_string (Format.sprintf "Implant foreign forest from `%s'" path_str); 173 - let blob = try EP.load path with _ -> Reporter.fatal IO_error ~extra_remarks: [Asai.Diagnostic.loctextf "Could not read foreign forest blob at `%s`" path_str] in 154 + Reporter.log Format.pp_print_string 155 + (Format.sprintf "Implant foreign forest from `%s'" path_str); 156 + let blob = 157 + try EP.load path 158 + with _ -> 159 + Reporter.fatal IO_error 160 + ~extra_remarks: 161 + [ 162 + Asai.Diagnostic.loctextf 163 + "Could not read foreign forest blob at `%s`" path_str; 164 + ] 165 + in 174 166 match Repr.of_json_string (T.forest_t T.content_t) blob with 175 167 | Ok foreign_forest -> 176 168 let@ r = List.iter @~ foreign_forest in 177 - State.plant_resource ~route_locally: foreign.route_locally ~include_in_manifest: foreign.include_in_manifest r state 169 + State.plant_resource ~route_locally:foreign.route_locally 170 + ~include_in_manifest:foreign.include_in_manifest r state 178 171 | Error (`Msg err) -> 179 - Reporter.fatal Parse_error ~extra_remarks: [Asai.Diagnostic.loctextf "Could not parse foreign forest blob: %s" err] 172 + Reporter.fatal Parse_error 173 + ~extra_remarks: 174 + [ 175 + Asai.Diagnostic.loctextf "Could not parse foreign forest blob: %s" 176 + err; 177 + ] 180 178 | exception exn -> 181 - Reporter.fatal Parse_error ~extra_remarks: [Asai.Diagnostic.loctextf "Encountered unknown error while decoding foreign forest blob: %s" (Printexc.to_string exn)] 179 + Reporter.fatal Parse_error 180 + ~extra_remarks: 181 + [ 182 + Asai.Diagnostic.loctextf 183 + "Encountered unknown error while decoding foreign forest blob: %s" 184 + (Printexc.to_string exn); 185 + ] 182 186 end; 183 - state, [] 187 + (state, [])
+143 -157
lib/compiler/State.ml
··· 6 6 7 7 open Forester_prelude 8 8 open Forester_core 9 - 10 9 open Tree 11 10 open Forester_core 12 - open struct module T = Types end 11 + 12 + open struct 13 + module T = Types 14 + end 15 + 13 16 type resource = T.content T.resource 14 17 15 18 type t = { ··· 26 29 usages: (Tree.exports, URI.t Asai.Range.located) Hashtbl.t; 27 30 history: Action.t list; 28 31 hosts: (string, unit) Hashtbl.t; 29 - suggestions: URI.t URI.Tbl.t 32 + suggestions: URI.t URI.Tbl.t; 30 33 } 31 34 32 - let make 33 - ~(env : Eio_unix.Stdenv.base) 34 - ~(config : Config.t) 35 - ~(dev : bool) 36 - ?(graphs = (module Forest_graphs.Make (): Forest_graphs.S)) 37 - ?(import_graph = Forest_graph.create ~size: 1000 ()) 38 - ?(resolver = URI.Tbl.create 1000) 39 - ?(index = URI.Tbl.create 1000) 40 - ?(diagnostics = URI.Tbl.create 1000) 41 - ?(usages = Hashtbl.create 1000) 42 - ?(search_index = Forester_search.Index.create []) 43 - ?(dependency_cache = Cache.empty) 44 - ?(hosts = Hashtbl.create 10) 45 - ?(suggestions = URI.Tbl.create 1000) 46 - () 47 - = {env; dev; config; index; diagnostics; resolver; import_graph; graphs; search_index; dependency_cache; usages; hosts; suggestions; history = []} 35 + let make ~(env : Eio_unix.Stdenv.base) ~(config : Config.t) ~(dev : bool) 36 + ?(graphs = (module Forest_graphs.Make () : Forest_graphs.S)) 37 + ?(import_graph = Forest_graph.create ~size:1000 ()) 38 + ?(resolver = URI.Tbl.create 1000) ?(index = URI.Tbl.create 1000) 39 + ?(diagnostics = URI.Tbl.create 1000) ?(usages = Hashtbl.create 1000) 40 + ?(search_index = Forester_search.Index.create []) 41 + ?(dependency_cache = Cache.empty) ?(hosts = Hashtbl.create 10) 42 + ?(suggestions = URI.Tbl.create 1000) () = 43 + { 44 + env; 45 + dev; 46 + config; 47 + index; 48 + diagnostics; 49 + resolver; 50 + import_graph; 51 + graphs; 52 + search_index; 53 + dependency_cache; 54 + usages; 55 + hosts; 56 + suggestions; 57 + history = []; 58 + } 48 59 49 60 module Syntax = struct 50 - let (.={}) state uri = 51 - URI.Tbl.find_opt state.index uri 61 + let ( .={} ) state uri = URI.Tbl.find_opt state.index uri 52 62 53 - let (.={} <-) state uri tree = 63 + let ( .={}<- ) state uri tree = 54 64 match state.={uri} with 55 - | None -> 56 - URI.Tbl.replace state.index uri tree 65 + | None -> URI.Tbl.replace state.index uri tree 57 66 | Some existing -> 58 67 let o1 = Tree.origin tree in 59 68 let o2 = Tree.origin existing in 60 - if o1 <> o2 then 61 - begin 62 - Reporter.emit (Duplicate_tree (o1, o2)); 63 - URI.Tbl.replace state.index uri tree 64 - end 65 - else 69 + if o1 <> o2 then begin 70 + Reporter.emit (Duplicate_tree (o1, o2)); 66 71 URI.Tbl.replace state.index uri tree 72 + end 73 + else URI.Tbl.replace state.index uri tree 67 74 (* URI.Tbl.replace state.index uri item *) 68 75 69 76 (* / for units*) 70 - let (./{}) state uri = 71 - Option.bind 72 - (URI.Tbl.find_opt state.index uri) 73 - Tree.get_units 77 + let ( ./{} ) state uri = 78 + Option.bind (URI.Tbl.find_opt state.index uri) Tree.get_units 74 79 75 80 (* updating units*) 76 - let (./{} <-) state uri units = 81 + let ( ./{}<- ) state uri units = 77 82 let@ () = Reporter.tracef "when updating units for %a" URI.pp uri in 78 83 match URI.Tbl.find_opt state.index uri with 79 - | None -> Reporter.fatal Internal_error ~extra_remarks: [Asai.Diagnostic.loctextf "Updating units: %a not found" URI.pp uri] 80 - | Some (Document _) 81 - | Some (Parsed _) -> 82 - Reporter.fatal Internal_error ~extra_remarks: [Asai.Diagnostic.loctextf "%a has not been expanded yet" URI.pp uri] 84 + | None -> 85 + Reporter.fatal Internal_error 86 + ~extra_remarks: 87 + [Asai.Diagnostic.loctextf "Updating units: %a not found" URI.pp uri] 88 + | Some (Document _) | Some (Parsed _) -> 89 + Reporter.fatal Internal_error 90 + ~extra_remarks: 91 + [Asai.Diagnostic.loctextf "%a has not been expanded yet" URI.pp uri] 83 92 | Some (Expanded expanded) -> 84 - URI.Tbl.replace 85 - state.index 86 - uri 87 - (Expanded {expanded with units}) 93 + URI.Tbl.replace state.index uri (Expanded {expanded with units}) 88 94 | Some (Resource _) -> () 89 95 90 96 (* ? for diagnostics*) 91 - let (.?{}) state uri = 92 - Option.value ~default: [] (URI.Tbl.find_opt state.diagnostics uri) 97 + let ( .?{} ) state uri = 98 + Option.value ~default:[] (URI.Tbl.find_opt state.diagnostics uri) 93 99 94 - let (.?{} <-) state uri diagnostics = URI.Tbl.add state.diagnostics uri diagnostics 100 + let ( .?{}<- ) state uri diagnostics = 101 + URI.Tbl.add state.diagnostics uri diagnostics 95 102 96 103 (* @ for article/resource *) 97 - let (.@{}) state uri = 104 + let ( .@{} ) state uri = 98 105 match URI.Tbl.find_opt state.index uri with 99 106 | Some (Document _) -> None 100 - | Some (Parsed _) 101 - | Some (Expanded (_)) 102 - | None -> 103 - None 107 + | Some (Parsed _) | Some (Expanded _) | None -> None 104 108 | Some (Resource res) -> Some res.resource 105 109 end 106 110 107 111 open Syntax 108 112 109 - let update_history forest action = {forest with history = action :: forest.history} 113 + let update_history forest action = 114 + {forest with history = action :: forest.history} 110 115 111 116 let find_opt state uri = URI.Tbl.find_opt state.index uri 112 117 let to_seq state = URI.Tbl.to_seq state.index 113 118 114 119 let get_all_unparsed state = 115 - state.index 116 - |> URI.Tbl.to_seq_values 117 - |> Seq.filter is_unparsed 120 + state.index |> URI.Tbl.to_seq_values |> Seq.filter is_unparsed 118 121 119 122 let get_all_code state = 120 - state.index 121 - |> URI.Tbl.to_seq_values 122 - |> Seq.filter_map to_code 123 + state.index |> URI.Tbl.to_seq_values |> Seq.filter_map to_code 123 124 124 125 let get_all_unexpanded state = 125 - state.index 126 - |> URI.Tbl.to_seq_values 127 - |> Seq.filter is_unexpanded 126 + state.index |> URI.Tbl.to_seq_values |> Seq.filter is_unexpanded 128 127 129 128 let get_all_expanded state = 130 - state.index 131 - |> URI.Tbl.to_seq_values 132 - |> Seq.filter_map to_syn 129 + state.index |> URI.Tbl.to_seq_values |> Seq.filter_map to_syn 133 130 134 131 let get_all_unevaluated state = 135 - state.index 136 - |> URI.Tbl.to_seq_values 137 - |> Seq.filter is_unevaluated 132 + state.index |> URI.Tbl.to_seq_values |> Seq.filter is_unevaluated 138 133 139 - let get_all_articles : t -> T.content T.article Seq.t = fun state -> 140 - state.index 141 - |> URI.Tbl.to_seq_values 142 - |> Seq.filter_map to_article 134 + let get_all_articles : t -> T.content T.article Seq.t = 135 + fun state -> state.index |> URI.Tbl.to_seq_values |> Seq.filter_map to_article 143 136 144 - let get_all_evaluated : t -> evaluated Seq.t = fun state -> 145 - state.index 146 - |> URI.Tbl.to_seq_values 147 - |> Seq.filter_map to_evaluated 137 + let get_all_evaluated : t -> evaluated Seq.t = 138 + fun state -> 139 + state.index |> URI.Tbl.to_seq_values |> Seq.filter_map to_evaluated 148 140 149 - let get_all_resources : t -> T.content T.resource Seq.t = fun state -> 150 - state.index 151 - |> URI.Tbl.to_seq_values 152 - |> Seq.filter_map to_resource 141 + let get_all_resources : t -> T.content T.resource Seq.t = 142 + fun state -> state.index |> URI.Tbl.to_seq_values |> Seq.filter_map to_resource 153 143 154 144 let get_resource state uri = 155 - match state.={uri} with 156 - | None -> None 157 - | Some tree -> to_resource tree 145 + match state.={uri} with None -> None | Some tree -> to_resource tree 158 146 159 147 let get_code state uri = 160 - match state.={uri} with 161 - | None -> None 162 - | Some tree -> to_code tree 148 + match state.={uri} with None -> None | Some tree -> to_code tree 163 149 164 - let get_article : URI.t -> t -> T.content T.article option = fun uri forest -> 150 + let get_article : URI.t -> t -> T.content T.article option = 151 + fun uri forest -> 165 152 match URI.Tbl.find_opt forest.index uri with 166 - | None 167 - | Some (Document _) 168 - | Some (Parsed _) 169 - | Some (Expanded _) -> 170 - None 171 - | Some (Resource {resource; _}) -> 172 - match resource with 173 - | T.Article a -> Some a 174 - | _ -> None 153 + | None | Some (Document _) | Some (Parsed _) | Some (Expanded _) -> None 154 + | Some (Resource {resource; _}) -> ( 155 + match resource with T.Article a -> Some a | _ -> None) 175 156 176 157 let section_symbol = "§" 177 158 178 - let rec get_expanded_title ?scope ?(flags = T.{empty_when_untitled = false}) (frontmatter : _ T.frontmatter) forest = 159 + let rec get_expanded_title ?scope ?(flags = T.{empty_when_untitled = false}) 160 + (frontmatter : _ T.frontmatter) forest = 179 161 let short_title = 180 162 match frontmatter.title with 181 163 | Some content -> content 182 - | None when not flags.empty_when_untitled -> 183 - begin 184 - match frontmatter.uri with 185 - | Some uri -> T.Content [T.Uri uri] 186 - | _ -> T.Content [T.Text "Untitled"] 187 - end 164 + | None when not flags.empty_when_untitled -> begin 165 + match frontmatter.uri with 166 + | Some uri -> T.Content [T.Uri uri] 167 + | _ -> T.Content [T.Text "Untitled"] 168 + end 188 169 | _ -> T.Content [] 189 170 in 190 - Option.value ~default: short_title @@ 191 - match frontmatter.designated_parent with 192 - | Some parent_uri when not (Option.equal URI.equal scope frontmatter.designated_parent) -> 193 - let@ parent = Option.map @~ get_article parent_uri forest in 194 - let parent_title = get_expanded_title parent.frontmatter forest in 195 - let parent_link = T.Link {href = parent_uri; content = parent_title} in 196 - let chevron = T.Text " › " in 197 - T.map_content (fun xs -> parent_link :: chevron :: xs) short_title 198 - | _ -> None 171 + Option.value ~default:short_title 172 + @@ 173 + match frontmatter.designated_parent with 174 + | Some parent_uri 175 + when not (Option.equal URI.equal scope frontmatter.designated_parent) -> 176 + let@ parent = Option.map @~ get_article parent_uri forest in 177 + let parent_title = get_expanded_title parent.frontmatter forest in 178 + let parent_link = T.Link {href = parent_uri; content = parent_title} in 179 + let chevron = T.Text " › " in 180 + T.map_content (fun xs -> parent_link :: chevron :: xs) short_title 181 + | _ -> None 199 182 200 183 let get_content_of_transclusion (transclusion : T.transclusion) forest = 201 184 match transclusion.target with ··· 206 189 let@ article = Option.map @~ get_article transclusion.href forest in 207 190 article.mainmatter 208 191 | Title flags -> 209 - Option.some @@ 210 - begin 211 - match get_article transclusion.href forest with 212 - | None -> T.Content [T.Uri transclusion.href] 213 - | Some article -> get_expanded_title ~flags article.frontmatter forest 214 - end 192 + Option.some 193 + @@ begin match get_article transclusion.href forest with 194 + | None -> T.Content [T.Uri transclusion.href] 195 + | Some article -> get_expanded_title ~flags article.frontmatter forest 196 + end 215 197 | Taxon -> 216 198 let@ article = Option.map @~ get_article transclusion.href forest in 217 199 let default = T.Content [T.Text section_symbol] in ··· 220 202 let get_title_or_content_of_vertex ?(not_found = fun _ -> None) vertex forest = 221 203 match vertex with 222 204 | T.Content_vertex content -> Some content 223 - | T.Uri_vertex uri -> 224 - begin 225 - match get_article uri forest with 226 - | Some article -> article.frontmatter.title 227 - | None -> not_found uri 228 - end 205 + | T.Uri_vertex uri -> begin 206 + match get_article uri forest with 207 + | Some article -> article.frontmatter.title 208 + | None -> not_found uri 209 + end 229 210 230 - (* A list of mistakes that a user might make when typing a given URI. 231 - For example, they might type "https://www.forester-notes.com/005P" instead of "https://www.forester-notes.com/005P/". 232 - *) 211 + (* A list of mistakes that a user might make when typing a given URI. For 212 + example, they might type "https://www.forester-notes.com/005P" instead of 213 + "https://www.forester-notes.com/005P/". 214 + *) 233 215 let wrong_variants_for_uri uri = 234 216 let components = URI.path_components uri in 235 217 match List.rev components with ··· 237 219 [ 238 220 URI.with_path_components (List.rev rest) uri; 239 221 URI.with_path_components (components @ ["index.html"]) uri; 240 - URI.with_path_components (components @ ["index.xml"]) uri 222 + URI.with_path_components (components @ ["index.xml"]) uri; 241 223 ] 242 224 | _ -> [] 243 225 244 - type uri_suggestion = 245 - | Ok 246 - | Not_found of {suggestion: URI.t option} 226 + type uri_suggestion = Ok | Not_found of {suggestion: URI.t option} 247 227 248 228 let suggestion_for_uri uri forest = 249 229 match URI.host uri with 250 230 | None -> Ok 251 - | Some host -> 231 + | Some host -> ( 252 232 match Hashtbl.find_opt forest.hosts host with 253 233 | None -> Ok 254 - | Some() -> 234 + | Some () -> ( 255 235 match URI.Tbl.find_opt forest.index uri with 256 236 | Some _ -> Ok 257 237 | None -> Not_found {suggestion = URI.Tbl.find_opt forest.suggestions uri} 238 + )) 258 239 259 - let plant_resource ?(route_locally = true) ?(include_in_manifest = true) resource forest = 240 + let plant_resource ?(route_locally = true) ?(include_in_manifest = true) 241 + resource forest = 260 242 let module Graphs = (val forest.graphs) in 261 243 Forest.analyse_resource forest.graphs resource; 262 244 let@ uri = Option.iter @~ T.uri_for_resource resource in 263 - let uri = URI.canonicalise uri in (* Seems dodgy if this isn't already canonical! *) 245 + let uri = URI.canonicalise uri in 246 + (* Seems dodgy if this isn't already canonical! *) 264 247 Graphs.register_uri uri; 265 248 begin 266 249 let@ host = Option.iter @~ URI.host uri in ··· 272 255 end; 273 256 match forest.={uri} with 274 257 | None -> 275 - forest.={uri} <- Resource {resource; expanded = None; route_locally; include_in_manifest} 258 + forest.={uri} <- 259 + Resource {resource; expanded = None; route_locally; include_in_manifest} 276 260 | Some (Tree.Expanded syn) -> 277 - forest.={uri} <- Resource {resource; expanded = Some syn; route_locally; include_in_manifest} 261 + forest.={uri} <- 262 + Resource 263 + {resource; expanded = Some syn; route_locally; include_in_manifest} 278 264 | _ -> 279 - forest.={uri} <- Resource {resource; expanded = None; route_locally; include_in_manifest} 265 + forest.={uri} <- 266 + Resource {resource; expanded = None; route_locally; include_in_manifest} 280 267 281 - let serialize_graphs 282 - : (module Forest_graphs.S) -> 'a 283 - = fun s -> 268 + let serialize_graphs : (module Forest_graphs.S) -> 'a = 269 + fun s -> 284 270 let module Graphs = (val s) in 285 271 Graphs.dl_db 286 272 ··· 288 274 | {import_graph; _} -> 289 275 (* let dl_db = serialize_graphs graphs in *) 290 276 let open Cache in 291 - let module Gmap = Forest_graph.Map(Cache.Dependecy_graph) in 277 + let module Gmap = Forest_graph.Map (Cache.Dependecy_graph) in 292 278 let tbl = Dependency_tbl.create 100 in 293 279 let now = Unix.time () in 294 280 let g = 295 281 import_graph 296 282 |> Gmap.map @@ function 297 - | T.Content_vertex _ -> 298 - (*Import graph has no content vertices*) 299 - assert false 300 - | T.Uri_vertex uri -> 301 - let item = Item.Tree uri in 302 - Dependency_tbl.add tbl item Item.{timestamp = Some now; color = Green}; 303 - item 283 + | T.Content_vertex _ -> 284 + (*Import graph has no content vertices*) 285 + assert false 286 + | T.Uri_vertex uri -> 287 + let item = Item.Tree uri in 288 + Dependency_tbl.add tbl item 289 + Item.{timestamp = Some now; color = Green}; 290 + item 304 291 in 305 - {Cache.empty with graph = g; tbl;} 292 + {Cache.empty with graph = g; tbl} 306 293 307 - let reconstruct = fun ~env: _ ~(_config : Config.t) paths cache -> 294 + let reconstruct = 295 + fun ~env:_ ~(_config : Config.t) paths cache -> 308 296 match cache with 309 297 | {search_index = _; _} -> 310 298 (* let init = Phases.init ~env ~config ~dev: true in *) ··· 317 305 (* | Some tree -> *) 318 306 (* match check_timestamp path tree.timestamp with *) 319 307 (* | _ -> () *) 320 - () 321 - ) 308 + ()) 322 309 323 310 let rec lsp_uri_of_uri (uri : URI.t) (forest : t) : Lsp.Uri.t option = 324 311 let@ tree = Option.bind @@ find_opt forest uri in ··· 333 320 334 321 and lsp_uri_of_resource (resource : resource) (forest : t) : Lsp.Uri.t option = 335 322 match resource with 336 - | Article article -> Option.map Lsp.Uri.of_string article.frontmatter.source_path 323 + | Article article -> 324 + Option.map Lsp.Uri.of_string article.frontmatter.source_path 337 325 | Asset _ | Syndication _ -> None 338 326 339 327 and lsp_uri_of_origin (origin : origin) (forest : t) : Lsp.Uri.t option = ··· 343 331 | Undefined -> None 344 332 345 333 and lsp_uri_of_identity (identity : identity) (forest : t) : Lsp.Uri.t option = 346 - match identity with 347 - | URI uri -> lsp_uri_of_uri uri forest 348 - | Anonymous -> None 334 + match identity with URI uri -> lsp_uri_of_uri uri forest | Anonymous -> None 349 335 350 336 let source_path_of_uri uri forest = 351 - Option.map Lsp.Uri.to_path @@ lsp_uri_of_uri uri forest 337 + Option.map Lsp.Uri.to_path @@ lsp_uri_of_uri uri forest
+17 -21
lib/compiler/Suggestions.ml
··· 10 10 11 11 (* TODO: remove this in favor of https://github.com/ocaml/ocaml/pull/13760 *) 12 12 let edit_distance ~cutoff x y = 13 - let len_x, len_y = String.length x, String.length y in 13 + let len_x, len_y = (String.length x, String.length y) in 14 14 let grid = Array.make_matrix (len_x + 1) (len_y + 1) 0 in 15 15 for i = 1 to len_x do 16 16 grid.(i).(0) <- i ··· 23 23 let cost = if x.[i - 1] = y.[j - 1] then 0 else 1 in 24 24 let k = Int.min (grid.(i - 1).(j) + 1) (grid.(i).(j - 1) + 1) in 25 25 grid.(i).(j) <- Int.min k (grid.(i - 1).(j - 1) + cost) 26 - done; 26 + done 27 27 done; 28 28 let result = grid.(len_x).(len_y) in 29 - if result > cutoff then None 30 - else 31 - Some result 29 + if result > cutoff then None else Some result 32 30 33 - let suggestions ?prefix ~(cutoff : int) (p : Trie.bwd_path) : ('data, 'tag) Trie.t -> ('data, int) Trie.t = 31 + let suggestions ?prefix ~(cutoff : int) (p : Trie.bwd_path) : 32 + ('data, 'tag) Trie.t -> ('data, int) Trie.t = 34 33 let compare p d = 35 - edit_distance 36 - ~cutoff 34 + edit_distance ~cutoff 37 35 (String.concat "" (Bwd.to_list p)) 38 36 (String.concat "" (Bwd.to_list d)) 39 37 in ··· 42 40 if i > cutoff then None else Some (data, i) 43 41 44 42 let suggestions ~visible path = 45 - suggestions ~cutoff: 2 (Bwd.of_list path) visible 43 + suggestions ~cutoff:2 (Bwd.of_list path) visible 46 44 |> Trie.to_seq 47 45 |> Seq.map (fun (path, (data, distance)) -> (path, data, distance)) 48 46 |> List.of_seq ··· 52 50 let suggestions = suggestions ~visible path in 53 51 let extra_remarks = 54 52 if List.length suggestions > 0 then 55 - let (path, data, _) = List.hd suggestions in 53 + let path, data, _ = List.hd suggestions in 56 54 let location_hint = 57 55 match data with 58 - | Syn.Term ({loc = Some loc; _} :: _) -> 59 - begin 60 - match Range.view loc with 61 - | `End_of_file {source; _} 62 - | `Range ({source; _}, _) -> 63 - match Range.title source with 64 - | Some string -> 65 - [Asai.Diagnostic.loctextf "defined in %s" string] 66 - | _ -> [] 67 - end 56 + | Syn.Term ({loc = Some loc; _} :: _) -> begin 57 + match Range.view loc with 58 + | `End_of_file {source; _} | `Range ({source; _}, _) -> ( 59 + match Range.title source with 60 + | Some string -> [Asai.Diagnostic.loctextf "defined in %s" string] 61 + | _ -> []) 62 + end 68 63 | _ -> [] 69 64 in 70 - [Asai.Diagnostic.loctextf "Did you mean %a?" Trie.pp_path path] @ location_hint 65 + [Asai.Diagnostic.loctextf "Did you mean %a?" Trie.pp_path path] 66 + @ location_hint 71 67 else [] 72 68 in 73 69 extra_remarks
+19 -11
lib/compiler/Tape_effect.ml
··· 7 7 open Forester_core 8 8 9 9 module type S = sig 10 - val run : tape: Syn.t -> (unit -> 'a) -> 'a 10 + val run : tape:Syn.t -> (unit -> 'a) -> 'a 11 11 val pop_node_opt : unit -> Syn.node Range.located option 12 - 13 12 val pop_arg_opt : unit -> Syn.t Range.located option 14 - val pop_arg : loc: Range.t option -> Syn.t Range.located 13 + val pop_arg : loc:Range.t option -> Syn.t Range.located 15 14 val pop_args : unit -> Syn.t Range.located list 16 15 end 17 16 18 17 module Make () = struct 19 18 open Bwd 20 19 21 - module T = Algaeff.State.Make(struct type t = Syn.t end) 20 + module T = Algaeff.State.Make (struct 21 + type t = Syn.t 22 + end) 22 23 23 24 let pop_node_opt () = 24 25 match T.get () with ··· 29 30 30 31 let pop_arg_opt () = 31 32 match T.get () with 32 - | Range.{value = Syn.Group (Braces, arg); _} as node :: nodes -> 33 + | (Range.{value = Syn.Group (Braces, arg); _} as node) :: nodes -> 33 34 T.set nodes; 34 - Some ({node with value = arg}) 35 - | Range.{value = (Syn.Sym _ | Syn.Verbatim _ | Syn.Var _ | Syn.Dx_sequent _ | Syn.Dx_query _); _} as node :: nodes -> 35 + Some {node with value = arg} 36 + | (Range. 37 + { 38 + value = 39 + ( Syn.Sym _ | Syn.Verbatim _ | Syn.Var _ | Syn.Dx_sequent _ 40 + | Syn.Dx_query _ ); 41 + _; 42 + } as node) 43 + :: nodes -> 36 44 T.set nodes; 37 - Some ({node with value = [node]}) 45 + Some {node with value = [node]} 38 46 | _ -> None 39 47 40 48 let pop_arg ~loc = 41 49 match pop_arg_opt () with 42 50 | Some arg -> arg 43 - | None -> Reporter.fatal ?loc (Type_error {got = None; expected = [Argument]}) 51 + | None -> 52 + Reporter.fatal ?loc (Type_error {got = None; expected = [Argument]}) 44 53 45 54 let pop_args () = 46 55 let rec loop acc = ··· 50 59 in 51 60 loop Bwd.Emp 52 61 53 - let run ~tape = 54 - T.run ~init: tape 62 + let run ~tape = T.run ~init:tape 55 63 end
+2 -3
lib/compiler/Tape_effect.mli
··· 7 7 open Forester_core 8 8 9 9 module type S = sig 10 - val run : tape: Syn.t -> (unit -> 'a) -> 'a 10 + val run : tape:Syn.t -> (unit -> 'a) -> 'a 11 11 val pop_node_opt : unit -> Syn.node Range.located option 12 - 13 12 val pop_arg_opt : unit -> Syn.t Range.located option 14 - val pop_arg : loc: Range.t option -> Syn.t Range.located 13 + val pop_arg : loc:Range.t option -> Syn.t Range.located 15 14 val pop_args : unit -> Syn.t Range.located list 16 15 end 17 16
+26 -21
lib/compiler/URI_util.ml
··· 6 6 7 7 open Forester_prelude 8 8 open Forester_core 9 + 9 10 open struct 10 11 module L = Lsp.Types 11 12 end 12 13 13 14 let rec random_not_in keys = 14 - let attempt = Random.int (36 * 36 * 36 * 36 - 1) in 15 - if List.fold_left (fun x y -> x || y) false (List.map (fun k -> k = attempt) keys) then 16 - random_not_in keys 17 - else 18 - attempt 15 + let attempt = Random.int ((36 * 36 * 36 * 36) - 1) in 16 + if 17 + List.fold_left 18 + (fun x y -> x || y) 19 + false 20 + (List.map (fun k -> k = attempt) keys) 21 + then random_not_in keys 22 + else attempt 19 23 20 - let next_uri ~(prefix : string option) ~(mode : [< `Random | `Sequential]) ~(forest : State.t) : string = 21 - let addrs = 22 - forest.index 23 - |> URI.Tbl.to_seq 24 - |> Seq.map fst 25 - in 24 + let next_uri ~(prefix : string option) ~(mode : [< `Random | `Sequential]) 25 + ~(forest : State.t) : string = 26 + let addrs = forest.index |> URI.Tbl.to_seq |> Seq.map fst in 26 27 let config = forest.config in 27 28 let keys = 28 - List.of_seq @@ 29 - let@ uri = Seq.filter_map @~ addrs in 30 - if URI.host config.url = URI.host uri then 31 - let@ prefix', key = Option.bind @@ URI_scheme.split_addr uri in 32 - if prefix = prefix' then Some key else None 33 - else None 29 + List.of_seq 30 + @@ 31 + let@ uri = Seq.filter_map @~ addrs in 32 + if URI.host config.url = URI.host uri then 33 + let@ prefix', key = Option.bind @@ URI_scheme.split_addr uri in 34 + if prefix = prefix' then Some key else None 35 + else None 34 36 in 35 37 let next = 36 38 match mode with 37 39 | `Sequential -> 38 - let last_sequential = List.fold_left (fun acc_i i -> if i > acc_i then i else acc_i) 0 keys in 40 + let last_sequential = 41 + List.fold_left (fun acc_i i -> if i > acc_i then i else acc_i) 0 keys 42 + in 39 43 last_sequential + 1 40 44 | `Random -> random_not_in keys 41 45 in 42 - (match prefix with (None | Some "") -> "" | Some prefix -> prefix ^ "-") ^ BaseN.Base36.string_of_int next 46 + (match prefix with None | Some "" -> "" | Some prefix -> prefix ^ "-") 47 + ^ BaseN.Base36.string_of_int next 43 48 44 49 let start_of_file = 45 - let beginning = L.Position.create ~character: 0 ~line: 0 in 46 - L.Range.create ~start: beginning ~end_: beginning 50 + let beginning = L.Position.create ~character:0 ~line:0 in 51 + L.Range.create ~start:beginning ~end_:beginning
+5 -37
lib/compiler/Xml_forester.ml
··· 10 10 let forester_xmlns = {prefix = "fr"; xmlns = "http://www.forester-notes.org"} 11 11 let html_xlmns = {prefix = "html"; xmlns = "http://www.w3.org/1999/xhtml"} 12 12 let xml_xmlns = {prefix = "xml"; xmlns = "http://www.w3.org/XML/1998/namespace"} 13 - 14 13 let reserved_xmlnss = [forester_xmlns; html_xlmns; xml_xmlns] 15 - 16 14 let null = HTML.null 17 15 let null_ = HTML.null_ 18 - 19 - let conditional b n = 20 - if b then 21 - n 22 - else null [] 23 - 24 - let optional kont opt = 25 - match opt with 26 - | Some x -> kont x 27 - | None -> null [] 28 - 29 - let optional_ kont opt = 30 - match opt with 31 - | Some x -> kont x 32 - | None -> null_ 33 - 16 + let conditional b n = if b then n else null [] 17 + let optional kont opt = match opt with Some x -> kont x | None -> null [] 18 + let optional_ kont opt = match opt with Some x -> kont x | None -> null_ 34 19 let add_forester_ns name = Format.sprintf "%s:%s" forester_xmlns.prefix name 35 20 let add_html_ns name = Format.sprintf "%s:%s" html_xlmns.prefix name 36 - 37 21 let f_std_tag name = std_tag @@ add_forester_ns name 38 22 let f_text_tag name = text_tag @@ add_forester_ns name 39 - 40 23 let f_void_tag name attrs = std_tag (add_forester_ns name) attrs [] 41 24 let html_void_tag name attrs = std_tag (add_html_ns name) attrs [] 42 - 43 25 let info = f_std_tag "info" 44 - 45 26 let tree = f_std_tag "tree" 46 27 let numbered = bool_attr "numbered" 47 28 let toc = bool_attr "toc" ··· 50 31 let show_heading = bool_attr "show-heading" 51 32 let show_metadata = bool_attr "show-metadata" 52 33 let root = bool_attr "root" 53 - 54 34 let frontmatter = f_std_tag "frontmatter" 55 35 let mainmatter = f_std_tag "mainmatter" 56 36 let backmatter = f_std_tag "backmatter" 57 - 58 37 let taxon attrs = f_std_tag "taxon" attrs 59 38 let uri attrs = f_text_tag "uri" attrs 60 39 let display_uri attrs = f_text_tag "display-uri" attrs ··· 70 49 let author = f_std_tag "author" 71 50 let contributor = f_std_tag "contributor" 72 51 let title = f_std_tag "title" 73 - 74 52 let link = f_std_tag "link" 75 53 let type_ fmt = string_attr "type" fmt 76 54 let uri_ fmt = string_attr "uri" fmt 77 55 let display_uri_ fmt = string_attr "display-uri" fmt 78 56 let text_ fmt = string_attr "text" fmt 79 - 80 57 let number attrs = f_text_tag "number" attrs 81 - 82 58 let meta = f_std_tag "meta" 83 59 let name fmt = string_attr "name" fmt 84 - 85 - let tex attrs = f_text_tag ~raw: true "tex" attrs 60 + let tex attrs = f_text_tag ~raw:true "tex" attrs 86 61 let display fmt = string_attr "display" fmt 87 - 88 62 let title_ fmt = string_attr "title" fmt 89 - 90 63 let ref = f_void_tag "ref" 91 - 92 64 let number_ fmt = string_attr "number" fmt 93 - 94 65 let img = html_void_tag "img" 95 66 let src fmt = string_attr "src" fmt 96 - 97 67 let resource = f_std_tag "resource" 98 68 let resource_content = f_std_tag "resource-content" 99 - let resource_source attrs = f_text_tag ~raw: true "resource-source" attrs 69 + let resource_source attrs = f_text_tag ~raw:true "resource-source" attrs 100 70 let resource_part fmt = string_attr "part" fmt 101 - 102 71 let contextual_number = f_void_tag "contextual-number" 103 - 104 72 let hash fmt = string_attr "hash" fmt
-19
lib/compiler/Xml_forester.mli
··· 8 8 open Forester_xml_names 9 9 10 10 val reserved_xmlnss : xmlns_attr list 11 - 12 11 val conditional : bool -> node -> node 13 12 val optional : ('a -> node) -> 'a option -> node 14 13 val optional_ : ('a -> attr) -> 'a option -> attr 15 - 16 14 val null : node list -> node 17 15 val null_ : attr 18 - 19 16 val tree : std_tag 20 - 21 17 val numbered : bool to_attr 22 18 val toc : bool to_attr 23 19 val expanded : bool to_attr 24 20 val show_heading : bool to_attr 25 21 val show_metadata : bool to_attr 26 22 val hidden_when_empty : bool to_attr 27 - 28 23 val root : bool to_attr 29 - 30 24 val info : std_tag 31 - 32 25 val frontmatter : std_tag 33 26 val mainmatter : std_tag 34 27 val backmatter : std_tag 35 - 36 28 val taxon : std_tag 37 29 val uri : _ text_tag 38 30 val display_uri : _ text_tag ··· 41 33 val date : std_tag 42 34 val last_changed : std_tag 43 35 val title : std_tag 44 - 45 36 val href : _ string_attr 46 37 val year : _ text_tag 47 38 val month : _ text_tag 48 39 val day : _ text_tag 49 - 50 40 val authors : std_tag 51 41 val author : std_tag 52 42 val contributor : std_tag 53 - 54 43 val link : std_tag 55 44 val type_ : _ string_attr 56 45 val uri_ : _ string_attr 57 46 val display_uri_ : _ string_attr 58 47 val title_ : _ string_attr 59 48 val text_ : _ string_attr 60 - 61 49 val number : _ text_tag 62 - 63 50 val meta : std_tag 64 51 val name : _ string_attr 65 - 66 52 val tex : _ text_tag 67 53 val display : _ string_attr 68 - 69 54 val ref : void_tag 70 55 val number_ : _ string_attr 71 - 72 56 val img : void_tag 73 57 val src : _ string_attr 74 - 75 58 val contextual_number : void_tag 76 - 77 59 val resource : std_tag 78 60 val resource_content : std_tag 79 61 val resource_source : _ text_tag 80 62 val resource_part : _ string_attr 81 - 82 63 val hash : _ string_attr
+91 -83
lib/compiler/test/Test_compiler.ml
··· 11 11 open Testables 12 12 open State.Syntax 13 13 14 - open struct module T = Types end 14 + open struct 15 + module T = Types 16 + end 15 17 16 18 let config = Config.default () 17 19 ··· 24 26 let t6 = {path = "t6.tree"; content = {||}} in 25 27 let t7 = {path = "t7.tree"; content = {||}} in 26 28 let t8 = {path = "t8.tree"; content = {||}} in 27 - [t1; t2; t3; t4; t5; t6; t7; t8;] 29 + [t1; t2; t3; t4; t5; t6; t7; t8] 28 30 29 31 let test_batch_run ~env () = 30 32 let forest, history = 31 - let@ path = 32 - with_test_forest 33 - ~raw_trees 34 - ~env 35 - ~config 36 - in 33 + let@ path = with_test_forest ~raw_trees ~env ~config in 37 34 Sys.chdir (Eio.Path.native_exn path); 38 35 let@ () = Reporter.easy_run in 39 - let forest = State.make ~env ~config ~dev: false () in 36 + let forest = State.make ~env ~config ~dev:false () in 40 37 Driver.run_with_history Load_all_configured_dirs forest 41 38 in 42 39 Alcotest.(check @@ list action) ··· 51 48 Done; 52 49 ] 53 50 history; 54 - Alcotest.(check @@ int) "no tree is unparsed" 0 (Seq.length (State.get_all_unparsed forest)); 55 - Alcotest.(check @@ int) "no tree is unexpanded" 0 (Seq.length (State.get_all_unexpanded forest)); 56 - Alcotest.(check @@ int) "no tree is unevaluated" 0 (Seq.length (State.get_all_unevaluated forest)); 57 - Alcotest.(check @@ int) "has correct number of articles" 8 (Seq.length (State.get_all_articles forest)) 51 + Alcotest.(check @@ int) 52 + "no tree is unparsed" 0 53 + (Seq.length (State.get_all_unparsed forest)); 54 + Alcotest.(check @@ int) 55 + "no tree is unexpanded" 0 56 + (Seq.length (State.get_all_unexpanded forest)); 57 + Alcotest.(check @@ int) 58 + "no tree is unevaluated" 0 59 + (Seq.length (State.get_all_unevaluated forest)); 60 + Alcotest.(check @@ int) 61 + "has correct number of articles" 8 62 + (Seq.length (State.get_all_articles forest)) 58 63 59 64 let test_includes_paths ~env () = 60 65 let@ () = Reporter.easy_run in 61 66 let config = Config.default () in 62 67 with_test_forest ~raw_trees ~env ~config (fun path -> 63 - Sys.chdir (Eio.Path.native_exn path); 64 - let@ () = Reporter.easy_run in 65 - let forest, history = 66 - State.make ~env ~config ~dev: true () 67 - |> Driver.run_with_history Load_all_configured_dirs 68 - in 69 - Alcotest.(check int) "number of parsed trees" 8 (URI.Tbl.length forest.index); 70 - Alcotest.(check int) "number of trees in resolver" 8 (URI.Tbl.length forest.resolver); 71 - Alcotest.(check @@ list action) 72 - "evaluation succeeded" 73 - [ 74 - Load_all_configured_dirs; 75 - Parse_all; 76 - Build_import_graph; 77 - Expand_all; 78 - Eval_all; 79 - (Run_jobs []); 80 - Done 81 - ] 82 - history; 83 - let uri = (URI.of_string_exn "http://forest.local/t8/") in 84 - let path = 85 - match forest.@{uri} with 86 - | Some (Article {frontmatter = {source_path; _}; _}) -> 87 - source_path 88 - | Some _ -> 89 - Alcotest.fail "not an article" 90 - | None -> 91 - URI.Tbl.iter (fun uri _ -> Logs.debug (fun m -> m "%a" URI.pp uri)) forest.index; 92 - Alcotest.fail "not found" 93 - in 94 - Alcotest.(check bool) "path is some" true (Option.is_some path) 95 - ) 68 + Sys.chdir (Eio.Path.native_exn path); 69 + let@ () = Reporter.easy_run in 70 + let forest, history = 71 + State.make ~env ~config ~dev:true () 72 + |> Driver.run_with_history Load_all_configured_dirs 73 + in 74 + Alcotest.(check int) 75 + "number of parsed trees" 8 76 + (URI.Tbl.length forest.index); 77 + Alcotest.(check int) 78 + "number of trees in resolver" 8 79 + (URI.Tbl.length forest.resolver); 80 + Alcotest.(check @@ list action) 81 + "evaluation succeeded" 82 + [ 83 + Load_all_configured_dirs; 84 + Parse_all; 85 + Build_import_graph; 86 + Expand_all; 87 + Eval_all; 88 + Run_jobs []; 89 + Done; 90 + ] 91 + history; 92 + let uri = URI.of_string_exn "http://forest.local/t8/" in 93 + let path = 94 + match forest.@{uri} with 95 + | Some (Article {frontmatter = {source_path; _}; _}) -> source_path 96 + | Some _ -> Alcotest.fail "not an article" 97 + | None -> 98 + URI.Tbl.iter 99 + (fun uri _ -> Logs.debug (fun m -> m "%a" URI.pp uri)) 100 + forest.index; 101 + Alcotest.fail "not found" 102 + in 103 + Alcotest.(check bool) "path is some" true (Option.is_some path)) 96 104 97 105 let test_reparsing ~env () = 98 106 let config = Config.default () in 99 107 let@ tmp_path = with_test_forest ~raw_trees ~env ~config in 100 - Logs.app (fun m -> m "In temp dir %s" (Unix.realpath @@ Eio.Path.native_exn tmp_path)); 108 + Logs.app (fun m -> 109 + m "In temp dir %s" (Unix.realpath @@ Eio.Path.native_exn tmp_path)); 101 110 let@ () = Reporter.easy_run in 102 111 let forest = 103 - State.make ~env ~config ~dev: false () 112 + State.make ~env ~config ~dev:false () 104 113 |> Driver.run_until_done Load_all_configured_dirs 105 114 in 106 115 let reparse_addr = "t8.tree" in 107 - let reparse_uri = URI_scheme.path_to_uri ~base: config.url reparse_addr in 116 + let reparse_uri = URI_scheme.path_to_uri ~base:config.url reparse_addr in 108 117 let vtx = T.Uri_vertex reparse_uri in 109 118 Alcotest.(check int) 110 - "Number of vertices before reparsing" 111 - 8 119 + "Number of vertices before reparsing" 8 112 120 (Forest_graph.nb_vertex forest.import_graph); 113 121 Alcotest.(check int) 114 - "old vertex has no import" 115 - 0 122 + "old vertex has no import" 0 116 123 (Forest_graph.in_degree forest.import_graph vtx); 117 124 let _, path = 118 - Option.get @@ 119 - Seq.find_map 120 - (fun (uri, path) -> 121 - if String.ends_with ~suffix: "t8.tree" path then 122 - begin 123 - Logs.debug (fun m -> m "%s" path); 124 - Some (uri, Eio.Path.(forest.env#fs / path)) 125 - end 126 - else 127 - None 128 - ) 129 - (URI.Tbl.to_seq forest.resolver) 125 + Option.get 126 + @@ Seq.find_map 127 + (fun (uri, path) -> 128 + if String.ends_with ~suffix:"t8.tree" path then begin 129 + Logs.debug (fun m -> m "%s" path); 130 + Some (uri, Eio.Path.(forest.env#fs / path)) 131 + end 132 + else None) 133 + (URI.Tbl.to_seq forest.resolver) 130 134 in 131 - Eio.Path.save ~create: (`Or_truncate 0o644) path {|\import{t1}|}; 135 + Eio.Path.save ~create:(`Or_truncate 0o644) path {|\import{t1}|}; 132 136 let reparsed = Driver.run_until_done (Load_tree path) forest in 133 - Alcotest.(check bool) "vertex has an import" true (Forest_graph.in_degree reparsed.import_graph vtx > 0) 137 + Alcotest.(check bool) 138 + "vertex has an import" true 139 + (Forest_graph.in_degree reparsed.import_graph vtx > 0) 134 140 135 141 let test_omits_paths ~env () = 136 142 let@ () = Reporter.easy_run in 137 - let forest = Driver.batch_run ~env ~config ~dev: false in 143 + let forest = Driver.batch_run ~env ~config ~dev:false in 138 144 let path = 139 145 match forest.@{URI.of_string_exn "http://forest.local/t8/"} with 140 146 | Some (Article {frontmatter = {source_path; _}; _}) -> source_path 141 - | Some _ -> 142 - Alcotest.fail "not an article" 147 + | Some _ -> Alcotest.fail "not an article" 143 148 | None -> 144 - URI.Tbl.iter (fun uri _ -> Logs.debug (fun m -> m "%a" URI.pp uri)) forest.index; 149 + URI.Tbl.iter 150 + (fun uri _ -> Logs.debug (fun m -> m "%a" URI.pp uri)) 151 + forest.index; 145 152 Alcotest.fail "not found" 146 153 in 147 154 Alcotest.(check bool) "" true @@ Option.is_none path ··· 151 158 Logs.set_level (Some Debug); 152 159 Logs.set_reporter (Logs.format_reporter ()); 153 160 let open Alcotest in 154 - run 155 - "Test_driver" 161 + run "Test_driver" 156 162 [ 157 - "Steps", 158 - [ 159 - test_case "Batch compilation steps" `Quick (test_batch_run ~env); 160 - test_case "reparsing" `Quick (test_reparsing ~env); 161 - ]; 162 - "dev mode", 163 - [ 164 - test_case "includes paths in dev mode" `Quick (test_includes_paths ~env); 165 - test_case "omits paths outside dev mode" `Quick (test_omits_paths ~env); 166 - ] 163 + ( "Steps", 164 + [ 165 + test_case "Batch compilation steps" `Quick (test_batch_run ~env); 166 + test_case "reparsing" `Quick (test_reparsing ~env); 167 + ] ); 168 + ( "dev mode", 169 + [ 170 + test_case "includes paths in dev mode" `Quick 171 + (test_includes_paths ~env); 172 + test_case "omits paths outside dev mode" `Quick 173 + (test_omits_paths ~env); 174 + ] ); 167 175 ]
-1
lib/compiler/test/Test_diagnostic_store.ml
··· 1 -
+23 -35
lib/compiler/test/Test_errors.ml
··· 17 17 18 18 let _test_parse_error_explanation src expect = 19 19 Alcotest.(check @@ result code string) 20 - "" 21 - (Result.Error expect) 22 - ( 23 - parse_string src 24 - |> Result.map_error 25 - (fun d -> Asai.Diagnostic.string_of_text d.explanation.value) 26 - ) 20 + "" (Result.Error expect) 21 + (parse_string src 22 + |> Result.map_error (fun d -> 23 + Asai.Diagnostic.string_of_text d.explanation.value)) 27 24 28 - let raw_trees = [ 29 - { 30 - path = "parse_error.tree"; 31 - content = "\\})--aa]jv" 32 - }; 33 - { 34 - path = "import_error.tree"; 35 - content = {|\import{nonexistent}|} 36 - } 37 - ] 25 + let raw_trees = 26 + [ 27 + {path = "parse_error.tree"; content = "\\})--aa]jv"}; 28 + {path = "import_error.tree"; content = {|\import{nonexistent}|}}; 29 + ] 38 30 39 31 let check_diagnostic expect kont = 40 - let fatal = fun d -> 41 - Alcotest.(check message) 42 - "" 43 - expect 44 - (d.message) 45 - in 32 + let fatal = fun d -> Alcotest.(check message) "" expect d.message in 46 33 let emit = Fun.const () in 47 - Reporter.run ~fatal ~emit (fun () -> kont (); ()) 34 + Reporter.run ~fatal ~emit (fun () -> 35 + kont (); 36 + ()) 48 37 49 38 let () = 50 39 let@ env = Eio_main.run in ··· 52 41 let _test () = 53 42 let@ tmp_dir = with_test_forest ~env ~raw_trees ~config in 54 43 Sys.chdir (Eio.Path.native_exn tmp_dir); 55 - let@ () = check_diagnostic (Resource_not_found (URI.of_string_exn "asdf")) in 44 + let@ () = 45 + check_diagnostic (Resource_not_found (URI.of_string_exn "asdf")) 46 + in 56 47 let@ () = Reporter.easy_run in 57 - let forest = Driver.batch_run ~env ~config ~dev: false in 48 + let forest = Driver.batch_run ~env ~config ~dev:false in 58 49 Alcotest.(check @@ list action) 59 50 "" 60 51 [ ··· 63 54 Build_import_graph; 64 55 Expand_all; 65 56 Eval_all; 66 - (Run_jobs []); 67 - Done 57 + Run_jobs []; 58 + Done; 68 59 ] 69 60 (List.rev forest.history); 70 - Alcotest.(check int) "" 1 (URI.Tbl.length forest.diagnostics); 61 + Alcotest.(check int) "" 1 (URI.Tbl.length forest.diagnostics) 71 62 in 72 63 let open Alcotest in 73 - run 74 - "verify error reporting" 75 - [ 76 - (* "parsing", *) 64 + run "verify error reporting" 65 + [ (* "parsing", *) 77 66 (* [ *) 78 67 (* test_case "nonexistent tree" `Quick test; *) 79 68 (* ]; *) ··· 84 73 (* [ *) 85 74 (* ]; *) 86 75 (* "driver", *) 87 - (* []; *) 88 - ] 76 + (* []; *) ]
+37 -41
lib/compiler/test/Test_expansion.ml
··· 12 12 open Forester_frontend 13 13 open Testables 14 14 15 - open struct module T = Types end 15 + open struct 16 + module T = Types 17 + end 16 18 17 19 open struct 18 20 module S = Resolver.Scope 19 21 module P = Resolver.P 22 + 20 23 let config = Config.default () 21 - let _data = Alcotest.testable Syn.pp_resolver_data (=) 24 + let _data = Alcotest.testable Syn.pp_resolver_data ( = ) 22 25 end 23 26 24 27 open State.Syntax 25 28 26 29 let expand ~forest src = 27 30 let@ code = Result.map @~ parse_string_no_loc src in 28 - S.run ~init_visible: Expand.initial_visible_trie @@ fun () -> 31 + S.run ~init_visible:Expand.initial_visible_trie @@ fun () -> 29 32 Expand.expand ~forest code 30 33 31 34 let render ~forest expanded = 32 35 Result.map 33 36 (fun expanded -> 34 37 let Eval.{articles; _}, _ = 35 - Eval.eval_tree 36 - ~config: (Config.default ()) 37 - ~uri: (URI.of_string_exn "http://localhost/test") 38 - ~source_path: None 39 - expanded 38 + Eval.eval_tree ~config:(Config.default ()) 39 + ~uri:(URI.of_string_exn "http://localhost/test") 40 + ~source_path:None expanded 40 41 in 41 42 let () = 42 43 List.iter 43 44 (fun article -> 44 45 let@ uri = Option.iter @~ T.(article.frontmatter.uri) in 45 - forest.={uri} <- Resource {resource = Article article; expanded = None; route_locally = true; include_in_manifest = true} 46 - ) 46 + forest.={uri} <- 47 + Resource 48 + { 49 + resource = Article article; 50 + expanded = None; 51 + route_locally = true; 52 + include_in_manifest = true; 53 + }) 47 54 articles 48 55 in 49 56 let rendered = 50 57 List.map 51 58 (fun article -> 52 - Plain_text_client.string_of_content ~forest T.(article.mainmatter) 53 - ) 59 + Plain_text_client.string_of_content ~forest T.(article.mainmatter)) 54 60 articles 55 61 in 56 - String.concat "" rendered 57 - ) 62 + String.concat "" rendered) 58 63 expanded 59 64 60 65 let test_subtree ~env () = 61 66 let@ () = Reporter.easy_run in 62 - let forest = State.make ~env ~config ~dev: false () in 67 + let forest = State.make ~env ~config ~dev:false () in 63 68 let expanded = 64 - expand 65 - ~forest 69 + expand ~forest 66 70 {| 67 71 \subtree[foo]{ 68 72 \title{Hello} ··· 72 76 in 73 77 let evaluated = render ~forest expanded in 74 78 Alcotest.(check @@ result string diagnostic) 75 - "" 76 - ( 77 - Ok 78 - {|<omitted content: Hello>|} 79 - ) 80 - evaluated 79 + "" (Ok {|<omitted content: Hello>|}) evaluated 81 80 82 81 let test_visible ~env () = 83 - let forest = State.make ~env ~config ~dev: false () in 82 + let forest = State.make ~env ~config ~dev:false () in 84 83 let code = 85 - Result.get_ok @@ 86 - parse_string 87 - {| 84 + Result.get_ok 85 + @@ parse_string {| 88 86 \def\greet[name]{Hello, \name!} 89 87 \p{\greet{Jon}} 90 88 |} 91 89 in 92 90 let result = 93 - Trie.to_seq @@ 94 - Analysis.get_visible ~forest ~position: {line = 2; character = 5;} code 91 + Trie.to_seq 92 + @@ Analysis.get_visible ~forest ~position:{line = 2; character = 5} code 95 93 in 96 94 let greet = 97 - let@ (path, _) = Option.map @~ Seq.find (fun (p, _) -> p = ["greet"]) result in 95 + let@ path, _ = 96 + Option.map @~ Seq.find (fun (p, _) -> p = ["greet"]) result 97 + in 98 98 path 99 99 in 100 - Alcotest.(check (option path)) 101 - "greet is visible" 102 - (Some (["greet"])) 103 - greet 100 + Alcotest.(check (option path)) "greet is visible" (Some ["greet"]) greet 104 101 105 102 let () = 106 103 Logs.set_level (Some Debug); 107 104 Logs.set_reporter (Logs.format_reporter ()); 108 105 let open Alcotest in 109 106 let@ env = Eio_main.run in 110 - run 111 - "Test_expansion" 107 + run "Test_expansion" 112 108 [ 113 - "", 114 - [ 115 - test_case "subtree" `Quick (test_subtree ~env); 116 - test_case "get_visible" `Quick (test_visible ~env); 117 - ] 109 + ( "", 110 + [ 111 + test_case "subtree" `Quick (test_subtree ~env); 112 + test_case "get_visible" `Quick (test_visible ~env); 113 + ] ); 118 114 ]
+50 -70
lib/compiler/test/Test_import_graph.ml
··· 10 10 open Forester_test 11 11 open Testables 12 12 13 - open struct module T = Types end 13 + open struct 14 + module T = Types 15 + end 14 16 15 17 let config = {(Config.default ()) with trees = ["imports"]} 16 - 17 - let mk_vertex v = T.Uri_vertex (URI_scheme.named_uri ~base: config.url v) 18 - 19 - let has_edge g v w = 20 - Forest_graph.mem_edge g (mk_vertex v) (mk_vertex w) 18 + let mk_vertex v = T.Uri_vertex (URI_scheme.named_uri ~base:config.url v) 19 + let has_edge g v w = Forest_graph.mem_edge g (mk_vertex v) (mk_vertex w) 21 20 22 21 (* 23 - ┌─1 24 - │ ┌─4 25 - │ ├─5 26 - ├─2─┬─3─┼─6 27 - index─┤ │ └─7 28 - │ └─8 29 - ├─9 30 - └─10 22 + ┌─1 │ ┌─4 │ ├─5 ├─2─┬─3─┼─6 index─┤ │ └─7 │ └─8 ├─9 └─10 31 23 *) 32 24 33 - let raw_trees = [ 34 - { 35 - path = "index.tree"; 36 - content = {| 25 + let raw_trees = 26 + [ 27 + { 28 + path = "index.tree"; 29 + content = 30 + {| 37 31 \import{1} 38 32 \import{2} 39 33 \import{9} 40 34 \import{10} 41 - |} 42 - }; 43 - { 44 - path = "1.tree"; 45 - content = {||} 46 - }; 47 - { 48 - path = "2.tree"; 49 - content = {| 35 + |}; 36 + }; 37 + {path = "1.tree"; content = {||}}; 38 + {path = "2.tree"; content = {| 50 39 \import{3} 51 40 \import{8} 52 - |} 53 - }; 54 - { 55 - path = "3.tree"; 56 - content = {| 41 + |}}; 42 + { 43 + path = "3.tree"; 44 + content = 45 + {| 57 46 \import{4} 58 47 \import{5} 59 48 \import{6} 60 49 \import{7} 61 - |} 62 - }; 63 - {path = "4.tree"; content = {||}}; 64 - {path = "5.tree"; content = {||}}; 65 - {path = "6.tree"; content = {||}}; 66 - {path = "7.tree"; content = {||}}; 67 - {path = "8.tree"; content = {||}}; 68 - {path = "9.tree"; content = {||}}; 69 - {path = "10.tree"; content = {||}}; 70 - {path = "11.tree"; content = {||}}; 71 - {path = "12.tree"; content = {||}}; 72 - ] 50 + |}; 51 + }; 52 + {path = "4.tree"; content = {||}}; 53 + {path = "5.tree"; content = {||}}; 54 + {path = "6.tree"; content = {||}}; 55 + {path = "7.tree"; content = {||}}; 56 + {path = "8.tree"; content = {||}}; 57 + {path = "9.tree"; content = {||}}; 58 + {path = "10.tree"; content = {||}}; 59 + {path = "11.tree"; content = {||}}; 60 + {path = "12.tree"; content = {||}}; 61 + ] 73 62 74 63 let test_import_graph ~env () = 75 64 let@ () = Reporter.easy_run in 76 65 let@ tmp_dir = with_test_forest ~env ~config ~raw_trees in 77 66 Sys.chdir (Eio.Path.native_exn tmp_dir); 78 67 let forest, history = 79 - State.make ~env ~config ~dev: false () 68 + State.make ~env ~config ~dev:false () 80 69 |> Driver.run_with_history Load_all_configured_dirs 81 70 in 82 71 Alcotest.(check @@ list action) ··· 87 76 Build_import_graph; 88 77 Expand_all; 89 78 Eval_all; 90 - (Run_jobs []); 91 - Done 79 + Run_jobs []; 80 + Done; 92 81 ] 93 82 history; 94 83 (* Alcotest.(check int) *) ··· 96 85 (* (Hashtbl.length forest.documents) *) 97 86 (* (Forest.length forest.parsed); *) 98 87 Alcotest.(check bool) 99 - "has some edges" 100 - true 101 - ( 102 - List.for_all 103 - Fun.id 104 - [ 105 - List.for_all 106 - (fun v -> has_edge forest.import_graph v "3") 107 - [ 108 - "4"; 109 - "5"; 110 - "6"; 111 - "7"; 112 - ]; 113 - has_edge forest.import_graph "2" "index"; 114 - ] 115 - ) 88 + "has some edges" true 89 + (List.for_all Fun.id 90 + [ 91 + List.for_all 92 + (fun v -> has_edge forest.import_graph v "3") 93 + ["4"; "5"; "6"; "7"]; 94 + has_edge forest.import_graph "2" "index"; 95 + ]) 116 96 117 97 let () = 118 98 let@ env = Eio_main.run in 119 99 Logs.set_level (Some Debug); 120 100 Logs.set_reporter (Logs_fmt.reporter ()); 121 101 let open Alcotest in 122 - run 123 - "Import_graph" 102 + run "Import_graph" 124 103 [ 125 - "creating import graph", 126 - [ 127 - test_case "parsing and creating the import graph" `Quick (test_import_graph ~env); 128 - ]; 104 + ( "creating import graph", 105 + [ 106 + test_case "parsing and creating the import graph" `Quick 107 + (test_import_graph ~env); 108 + ] ); 129 109 ]
+5 -8
lib/compiler/test/Test_incremental_compilation.ml
··· 9 9 open Forester_prelude 10 10 open Forester_frontend 11 11 12 - open struct module T = Types end 12 + open struct 13 + module T = Types 14 + end 13 15 14 16 let () = 15 17 let@ env = Eio_main.run in 16 18 let open Alcotest in 17 - run 18 - "Test_incremental_compilation" 19 - [ 20 - "", 21 - [] 22 - (* [test_case "separate" `Quick test_separate] *) 23 - ] 19 + run "Test_incremental_compilation" 20 + [("", []) (* [test_case "separate" `Quick test_separate] *)]
+3 -11
lib/compiler/test/Test_uri_util.ml
··· 8 8 9 9 let test_baseN () = 10 10 Alcotest.(check @@ option int) 11 - "" 12 - (Some 460198) 11 + "" (Some 460198) 13 12 (BaseN.Base36.int_of_string "9V3A"); 14 - Alcotest.(check string) 15 - "" 16 - "9V3A" 17 - (BaseN.Base36.string_of_int 460198) 13 + Alcotest.(check string) "" "9V3A" (BaseN.Base36.string_of_int 460198) 18 14 19 15 let () = 20 16 let open Alcotest in 21 - run 22 - "URI_util" 23 - [ 24 - "BaseN", [test_case "" `Quick test_baseN]; 25 - ] 17 + run "URI_util" [("BaseN", [test_case "" `Quick test_baseN])]
+16 -39
lib/core/Base.ml
··· 4 4 * SPDX-License-Identifier: GPL-3.0-or-later 5 5 *) 6 6 7 - type eval_mode = 8 - | Text_mode 9 - | TeX_mode 10 - [@@deriving show, repr] 11 - 12 - type binding_info = 13 - | Strict 14 - | Lazy 15 - [@@deriving show, repr] 16 - 17 - type 'a binding = binding_info * 'a 18 - [@@deriving show, repr] 19 - 20 - type delim = 21 - Braces | Squares | Parens 22 - [@@deriving show, repr] 7 + type eval_mode = Text_mode | TeX_mode [@@deriving show, repr] 8 + type binding_info = Strict | Lazy [@@deriving show, repr] 9 + type 'a binding = binding_info * 'a [@@deriving show, repr] 10 + type delim = Braces | Squares | Parens [@@deriving show, repr] 23 11 24 12 let delim_to_strings = function 25 - | Braces -> "{", "}" 26 - | Squares -> "[", "]" 27 - | Parens -> "(", ")" 13 + | Braces -> ("{", "}") 14 + | Squares -> ("[", "]") 15 + | Parens -> ("(", ")") 28 16 29 - type math_mode = 30 - | Inline 31 - | Display 32 - [@@deriving show, repr] 33 - 34 - type visibility = 35 - Private | Public 36 - [@@deriving show, repr] 17 + type math_mode = Inline | Display [@@deriving show, repr] 18 + type visibility = Private | Public [@@deriving show, repr] 19 + type identity = Anonymous | URI of URI.t [@@deriving show] 37 20 38 - type identity = 39 - | Anonymous 40 - | URI of URI.t 41 - [@@deriving show] 42 - 43 - let identity_to_uri = function 44 - | URI uri -> Some uri 45 - | Anonymous -> None 21 + let identity_to_uri = function URI uri -> Some uri | Anonymous -> None 46 22 47 23 type origin = 48 24 | Physical of 49 - (Lsp.Text_document.t [@printer fun ppf doc -> 50 - Format.pp_print_string 51 - ppf 52 - (Lsp.(Uri.to_path @@ Text_document.documentUri doc))]) 25 + (Lsp.Text_document.t 26 + [@printer 27 + fun ppf doc -> 28 + Format.pp_print_string ppf 29 + Lsp.(Uri.to_path @@ Text_document.documentUri doc)]) 53 30 | Subtree of {parent: identity} 54 31 | Undefined 55 32 [@@deriving show]
+12 -24
lib/core/Base.mli
··· 6 6 7 7 (** {1 Base} *) 8 8 9 - type eval_mode = 10 - | Text_mode 11 - | TeX_mode 12 - [@@deriving show, repr] 13 - 14 - type binding_info = 15 - | Strict 16 - | Lazy 17 - [@@deriving show, repr] 9 + type eval_mode = Text_mode | TeX_mode [@@deriving show, repr] 10 + type binding_info = Strict | Lazy [@@deriving show, repr] 18 11 19 12 (** {2 Delimiters} *) 20 13 21 14 type delim = Braces | Squares | Parens 22 - val pp_delim : 23 - Format.formatter -> delim -> unit 15 + 16 + val pp_delim : Format.formatter -> delim -> unit 24 17 val show_delim : delim -> string 25 18 val delim_t : delim Repr.t 26 19 val delim_to_strings : delim -> string * string 27 20 21 + type 'a binding = binding_info * 'a [@@deriving show, repr] 28 22 (** {2 Variable binding} *) 29 - type 'a binding = binding_info * 'a 30 - [@@deriving show, repr] 31 23 32 24 (** {2 Math modes} *) 33 25 34 26 type math_mode = Inline | Display 35 27 36 - val pp_math_mode : 37 - Format.formatter -> 38 - math_mode -> 39 - unit 40 - 28 + val pp_math_mode : Format.formatter -> math_mode -> unit 41 29 val show_math_mode : math_mode -> string 42 - 43 30 val math_mode_t : math_mode Repr.t 44 31 45 32 (** {2 Import visibility} *) 46 33 47 34 type visibility = Private | Public 48 35 49 - val pp_visibility : 50 - Format.formatter -> 51 - visibility -> 52 - unit 36 + val pp_visibility : Format.formatter -> visibility -> unit 53 37 val show_visibility : visibility -> string 38 + 54 39 type identity = Anonymous | URI of URI.t 40 + 55 41 val pp_identity : Format.formatter -> identity -> unit 56 42 val show_identity : identity -> string 57 43 val identity_to_uri : identity -> URI.t option 44 + 58 45 type origin = 59 46 | Physical of Lsp.Text_document.t 60 - | Subtree of {parent: identity;} 47 + | Subtree of {parent: identity} 61 48 | Undefined 49 + 62 50 val pp_origin : Format.formatter -> origin -> unit 63 51 val show_origin : origin -> string 64 52 val visibility_t : visibility Repr.t
+46 -38
lib/core/Builtin_queries.ml
··· 9 9 let context_datalog vtx : _ Dx.query = 10 10 let open Dx.Notation in 11 11 let x = "X" in 12 - Dx.{ 13 - var = x; 14 - positives = [Builtin_relation.transcludes @* [var x; const vtx]]; 15 - negatives = [] 16 - } 12 + Dx. 13 + { 14 + var = x; 15 + positives = [Builtin_relation.transcludes @* [var x; const vtx]]; 16 + negatives = []; 17 + } 17 18 18 19 let children_datalog vtx : _ Dx.query = 19 20 let open Dx.Notation in 20 21 let x = "X" in 21 - Dx.{ 22 - var = x; 23 - positives = [Builtin_relation.transcludes @* [const vtx; var x]]; 24 - negatives = [] 25 - } 22 + Dx. 23 + { 24 + var = x; 25 + positives = [Builtin_relation.transcludes @* [const vtx; var x]]; 26 + negatives = []; 27 + } 26 28 27 29 let backlinks_datalog vtx : _ Dx.query = 28 30 let open Dx.Notation in 29 31 let x = "X" in 30 - Dx.{ 31 - var = x; 32 - positives = [Builtin_relation.links_to @* [var x; const vtx]]; 33 - negatives = [] 34 - } 32 + Dx. 33 + { 34 + var = x; 35 + positives = [Builtin_relation.links_to @* [var x; const vtx]]; 36 + negatives = []; 37 + } 35 38 36 39 let fwdlinks_datalog vtx : _ Dx.query = 37 40 let open Dx.Notation in 38 41 let x = "X" in 39 - Dx.{ 40 - var = x; 41 - positives = [Builtin_relation.links_to @* [const vtx; var x]]; 42 - negatives = [] 43 - } 42 + Dx. 43 + { 44 + var = x; 45 + positives = [Builtin_relation.links_to @* [const vtx; var x]]; 46 + negatives = []; 47 + } 44 48 45 49 let related_datalog vtx : _ Dx.query = 46 50 let open Dx.Notation in 47 51 let x = "X" in 48 - Dx.{ 49 - var = x; 50 - positives = [Builtin_relation.links_to @* [const vtx; var x]]; 51 - negatives = [Builtin_relation.is_reference @* [var x]] 52 - } 52 + Dx. 53 + { 54 + var = x; 55 + positives = [Builtin_relation.links_to @* [const vtx; var x]]; 56 + negatives = [Builtin_relation.is_reference @* [var x]]; 57 + } 53 58 54 59 let contributions_datalog vtx : _ Dx.query = 55 60 let open Dx.Notation in 56 61 let x = "X" in 57 - Dx.{ 58 - var = x; 59 - positives = [ 60 - Builtin_relation.has_direct_contributor @* [var x; const vtx]; 61 - Builtin_relation.is_reference @* [var x] 62 - ]; 63 - negatives = [] 64 - } 62 + Dx. 63 + { 64 + var = x; 65 + positives = 66 + [ 67 + Builtin_relation.has_direct_contributor @* [var x; const vtx]; 68 + Builtin_relation.is_reference @* [var x]; 69 + ]; 70 + negatives = []; 71 + } 65 72 66 73 let references_datalog vtx : _ Datalog_expr.query = 67 74 let open Dx.Notation in 68 75 let x = "X" in 69 - Dx.{ 70 - var = x; 71 - positives = [Builtin_relation.references @* [const vtx; var x]]; 72 - negatives = [] 73 - } 76 + Dx. 77 + { 78 + var = x; 79 + positives = [Builtin_relation.references @* [const vtx; var x]]; 80 + negatives = []; 81 + }
+24 -19
lib/core/Builtin_relation.ml
··· 5 5 *) 6 6 7 7 let make_builtin name = "org.forester.rel." ^ name 8 - 9 8 let links_to = make_builtin "links-to" 10 9 let transcludes = make_builtin "transcludes" 11 10 let has_author = make_builtin "authored-by" ··· 15 14 let is_asset = make_builtin "is-asset" 16 15 let is_article = make_builtin "is-article" 17 16 let in_host = make_builtin "in-host" 18 - 19 17 let transcludes_rtc = make_builtin "transcludes.reflexive-transitive-closure" 20 18 let transcludes_tc = make_builtin "transcludes.transitive-closure" 21 19 let references = make_builtin "references" 22 20 let is_reference = make_builtin "is-reference" 23 21 let is_person = make_builtin "is-person" 24 - 25 22 let has_direct_contributor = make_builtin "has-direct-contributor" 26 23 let has_indirect_contributor = make_builtin "has-indirect-contributor" 27 24 ··· 34 31 let person_taxon : Vertex.t Dx.term = 35 32 Const (Content_vertex (Content [Text "Person"])) 36 33 37 - let axioms : _ Dx.script = [ 38 - is_reference @* [var "X"] << [has_taxon @* [var "X"; reference_taxon]]; 39 - is_person @* [var "X"] << [has_taxon @* [var "X"; person_taxon]]; 40 - transcludes_tc @* [var "X"; var "Y"] << [transcludes @* [var "X"; var "Y"]]; 41 - transcludes_tc @* [var "X"; var "Z"] << [transcludes_tc @* [var "X"; var "Y"]; transcludes @* [var "Y"; var "Z"]]; 42 - transcludes_rtc @* [var "X"; var "X"] << [is_node @* [var "X"]]; 43 - transcludes_rtc @* [var "X"; var "Y"] << [transcludes_tc @* [var "X"; var "Y"]]; 44 - references @* [var "X"; var "Z"] 45 - << [ 46 - transcludes_rtc @* [var "X"; var "Y"]; 47 - links_to @* [var "Y"; var "Z"]; 48 - is_reference @* [var "Z"] 49 - ]; 50 - has_direct_contributor @* [var "X"; var "Y"] << [has_author @* [var "X"; var "Y"]]; 51 - has_indirect_contributor @* [var "X"; var "Z"] << [transcludes_rtc @* [var "X"; var "Y"]; has_direct_contributor @* [var "Y"; var "Z"]]; 52 - ] 34 + let axioms : _ Dx.script = 35 + [ 36 + is_reference @* [var "X"] << [has_taxon @* [var "X"; reference_taxon]]; 37 + is_person @* [var "X"] << [has_taxon @* [var "X"; person_taxon]]; 38 + transcludes_tc @* [var "X"; var "Y"] << [transcludes @* [var "X"; var "Y"]]; 39 + transcludes_tc @* [var "X"; var "Z"] 40 + << [transcludes_tc @* [var "X"; var "Y"]; transcludes @* [var "Y"; var "Z"]]; 41 + transcludes_rtc @* [var "X"; var "X"] << [is_node @* [var "X"]]; 42 + transcludes_rtc @* [var "X"; var "Y"] 43 + << [transcludes_tc @* [var "X"; var "Y"]]; 44 + references @* [var "X"; var "Z"] 45 + << [ 46 + transcludes_rtc @* [var "X"; var "Y"]; 47 + links_to @* [var "Y"; var "Z"]; 48 + is_reference @* [var "Z"]; 49 + ]; 50 + has_direct_contributor @* [var "X"; var "Y"] 51 + << [has_author @* [var "X"; var "Y"]]; 52 + has_indirect_contributor @* [var "X"; var "Z"] 53 + << [ 54 + transcludes_rtc @* [var "X"; var "Y"]; 55 + has_direct_contributor @* [var "Y"; var "Z"]; 56 + ]; 57 + ]
+27 -40
lib/core/Code.ml
··· 6 6 7 7 open Base 8 8 9 - open struct module T = Types end 9 + open struct 10 + module T = Types 11 + end 10 12 11 - type 'a _object = { 12 - self: string option; 13 - methods: (string * 'a) list 14 - } 13 + type 'a _object = {self: string option; methods: (string * 'a) list} 15 14 [@@deriving show, repr] 16 15 17 16 type 'a patch = { 18 17 obj: 'a; 19 18 self: string option; 20 19 super: string option; 21 - methods: (string * 'a) list 20 + methods: (string * 'a) list; 22 21 } 23 22 [@@deriving show, repr] 24 23 ··· 56 55 | Error of string 57 56 [@@deriving show, repr] 58 57 59 - and t = node Range.located list 60 - [@@deriving show, repr] 58 + and t = node Range.located list [@@deriving show, repr] 61 59 62 60 type tree = { 63 61 source_path: string option; 64 62 uri: URI.t option; 65 63 timestamp: float option; 66 - code: t 64 + code: t; 67 65 } 68 66 [@@deriving show, repr] 69 67 70 68 let import_private x = Import (Private, x) 71 69 let import_public x = Import (Public, x) 72 - 73 70 let inline_math e = Math (Inline, e) 74 71 let display_math e = Math (Display, e) 75 72 let parens e = Group (Parens, e) ··· 94 91 | Put (p, t) -> Put (p, f t) 95 92 | Fun (b, t) -> Fun (b, f t) 96 93 | Call (t, s) -> Call (f t, s) 97 - | Object {self; methods} -> Object {self; methods = List.map (fun (s, t) -> (s, f t)) methods} 98 - | Patch {obj; self; super; methods} -> Patch {obj = f obj; self; super; methods = List.map (fun (s, t) -> (s, f t)) methods} 99 - | Text _ 100 - | Verbatim _ 101 - | Ident _ 102 - | Hash_ident _ 94 + | Object {self; methods} -> 95 + Object {self; methods = List.map (fun (s, t) -> (s, f t)) methods} 96 + | Patch {obj; self; super; methods} -> 97 + Patch 98 + { 99 + obj = f obj; 100 + self; 101 + super; 102 + methods = List.map (fun (s, t) -> (s, f t)) methods; 103 + } 104 + | Text _ | Verbatim _ | Ident _ | Hash_ident _ 103 105 | Xml_ident (_, _) 104 - | Open _ 105 - | Get _ 106 + | Open _ | Get _ 106 107 | Import (_, _) 107 108 | Decl_xmlns (_, _) 108 - | Alloc _ 109 - | Dx_var _ 110 - | Comment _ 111 - | Error _ -> 109 + | Alloc _ | Dx_var _ | Comment _ | Error _ -> 112 110 node 113 111 114 112 let children (node : node Range.located) = ··· 127 125 | Call (t, _) 128 126 | Subtree (_, t) -> 129 127 t 130 - | Dx_prop (_, t) 131 - | Dx_query (_, _, t) 132 - | Dx_sequent (_, t) -> 133 - (List.concat t) 134 - | Object {methods; _} -> 135 - (methods |> List.map snd |> List.concat) 128 + | Dx_prop (_, t) | Dx_query (_, _, t) | Dx_sequent (_, t) -> List.concat t 129 + | Object {methods; _} -> methods |> List.map snd |> List.concat 136 130 | Patch {obj; methods; _} -> 137 - let methods = (methods |> List.map snd |> List.concat) in 138 - (List.append obj methods) 139 - | Text _ 140 - | Verbatim _ 141 - | Ident _ 142 - | Hash_ident _ 131 + let methods = methods |> List.map snd |> List.concat in 132 + List.append obj methods 133 + | Text _ | Verbatim _ | Ident _ | Hash_ident _ 143 134 | Xml_ident (_, _) 144 - | Open _ 145 - | Get _ 135 + | Open _ | Get _ 146 136 | Import (_, _) 147 137 | Decl_xmlns (_, _) 148 - | Alloc _ 149 - | Dx_var _ 150 - | Comment _ 151 - | Error _ -> 138 + | Alloc _ | Dx_var _ | Comment _ | Error _ -> 152 139 []
+3 -16
lib/core/Code.mli
··· 5 5 *) 6 6 7 7 open Base 8 - 9 8 module T := Types 10 9 11 10 type node = ··· 17 16 | Hash_ident of string 18 17 | Xml_ident of string option * string 19 18 | Subtree of string option * t 20 - | Let of 21 - Trie.path 22 - * string binding list 23 - * t 19 + | Let of Trie.path * string binding list * t 24 20 | Open of Trie.path 25 21 | Scope of t 26 22 | Put of Trie.path * t ··· 31 27 | Patch of t patch 32 28 | Call of t * string 33 29 | Import of visibility * string 34 - | Def of 35 - Trie.path 36 - * string binding list 37 - * t 30 + | Def of Trie.path * string binding list * t 38 31 | Decl_xmlns of string * string 39 32 | Alloc of Trie.path 40 33 | Namespace of Trie.path * t ··· 49 42 [@@deriving show] 50 43 51 44 and t = node Range.located list 52 - 53 - and 'a _object = { 54 - self: string option; 55 - methods: (string * 'a) list; 56 - } 45 + and 'a _object = {self: string option; methods: (string * 'a) list} 57 46 58 47 and 'a patch = { 59 48 obj: 'a; ··· 76 65 val parens : t -> node 77 66 val squares : t -> node 78 67 val braces : t -> node 79 - 80 68 val import_private : string -> node 81 69 val import_public : string -> node 82 70 val inline_math : t -> node 83 71 val display_math : t -> node 84 - 85 72 val map : (t -> t) -> node -> node 86 73 val children : node Range.located -> t
+9 -12
lib/core/Config.ml
··· 4 4 * SPDX-License-Identifier: GPL-3.0-or-later 5 5 *) 6 6 7 - type foreign = { 8 - path: string; 9 - route_locally: bool; 10 - include_in_manifest: bool 11 - } 7 + type foreign = {path: string; route_locally: bool; include_in_manifest: bool} 12 8 [@@deriving show, repr] 13 9 14 10 type t = { ··· 22 18 23 19 let default_url = URI.of_string_exn "http://forest.local/" 24 20 25 - let default ?(url = default_url) () : t = { 26 - trees = ["trees"]; 27 - assets = []; 28 - foreign = []; 29 - url; 30 - home = URI_scheme.named_uri ~base: url "index"; 31 - } 21 + let default ?(url = default_url) () : t = 22 + { 23 + trees = ["trees"]; 24 + assets = []; 25 + foreign = []; 26 + url; 27 + home = URI_scheme.named_uri ~base:url "index"; 28 + } 32 29 33 30 let home_uri config = config.home
+2 -6
lib/core/Config.mli
··· 4 4 * SPDX-License-Identifier: GPL-3.0-or-later 5 5 *) 6 6 7 - type foreign = { 8 - path: string; 9 - route_locally: bool; 10 - include_in_manifest: bool 11 - } 7 + type foreign = {path: string; route_locally: bool; include_in_manifest: bool} 12 8 [@@deriving show] 13 9 14 10 type t = { ··· 21 17 [@@deriving show] 22 18 23 19 val default_url : URI.t 24 - val default : ?url: URI.t -> unit -> t 20 + val default : ?url:URI.t -> unit -> t 25 21 val home_uri : t -> URI.t
+5 -6
lib/core/Datalog_engine.ml
··· 6 6 7 7 module V = struct 8 8 include Vertex 9 + 9 10 let to_string = show 10 11 end 11 12 12 - module S = Datalog.BottomUp.Hashcons(V) 13 + module S = Datalog.BottomUp.Hashcons (V) 13 14 14 15 open struct 15 16 module T = Types 16 - module D = Datalog.BottomUp.Make(S) 17 + module D = Datalog.BottomUp.Make (S) 17 18 end 18 19 19 20 type relation = string ··· 28 29 S.make vtx 29 30 30 31 let pack_vertex vtx : D.symbol = S.make vtx 31 - 32 32 let var_of_string = String.hash 33 - 34 33 let mk_var = D.mk_var 35 34 let mk_const vtx = D.mk_const (pack_vertex vtx) 36 35 let mk_literal rel = D.mk_literal (symbol_of_string rel) ··· 41 40 | _ -> failwith "const_of_term: unexpected variable" 42 41 43 42 type db = D.db 43 + 44 44 let db_create = D.db_create 45 45 let db_add_fact db lit = D.db_add_fact db lit 46 46 let db_add db clause = D.db_add db clause ··· 48 48 type answers = D.Query.set 49 49 50 50 let list_of_answers answers = 51 - List.map (Array.map vertex_of_term) @@ 52 - D.Query.to_list answers 51 + List.map (Array.map vertex_of_term) @@ D.Query.to_list answers 53 52 54 53 let ask = D.Query.ask
+4 -3
lib/core/Datalog_engine.mli
··· 9 9 type term 10 10 type literal 11 11 type clause 12 - 13 12 type var 13 + 14 14 val var_of_string : string -> var 15 - 16 15 val mk_var : var -> term 17 16 val mk_const : vertex -> term 18 17 val mk_literal : relation -> term list -> literal 19 18 val mk_clause : literal -> literal list -> clause 20 19 21 20 type db 21 + 22 22 val db_create : unit -> db 23 23 val db_add_fact : db -> literal -> unit 24 24 val db_add : db -> clause -> unit 25 25 26 26 type answers 27 + 27 28 val list_of_answers : answers -> vertex array list 28 - val ask : db -> ?neg: literal list -> var array -> literal list -> answers 29 + val ask : db -> ?neg:literal list -> var array -> literal list -> answers
+10 -18
lib/core/Datalog_eval.ml
··· 5 5 *) 6 6 7 7 open Forester_prelude 8 - 9 8 module Dx = Datalog_expr 10 9 module D = Datalog_engine 11 10 12 - let eval_var (var : Dx.var) = 13 - D.mk_var (D.var_of_string var) 14 - 15 - let eval_const (vtx : Vertex.t) = 16 - D.mk_const vtx 11 + let eval_var (var : Dx.var) = D.mk_var (D.var_of_string var) 12 + let eval_const (vtx : Vertex.t) = D.mk_const vtx 17 13 18 14 let eval_term : _ Dx.term -> D.term = function 19 15 | Dx.Var var -> eval_var var ··· 26 22 let eval_premises = List.map eval_prop 27 23 28 24 let eval_sequent (sequent : _ Dx.sequent) : D.clause = 29 - D.mk_clause (eval_prop sequent.conclusion) @@ 30 - eval_premises sequent.premises 25 + D.mk_clause (eval_prop sequent.conclusion) @@ eval_premises sequent.premises 31 26 32 - let eval_script : _ Dx.script -> D.clause list = 33 - List.map eval_sequent 27 + let eval_script : _ Dx.script -> D.clause list = List.map eval_sequent 34 28 35 29 let run_query (db : D.db) (query : (string, Vertex.t) Dx.query) : Vertex_set.t = 36 30 let answers = 37 - D.ask 38 - db 39 - ~neg: (eval_premises query.negatives) 40 - [|D.var_of_string query.var|] @@ 41 - eval_premises query.positives 31 + D.ask db ~neg:(eval_premises query.negatives) [|D.var_of_string query.var|] 32 + @@ eval_premises query.positives 42 33 in 43 - Vertex_set.of_list @@ 44 - let@ answer = List.map @~ D.list_of_answers answers in 45 - answer.(0) 34 + Vertex_set.of_list 35 + @@ 36 + let@ answer = List.map @~ D.list_of_answers answers in 37 + answer.(0)
-1
lib/core/Datalog_eval.mli
··· 13 13 val eval_prop : (string, Vertex.t) Dx.prop -> D.literal 14 14 val eval_sequent : (string, Vertex.t) Dx.sequent -> D.clause 15 15 val eval_script : (string, Vertex.t) Dx.script -> D.clause list 16 - 17 16 val run_query : D.db -> (string, Vertex.t) Dx.query -> Vertex_set.t
+24 -36
lib/core/Datalog_expr.ml
··· 4 4 * SPDX-License-Identifier: GPL-3.0-or-later 5 5 *) 6 6 7 - type var = string 8 - [@@deriving show, repr] 9 - 10 - type 'a term = 11 - | Const of 'a 12 - | Var of var 13 - [@@deriving show, repr] 14 - 15 - type ('sym, 'a) prop = { 16 - rel: 'sym; 17 - args: 'a term list 18 - } 19 - [@@deriving show, repr] 7 + type var = string [@@deriving show, repr] 8 + type 'a term = Const of 'a | Var of var [@@deriving show, repr] 9 + type ('sym, 'a) prop = {rel: 'sym; args: 'a term list} [@@deriving show, repr] 20 10 21 11 type ('sym, 'a) sequent = { 22 12 conclusion: ('sym, 'a) prop; 23 - premises: ('sym, 'a) prop list 13 + premises: ('sym, 'a) prop list; 24 14 } 25 15 [@@deriving show, repr] 26 16 27 - type ('sym, 'a) script = ('sym, 'a) sequent list 28 - [@@deriving show, repr] 17 + type ('sym, 'a) script = ('sym, 'a) sequent list [@@deriving show, repr] 29 18 30 19 type ('sym, 'a) query = { 31 20 var: var; 32 21 positives: ('sym, 'a) prop list; 33 - negatives: ('sym, 'a) prop list 22 + negatives: ('sym, 'a) prop list; 34 23 } 35 24 [@@deriving show, repr] 36 25 37 - let map_term f = function 38 - | Const c -> Const (f c) 39 - | Var x -> Var x 26 + let map_term f = function Const c -> Const (f c) | Var x -> Var x 40 27 41 - let map_prop f g prop = {rel = f prop.rel; args = List.map (map_term g) prop.args} 28 + let map_prop f g prop = 29 + {rel = f prop.rel; args = List.map (map_term g) prop.args} 42 30 43 31 let map_premises f g = List.map (map_prop f g) 44 32 45 - let map_sequent f g sequent = { 46 - conclusion = map_prop f g sequent.conclusion; 47 - premises = map_premises f g sequent.premises 48 - } 33 + let map_sequent f g sequent = 34 + { 35 + conclusion = map_prop f g sequent.conclusion; 36 + premises = map_premises f g sequent.premises; 37 + } 49 38 50 39 let map_script f g = List.map (map_sequent f g) 51 40 52 - let map_query f g query = {query with 53 - positives = map_premises f g query.positives; 54 - negatives = map_premises f g query.negatives 55 - } 56 - 57 - let iter_script f script = 58 - ignore @@ map_script Fun.id f script 41 + let map_query f g query = 42 + { 43 + query with 44 + positives = map_premises f g query.positives; 45 + negatives = map_premises f g query.negatives; 46 + } 59 47 60 - let iter_query f query = 61 - ignore @@ map_query Fun.id f query 48 + let iter_script f script = ignore @@ map_script Fun.id f script 49 + let iter_query f query = ignore @@ map_query Fun.id f query 62 50 63 51 module Constructors = struct 64 52 let const x = Const x ··· 70 58 module Notation = struct 71 59 include Constructors 72 60 73 - let (<<) conclusion premises = {conclusion; premises} 74 - let (@*) rel args = {rel; args} 61 + let ( << ) conclusion premises = {conclusion; premises} 62 + let ( @* ) rel args = {rel; args} 75 63 end
+27 -31
lib/core/Forest_graph.ml
··· 4 4 * SPDX-License-Identifier: GPL-3.0-or-later 5 5 *) 6 6 7 - module G = Graph.Imperative.Digraph.ConcreteBidirectional(Vertex) 7 + module G = Graph.Imperative.Digraph.ConcreteBidirectional (Vertex) 8 8 include G 9 - include Graph.Oper.I(G) 10 - module Map = Graph.Gmap.Vertex(G) 9 + include Graph.Oper.I (G) 10 + module Map = Graph.Gmap.Vertex (G) 11 11 12 - module Reachability = Graph.Fixpoint.Make(G)(struct 13 - type vertex = G.E.vertex 14 - type edge = G.E.t 15 - type g = G.t 16 - type data = bool 17 - let direction = Graph.Fixpoint.Forward 18 - let equal = (=) 19 - let join = (||) 20 - let analyze _ = (fun x -> x) 21 - end) 12 + module Reachability = 13 + Graph.Fixpoint.Make 14 + (G) 15 + (struct 16 + type vertex = G.E.vertex 17 + type edge = G.E.t 18 + type g = G.t 19 + type data = bool 22 20 23 - module Topo = Graph.Topological.Make(G) 24 - let topo_fold = Topo.fold 25 - let topo_iter = Topo.iter 21 + let direction = Graph.Fixpoint.Forward 22 + let equal = ( = ) 23 + let join = ( || ) 24 + let analyze _ = fun x -> x 25 + end) 26 26 27 - let safe_succ g x = 28 - if mem_vertex g x then succ g x else [] 27 + module Topo = Graph.Topological.Make (G) 29 28 29 + let topo_fold = Topo.fold 30 + let topo_iter = Topo.iter 31 + let safe_succ g x = if mem_vertex g x then succ g x else [] 30 32 let safe_dependents = safe_succ 31 - 32 - let safe_pred g x = 33 - if mem_vertex g x then pred g x else [] 34 - 33 + let safe_pred g x = if mem_vertex g x then pred g x else [] 35 34 let immediate_dependencies = safe_pred 36 35 37 36 let dependencies graph vertex : t = ··· 40 39 iter_pred 41 40 (fun dep -> 42 41 if mem_vertex dep_graph dep then () 43 - else 44 - begin 45 - add_edge dep_graph dep v; 46 - go dep 47 - end 48 - ) 49 - graph 50 - v 42 + else begin 43 + add_edge dep_graph dep v; 44 + go dep 45 + end) 46 + graph v 51 47 in 52 48 go vertex; 53 49 dep_graph 54 50 55 - module Graphviz = Graph.Graphviz.Dot(struct 51 + module Graphviz = Graph.Graphviz.Dot (struct 56 52 include G 57 53 module V = Vertex 58 54
+4 -10
lib/core/Forest_graph.mli
··· 6 6 7 7 type t 8 8 9 - module Map (G_Dst : Graph.Gmap.V_DST) : 10 - sig 9 + module Map (G_Dst : Graph.Gmap.V_DST) : sig 11 10 val map : (Vertex.t -> G_Dst.vertex) -> t -> G_Dst.t 12 11 val filter_map : (Vertex.t -> G_Dst.vertex option) -> t -> G_Dst.t 13 12 end 14 13 15 - val create : ?size: int -> unit -> t 14 + val create : ?size:int -> unit -> t 16 15 val add_vertex : t -> Vertex.t -> unit 17 16 val add_edge : t -> Vertex.t -> Vertex.t -> unit 18 - 19 17 val safe_pred : t -> Vertex.t -> Vertex.t list 20 18 val safe_succ : t -> Vertex.t -> Vertex.t list 21 19 val immediate_dependencies : t -> Vertex.t -> Vertex.t list 22 20 val safe_dependents : t -> Vertex.t -> Vertex.t list 23 21 val mem_edge : t -> Vertex.t -> Vertex.t -> bool 24 - val transitive_closure : ?reflexive: bool -> t -> t 25 - 22 + val transitive_closure : ?reflexive:bool -> t -> t 26 23 val out_degree : t -> Vertex.t -> int 27 24 val in_degree : t -> Vertex.t -> int 28 - 29 25 val remove_vertex : t -> Vertex.t -> unit 30 26 val remove_edge : t -> Vertex.t -> Vertex.t -> unit 31 - val transitive_reduction : ?reflexive: bool -> t -> t 27 + val transitive_reduction : ?reflexive:bool -> t -> t 32 28 val nb_vertex : t -> int 33 29 val iter_edges : (Vertex.t -> Vertex.t -> unit) -> t -> unit 34 30 val iter_vertex : (Vertex.t -> unit) -> t -> unit 35 31 val mem_vertex : t -> Vertex.t -> bool 36 32 val topo_fold : (Vertex.t -> 'a -> 'a) -> t -> 'a -> 'a 37 33 val topo_iter : (Vertex.t -> unit) -> t -> unit 38 - 39 34 val iter_succ : (Vertex.t -> unit) -> t -> Vertex.t -> unit 40 - 41 35 val dependencies : t -> Vertex.t -> t 42 36 43 37 module Graphviz : sig
+13 -10
lib/core/Forest_graphs.ml
··· 17 17 end 18 18 19 19 let init (db : Dl.db) : (module S) = 20 - (module struct 21 - let dl_db = db 20 + (module struct 21 + let dl_db = db 22 22 23 - let register_uri uri = 24 - let vtx : Vertex.t = T.Uri_vertex uri in 25 - Dl.db_add_fact dl_db @@ Dl.mk_literal Builtin_relation.is_node [Dl.mk_const vtx]; 26 - let@ host = Option.iter @~ URI.host uri in 27 - let host_vtx = T.Content_vertex (T.Content [T.Text host]) in 28 - Dl.db_add_fact dl_db @@ Dl.mk_literal Builtin_relation.in_host [Dl.mk_const vtx; Dl.mk_const host_vtx] 29 - end) 23 + let register_uri uri = 24 + let vtx : Vertex.t = T.Uri_vertex uri in 25 + Dl.db_add_fact dl_db 26 + @@ Dl.mk_literal Builtin_relation.is_node [Dl.mk_const vtx]; 27 + let@ host = Option.iter @~ URI.host uri in 28 + let host_vtx = T.Content_vertex (T.Content [T.Text host]) in 29 + Dl.db_add_fact dl_db 30 + @@ Dl.mk_literal Builtin_relation.in_host 31 + [Dl.mk_const vtx; Dl.mk_const host_vtx] 32 + end) 30 33 31 - module Make () : S = (val (init @@ Dl.db_create ())) 34 + module Make () : S = (val init @@ Dl.db_create ())
+2 -1
lib/core/Forest_graphs.mli
··· 4 4 * SPDX-License-Identifier: GPL-3.0-or-later 5 5 *) 6 6 7 - (** A simple graph database. Used to record the {{!Forester_core.Builtin_relation}relations} that exist between trees.*) 7 + (** A simple graph database. Used to record the 8 + {{!Forester_core.Builtin_relation}relations} that exist between trees.*) 8 9 9 10 module type S = sig 10 11 val dl_db : Datalog_engine.db
+6 -10
lib/core/Forester_core.ml
··· 15 15 16 16 (** {1 Vertices} 17 17 18 - The type of vertices used by the {{!Forester_core.Forest_graphs}graph database} 19 - 20 - *) 18 + The type of vertices used by the 19 + {{!Forester_core.Forest_graphs}graph database} *) 21 20 22 21 module Vertex = Vertex 23 22 module Vertex_set = Vertex_set ··· 33 32 34 33 module Range = Range 35 34 35 + module Builtin_relation = Builtin_relation 36 36 (** {2 Builtins}*) 37 - module Builtin_relation = Builtin_relation 37 + 38 38 module Builtin_queries = Builtin_queries 39 39 40 40 module Forest_graph = Forest_graph 41 - (** The graph type used by the datalog database. Used in particular to track imports, links and transclusions. *) 41 + (** The graph type used by the datalog database. Used in particular to track 42 + imports, links and transclusions. *) 42 43 43 44 module Forest_graphs = Forest_graphs 44 45 (** The graph database*) ··· 48 49 module Datalog_engine = Datalog_engine 49 50 module Datalog_expr = Datalog_expr 50 51 module Datalog_eval = Datalog_eval 51 - 52 52 module Prim = Prim 53 - 54 53 module TeX_cs = TeX_cs 55 - 56 54 module Types = Types 57 55 module TeX_like = TeX_like (* TODO: rename this *) 58 - 59 56 module Trie = Trie 60 - 61 57 module Syn = Syn 62 58 module Symbol = Symbol 63 59 module Value = Value
+12 -1
lib/core/Prim.ml
··· 4 4 * SPDX-License-Identifier: GPL-3.0-or-later 5 5 *) 6 6 7 - type t = [`P | `Ol | `Ul | `Li | `Em | `Strong | `Code | `Blockquote | `Pre | `Figure | `Figcaption] 7 + type t = 8 + [ `P 9 + | `Ol 10 + | `Ul 11 + | `Li 12 + | `Em 13 + | `Strong 14 + | `Code 15 + | `Blockquote 16 + | `Pre 17 + | `Figure 18 + | `Figcaption ] 8 19 [@@deriving show, repr]
+6 -15
lib/core/Range.ml
··· 6 6 7 7 include Asai.Range 8 8 9 - let pp_located pp_arg fmt (x : 'a located) = 10 - pp_arg fmt x.value 11 - 9 + let pp_located pp_arg fmt (x : 'a located) = pp_arg fmt x.value 12 10 let map f node = {node with value = f node.value} 13 11 14 12 type string_source = Asai.Range.string_source = { ··· 17 15 } 18 16 [@@deriving repr] 19 17 20 - type source = [ 21 - | `File of string 22 - | `String of string_source 23 - ] 24 - [@@deriving repr] 18 + type source = [`File of string | `String of string_source] [@@deriving repr] 25 19 26 20 type position = Asai.Range.position = { 27 21 source: source; ··· 33 27 34 28 let t : t Repr.t = 35 29 let open Repr in 36 - variant 37 - "t" 38 - begin 39 - fun range end_of_file t -> 40 - match view t with 41 - | `Range (x, y) -> range (x, y) 42 - | `End_of_file x -> end_of_file x 30 + variant "t" begin fun range end_of_file t -> 31 + match view t with 32 + | `Range (x, y) -> range (x, y) 33 + | `End_of_file x -> end_of_file x 43 34 end 44 35 |~ case1 "Range" (pair position_t position_t) make 45 36 |~ case1 "End_of_file" position_t eof
+18 -22
lib/core/Reporter.ml
··· 6 6 7 7 module R = Resolver 8 8 module Sc = R.Scope 9 - 10 9 module Message = Reporter_message 11 - 12 - include Asai.StructuredReporter.Make(Message) 10 + include Asai.StructuredReporter.Make (Message) 13 11 14 12 type diagnostic = Message.t Asai.Diagnostic.t 15 13 16 - let log pp s = 17 - Logs.info (fun m -> m "%a...@." pp s) 14 + let log pp s = Logs.info (fun m -> m "%a...@." pp s) 18 15 19 16 let profile msg body = 20 17 let before = Unix.gettimeofday () in 21 18 let result = body () in 22 19 let after = Unix.gettimeofday () in 23 - emit ~extra_remarks: [Asai.Diagnostic.loctextf "%s" msg] (Profiling (after, before)); 20 + emit 21 + ~extra_remarks:[Asai.Diagnostic.loctextf "%s" msg] 22 + (Profiling (after, before)); 24 23 result 25 24 26 - module Tty = Asai.Tty.Make(Message) 25 + module Tty = Asai.Tty.Make (Message) 27 26 28 27 let easy_run k = 29 28 let fatal diagnostics = 30 29 Tty.display diagnostics; 31 30 exit 1 32 31 in 33 - run ~emit: Tty.display ~fatal k 32 + run ~emit:Tty.display ~fatal k 34 33 35 34 let silence k = 36 35 let fatal diagnostics = 37 36 Tty.display diagnostics; 38 37 exit 1 39 38 in 40 - run ~emit: Tty.display ~fatal k 39 + run ~emit:Tty.display ~fatal k 41 40 42 41 let test_run k = 43 42 let fatal diagnostics = 44 - Tty.display 45 - ~use_color: false 46 - ~use_ansi: false 47 - diagnostics; 43 + Tty.display ~use_color:false ~use_ansi:false diagnostics; 48 44 exit 1 49 45 in 50 46 let emit _diagnostics = () in ··· 53 49 (* Reporting diagnostics requires a document URI to publish *) 54 50 let guess_uri (d : diagnostic) = 55 51 match d with 56 - | {explanation; _} -> 52 + | {explanation; _} -> ( 57 53 match explanation.loc with 58 54 | None -> None 59 - | Some loc -> 55 + | Some loc -> ( 60 56 match Range.view loc with 61 - | `End_of_file {source; _} 62 - | `Range ({source; _}, _) -> 57 + | `End_of_file {source; _} | `Range ({source; _}, _) -> ( 63 58 match source with 64 59 | `String _ -> None 65 - | `File path -> 66 - if path <> "" then 67 - Some (Lsp.Uri.of_path path) 68 - else None 60 + | `File path -> if path <> "" then Some (Lsp.Uri.of_path path) else None 61 + ))) 69 62 70 63 let ignore = 71 64 let emit _ = () in 72 - let fatal _ = fatal Message.Internal_error ~extra_remarks: [Asai.Diagnostic.loctext "ignoring error"] in 65 + let fatal _ = 66 + fatal Message.Internal_error 67 + ~extra_remarks:[Asai.Diagnostic.loctext "ignoring error"] 68 + in 73 69 run ~emit ~fatal
+5 -6
lib/core/Reporter.mli
··· 5 5 *) 6 6 7 7 module Message : module type of Reporter_message 8 - 9 - include module type of Asai.StructuredReporter.Make(Message) 10 - module Tty : module type of Asai.Tty.Make(Message) 8 + include module type of Asai.StructuredReporter.Make (Message) 9 + module Tty : module type of Asai.Tty.Make (Message) 11 10 12 11 type diagnostic = Message.t Asai.Diagnostic.t 12 + 13 13 val log : (Format.formatter -> 'a -> unit) -> 'a -> unit 14 14 val profile : string -> (unit -> 'a) -> 'a 15 15 val easy_run : (unit -> 'a) -> 'a 16 16 val silence : (unit -> 'a) -> 'a 17 17 val test_run : (unit -> 'a) -> 'a 18 - 19 18 val guess_uri : diagnostic -> Lsp.Uri.t option 20 19 21 20 val ignore : 22 - ?init_loc: Asai.Range.t -> 23 - ?init_backtrace: Asai.Diagnostic.backtrace -> 21 + ?init_loc:Asai.Range.t -> 22 + ?init_backtrace:Asai.Diagnostic.backtrace -> 24 23 (unit -> 'a) -> 25 24 'a
+74 -86
lib/core/Reporter_message.ml
··· 30 30 | Parse_error 31 31 | Unbound_method of (string * Value.obj) 32 32 | Type_warning 33 - | Type_error of 34 - { 35 - got: Value.t option; 36 - expected: expected_value list 37 - } 33 + | Type_error of {got: Value.t option; expected: expected_value list} 38 34 | Unbound_fluid_symbol of Symbol.t 39 35 | Unbound_variable of string 40 - | Unresolved_identifier of ((Sc.data, R.P.tag) Trie.t [@opaque]) * Trie.path 36 + | Unresolved_identifier of ((Sc.data, R.P.tag) Trie.t[@opaque]) * Trie.path 41 37 | Unresolved_xmlns of string 42 38 | Reference_error of URI.t 43 39 | Unhandled_case ··· 94 90 let short_code : t -> string = function 95 91 | Import_not_found _ -> "import_not_found" 96 92 | Invalid_URI -> "invalid_uri" 97 - | Asset_has_no_content_address _ -> "asset_not_found" (* This is taken from the original wording of the message, but I think this is very confusing.*) 93 + | Asset_has_no_content_address _ -> 94 + "asset_not_found" 95 + (* This is taken from the original wording of the message, but I think this 96 + is very confusing.*) 98 97 | Asset_not_found _ -> "asset_not_found" 99 98 | Current_tree_has_no_uri -> "current_tree_has_no_uri" 100 99 | Duplicate_tree _ -> "duplicate_tree" ··· 152 151 let default_text : t -> Asai.Diagnostic.text = function 153 152 | Import_not_found uri -> Asai.Diagnostic.textf "%a not found" URI.pp uri 154 153 | Unresolved_xmlns prefix -> 155 - Asai.Diagnostic.textf "Could not resolve prefix `%s` to XML namespace" prefix 154 + Asai.Diagnostic.textf "Could not resolve prefix `%s` to XML namespace" 155 + prefix 156 156 | Unresolved_identifier (_, p) -> 157 - Asai.Diagnostic.textf "Unknown binding \\%a. To interpret as a TeX control sequence, explicitly enter TeX mode using #{...}." Trie.pp_path p 158 - | Type_error {got; expected} -> 159 - begin 160 - let expected_msg = 161 - match expected with 162 - | [] -> Asai.Diagnostic.textf "An unknown type error ocurred" 163 - | expected :: [] -> 164 - Asai.Diagnostic.textf "Expected %s" (show_expected_value expected) 165 - | _ -> 166 - Asai.Diagnostic.textf "Expected one of %a" (Format.pp_print_list ~pp_sep: (fun out () -> Format.fprintf out ", ") pp_expected_value) expected 167 - in 168 - let got_msg = 169 - match got with 170 - | None -> Asai.Diagnostic.textf "" 171 - | Some v -> 172 - Asai.Diagnostic.textf " but this is %s" (this_is v) 173 - in 174 - let hint = 175 - match got with 176 - | Some Value.Clo (_, _, _) -> Asai.Diagnostic.textf "Did you forget to supply an argument?" 177 - | Some Value.Content _ 178 - | Some Value.Dx_prop _ 179 - | Some Value.Dx_sequent _ 180 - | Some Value.Dx_query _ 181 - | Some Value.Dx_var _ 182 - | Some Value.Dx_const _ 183 - | Some Value.Sym _ 184 - | Some Value.Obj _ 185 - | None -> 186 - Asai.Diagnostic.textf "" 187 - in 188 - Asai.Diagnostic.textf "%t%t.\n%t" expected_msg got_msg hint 189 - end 157 + Asai.Diagnostic.textf 158 + "Unknown binding \\%a. To interpret as a TeX control sequence, \ 159 + explicitly enter TeX mode using #{...}." 160 + Trie.pp_path p 161 + | Type_error {got; expected} -> begin 162 + let expected_msg = 163 + match expected with 164 + | [] -> Asai.Diagnostic.textf "An unknown type error ocurred" 165 + | expected :: [] -> 166 + Asai.Diagnostic.textf "Expected %s" (show_expected_value expected) 167 + | _ -> 168 + Asai.Diagnostic.textf "Expected one of %a" 169 + (Format.pp_print_list 170 + ~pp_sep:(fun out () -> Format.fprintf out ", ") 171 + pp_expected_value) 172 + expected 173 + in 174 + let got_msg = 175 + match got with 176 + | None -> Asai.Diagnostic.textf "" 177 + | Some v -> Asai.Diagnostic.textf " but this is %s" (this_is v) 178 + in 179 + let hint = 180 + match got with 181 + | Some (Value.Clo (_, _, _)) -> 182 + Asai.Diagnostic.textf "Did you forget to supply an argument?" 183 + | Some (Value.Content _) 184 + | Some (Value.Dx_prop _) 185 + | Some (Value.Dx_sequent _) 186 + | Some (Value.Dx_query _) 187 + | Some (Value.Dx_var _) 188 + | Some (Value.Dx_const _) 189 + | Some (Value.Sym _) 190 + | Some (Value.Obj _) 191 + | None -> 192 + Asai.Diagnostic.textf "" 193 + in 194 + Asai.Diagnostic.textf "%t%t.\n%t" expected_msg got_msg hint 195 + end 190 196 | Asset_not_found msg -> Asai.Diagnostic.text msg 191 197 | Unbound_method (mthd, {prototype = _; methods; _}) -> 192 198 let method_names = List.map fst @@ Value.Method_table.to_list methods in 193 - Asai.Diagnostic.textf 194 - "Unbound method %s. Available methods are:@.%a" 195 - mthd 199 + Asai.Diagnostic.textf "Unbound method %s. Available methods are:@.%a" mthd 196 200 Format.(pp_print_list (fun ppf s -> fprintf ppf " %s" s)) 197 201 method_names 198 202 | Uninterpreted_config_options keys -> 199 - Asai.Diagnostic.textf 200 - "Uninterpreted config option%s: %a" 201 - ( 202 - if List.length keys = 1 then "" 203 - else if List.length keys > 1 then "s" 204 - else assert false 205 - ) 203 + Asai.Diagnostic.textf "Uninterpreted config option%s: %a" 204 + (if List.length keys = 1 then "" 205 + else if List.length keys > 1 then "s" 206 + else assert false) 206 207 Format.( 207 208 pp_print_list 208 - ~pp_sep: (fun out () -> fprintf out ", ") 209 + ~pp_sep:(fun out () -> fprintf out ", ") 209 210 (fun ppf k -> 210 - fprintf ppf "%a" (pp_print_list ~pp_sep: (fun out () -> fprintf out ".") pp_print_string) k 211 - ) 212 - ) 211 + fprintf ppf "%a" 212 + (pp_print_list 213 + ~pp_sep:(fun out () -> fprintf out ".") 214 + pp_print_string) 215 + k)) 213 216 keys 214 217 | Using_default_option k -> 215 218 Asai.Diagnostic.textf 216 219 "Configuration option %a is not set. Using default value." 217 - Format.(pp_print_list ~pp_sep: (fun out () -> fprintf out ".") pp_print_string) 220 + Format.( 221 + pp_print_list ~pp_sep:(fun out () -> fprintf out ".") pp_print_string) 218 222 k 219 223 | Required_config_option k -> 220 224 Asai.Diagnostic.textf "Required option %s is not set." k 221 - | Broken_link {uri; suggestion} -> 222 - begin 223 - match suggestion with 224 - | None -> 225 - Asai.Diagnostic.textf "Potentially broken link to `%a`" URI.pp uri 226 - | Some suggestion -> 227 - Asai.Diagnostic.textf "Potentially broken link to `%a`; did you mean `%a`?" URI.pp uri URI.pp suggestion 228 - end 225 + | Broken_link {uri; suggestion} -> begin 226 + match suggestion with 227 + | None -> Asai.Diagnostic.textf "Potentially broken link to `%a`" URI.pp uri 228 + | Some suggestion -> 229 + Asai.Diagnostic.textf 230 + "Potentially broken link to `%a`; did you mean `%a`?" URI.pp uri URI.pp 231 + suggestion 232 + end 229 233 | Resource_not_found uri -> 230 234 Asai.Diagnostic.textf "Resource not found: %a" URI.pp uri 231 235 | Duplicate_tree (o1, o2) -> ··· 234 238 | Subtree {parent} -> Format.asprintf "%a" pp_identity parent 235 239 | Undefined -> "undefined" 236 240 in 237 - Asai.Diagnostic.textf 238 - "%s@ and@ %s@ use@ the@ same@ URI" 239 - (show_origin o1) 241 + Asai.Diagnostic.textf "%s@ and@ %s@ use@ the@ same@ URI" (show_origin o1) 240 242 (show_origin o2) 241 - | Invalid_URI 242 - | Asset_has_no_content_address _ 243 - | Reference_error _ 244 - | Parse_error 245 - | Type_warning 246 - | Unbound_fluid_symbol _ 247 - | Unbound_variable _ 248 - | Unhandled_case 249 - | Transclusion_loop 250 - | Internal_error 251 - | Configuration_error 252 - | Initialization_warning 253 - | Routing_error 254 - | Profiling _ 255 - | External_error 256 - | Current_tree_has_no_uri 257 - | IO_error 258 - | Log 259 - | Missing_argument -> 243 + | Invalid_URI | Asset_has_no_content_address _ | Reference_error _ 244 + | Parse_error | Type_warning | Unbound_fluid_symbol _ | Unbound_variable _ 245 + | Unhandled_case | Transclusion_loop | Internal_error | Configuration_error 246 + | Initialization_warning | Routing_error | Profiling _ | External_error 247 + | Current_tree_has_no_uri | IO_error | Log | Missing_argument -> 260 248 Asai.Diagnostic.text ""
+11 -16
lib/core/Resolver.ml
··· 6 6 7 7 module P = struct 8 8 type data = Syn.resolver_data 9 - 10 9 type tag = Asai.Range.t option 11 - 12 10 type hook = unit (* for modifier hooks; unused here *) 13 11 type context = unit (* for advanced printing and reporting; unused here *) 14 12 end 15 13 16 14 module Scope = struct 17 - include Yuujinchou.Scope.Make(P) 18 - type data = P.data 15 + include Yuujinchou.Scope.Make (P) 19 16 20 - let import_singleton x v = 21 - import_singleton (x, v) 17 + type data = P.data 22 18 23 - let include_singleton x v = 24 - include_singleton (x, v) 19 + let import_singleton x v = import_singleton (x, v) 20 + let include_singleton x v = include_singleton (x, v) 25 21 26 22 let import_subtree ?modifier path subtree = 27 23 import_subtree ?modifier (path, subtree) ··· 31 27 32 28 let pp_path ppf path = 33 29 let pp_slash ppf () = Format.fprintf ppf "/" in 34 - Format.(fprintf ppf "%a" (pp_print_list ~pp_sep: pp_slash pp_print_string) path) 30 + Format.( 31 + fprintf ppf "%a" (pp_print_list ~pp_sep:pp_slash pp_print_string) path) 35 32 36 33 let pp_trie = 37 34 let pp_print_pair pp1 pp2 ppf (left, right) = 38 - pp1 ppf left; pp2 ppf right 35 + pp1 ppf left; 36 + pp2 ppf right 39 37 in 40 38 Format.( 41 39 pp_print_seq 42 - ( 43 - pp_print_pair 44 - Trie.pp_path 45 - (pp_print_pair Syn.pp_resolver_data (pp_print_option Asai.Range.dump)) 46 - ) 47 - ) 40 + (pp_print_pair Trie.pp_path 41 + (pp_print_pair Syn.pp_resolver_data 42 + (pp_print_option Asai.Range.dump)))) 48 43 end 49 44 50 45 module Lang = Yuujinchou.Language
+4 -13
lib/core/Symbol.ml
··· 4 4 * SPDX-License-Identifier: GPL-3.0-or-later 5 5 *) 6 6 7 - type t = (Trie.path [@repr Repr.(list string)]) * int 8 - [@@deriving repr] 7 + type t = (Trie.path[@repr Repr.(list string)]) * int [@@deriving repr] 9 8 10 9 let counter = ref 0 11 10 12 11 let named path = 13 12 counter := !counter + 1; 14 - path, !counter 13 + (path, !counter) 15 14 16 15 let fresh () = named [] 17 - 18 16 let clone (path, _) = named path 19 - 20 - let pp fmt (sym, ix) = 21 - Format.fprintf fmt "%a@%i" Trie.pp_path sym ix 22 - 17 + let pp fmt (sym, ix) = Format.fprintf fmt "%a@%i" Trie.pp_path sym ix 23 18 let show x = Format.asprintf "%a" pp x 24 - 25 19 let compare = compare 26 - 27 20 let name (sym, _) = sym 28 - 29 - let repr : t Repr.t = 30 - Repr.pair (Repr.list Repr.string) Repr.int 21 + let repr : t Repr.t = Repr.pair (Repr.list Repr.string) Repr.int
-3
lib/core/Symbol.mli
··· 8 8 9 9 val pp : Format.formatter -> t -> unit 10 10 val show : t -> string 11 - 12 11 val t : t Repr.t 13 - 14 12 val named : Trie.path -> t 15 13 val name : t -> Trie.path 16 14 val fresh : unit -> t 17 - 18 15 val clone : t -> t 19 16 val compare : t -> t -> int 20 17 val repr : t Repr.t
+30 -60
lib/core/Syn.ml
··· 22 22 | Get of t 23 23 | Xml_tag of xml_qname * (xml_qname * t) list * t 24 24 | TeX_cs of TeX_cs.t 25 - | Unresolved_ident of ((resolver_data, Range.t option) Trie.t [@opaque]) * Trie.path 25 + | Unresolved_ident of 26 + ((resolver_data, Range.t option) Trie.t[@opaque]) * Trie.path 26 27 | Prim of Prim.t 27 28 | Object of {self: string option; methods: (string * t) list} 28 - | Patch of {obj: t; self: string option; super: string option; methods: (string * t) list} 29 + | Patch of { 30 + obj: t; 31 + self: string option; 32 + super: string option; 33 + methods: (string * t) list; 34 + } 29 35 | Call of t * string 30 36 | Results_of_query 31 37 | Transclude ··· 51 57 | Current_tree 52 58 [@@deriving show] 53 59 54 - and t = node Range.located list 55 - [@@deriving show] 60 + and t = node Range.located list [@@deriving show] 56 61 57 - and resolver_data = 58 - | Term of t 59 - | Xmlns of {xmlns: string; prefix: string} 62 + and resolver_data = Term of t | Xmlns of {xmlns: string; prefix: string} 60 63 [@@deriving show] 61 64 62 65 let map f node = ··· 69 72 | Put (r, s, t) -> Put (f r, f s, f t) 70 73 | Default (r, s, t) -> Default (f r, f s, f t) 71 74 | Get t -> Get (f t) 72 - | Xml_tag (q, qs, t) -> Xml_tag (q, List.map (fun (q, t) -> q, f t) qs, f t) 75 + | Xml_tag (q, qs, t) -> Xml_tag (q, List.map (fun (q, t) -> (q, f t)) qs, f t) 73 76 | Call (t, s) -> Call (f t, s) 74 77 | Object {self; methods} -> 75 - Object {self; methods = List.map (fun (str, t) -> str, f t) methods} 78 + Object {self; methods = List.map (fun (str, t) -> (str, f t)) methods} 76 79 | Patch {obj; self; super; methods} -> 77 - Patch {obj = f obj; self; super; methods = List.map (fun (str, t) -> str, f t) methods} 80 + Patch 81 + { 82 + obj = f obj; 83 + self; 84 + super; 85 + methods = List.map (fun (str, t) -> (str, f t)) methods; 86 + } 78 87 | Dx_sequent (t, ts) -> Dx_sequent (f t, List.map f ts) 79 88 | Dx_query (s, ps, ns) -> Dx_query (s, List.map f ps, List.map f ns) 80 89 | Dx_const (s, n) -> Dx_const (s, f n) 81 90 | Dx_prop (t, ts) -> Dx_prop (f t, List.map f ts) 82 - | Text _ 83 - | Verbatim _ 84 - | Var _ 85 - | Sym _ 86 - | TeX_cs _ 87 - | Unresolved_ident _ 88 - | Prim _ 89 - | Results_of_query 90 - | Transclude 91 - | Embed_tex 92 - | Ref 93 - | Title 94 - | Parent 95 - | Taxon 91 + | Text _ | Verbatim _ | Var _ | Sym _ | TeX_cs _ | Unresolved_ident _ | Prim _ 92 + | Results_of_query | Transclude | Embed_tex | Ref | Title | Parent | Taxon 96 93 | Meta 97 94 | Attribution (_, _) 98 - | Tag _ 99 - | Date 100 - | Number 101 - | Dx_var _ 102 - | Dx_execute 103 - | Route_asset 104 - | Syndicate_current_tree_as_atom_feed 105 - | Syndicate_query_as_json_blob 95 + | Tag _ | Date | Number | Dx_var _ | Dx_execute | Route_asset 96 + | Syndicate_current_tree_as_atom_feed | Syndicate_query_as_json_blob 106 97 | Current_tree -> 107 98 node 108 99 ··· 111 102 | Group (_, t) -> t 112 103 | Math (_, t) -> t 113 104 | Subtree (_, t) -> t 114 - | Link {dest; title} -> Option.fold ~some: (fun t -> t @ dest) ~none: dest title 105 + | Link {dest; title} -> Option.fold ~some:(fun t -> t @ dest) ~none:dest title 115 106 | Fun (_, t) -> t 116 107 | Put (r, s, t) -> r @ s @ t 117 108 | Default (r, s, t) -> r @ s @ t 118 109 | Get t -> t 119 110 | Xml_tag (_, qs, t) -> List.concat_map snd qs @ t 120 111 | Call (t, _) -> t 121 - | Object {methods; _} -> 122 - List.concat_map snd methods 123 - | Patch {obj; methods; _} -> 124 - List.concat_map snd methods @ 125 - obj 112 + | Object {methods; _} -> List.concat_map snd methods 113 + | Patch {obj; methods; _} -> List.concat_map snd methods @ obj 126 114 | Dx_sequent (t, ts) -> t @ List.concat ts 127 115 | Dx_query (_, ps, ns) -> List.concat ps @ List.concat ns 128 116 | Dx_const (_, n) -> n 129 117 | Dx_prop (t, ts) -> t @ List.concat ts 130 - | Text _ 131 - | Verbatim _ 132 - | Var _ 133 - | Sym _ 134 - | TeX_cs _ 135 - | Unresolved_ident _ 136 - | Prim _ 137 - | Results_of_query 138 - | Transclude 139 - | Embed_tex 140 - | Ref 141 - | Title 142 - | Parent 143 - | Taxon 118 + | Text _ | Verbatim _ | Var _ | Sym _ | TeX_cs _ | Unresolved_ident _ | Prim _ 119 + | Results_of_query | Transclude | Embed_tex | Ref | Title | Parent | Taxon 144 120 | Meta 145 121 | Attribution (_, _) 146 - | Tag _ 147 - | Date 148 - | Number 149 - | Dx_var _ 150 - | Dx_execute 151 - | Route_asset 152 - | Syndicate_current_tree_as_atom_feed 153 - | Syndicate_query_as_json_blob 122 + | Tag _ | Date | Number | Dx_var _ | Dx_execute | Route_asset 123 + | Syndicate_current_tree_as_atom_feed | Syndicate_query_as_json_blob 154 124 | Current_tree -> 155 125 []
+7 -14
lib/core/TeX_cs.ml
··· 6 6 7 7 open Forester_prelude 8 8 9 - type t = 10 - | Word of string 11 - | Symbol of char 12 - [@@deriving repr] 9 + type t = Word of string | Symbol of char [@@deriving repr] 13 10 14 11 let pp fmt = function 15 12 | Word x -> Format.fprintf fmt "%s" x ··· 19 16 20 17 let is_alpha c = 21 18 let i = Char.code c in 22 - i >= 65 && i <= 90 || i >= 97 && i <= 122 19 + (i >= 65 && i <= 90) || (i >= 97 && i <= 122) 23 20 24 21 let rec parse_word acc xs = 25 22 match xs with 26 - | [] -> Word (String_util.implode_bwd acc), "" 23 + | [] -> (Word (String_util.implode_bwd acc), "") 27 24 | x :: xs -> 28 - if is_alpha x then 29 - parse_word (Bwd.Snoc (acc, x)) xs 30 - else 31 - Word (String_util.implode_bwd acc), String_util.implode (x :: xs) 25 + if is_alpha x then parse_word (Bwd.Snoc (acc, x)) xs 26 + else (Word (String_util.implode_bwd acc), String_util.implode (x :: xs)) 32 27 33 28 let parse input = 34 29 match String_util.explode input with 35 30 | x :: xs -> 36 - if is_alpha x then 37 - Some (parse_word (Bwd.Snoc (Bwd.Emp, x)) xs) 38 - else 39 - Some (Symbol x, String_util.implode xs) 31 + if is_alpha x then Some (parse_word (Bwd.Snoc (Bwd.Emp, x)) xs) 32 + else Some (Symbol x, String_util.implode xs) 40 33 | [] -> None
+1 -5
lib/core/TeX_cs.mli
··· 4 4 * SPDX-License-Identifier: GPL-3.0-or-later 5 5 *) 6 6 7 - type t = 8 - | Word of string 9 - | Symbol of char 7 + type t = Word of string | Symbol of char 10 8 11 9 val pp : Format.formatter -> t -> unit 12 10 val show : t -> string 13 - 14 11 val t : t Repr.t 15 - 16 12 val parse : string -> (t * string) option
+11 -6
lib/core/TeX_like.ml
··· 8 8 open Types 9 9 10 10 let rec pp_content fmt = function 11 - | Content nodes -> 12 - List.iter (pp_content_node fmt) nodes 11 + | Content nodes -> List.iter (pp_content_node fmt) nodes 13 12 14 13 and pp_content_node fmt = function 15 14 | Text str -> Format.fprintf fmt "%s" str 16 15 | CDATA str -> Format.fprintf fmt "%s" str 17 16 | KaTeX (_, xs) -> pp_content fmt xs 18 - | Xml_elt _ | Transclude _ | Contextual_number _ | Section _ | Link _ | Artefact _ | Uri _ | Route_of_uri _ | Datalog_script _ | Results_of_datalog_query _ -> 19 - Reporter.fatal Internal_error ~extra_remarks: [Asai.Diagnostic.loctextf "Cannot render this kind of content node as TeX-like string"] 17 + | Xml_elt _ | Transclude _ | Contextual_number _ | Section _ | Link _ 18 + | Artefact _ | Uri _ | Route_of_uri _ | Datalog_script _ 19 + | Results_of_datalog_query _ -> 20 + Reporter.fatal Internal_error 21 + ~extra_remarks: 22 + [ 23 + Asai.Diagnostic.loctextf 24 + "Cannot render this kind of content node as TeX-like string"; 25 + ] 20 26 21 - let string_of_content = 22 - Format.asprintf "%a" pp_content 27 + let string_of_content = Format.asprintf "%a" pp_content
+50 -72
lib/core/Tree.ml
··· 38 38 [@@deriving show] 39 39 40 40 type t = 41 - | Document of (Lsp.Text_document.t [@opaque]) 41 + | Document of (Lsp.Text_document.t[@opaque]) 42 42 | Parsed of code 43 43 | Expanded of syn 44 44 | Resource of evaluated ··· 48 48 | Document doc -> Physical doc 49 49 | Parsed parsed -> parsed.origin 50 50 | Expanded expanded -> expanded.code.origin 51 - | Resource resource -> 51 + | Resource resource -> ( 52 52 match resource.expanded with 53 53 | None -> Undefined 54 - | Some expanded -> expanded.code.origin 54 + | Some expanded -> expanded.code.origin) 55 55 56 56 let show_phase = function 57 57 | Document _ -> "document" ··· 76 76 (* IDK if subtrees should resolve to their parent document*) 77 77 let to_doc : t -> Lsp.Text_document.t option = function 78 78 | Document doc -> Some doc 79 - | Resource {expanded; _} -> 80 - begin 81 - match expanded with 82 - | None -> None 83 - | Some {code; _} -> 84 - match code.origin with 85 - | Physical doc -> 86 - Some doc 87 - | Subtree _ -> None 88 - | Undefined -> None 89 - end 90 - | Parsed {origin; _;} 91 - | Expanded {code = {origin; _}; _;} -> 79 + | Resource {expanded; _} -> begin 80 + match expanded with 81 + | None -> None 82 + | Some {code; _} -> ( 83 + match code.origin with 84 + | Physical doc -> Some doc 85 + | Subtree _ -> None 86 + | Undefined -> None) 87 + end 88 + | Parsed {origin; _} | Expanded {code = {origin; _}; _} -> ( 92 89 match origin with 93 - | Physical doc -> 94 - Some doc 90 + | Physical doc -> Some doc 95 91 | Subtree _ -> None 96 - | Undefined -> None 92 + | Undefined -> None) 97 93 98 94 let to_resource : t -> T.content T.resource option = function 99 - | Document _ 100 - | Parsed _ 101 - | Expanded _ -> 102 - None 103 - | Resource {resource; _;} -> Some resource 95 + | Document _ | Parsed _ | Expanded _ -> None 96 + | Resource {resource; _} -> Some resource 104 97 105 98 let to_evaluated : t -> evaluated option = function 106 - | Document _ 107 - | Parsed _ 108 - | Expanded _ -> 109 - None 99 + | Document _ | Parsed _ | Expanded _ -> None 110 100 | Resource evaluated -> Some evaluated 111 101 112 102 let to_article : t -> T.content T.article option = function 113 - | Document _ 114 - | Parsed _ 115 - | Expanded _ -> 116 - None 117 - | Resource {resource; _;} -> 118 - match resource with 119 - | T.Article a -> Some a 120 - | _ -> None 103 + | Document _ | Parsed _ | Expanded _ -> None 104 + | Resource {resource; _} -> ( 105 + match resource with T.Article a -> Some a | _ -> None) 121 106 122 107 let get_frontmatter : t -> T.content T.frontmatter option = function 123 108 | Resource {resource = Types.Article {frontmatter; _}; _} -> Some frontmatter ··· 129 114 (* assert false *) 130 115 None 131 116 | Parsed code -> Some code 132 - | Resource {expanded; _} -> 133 - begin 134 - match expanded with 135 - | None -> None 136 - | Some {code; _} -> Some code 137 - end 138 - | Expanded {code; _;} -> Some code 117 + | Resource {expanded; _} -> begin 118 + match expanded with None -> None | Some {code; _} -> Some code 119 + end 120 + | Expanded {code; _} -> Some code 139 121 140 122 let to_syn : t -> syn option = function 141 123 | Document _ -> None 142 124 | Parsed _ -> None 143 125 | Expanded syn -> Some syn 144 - | Resource {expanded; _} -> 145 - expanded 126 + | Resource {expanded; _} -> expanded 146 127 147 - let get_units : t -> exports option = fun item -> 128 + let get_units : t -> exports option = 129 + fun item -> 148 130 match item with 149 131 | Document _ -> None 150 132 | Parsed _ -> None 151 133 | Expanded {units; _} -> Some units 152 - | Resource {expanded; _} -> 153 - match expanded with 154 - | Some {units; _} -> Some units 155 - | None -> None 134 + | Resource {expanded; _} -> ( 135 + match expanded with Some {units; _} -> Some units | None -> None) 156 136 157 - let is_unparsed = function 158 - | Document _ -> true 159 - | _ -> false 160 - 137 + let is_unparsed = function Document _ -> true | _ -> false 161 138 let is_parsed t = not @@ is_unparsed t 162 139 163 140 let is_unexpanded = function ··· 175 152 176 153 let is_asset = function 177 154 | Document _ | Parsed _ | Expanded _ -> false 178 - | Resource {resource; _} -> 179 - match resource with 180 - | T.Asset _ -> true 181 - | _ -> false 155 + | Resource {resource; _} -> ( 156 + match resource with T.Asset _ -> true | _ -> false) 182 157 183 - let update_units 184 - : t -> exports -> t 185 - = fun item units -> 158 + let update_units : t -> exports -> t = 159 + fun item units -> 186 160 match item with 187 - | Document _ 188 - | Parsed _ -> 189 - Reporter.fatal 190 - Internal_error 191 - ~extra_remarks: [Asai.Diagnostic.loctext "can't update units for this item. It has not been expanded yet"] 161 + | Document _ | Parsed _ -> 162 + Reporter.fatal Internal_error 163 + ~extra_remarks: 164 + [ 165 + Asai.Diagnostic.loctext 166 + "can't update units for this item. It has not been expanded yet"; 167 + ] 192 168 | Expanded e -> Expanded {e with units} 193 - | Resource ({expanded; _} as e) -> 169 + | Resource ({expanded; _} as e) -> ( 194 170 match expanded with 195 171 | None -> 196 - Reporter.fatal 197 - Internal_error 198 - ~extra_remarks: [Asai.Diagnostic.loctext "can't update units for this item. It is not a tree."] 199 - | Some expanded -> 200 - Resource {e with expanded = Some {expanded with units}} 172 + Reporter.fatal Internal_error 173 + ~extra_remarks: 174 + [ 175 + Asai.Diagnostic.loctext 176 + "can't update units for this item. It is not a tree."; 177 + ] 178 + | Some expanded -> Resource {e with expanded = Some {expanded with units}})
+1 -2
lib/core/Trie.ml
··· 6 6 7 7 include Yuujinchou.Trie 8 8 9 - type path = string list 10 - [@@deriving repr] 9 + type path = string list [@@deriving repr] 11 10 12 11 let pp_path = 13 12 let pp_sep fmt () = Format.pp_print_string fmt "/" in
+90 -85
lib/core/Types.ml
··· 8 8 open Forester_xml_names 9 9 open Base 10 10 11 - type xml_qname = Forester_xml_names.xml_qname = {prefix: string; uname: string; xmlns: string option} 11 + type xml_qname = Forester_xml_names.xml_qname = { 12 + prefix: string; 13 + uname: string; 14 + xmlns: string option; 15 + } 12 16 13 - type 'content vertex = 14 - | Uri_vertex of URI.t 15 - | Content_vertex of 'content 17 + type 'content vertex = Uri_vertex of URI.t | Content_vertex of 'content 16 18 [@@deriving show, repr] 17 19 18 20 type section_flags = { ··· 21 23 header_shown: bool option; 22 24 metadata_shown: bool option; 23 25 numbered: bool option; 24 - expanded: bool option 26 + expanded: bool option; 25 27 } 26 28 [@@deriving show, repr] 27 29 28 - type title_flags = {empty_when_untitled: bool} 29 - [@@deriving show, repr] 30 + type title_flags = {empty_when_untitled: bool} [@@deriving show, repr] 30 31 31 - let default_section_flags = { 32 - hidden_when_empty = None; 33 - included_in_toc = None; 34 - header_shown = None; 35 - metadata_shown = Some false; 36 - numbered = None; 37 - expanded = None 38 - } 32 + let default_section_flags = 33 + { 34 + hidden_when_empty = None; 35 + included_in_toc = None; 36 + header_shown = None; 37 + metadata_shown = Some false; 38 + numbered = None; 39 + expanded = None; 40 + } 39 41 40 42 type 'content xml_attr = {key: xml_qname; value: 'content} 41 43 [@@deriving show, repr] ··· 43 45 type 'content xml_elt = { 44 46 name: xml_qname; 45 47 attrs: 'content xml_attr list; 46 - content: 'content 48 + content: 'content; 47 49 } 48 50 [@@deriving show, repr] 49 51 50 - type attribution_role = 51 - | Author 52 - | Contributor 53 - [@@deriving show, repr] 52 + type attribution_role = Author | Contributor [@@deriving show, repr] 54 53 55 - type 'content attribution = { 56 - role: attribution_role; 57 - vertex: 'content vertex 58 - } 54 + type 'content attribution = {role: attribution_role; vertex: 'content vertex} 59 55 [@@deriving show, repr] 60 56 61 57 type 'content frontmatter = { ··· 76 72 type 'content section = { 77 73 frontmatter: 'content frontmatter; 78 74 mainmatter: 'content; 79 - flags: section_flags 75 + flags: section_flags; 80 76 } 81 77 [@@deriving show, repr] 82 78 ··· 87 83 } 88 84 [@@deriving show, repr] 89 85 90 - type asset = {uri: URI.t; content: string} 91 - [@@deriving show, repr] 86 + type asset = {uri: URI.t; content: string} [@@deriving show, repr] 92 87 93 - type 'a json_blob_syndication = {blob_uri: URI.t; query: (string, 'a vertex) Datalog_expr.query} 88 + type 'a json_blob_syndication = { 89 + blob_uri: URI.t; 90 + query: (string, 'a vertex) Datalog_expr.query; 91 + } 94 92 [@@deriving show, repr] 95 93 96 94 type atom_feed_syndication = {source_uri: URI.t; feed_uri: URI.t} ··· 107 105 | Syndication of 'content syndication 108 106 [@@deriving show, repr] 109 107 110 - type 'content forest = 'content resource list 111 - [@@deriving show, repr] 108 + type 'content forest = 'content resource list [@@deriving show, repr] 112 109 113 110 type content_target = 114 111 | Full of section_flags ··· 117 114 | Taxon 118 115 [@@deriving show, repr] 119 116 120 - type transclusion = { 121 - href: URI.t; 122 - target: content_target 123 - } 117 + type transclusion = {href: URI.t; target: content_target} 124 118 [@@deriving show, repr] 125 119 126 - type 'content link = { 127 - href: URI.t; 128 - content: 'content 129 - } 130 - [@@deriving show, repr] 120 + type 'content link = {href: URI.t; content: 'content} [@@deriving show, repr] 131 121 132 - type artefact_source = { 133 - type_: string; 134 - part: string; 135 - source: string 136 - } 122 + type artefact_source = {type_: string; part: string; source: string} 137 123 [@@deriving show, repr] 138 124 139 125 type 'content artefact = { 140 126 hash: string; 141 127 content: 'content; 142 - sources: artefact_source list 128 + sources: artefact_source list; 143 129 } 144 130 [@@deriving show, repr] 145 131 ··· 159 145 | Results_of_datalog_query of (string, 'content vertex) Datalog_expr.query 160 146 [@@deriving show, repr] 161 147 162 - type content = 163 - Content of content content_node list 164 - [@@deriving show, repr] 148 + type content = Content of content content_node list [@@deriving show, repr] 165 149 166 150 let rec compress_nodes = function 167 151 | [] -> [] ··· 173 157 174 158 let concat_compressed_content (Content xs) (Content ys) = 175 159 let rec loop xs ys = 176 - match xs, ys with 160 + match (xs, ys) with 177 161 | Bwd.Emp, ys -> ys 178 162 | _, [] -> Bwd.prepend xs [] 179 163 | Bwd.Snoc (xs, Text x), Text y :: ys -> loop xs (Text (x ^ y) :: ys) ··· 182 166 Content (loop (Bwd.append Bwd.Emp xs) ys) 183 167 184 168 let html_elt uname (content : 'content) : 'content content_node = 185 - let name = {prefix = "html"; uname; xmlns = Some "http://www.w3.org/1999/xhtml"} in 169 + let name = 170 + {prefix = "html"; uname; xmlns = Some "http://www.w3.org/1999/xhtml"} 171 + in 186 172 Xml_elt {content; name; attrs = []} 187 173 188 174 let prim (p : Prim.t) : 'content -> 'content content_node = 189 - html_elt @@ 190 - match p with 191 - | `P -> "p" 192 - | `Ol -> "ol" 193 - | `Ul -> "ul" 194 - | `Li -> "li" 195 - | `Figure -> "figure" 196 - | `Figcaption -> "figcaption" 197 - | `Em -> "em" 198 - | `Strong -> "strong" 199 - | `Blockquote -> "blockquote" 200 - | `Pre -> "pre" 201 - | `Code -> "code" 175 + html_elt 176 + @@ 177 + match p with 178 + | `P -> "p" 179 + | `Ol -> "ol" 180 + | `Ul -> "ul" 181 + | `Li -> "li" 182 + | `Figure -> "figure" 183 + | `Figcaption -> "figcaption" 184 + | `Em -> "em" 185 + | `Strong -> "strong" 186 + | `Blockquote -> "blockquote" 187 + | `Pre -> "pre" 188 + | `Code -> "code" 202 189 203 190 let map_content f = function Content nodes -> Content (f nodes) 204 191 let extract_content = function Content nodes -> nodes ··· 206 193 type dx_query = (string, content vertex) Datalog_expr.query [@@deriving show] 207 194 208 195 let is_whitespace node = 209 - match node with 210 - | Text txt -> String.trim txt = "" 211 - | _ -> false 196 + match node with Text txt -> String.trim txt = "" | _ -> false 212 197 213 198 let strip_whitespace = 214 - map_content @@ 215 - List.filter @@ 216 - Fun.compose not is_whitespace 199 + map_content @@ List.filter @@ Fun.compose not is_whitespace 217 200 218 201 let trim_whitespace xs = 219 202 let rec trim_front = function 220 203 | x :: xs when is_whitespace x -> trim_front xs 221 204 | xs -> xs 222 - and trim_back xs = List.rev @@ trim_front @@ List.rev xs 223 - in 205 + and trim_back xs = List.rev @@ trim_front @@ List.rev xs in 224 206 trim_back @@ trim_front xs 225 207 226 - let default_frontmatter ?uri ?source_path ?designated_parent ?(dates = []) ?(attributions = []) ?taxon ?number ?(metas = []) ?(tags = []) ?title ?last_changed () = {uri; source_path; designated_parent; dates; attributions; taxon; number; metas; tags; title; last_changed} 208 + let default_frontmatter ?uri ?source_path ?designated_parent ?(dates = []) 209 + ?(attributions = []) ?taxon ?number ?(metas = []) ?(tags = []) ?title 210 + ?last_changed () = 211 + { 212 + uri; 213 + source_path; 214 + designated_parent; 215 + dates; 216 + attributions; 217 + taxon; 218 + number; 219 + metas; 220 + tags; 221 + title; 222 + last_changed; 223 + } 227 224 228 225 let article_to_section ?(flags = default_section_flags) (article : 'a article) = 229 226 let mainmatter = ··· 231 228 | Some href -> Content [Transclude {href; target = Mainmatter}] 232 229 | None -> article.mainmatter 233 230 in 234 - { 235 - frontmatter = article.frontmatter; 236 - mainmatter; 237 - flags 238 - } 231 + {frontmatter = article.frontmatter; mainmatter; flags} 239 232 240 233 let uri_for_syndication = function 241 234 | Atom_feed feed -> Some feed.feed_uri ··· 246 239 | Asset asset -> Some asset.uri 247 240 | Syndication syndication -> uri_for_syndication syndication 248 241 249 - module Comparators (I : sig val string_of_content : content -> string end) = struct 250 - let compare_content = 251 - Compare.under I.string_of_content String.compare 242 + module Comparators (I : sig 243 + val string_of_content : content -> string 244 + end) = 245 + struct 246 + let compare_content = Compare.under I.string_of_content String.compare 252 247 253 248 let compare_frontmatter = 254 249 let latest_date (fm : content frontmatter) = 255 - let sorted_dates = fm.dates |> List.sort @@ Compare.invert Human_datetime.compare in 250 + let sorted_dates = 251 + fm.dates |> List.sort @@ Compare.invert Human_datetime.compare 252 + in 256 253 List.nth_opt sorted_dates 0 257 254 in 258 - let by_date = Fun.flip @@ Compare.under latest_date @@ Compare.option Human_datetime.compare in 259 - let by_title = Compare.option compare_content |> Compare.under @@ fun fm -> fm.title in 260 - let by_parent = compare |> Compare.under @@ fun fm -> Option.is_some fm.designated_parent in 255 + let by_date = 256 + Fun.flip @@ Compare.under latest_date 257 + @@ Compare.option Human_datetime.compare 258 + in 259 + let by_title = 260 + Compare.option compare_content |> Compare.under @@ fun fm -> fm.title 261 + in 262 + let by_parent = 263 + compare |> Compare.under @@ fun fm -> Option.is_some fm.designated_parent 264 + in 261 265 Compare.cascade by_parent @@ Compare.cascade by_date by_title 262 266 263 - let compare_article = compare_frontmatter |> Compare.under @@ fun x -> x.frontmatter 267 + let compare_article = 268 + compare_frontmatter |> Compare.under @@ fun x -> x.frontmatter 264 269 end
+36 -48
lib/core/URI.ml
··· 18 18 let hydrate {scheme; userinfo; host; port; path; query; fragment} = 19 19 Uri.make ?scheme ?userinfo ?host ?port ~path ~query ?fragment () 20 20 21 - let dehydrate x = { 22 - scheme = Uri.scheme x; 23 - userinfo = Uri.userinfo x; 24 - host = Uri.host x; 25 - port = Uri.port x; 26 - path = Uri.path x; 27 - query = Uri.query x; 28 - fragment = Uri.fragment x 29 - } 21 + let dehydrate x = 22 + { 23 + scheme = Uri.scheme x; 24 + userinfo = Uri.userinfo x; 25 + host = Uri.host x; 26 + port = Uri.port x; 27 + path = Uri.path x; 28 + query = Uri.query x; 29 + fragment = Uri.fragment x; 30 + } 30 31 31 32 let host x = x.host 32 33 let scheme x = x.scheme 33 34 let port x = x.port 34 - 35 - let path_components x = 36 - String.split_on_char '/' @@ Uri.pct_decode x.path 35 + let path_components x = String.split_on_char '/' @@ Uri.pct_decode x.path 37 36 38 37 let rec strip_path_components xs = 39 - match xs with 40 - | "" :: xs -> strip_path_components xs 41 - | xs -> xs 38 + match xs with "" :: xs -> strip_path_components xs | xs -> xs 42 39 43 - let stripped_path_components x = 44 - strip_path_components @@ path_components x 45 - 46 - let path_string x = 47 - String.concat "/" @@ path_components x 40 + let stripped_path_components x = strip_path_components @@ path_components x 41 + let path_string x = String.concat "/" @@ path_components x 48 42 49 43 let append_path_component xs x = 50 - List.rev @@ x :: strip_path_components (List.rev xs) 44 + List.rev @@ (x :: strip_path_components (List.rev xs)) 51 45 52 - let equal = (=) 46 + let equal = ( = ) 53 47 let compare = compare 54 - 55 - let resolve ~base x = 56 - dehydrate @@ Uri.resolve "" (hydrate base) (hydrate x) 57 - 48 + let resolve ~base x = dehydrate @@ Uri.resolve "" (hydrate base) (hydrate x) 58 49 let canonicalise uri = dehydrate @@ Uri.canonicalize @@ hydrate uri 59 50 let hash (uri : t) = Hashtbl.hash uri 60 51 61 52 let with_path_components xs uri = 62 - dehydrate @@ 63 - Uri.canonicalize @@ 64 - Uri.with_path (hydrate uri) @@ String.concat "/" xs 53 + dehydrate @@ Uri.canonicalize 54 + @@ Uri.with_path (hydrate uri) 55 + @@ String.concat "/" xs 65 56 66 57 let pp (fmt : Format.formatter) (uri : t) = 67 - Format.fprintf fmt "%s" @@ 68 - Uri.pct_decode @@ Uri.to_string @@ hydrate uri 58 + Format.fprintf fmt "%s" @@ Uri.pct_decode @@ Uri.to_string @@ hydrate uri 69 59 70 - let to_string x = 71 - Uri.pct_decode @@ Uri.to_string @@ hydrate x 72 - 60 + let to_string x = Uri.pct_decode @@ Uri.to_string @@ hydrate x 73 61 let t = Repr.map Repr.string (Fun.compose dehydrate Uri.of_string) to_string 74 - 75 - let of_string_exn str = 76 - dehydrate @@ Uri.canonicalize @@ Uri.of_string str 62 + let of_string_exn str = dehydrate @@ Uri.canonicalize @@ Uri.of_string str 77 63 78 64 let make ?scheme ?user ?host ?port ?path () = 79 65 let path = Option.map (String.concat "/") path in 80 - dehydrate @@ Uri.canonicalize @@ Uri.make ?scheme ?userinfo: user ?host ?port ?path () 66 + dehydrate @@ Uri.canonicalize 67 + @@ Uri.make ?scheme ?userinfo:user ?host ?port ?path () 81 68 82 69 let relative_path_string ~(base : t) uri : string = 83 - Str.replace_first (Str.regexp (Format.asprintf "^%a" pp base)) "" @@ 84 - to_string uri 70 + Str.replace_first (Str.regexp (Format.asprintf "^%a" pp base)) "" 71 + @@ to_string uri 85 72 86 73 let display_path_string ~base uri = 87 74 if host uri = host base then 88 - Str.replace_first (Str.regexp (Format.asprintf "^%a" pp base)) "" @@ 89 - to_string @@ with_path_components (List.rev @@ strip_path_components @@ List.rev @@ path_components uri) uri 90 - else 91 - to_string uri 75 + Str.replace_first (Str.regexp (Format.asprintf "^%a" pp base)) "" 76 + @@ to_string 77 + @@ with_path_components 78 + (List.rev @@ strip_path_components @@ List.rev @@ path_components uri) 79 + uri 80 + else to_string uri 92 81 end 93 82 94 - module Set = Set.Make(Basics) 95 - module Map = Map.Make(Basics) 96 - module Tbl = Hashtbl.Make(Basics) 97 - 83 + module Set = Set.Make (Basics) 84 + module Map = Map.Make (Basics) 85 + module Tbl = Hashtbl.Make (Basics) 98 86 include Basics
+8 -9
lib/core/URI.mli
··· 13 13 val append_path_component : string list -> string -> string list 14 14 val path_components : t -> string list 15 15 val with_path_components : string list -> t -> t 16 - 17 16 val canonicalise : t -> t 18 - val relative_path_string : base: t -> t -> string 19 - val display_path_string : base: t -> t -> string 20 - val resolve : base: t -> t -> t 17 + val relative_path_string : base:t -> t -> string 18 + val display_path_string : base:t -> t -> string 19 + val resolve : base:t -> t -> t 21 20 val equal : t -> t -> bool 22 21 val compare : t -> t -> int 23 22 24 23 val make : 25 - ?scheme: string -> 26 - ?user: string -> 27 - ?host: string -> 28 - ?port: int -> 29 - ?path: string list -> 24 + ?scheme:string -> 25 + ?user:string -> 26 + ?host:string -> 27 + ?port:int -> 28 + ?path:string list -> 30 29 unit -> 31 30 t 32 31
+15 -27
lib/core/URI_scheme.ml
··· 7 7 open Forester_prelude 8 8 9 9 let named_uri ~base name = 10 - URI.resolve ~base @@ 11 - let path = 12 - if Filename.extension name = "" then [name; ""] else [name] 13 - in 14 - URI.make ~path () 10 + URI.resolve ~base 11 + @@ 12 + let path = if Filename.extension name = "" then [name; ""] else [name] in 13 + URI.make ~path () 15 14 16 - let last_segment str = 17 - str 18 - |> String.split_on_char '/' 19 - |> List.rev 20 - |> List.hd 15 + let last_segment str = str |> String.split_on_char '/' |> List.rev |> List.hd 21 16 22 17 let name (uri : URI.t) : string option = 23 - uri 24 - |> URI.path_components 18 + uri |> URI.path_components 25 19 |> List.filter (fun x -> not (x = "")) 26 - |> List.rev 27 - |> (List.nth_opt @~ 0) 20 + |> List.rev |> List.nth_opt @~ 0 28 21 29 22 let split_addr (uri : URI.t) : (string option * int) option = 30 23 let@ name = Option.bind @@ name uri in 31 24 (* primitively check for address of form YYYY-MM-DD *) 32 - let date_regex = Str.regexp {|^[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]$|} in 25 + let date_regex = 26 + Str.regexp {|^[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]$|} 27 + in 33 28 if Str.string_match date_regex name 0 then None 34 29 else 35 30 match String.rindex_opt name '-' with 36 31 | Some i -> 37 32 let prefix = String.sub name 0 i 38 - and suffix = String.sub name (i + 1) (String.length name - i - 1) 39 - in 33 + and suffix = String.sub name (i + 1) (String.length name - i - 1) in 40 34 let@ key = Option.map @~ BaseN.Base36.int_of_string suffix in 41 - Some prefix, key 35 + (Some prefix, key) 42 36 | _ -> 43 37 let@ key = Option.map @~ BaseN.Base36.int_of_string name in 44 - None, key 38 + (None, key) 45 39 46 40 let lsp_uri_to_uri ~(base : URI.t) (uri : Lsp.Uri.t) : URI.t = 47 41 let uri = 48 - uri 49 - |> Lsp.Uri.to_path 50 - |> Filename.chop_extension 51 - |> last_segment 42 + uri |> Lsp.Uri.to_path |> Filename.chop_extension |> last_segment 52 43 |> named_uri ~base 53 44 in 54 45 uri 55 46 56 47 let path_to_uri ~(base : URI.t) str = 57 - str 58 - |> last_segment 59 - |> Filename.chop_extension 60 - |> named_uri ~base 48 + str |> last_segment |> Filename.chop_extension |> named_uri ~base
+4 -19
lib/core/URI_scheme.mli
··· 4 4 * SPDX-License-Identifier: GPL-3.0-or-later 5 5 *) 6 6 7 - val named_uri : 8 - base: URI.t -> 9 - string -> 10 - URI.t 11 - 12 - val lsp_uri_to_uri : 13 - base: URI.t -> 14 - Lsp.Uri.t -> 15 - URI.t 16 - 17 - val split_addr : 18 - URI.t -> 19 - (string option * int) option 20 - 21 - val path_to_uri : 22 - base: URI.t -> 23 - string -> 24 - URI.t 25 - 7 + val named_uri : base:URI.t -> string -> URI.t 8 + val lsp_uri_to_uri : base:URI.t -> Lsp.Uri.t -> URI.t 9 + val split_addr : URI.t -> (string option * int) option 10 + val path_to_uri : base:URI.t -> string -> URI.t 26 11 val last_segment : string -> string 27 12 val name : URI.t -> string option
+12 -11
lib/core/Value.ml
··· 7 7 open Forester_prelude 8 8 open Base 9 9 10 - open struct module T = Types end 10 + open struct 11 + module T = Types 12 + end 11 13 12 - module String_map = Map.Make(String) 13 - module Symbol_map = Map.Make(Symbol) 14 + module String_map = Map.Make (String) 15 + module Symbol_map = Map.Make (Symbol) 14 16 15 17 type t = 16 18 | Content of T.content 17 - | Clo of (t String_map.t [@opaque]) * string option binding list * Syn.t 19 + | Clo of (t String_map.t[@opaque]) * string option binding list * Syn.t 18 20 | Dx_prop of (string, T.content T.vertex) Datalog_expr.prop 19 21 | Dx_sequent of (string, T.content T.vertex) Datalog_expr.sequent 20 22 | Dx_query of (string, T.content T.vertex) Datalog_expr.query ··· 28 30 body: Syn.t; 29 31 self: string option; 30 32 super: string option; 31 - env: t String_map.t [@opaque] 33 + env: t String_map.t; [@opaque] 32 34 } 33 35 [@@deriving show] 34 36 35 37 module Method_table = struct 36 - include Map.Make(String) 37 - let pp (pp_el : Format.formatter -> 'a -> unit) (fmt : Format.formatter) (map : 'a t) = 38 + include Map.Make (String) 39 + 40 + let pp (pp_el : Format.formatter -> 'a -> unit) (fmt : Format.formatter) 41 + (map : 'a t) = 38 42 Format.fprintf fmt "@[<v1>{"; 39 43 begin 40 44 let@ k, v = Seq.iter @~ to_seq map in ··· 43 47 Format.fprintf fmt "}@]" 44 48 end 45 49 46 - type obj = { 47 - prototype: Symbol.t option; 48 - methods: obj_method Method_table.t 49 - } 50 + type obj = {prototype: Symbol.t option; methods: obj_method Method_table.t} 50 51 [@@deriving show]
+1 -3
lib/core/Vertex.ml
··· 6 6 7 7 open Types 8 8 9 - type t = content vertex 10 - [@@deriving show] 9 + type t = content vertex [@@deriving show] 11 10 12 11 let clean = function 13 12 | Content_vertex x -> Content_vertex x 14 13 | Uri_vertex uri -> Uri_vertex uri 15 14 16 15 let hash x = Hashtbl.hash (clean x) 17 - 18 16 let compare x y = compare (clean x) (clean y) 19 17 let equal x y = clean x = clean y 20 18
+2 -2
lib/core/Vertex.mli
··· 5 5 *) 6 6 7 7 type t = Types.content Types.vertex 8 + 8 9 include Set.OrderedType with type t := t 10 + 9 11 val equal : t -> t -> bool 10 12 val hash : t -> int 11 - 12 13 val pp : Format.formatter -> t -> unit 13 14 val show : t -> string 14 - 15 15 val uri_of_vertex : t -> URI.t option
+1 -1
lib/core/Vertex_set.ml
··· 4 4 * SPDX-License-Identifier: GPL-3.0-or-later 5 5 *) 6 6 7 - include Set.Make(Vertex) 7 + include Set.Make (Vertex)
-4
lib/core/Vertex_set.mli
··· 9 9 val empty : t 10 10 val add : Vertex.t -> t -> t 11 11 val diff : t -> t -> t 12 - 13 12 val of_list : Vertex.t list -> t 14 13 val to_list : t -> Vertex.t list 15 14 val to_seq : t -> Vertex.t Seq.t 16 15 val of_seq : Vertex.t Seq.t -> t 17 16 val union : t -> t -> t 18 17 val filter : (Vertex.t -> bool) -> t -> t 19 - 20 18 val elements : t -> Vertex.t list 21 - 22 19 val cardinal : t -> int 23 - 24 20 val mem : Vertex.t -> t -> bool 25 21 val fold : (Vertex.t -> 'acc -> 'acc) -> t -> 'acc -> 'acc 26 22 val iter : (Vertex.t -> unit) -> t -> unit
+9 -11
lib/core/test/Test_uri_util.ml
··· 6 6 7 7 open Forester_core 8 8 9 - 10 9 let test_split_addr_1 () = 11 10 let uri = URI.of_string_exn "forest://test/foo-bar" in 12 11 Alcotest.(check @@ option @@ pair (option string) int) ··· 44 43 45 44 let () = 46 45 let open Alcotest in 47 - run 48 - "Test_uri_util" 46 + run "Test_uri_util" 49 47 [ 50 - "split_addr", 51 - [ 52 - test_case "split_addr" `Quick test_split_addr_1; 53 - test_case "split_addr" `Quick test_split_addr_2; 54 - test_case "split_addr" `Quick test_split_addr_3; 55 - test_case "split_addr" `Quick test_split_addr_4; 56 - test_case "split_addr" `Quick test_split_addr_5; 57 - ] 48 + ( "split_addr", 49 + [ 50 + test_case "split_addr" `Quick test_split_addr_1; 51 + test_case "split_addr" `Quick test_split_addr_2; 52 + test_case "split_addr" `Quick test_split_addr_3; 53 + test_case "split_addr" `Quick test_split_addr_4; 54 + test_case "split_addr" `Quick test_split_addr_5; 55 + ] ); 58 56 ]
+62 -57
lib/frontend/Atom_client.ml
··· 17 17 let null = P.HTML.null 18 18 19 19 let feed attrs = 20 - P.std_tag "feed" @@ 21 - P.string_attr "xmlns" "http://www.w3.org/2005/Atom" :: attrs 20 + P.std_tag "feed" 21 + @@ (P.string_attr "xmlns" "http://www.w3.org/2005/Atom" :: attrs) 22 22 23 23 let title fmt = P.text_tag "title" fmt 24 24 let link = P.void_tag "link" 25 - 26 25 let href fmt = P.string_attr "href" fmt 27 - 28 26 let updated fmt = P.text_tag "updated" fmt 29 27 let published fmt = P.text_tag "published" fmt 30 28 let author = P.std_tag "author" ··· 40 38 let rel fmt = P.string_attr "rel" fmt 41 39 end 42 40 43 - open struct module A = Atom end 41 + open struct 42 + module A = Atom 43 + end 44 44 45 - let get_date_range (dates : Human_datetime.t list) : (Human_datetime.t * Human_datetime.t) option = 45 + let get_date_range (dates : Human_datetime.t list) : 46 + (Human_datetime.t * Human_datetime.t) option = 46 47 let sorted = List.sort Human_datetime.compare dates in 47 48 let@ first = Option.bind @@ List.nth_opt sorted 0 in 48 49 let@ last = Option.bind @@ List.nth_opt (List.rev sorted) 0 in 49 50 Some (first, last) 50 51 51 52 let render_title forest ?scope (frontmatter : _ T.frontmatter) = 52 - A.title 53 - [] 54 - "%s" @@ 55 - Plain_text_client.string_of_content ~forest @@ 56 - State.get_expanded_title ?scope frontmatter forest 53 + A.title [] "%s" 54 + @@ Plain_text_client.string_of_content ~forest 55 + @@ State.get_expanded_title ?scope frontmatter forest 57 56 58 57 let render_dates_exn dates = 59 58 match get_date_range dates with ··· 61 60 | Some (oldest, newest) -> 62 61 A.null 63 62 [ 64 - A.published [] "%s" @@ Format.asprintf "%a" Human_datetime.pp_rfc_3399 oldest; 65 - A.updated [] "%s" @@ Format.asprintf "%a" Human_datetime.pp_rfc_3399 newest 63 + A.published [] "%s" 64 + @@ Format.asprintf "%a" Human_datetime.pp_rfc_3399 oldest; 65 + A.updated [] "%s" 66 + @@ Format.asprintf "%a" Human_datetime.pp_rfc_3399 newest; 66 67 ] 67 68 68 69 let render_updated_date dates = 69 70 let sorted_dates = List.sort Human_datetime.compare dates in 70 71 match List.nth_opt (List.rev sorted_dates) 0 with 71 72 | None -> A.null [] 72 - | Some newest -> A.updated [] "%s" @@ Format.asprintf "%a" Human_datetime.pp newest 73 - 74 - let render_dates dates = 75 - try render_dates_exn dates with _ -> A.null [] 73 + | Some newest -> 74 + A.updated [] "%s" @@ Format.asprintf "%a" Human_datetime.pp newest 76 75 76 + let render_dates dates = try render_dates_exn dates with _ -> A.null [] 77 77 let string_of_content forest = Plain_text_client.string_of_content ~forest 78 78 79 79 let render_attribution forest (attribution : _ T.attribution) = ··· 87 87 | T.Content_vertex content -> 88 88 [A.name [] "%s" @@ string_of_content forest content] 89 89 | T.Uri_vertex href -> 90 - let content = T.Content [T.Transclude {href; target = Title {empty_when_untitled = false}}] in 91 - [A.name [] "%s" @@ string_of_content forest content; A.uri [] "%s" @@ URI.to_string href] 90 + let content = 91 + T.Content 92 + [T.Transclude {href; target = Title {empty_when_untitled = false}}] 93 + in 94 + [ 95 + A.name [] "%s" @@ string_of_content forest content; 96 + A.uri [] "%s" @@ URI.to_string href; 97 + ] 92 98 in 93 99 tag [] body 94 100 95 101 let render_attributions (forest : State.t) uri_opt attributions : P.node = 96 - A.null @@ 97 - List.map (render_attribution forest) @@ 98 - Forest_util.collect_attributions forest uri_opt attributions 102 + A.null 103 + @@ List.map (render_attribution forest) 104 + @@ Forest_util.collect_attributions forest uri_opt attributions 99 105 100 106 let get_embedded_articles (forest : State.t) (article : _ T.article) = 101 107 let visit_node = function 102 108 | T.Transclude {href; target = Full _; _} -> 103 109 Vertex_set.add @@ Uri_vertex href 104 110 | T.Section section -> 105 - Option.fold ~none: Fun.id ~some: (fun x -> Vertex_set.add @@ T.Uri_vertex x) section.frontmatter.uri 111 + Option.fold ~none:Fun.id 112 + ~some:(fun x -> Vertex_set.add @@ T.Uri_vertex x) 113 + section.frontmatter.uri 106 114 | T.Results_of_datalog_query query -> 107 115 Vertex_set.union @@ Forest.run_datalog_query forest.graphs query 108 116 | _ -> Fun.id 109 117 in 110 - let vertices = List.fold_left (Fun.flip visit_node) Vertex_set.empty @@ T.extract_content article.mainmatter in 118 + let vertices = 119 + List.fold_left (Fun.flip visit_node) Vertex_set.empty 120 + @@ T.extract_content article.mainmatter 121 + in 111 122 Forest_util.get_sorted_articles forest vertices 112 123 113 - let render_entry ~(forest : State.t) ?(scope : URI.t option) (article : T.content T.article) : P.node = 114 - A.entry 115 - [] 124 + let render_entry ~(forest : State.t) ?(scope : URI.t option) 125 + (article : T.content T.article) : P.node = 126 + A.entry [] 116 127 [ 117 128 render_title forest ?scope article.frontmatter; 118 129 render_dates article.frontmatter.dates; 119 - render_attributions forest article.frontmatter.uri article.frontmatter.attributions; 120 - begin 121 - match article.frontmatter.uri with 122 - | None -> A.null [] 123 - | Some uri -> 124 - let uri_string = URI.to_string uri in 125 - A.null 126 - [ 127 - A.link 128 - [ 129 - A.rel "alternate"; 130 - A.type_ "text/html"; 131 - A.href "%s" uri_string 132 - ]; 133 - A.id [] "%s" uri_string 134 - ] 130 + render_attributions forest article.frontmatter.uri 131 + article.frontmatter.attributions; 132 + begin match article.frontmatter.uri with 133 + | None -> A.null [] 134 + | Some uri -> 135 + let uri_string = URI.to_string uri in 136 + A.null 137 + [ 138 + A.link 139 + [A.rel "alternate"; A.type_ "text/html"; A.href "%s" uri_string]; 140 + A.id [] "%s" uri_string; 141 + ] 135 142 end; 136 143 A.content 137 - [ 138 - A.type_ "xhtml" 139 - ] 140 - [ 141 - Html_client.render_article_as_div ~heading_level: 1 forest article 142 - ] 144 + [A.type_ "xhtml"] 145 + [Html_client.render_article_as_div ~heading_level:1 forest article]; 143 146 ] 144 147 145 - let render_feed (forest : State.t) ~(source_uri : URI.t) ~(feed_uri : URI.t) : P.node = 148 + let render_feed (forest : State.t) ~(source_uri : URI.t) ~(feed_uri : URI.t) : 149 + P.node = 146 150 match State.get_article source_uri forest with 147 151 | None -> Reporter.fatal @@ Resource_not_found source_uri 148 152 | Some blog -> 149 153 let articles = get_embedded_articles forest blog in 150 154 let all_dates = 151 - let@ article = List.concat_map @~ blog :: articles in 155 + let@ article = List.concat_map @~ (blog :: articles) in 152 156 article.frontmatter.dates 153 157 in 154 158 let blog_uri_string = URI.to_string source_uri in 155 - A.feed 156 - [] 159 + A.feed [] 157 160 [ 158 - render_attributions forest blog.frontmatter.uri blog.frontmatter.attributions; 161 + render_attributions forest blog.frontmatter.uri 162 + blog.frontmatter.attributions; 159 163 render_updated_date all_dates; 160 164 render_title forest blog.frontmatter; 161 165 A.id [] "%s" blog_uri_string; 162 166 A.link [A.rel "alternate"; A.href "%s" blog_uri_string]; 163 167 A.link [A.rel "self"; A.href "%s" @@ URI.to_string feed_uri]; 164 - A.null @@ 165 - let@ article = List.map @~ articles in 166 - render_entry ~forest ~scope: source_uri article 168 + (A.null 169 + @@ 170 + let@ article = List.map @~ articles in 171 + render_entry ~forest ~scope:source_uri article); 167 172 ]
+36 -39
lib/frontend/Config_parser.ml
··· 7 7 open Forester_prelude 8 8 open Forester_core 9 9 10 - (* type keys = (Toml.Types.Table.key [@printer fun fmt key -> fprintf fmt "%s" (Toml.Types.Table.Key.to_string key)]) list list [@@deriving show] *) 10 + (* type keys = (Toml.Types.Table.key 11 + [@printer fun fmt key -> fprintf fmt "%s" (Toml.Types.Table.Key.to_string 12 + key)]) list list [@@deriving show] *) 11 13 12 14 module Key_set = struct 13 - include Set.Make(struct 15 + include Set.Make (struct 14 16 type t = Toml.Types.Table.key list 17 + 15 18 let compare = compare 16 19 end) 17 20 18 - let remove : string list -> t -> t = fun strs set -> 21 + let remove : string list -> t -> t = 22 + fun strs set -> 19 23 let key = List.map Toml.Types.Table.Key.of_string strs in 20 24 remove key set 21 25 end ··· 23 27 let keys (tbl : Toml.Types.value Toml.Types.Table.t) = 24 28 let rec go current keys tbl = 25 29 List.fold_left 26 - begin 27 - fun acc (key, value) -> 28 - match value with 29 - | Toml.Types.TBool _ 30 - | TInt _ 31 - | TFloat _ 32 - | TString _ 33 - | TDate _ 34 - | TArray _ -> 35 - (key :: current) :: acc 36 - | TTable tbl -> 37 - go (key :: current) acc tbl 30 + begin fun acc (key, value) -> 31 + match value with 32 + | Toml.Types.TBool _ | TInt _ | TFloat _ | TString _ | TDate _ 33 + | TArray _ -> 34 + (key :: current) :: acc 35 + | TTable tbl -> go (key :: current) acc tbl 38 36 end 39 37 keys 40 38 (Toml.Types.Table.to_list tbl) ··· 46 44 match Toml.Parser.parse lexbuf filename with 47 45 | `Error (desc, {source; _}) -> 48 46 let@ () = Reporter.tracef "when parsing configuration file" in 49 - let loc = Asai.Range.of_lexbuf ~source: (`File source) lexbuf in 50 - Reporter.fatal ~loc Configuration_error ~extra_remarks: [Asai.Diagnostic.loctextf "%s" desc] 47 + let loc = Asai.Range.of_lexbuf ~source:(`File source) lexbuf in 48 + Reporter.fatal ~loc Configuration_error 49 + ~extra_remarks:[Asai.Diagnostic.loctextf "%s" desc] 51 50 | `Ok tbl -> 52 51 let open Toml.Lenses in 53 52 let keys = ref (keys tbl) in ··· 67 66 match get tbl (forest |-- key "url" |-- string) with 68 67 | Some url -> 69 68 keys := Key_set.remove k !keys; 70 - begin 71 - try 72 - URI.of_string_exn url 73 - with 74 - | _ -> Reporter.fatal Configuration_error ~extra_remarks: [Asai.Diagnostic.loctext "Invalid URL specified in `url` key."] 69 + begin try URI.of_string_exn url 70 + with _ -> 71 + Reporter.fatal Configuration_error 72 + ~extra_remarks: 73 + [Asai.Diagnostic.loctext "Invalid URL specified in `url` key."] 75 74 end 76 75 | None -> 77 76 Reporter.emit (Using_default_option k); ··· 80 79 let default = Config.default ~url () in 81 80 let trees = 82 81 let k = ["forest"; "trees"] in 83 - with_default ~value: default.trees k (forest |-- key "trees" |-- array |-- strings) 82 + with_default ~value:default.trees k 83 + (forest |-- key "trees" |-- array |-- strings) 84 84 in 85 85 let foreign = 86 86 let k = ["forest"; "foreign"] in ··· 107 107 Config.{path; route_locally; include_in_manifest} 108 108 in 109 109 let assets = 110 - with_default 111 - ~value: default.assets 112 - ["forest"; "assets"] 110 + with_default ~value:default.assets ["forest"; "assets"] 113 111 (forest |-- key "assets" |-- array |-- strings) 114 112 in 115 113 let home = 116 114 let k = ["forest"; "home"] in 117 - URI_scheme.named_uri ~base: url @@ 118 - with_default ~value: "index" k (forest |-- key "home" |-- string) 115 + URI_scheme.named_uri ~base:url 116 + @@ with_default ~value:"index" k (forest |-- key "home" |-- string) 119 117 in 120 - begin 121 - if not (Key_set.is_empty !keys) then 122 - let keys = 123 - !keys 124 - |> Key_set.to_list 125 - |> List.map (List.map (Toml.Types.Table.Key.to_string)) 126 - in 127 - Reporter.emit (Uninterpreted_config_options keys); 118 + begin if not (Key_set.is_empty !keys) then 119 + let keys = 120 + !keys |> Key_set.to_list 121 + |> List.map (List.map Toml.Types.Table.Key.to_string) 122 + in 123 + Reporter.emit (Uninterpreted_config_options keys) 128 124 end; 129 125 Config.{url; assets; trees; foreign; home} 130 126 ··· 135 131 let parse_forest_config_file filename = 136 132 try 137 133 let ch = open_in filename in 138 - let@ () = Fun.protect ~finally: (fun _ -> close_in ch) in 134 + let@ () = Fun.protect ~finally:(fun _ -> close_in ch) in 139 135 let lexbuf = Lexing.from_channel ch in 140 136 let result = parse lexbuf filename in 141 137 Sys.chdir @@ Filename.dirname filename; 142 138 result 143 - with 144 - | exn -> Reporter.fatal Configuration_error ~extra_remarks: [Asai.Diagnostic.loctextf "%a" Eio.Exn.pp exn] 139 + with exn -> 140 + Reporter.fatal Configuration_error 141 + ~extra_remarks:[Asai.Diagnostic.loctextf "%a" Eio.Exn.pp exn]
+13 -42
lib/frontend/DSL.ml
··· 8 8 9 9 open Forester_core 10 10 11 - open struct module T = Types end 11 + open struct 12 + module T = Types 13 + end 12 14 13 15 let txt str = T.Text str 14 - 15 16 let p content = T.prim `P @@ T.Content content 16 17 let ul content = T.prim `Ul @@ T.Content content 17 18 let ol content = T.prim `Ol @@ T.Content content ··· 30 31 31 32 module Datalog = struct 32 33 open Datalog_expr 34 + 33 35 let premises ~rel ~args = {rel; args} 34 36 let prop premises conclusion = {premises; conclusion} 35 37 let const v = Const v ··· 37 39 38 40 let datalog_script script = T.Datalog_script script 39 41 40 - let section 41 - ~mainmatter 42 - ?(frontmatter = T.default_frontmatter ()) 43 - ?(flags = T.default_section_flags) 44 - () 45 - = 46 - T.Section 47 - { 48 - frontmatter; 49 - mainmatter = T.Content mainmatter; 50 - flags; 51 - } 42 + let section ~mainmatter ?(frontmatter = T.default_frontmatter ()) 43 + ?(flags = T.default_section_flags) () = 44 + T.Section {frontmatter; mainmatter = T.Content mainmatter; flags} 52 45 53 46 let xml_elt (prefix, uname) content = 54 - let prefix = Option.value ~default: "" prefix in 47 + let prefix = Option.value ~default:"" prefix in 55 48 let qname = T.{prefix; uname; xmlns = None} in 56 - T.Xml_elt 57 - { 58 - name = qname; 59 - attrs = []; 60 - content = T.Content content 61 - } 49 + T.Xml_elt {name = qname; attrs = []; content = T.Content content} 62 50 63 51 let transclude href = 64 - T.Transclude 65 - T.{ 66 - href = URI.of_string_exn href; 67 - target = Mainmatter 68 - } 52 + T.Transclude T.{href = URI.of_string_exn href; target = Mainmatter} 69 53 70 54 let artefact content = 71 - T.Artefact 72 - T.{ 73 - hash = ""; 74 - content = Content content; 75 - sources = [] 76 - } 55 + T.Artefact T.{hash = ""; content = Content content; sources = []} 77 56 78 57 let link href content = 79 - T.Link 80 - { 81 - href = URI.of_string_exn href; 82 - content = T.Content content; 83 - } 58 + T.Link {href = URI.of_string_exn href; content = T.Content content} 84 59 85 60 module Code = struct 86 61 open Code ··· 88 63 89 64 let import_private = Fun.compose (locate_opt None) @@ Code.import_private 90 65 let import_public = Fun.compose (locate_opt None) @@ Code.import_public 91 - 92 66 let inline_math = Fun.compose (locate_opt None) @@ Code.inline_math 93 67 let display_math = Fun.compose (locate_opt None) @@ Code.display_math 94 68 let parens = Fun.compose (locate_opt None) @@ Code.parens 95 69 let squares = Fun.compose (locate_opt None) @@ Code.squares 96 70 let braces = Fun.compose (locate_opt None) @@ Code.braces 97 - 98 71 let ident i = locate_opt None @@ Ident i 99 72 let hash_ident str = locate_opt None @@ Hash_ident str 100 - 101 73 let ul = ident ["ul"] 102 74 let li = ident ["li"] 103 75 let text str = locate_opt None @@ Text str ··· 114 86 module Syn = struct 115 87 open Forester_core.Syn 116 88 open Asai.Range 89 + 117 90 let fun_ b t = locate_opt None @@ Fun (b, t) 118 91 let prim p = locate_opt None @@ Prim p 119 - 120 92 let text s = locate_opt None @@ Text s 121 - 122 93 let parens e = locate_opt None @@ Group (Parens, e) 123 94 let squares e = locate_opt None @@ Group (Squares, e) 124 95 let braces e = locate_opt None @@ Group (Braces, e)
+24 -11
lib/frontend/Forest_util.ml
··· 7 7 open Forester_prelude 8 8 open Forester_core 9 9 open Forester_compiler 10 - open struct module T = Types end 10 + 11 + open struct 12 + module T = Types 13 + end 11 14 12 15 let compare_article ~forest = 13 - let module C = Types.Comparators(struct 16 + let module C = Types.Comparators (struct 14 17 let string_of_content x = Plain_text_client.string_of_content ~forest x 15 18 end) in 16 19 C.compare_article 17 20 18 21 let get_sorted_articles (forest : State.t) addrs = 19 - addrs 20 - |> Vertex_set.to_seq 22 + addrs |> Vertex_set.to_seq 21 23 |> Seq.filter_map Vertex.uri_of_vertex 22 24 |> Seq.filter_map (fun uri -> State.get_article uri forest) 23 25 |> List.of_seq 24 26 |> List.sort (compare_article ~forest) 25 27 26 - let collect_attributions (forest : State.t) (uri_opt : URI.t option) (primary_attributions : _ T.attribution list) = 28 + let collect_attributions (forest : State.t) (uri_opt : URI.t option) 29 + (primary_attributions : _ T.attribution list) = 27 30 match uri_opt with 28 31 | None -> primary_attributions 29 32 | Some uri -> ··· 31 34 let open Datalog_expr.Notation in 32 35 let articles = 33 36 let x = "X" in 34 - let positives = [Builtin_relation.has_indirect_contributor @* [const (T.Uri_vertex uri); var x]] in 37 + let positives = 38 + [ 39 + Builtin_relation.has_indirect_contributor 40 + @* [const (T.Uri_vertex uri); var x]; 41 + ] 42 + in 35 43 let negatives = [] in 36 44 Datalog_expr.{var = x; positives; negatives} 37 45 |> Forest.run_datalog_query forest.graphs ··· 41 49 let@ uri = Option.map @~ biotree.frontmatter.uri in 42 50 T.{vertex = T.Uri_vertex uri; role = Contributor} 43 51 in 44 - primary_attributions @ 45 - let@ attribution = List.filter_map @~ indirect_attributions in 46 - if List.exists (fun (existing : _ T.attribution) -> Vertex.equal attribution.vertex existing.vertex) primary_attributions then None 47 - else 48 - Some attribution 52 + primary_attributions 53 + @ 54 + let@ attribution = List.filter_map @~ indirect_attributions in 55 + if 56 + List.exists 57 + (fun (existing : _ T.attribution) -> 58 + Vertex.equal attribution.vertex existing.vertex) 59 + primary_attributions 60 + then None 61 + else Some attribution
+101 -70
lib/frontend/Forester.ml
··· 16 16 17 17 type env = Eio_unix.Stdenv.base 18 18 type dir = Eio.Fs.dir_ty EP.t 19 - 20 19 type target = HTML | JSON | XML | STRING 21 20 22 21 let output_dir_name = "output" ··· 29 28 match template with 30 29 | None -> "" 31 30 | Some name -> 32 - EP.load 33 - EP.(Eio.Stdenv.cwd env / "templates" / (name ^ ".tree")) 31 + EP.load EP.(Eio.Stdenv.cwd env / "templates" / (name ^ ".tree")) 34 32 in 35 33 let body = Format.asprintf "\\date{%a}\n" Human_datetime.pp now in 36 34 let create = `Exclusive 0o644 in ··· 38 36 let dir = 39 37 match dest_dir with 40 38 | Some dir -> dir 41 - | None -> 39 + | None -> ( 42 40 match forest.config.trees with 43 41 | dir :: _ -> dir 44 - | [] -> Reporter.fatal Missing_argument ~extra_remarks: [Asai.Diagnostic.loctext "Unable to guess destination director for new tree; please supply one."] 45 - in 46 - let path = 47 - EP.(env#fs / dir / fname) 42 + | [] -> 43 + Reporter.fatal Missing_argument 44 + ~extra_remarks: 45 + [ 46 + Asai.Diagnostic.loctext 47 + "Unable to guess destination director for new tree; please \ 48 + supply one."; 49 + ]) 48 50 in 51 + let path = EP.(env#fs / dir / fname) in 49 52 EP.save ~create path @@ body ^ template_content; 50 53 EP.native_exn path 51 54 52 55 let complete ~(forest : State.t) prefix : (string * string) List.t = 53 56 let config = forest.config in 54 - let@ article = List.filter_map @~ List.of_seq @@ State.get_all_articles forest in 57 + let@ article = 58 + List.filter_map @~ List.of_seq @@ State.get_all_articles forest 59 + in 55 60 let@ uri = Option.bind article.frontmatter.uri in 56 - let short_uri = URI.display_path_string ~base: config.url uri in 61 + let short_uri = URI.display_path_string ~base:config.url uri in 57 62 let@ title = Option.bind article.frontmatter.title in 58 63 let title = Plain_text_client.string_of_content ~forest title in 59 - if String.starts_with ~prefix title then 60 - Some (short_uri, title) 61 - else 62 - None 64 + if String.starts_with ~prefix title then Some (short_uri, title) else None 63 65 64 - let is_hidden_file fname = 65 - String.starts_with ~prefix: "." fname 66 + let is_hidden_file fname = String.starts_with ~prefix:"." fname 66 67 67 68 let output_path ~cwd ~(forest : State.t) = 68 69 let suffix = 69 - String.concat "/" @@ 70 - List.filter (fun x -> not (x = "")) @@ 71 - URI.path_components forest.config.url 70 + String.concat "/" 71 + @@ List.filter (fun x -> not (x = "")) 72 + @@ URI.path_components forest.config.url 72 73 in 73 74 Eio.Path.(cwd / output_dir_name / suffix) 74 75 75 76 let copy_contents_of_dir ~env ~(forest : State.t) dir = 76 77 let cwd = Eio.Stdenv.cwd env in 77 78 let dest_dir = EP.native_exn @@ output_path ~cwd ~forest in 78 - Logs.debug (fun m -> m "copying contents of directory %s to %s." (Eio.Path.native_exn dir) dest_dir); 79 + Logs.debug (fun m -> 80 + m "copying contents of directory %s to %s." (Eio.Path.native_exn dir) 81 + dest_dir); 79 82 let@ fname = List.iter @~ EP.read_dir dir in 80 83 if not @@ is_hidden_file fname then 81 84 let path = EP.(dir / fname) in ··· 87 90 let articles = 88 91 let@ tree = Seq.filter_map @~ Forest.to_seq_values forest.index in 89 92 let@ evaluated = Option.bind @@ Tree.to_evaluated tree in 90 - if evaluated.include_in_manifest 91 - then Tree.to_article tree 92 - else None 93 + if evaluated.include_in_manifest then Tree.to_article tree else None 93 94 in 94 - articles 95 - |> List.of_seq 95 + articles |> List.of_seq 96 96 |> List.sort (Forest_util.compare_article ~forest) 97 97 |> List.filter_map (fun tree -> render ~dev tree) 98 98 |> (fun t -> `List t) 99 99 |> Yojson.Safe.to_string 100 100 101 101 let html_redirect uri_string = 102 - Pure_html.to_xml @@ 103 - let open Pure_html in 104 - let open HTML in 105 - html 106 - [] 107 - [ 108 - head 109 - [] 110 - [ 111 - meta 112 - [ 113 - http_equiv `refresh; 114 - content "0;url=%s" uri_string 115 - ]; 116 - meta [charset "utf-8"] 117 - ] 118 - ] 102 + Pure_html.to_xml 103 + @@ 104 + let open Pure_html in 105 + let open HTML in 106 + html [] 107 + [ 108 + head [] 109 + [ 110 + meta [http_equiv `refresh; content "0;url=%s" uri_string]; 111 + meta [charset "utf-8"]; 112 + ]; 113 + ] 119 114 120 115 let outputs_for_article ~(forest : State.t) (article : _ T.article) = 121 116 match article.frontmatter.uri with 122 117 | None -> [] 123 118 | Some uri -> 124 - let xml_route = URI.with_path_components (URI.append_path_component (URI.path_components uri) "index.xml") uri in 125 - let html_route = URI.with_path_components (URI.append_path_component (URI.path_components uri) "index.html") uri in 126 - let xml_content = Format.asprintf "%a" (Legacy_xml_client.pp_xml ~forest ~stylesheet: "default.xsl") article in 119 + let xml_route = 120 + URI.with_path_components 121 + (URI.append_path_component (URI.path_components uri) "index.xml") 122 + uri 123 + in 124 + let html_route = 125 + URI.with_path_components 126 + (URI.append_path_component (URI.path_components uri) "index.html") 127 + uri 128 + in 129 + let xml_content = 130 + Format.asprintf "%a" 131 + (Legacy_xml_client.pp_xml ~forest ~stylesheet:"default.xsl") 132 + article 133 + in 127 134 let html_content = 128 - html_redirect @@ String.concat "/" @@ "" :: Legacy_xml_client.local_path_components forest.config xml_route 135 + html_redirect @@ String.concat "/" 136 + @@ ("" :: Legacy_xml_client.local_path_components forest.config xml_route) 129 137 in 130 - [xml_route, xml_content; html_route, html_content] 138 + [(xml_route, xml_content); (html_route, html_content)] 131 139 132 140 let outputs_for_asset (asset : T.asset) = 133 141 let route = asset.uri in 134 - [route, asset.content] 142 + [(route, asset.content)] 135 143 136 - let outputs_for_json_blob_syndication ~(forest : State.t) (syndication : _ T.json_blob_syndication) = 144 + let outputs_for_json_blob_syndication ~(forest : State.t) 145 + (syndication : _ T.json_blob_syndication) = 137 146 if URI.host syndication.blob_uri = URI.host forest.config.url then 138 147 let vertices = Forest.run_datalog_query forest.graphs syndication.query in 139 148 let resources = ··· 142 151 | Content_vertex _ -> None 143 152 | Uri_vertex uri -> State.get_resource forest uri 144 153 in 145 - let json_content = Repr.to_json_string ~minify: true (T.forest_t T.content_t) resources in 146 - [syndication.blob_uri, json_content] 147 - else 148 - [] 154 + let json_content = 155 + Repr.to_json_string ~minify:true (T.forest_t T.content_t) resources 156 + in 157 + [(syndication.blob_uri, json_content)] 158 + else [] 149 159 150 - let outputs_for_atom_feed_syndication ~(forest : State.t) (syndication : T.atom_feed_syndication) = 151 - let atom_nodes = Atom_client.render_feed forest ~source_uri: syndication.source_uri ~feed_uri: syndication.feed_uri in 152 - let atom_content = Format.asprintf "%a" (Pure_html.pp_xml ~header: true) atom_nodes in 153 - [syndication.feed_uri, atom_content] 160 + let outputs_for_atom_feed_syndication ~(forest : State.t) 161 + (syndication : T.atom_feed_syndication) = 162 + let atom_nodes = 163 + Atom_client.render_feed forest ~source_uri:syndication.source_uri 164 + ~feed_uri:syndication.feed_uri 165 + in 166 + let atom_content = 167 + Format.asprintf "%a" (Pure_html.pp_xml ~header:true) atom_nodes 168 + in 169 + [(syndication.feed_uri, atom_content)] 154 170 155 171 let outputs_for_syndication ~(forest : State.t) = function 156 - | T.Json_blob syndication -> outputs_for_json_blob_syndication ~forest syndication 157 - | T.Atom_feed syndication -> outputs_for_atom_feed_syndication ~forest syndication 172 + | T.Json_blob syndication -> 173 + outputs_for_json_blob_syndication ~forest syndication 174 + | T.Atom_feed syndication -> 175 + outputs_for_atom_feed_syndication ~forest syndication 158 176 159 177 let outputs_for_resource ~(forest : State.t) (evaluated : Tree.evaluated) = 160 178 if not evaluated.route_locally then [] ··· 174 192 begin 175 193 let json_string = json_manifest ~dev ~forest in 176 194 let json_path = EP.(output_path ~cwd ~forest / "forest.json") in 177 - Eio_util.ensure_context_of_path ~perm: 0o755 json_path; 178 - EP.save ~create: (`Or_truncate 0o644) json_path json_string 195 + Eio_util.ensure_context_of_path ~perm:0o755 json_path; 196 + EP.save ~create:(`Or_truncate 0o644) json_path json_string 179 197 end; 180 198 let jobs = 181 199 let bare_host_uri = URI.with_path_components [] forest.config.url in 182 - let home_route = URI.with_path_components (URI.append_path_component (URI.path_components forest.config.url) "index.html") forest.config.url in 183 - let home_content = html_redirect @@ "/" ^ URI.relative_path_string ~base: bare_host_uri (Config.home_uri forest.config) in 184 - List.cons [home_route, home_content] @@ 185 - let@ resource = Eio.Fiber.List.map ~max_fibers: 40 @~ List.of_seq all_resources in 186 - let@ () = Reporter.easy_run in 187 - outputs_for_resource ~forest resource 200 + let home_route = 201 + URI.with_path_components 202 + (URI.append_path_component 203 + (URI.path_components forest.config.url) 204 + "index.html") 205 + forest.config.url 206 + in 207 + let home_content = 208 + html_redirect @@ "/" 209 + ^ URI.relative_path_string ~base:bare_host_uri 210 + (Config.home_uri forest.config) 211 + in 212 + List.cons [(home_route, home_content)] 213 + @@ 214 + let@ resource = 215 + Eio.Fiber.List.map ~max_fibers:40 @~ List.of_seq all_resources 216 + in 217 + let@ () = Reporter.easy_run in 218 + outputs_for_resource ~forest resource 188 219 in 189 220 Logs.debug (fun m -> m "Writing %i files to output" (List.length jobs)); 190 221 begin 191 222 (* Note: this part appears to be fast! *) 192 - let@ items = Eio.Fiber.List.iter ~max_fibers: 20 @~ jobs in 223 + let@ items = Eio.Fiber.List.iter ~max_fibers:20 @~ jobs in 193 224 let@ (route : URI.t), content = List.iter @~ items in 194 225 let@ () = Reporter.easy_run in 195 226 let path = EP.(cwd / output_dir_name / uri_to_local_path ~forest route) in 196 - Eio_util.ensure_context_of_path ~perm: 0o755 path; 197 - EP.save ~create: (`Or_truncate 0o644) path content; 227 + Eio_util.ensure_context_of_path ~perm:0o755 path; 228 + EP.save ~create:(`Or_truncate 0o644) path content 198 229 end
+10 -26
lib/frontend/Forester.mli
··· 8 8 9 9 type env = Eio_unix.Stdenv.base 10 10 type dir = Eio.Fs.dir_ty Eio.Path.t 11 - 12 11 type target = HTML | JSON | XML | STRING 13 12 14 - val render_forest : 15 - dev: bool -> 16 - forest: State.t -> 17 - unit 18 - 19 - val copy_contents_of_dir : 20 - env: env -> 21 - forest: State.t -> 22 - dir -> 23 - unit 13 + val render_forest : dev:bool -> forest:State.t -> unit 14 + val copy_contents_of_dir : env:env -> forest:State.t -> dir -> unit 24 15 25 16 val create_tree : 26 - env: env -> 27 - dest_dir: string option -> 28 - prefix: string option -> 29 - template: string option -> 30 - mode: [`Sequential | `Random] -> 31 - forest: State.t -> 32 - string 33 - 34 - val json_manifest : 35 - dev: bool -> 36 - forest: State.t -> 17 + env:env -> 18 + dest_dir:string option -> 19 + prefix:string option -> 20 + template:string option -> 21 + mode:[`Sequential | `Random] -> 22 + forest:State.t -> 37 23 string 38 24 39 - val complete : 40 - forest: State.t -> 41 - string -> 42 - (string * string) List.t 25 + val json_manifest : dev:bool -> forest:State.t -> string 26 + val complete : forest:State.t -> string -> (string * string) List.t
-2
lib/frontend/Forester_frontend.ml
··· 8 8 9 9 module Config_parser = Config_parser 10 10 module Forester = Forester 11 - 12 11 module DSL = DSL 13 - 14 12 module Htmx_client = Htmx_client 15 13 module Plain_text_client = Plain_text_client 16 14 module Legacy_xml_client = Legacy_xml_client
+62 -67
lib/frontend/Html_client.ml
··· 17 17 end 18 18 19 19 module Xmlns = Xmlns_effect.Make () 20 - module Scope = Algaeff.Reader.Make(struct type t = URI.t option end) 21 - module Section_depth = Algaeff.Reader.Make(struct type t = int end) 20 + 21 + module Scope = Algaeff.Reader.Make (struct 22 + type t = URI.t option 23 + end) 24 + 25 + module Section_depth = Algaeff.Reader.Make (struct 26 + type t = int 27 + end) 28 + 22 29 module Loop_detection = Loop_detection_effect.Make () 23 30 24 - let hx attrs children = P.std_tag (Format.sprintf "h%i" @@ min 6 @@ Section_depth.read ()) attrs children 31 + let hx attrs children = 32 + P.std_tag 33 + (Format.sprintf "h%i" @@ min 6 @@ Section_depth.read ()) 34 + attrs children 25 35 26 36 let incr_section_depth k = 27 37 let i = Section_depth.read () in 28 - Section_depth.run ~env: (i + 1) k 38 + Section_depth.run ~env:(i + 1) k 29 39 30 40 let route uri = URI.to_string uri 31 41 32 42 let get_expanded_title frontmatter forest = 33 43 let scope = Scope.read () in 34 - State.get_expanded_title ?scope ~flags: T.{empty_when_untitled = true} frontmatter forest 44 + State.get_expanded_title ?scope 45 + ~flags:T.{empty_when_untitled = true} 46 + frontmatter forest 35 47 36 48 let render_xml_qname qname = 37 49 let qname = Xmlns.normalise_qname qname in ··· 40 52 | _ -> Format.sprintf "%s:%s" qname.prefix qname.uname 41 53 42 54 let render_xml_attr (forest : State.t) T.{key; value} = 43 - let str_value = Plain_text_client.string_of_content ~forest: forest value in 55 + let str_value = Plain_text_client.string_of_content ~forest value in 44 56 P.string_attr (render_xml_qname key) "%s" str_value 45 57 46 - let render_xmlns_prefix ({prefix; xmlns}: Forester_xml_names.xmlns_attr) = 58 + let render_xmlns_prefix ({prefix; xmlns} : Forester_xml_names.xmlns_attr) = 47 59 let attr = match prefix with "" -> "xmlns" | _ -> "xmlns:" ^ prefix in 48 60 P.string_attr attr "%s" xmlns 49 61 50 - let rec render_content (forest : State.t) (Content content: T.content) : P.node list = 62 + let rec render_content (forest : State.t) (Content content : T.content) : 63 + P.node list = 51 64 match content with 52 65 | T.Text txt0 :: T.Text txt1 :: content -> 53 66 render_content forest (Content (T.Text (txt0 ^ txt1) :: content)) ··· 57 70 xs @ ys 58 71 | [] -> [] 59 72 60 - and render_content_node (forest : State.t) (node : 'a T.content_node) : P.node list = 73 + and render_content_node (forest : State.t) (node : 'a T.content_node) : 74 + P.node list = 61 75 let config = forest.config in 62 76 match node with 63 - | Text str -> 64 - [P.txt "%s" str] 65 - | CDATA str -> 66 - [P.txt ~raw: true "<![CDATA[%s]]>" str] 67 - | Uri uri -> 68 - [P.txt "%s" (URI.to_string uri)] 77 + | Text str -> [P.txt "%s" str] 78 + | CDATA str -> [P.txt ~raw:true "<![CDATA[%s]]>" str] 79 + | Uri uri -> [P.txt "%s" (URI.to_string uri)] 69 80 | Xml_elt elt -> 70 81 let prefixes_to_add, (name, attrs, content) = 71 82 let@ () = Xmlns.within_scope in 72 - render_xml_qname elt.name, 73 - List.map (render_xml_attr forest) elt.attrs, 74 - render_content forest elt.content 83 + ( render_xml_qname elt.name, 84 + List.map (render_xml_attr forest) elt.attrs, 85 + render_content forest elt.content ) 75 86 in 76 87 let attrs = 77 88 let xmlns_attrs = List.map render_xmlns_prefix prefixes_to_add in 78 89 attrs @ xmlns_attrs 79 90 in 80 91 [P.std_tag name attrs content] 81 - | Route_of_uri uri -> 82 - [P.txt "%s" (route uri)] 92 + | Route_of_uri uri -> [P.txt "%s" (route uri)] 83 93 | Contextual_number uri -> 84 94 let custom_number = 85 95 let@ resource = Option.bind @@ forest.@{uri} in 86 96 match resource with 87 - | T.Article article -> 88 - article.frontmatter.number 97 + | T.Article article -> article.frontmatter.number 89 98 | _ -> None 90 99 in 91 - begin 92 - match custom_number with 93 - | None -> [P.txt "%s" @@ URI.relative_path_string ~base: config.url uri] 94 - | Some num -> [P.txt "%s" num] 100 + begin match custom_number with 101 + | None -> [P.txt "%s" @@ URI.relative_path_string ~base:config.url uri] 102 + | Some num -> [P.txt "%s" num] 95 103 end 96 - | KaTeX (_, content) -> 97 - [P.HTML.code [] @@ render_content forest content] 104 + | KaTeX (_, content) -> [P.HTML.code [] @@ render_content forest content] 98 105 | Artefact artefact -> render_content forest @@ artefact.content 99 106 | Section section -> render_section forest section 100 107 | Transclude transclusion -> render_transclusion forest transclusion ··· 102 109 | Results_of_datalog_query _ -> [] (* TODO: just make a list of links *) 103 110 | Datalog_script _ -> [] 104 111 105 - and render_link (forest : State.t) (link : T.content T.link) : P.node list = [ 106 - P.HTML.a 107 - [ 108 - P.HTML.href "%s" (Format.asprintf "%a" URI.pp link.href); 109 - ] @@ 110 - render_content forest link.content 111 - ] 112 + and render_link (forest : State.t) (link : T.content T.link) : P.node list = 113 + [ 114 + P.HTML.a [P.HTML.href "%s" (Format.asprintf "%a" URI.pp link.href)] 115 + @@ render_content forest link.content; 116 + ] 112 117 113 - and render_transclusion (forest : State.t) (transclusion : T.transclusion) : P.node list = 118 + and render_transclusion (forest : State.t) (transclusion : T.transclusion) : 119 + P.node list = 114 120 match State.get_content_of_transclusion transclusion forest with 115 - | None -> 116 - Reporter.fatal (Resource_not_found transclusion.href) 117 - | Some content -> 118 - render_content forest content 121 + | None -> Reporter.fatal (Resource_not_found transclusion.href) 122 + | Some content -> render_content forest content 119 123 120 124 and render_section forest (section : T.content T.section) : P.node list = 121 - let@ () = Scope.run ~env: section.frontmatter.uri in 125 + let@ () = Scope.run ~env:section.frontmatter.uri in 122 126 let@ () = incr_section_depth in 123 127 [ 124 - P.HTML.section 125 - [] 128 + P.HTML.section [] 126 129 [ 127 - begin 128 - match section.frontmatter.title with 129 - | None -> P.HTML.null [] 130 - | Some title -> 131 - P.HTML.header 132 - [] 133 - [ 134 - hx [] @@ render_content forest title 135 - ] 130 + begin match section.frontmatter.title with 131 + | None -> P.HTML.null [] 132 + | Some title -> P.HTML.header [] [hx [] @@ render_content forest title] 136 133 end; 137 - if Loop_detection.have_seen_uri_opt section.frontmatter.uri then 138 - P.txt "Transclusion loop detected, rendering stopped." 139 - else 140 - let@ () = Loop_detection.add_seen_uri_opt section.frontmatter.uri in 141 - P.HTML.null @@ render_content forest section.mainmatter 142 - ] 134 + (if Loop_detection.have_seen_uri_opt section.frontmatter.uri then 135 + P.txt "Transclusion loop detected, rendering stopped." 136 + else 137 + let@ () = Loop_detection.add_seen_uri_opt section.frontmatter.uri in 138 + P.HTML.null @@ render_content forest section.mainmatter); 139 + ]; 143 140 ] 144 141 145 - let render_article_as_div ?(heading_level = 0) (forest : State.t) (article : T.content T.article) : P.node = 146 - let@ () = Section_depth.run ~env: heading_level in 147 - let@ () = Scope.run ~env: article.frontmatter.uri in 142 + let render_article_as_div ?(heading_level = 0) (forest : State.t) 143 + (article : T.content T.article) : P.node = 144 + let@ () = Section_depth.run ~env:heading_level in 145 + let@ () = Scope.run ~env:article.frontmatter.uri in 148 146 let@ () = Loop_detection.run in 149 - let reserved = [ 150 - {prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"} 151 - ] 152 - in 147 + let reserved = [{prefix = ""; xmlns = "http://www.w3.org/1999/xhtml"}] in 153 148 let@ () = Xmlns.run ~reserved in 154 149 P.HTML.div 155 150 (List.map render_xmlns_prefix reserved) 156 151 [ 157 - let@ () = Loop_detection.add_seen_uri_opt article.frontmatter.uri in 158 - P.HTML.null @@ render_content forest article.mainmatter 152 + (let@ () = Loop_detection.add_seen_uri_opt article.frontmatter.uri in 153 + P.HTML.null @@ render_content forest article.mainmatter); 159 154 ]
+214 -276
lib/frontend/Htmx_client.ml
··· 9 9 open Forester_core 10 10 open Forester_compiler 11 11 12 - open struct module T = Types end 12 + open struct 13 + module T = Types 14 + end 15 + 13 16 open Pure_html 14 17 open HTML 15 18 ··· 22 25 23 26 let local_path_components (uri : URI.t) = 24 27 let host = 25 - match URI.host uri with 26 - | Some host -> host 27 - | None -> assert false (* TODO*) 28 + match URI.host uri with Some host -> host | None -> assert false (* TODO*) 28 29 in 29 30 host :: URI.path_components uri 30 31 ··· 39 40 let title_flags_to_http_header (flags : T.title_flags) = 40 41 match flags with 41 42 | {empty_when_untitled} -> 42 - `Assoc ([("Empty-When-Untitled", `String (Bool.to_string empty_when_untitled))]) 43 + `Assoc 44 + [("Empty-When-Untitled", `String (Bool.to_string empty_when_untitled))] 43 45 44 - (* I am encoding these headers to JSON because that is what HTMX 45 - requires, but it would be more beautiful if we could directly use the 46 - header type*) 46 + (* I am encoding these headers to JSON because that is what HTMX requires, but 47 + it would be more beautiful if we could directly use the header type*) 47 48 let section_flags_to_http_header (flags : T.section_flags) = 48 49 match flags with 49 - | {hidden_when_empty; 50 - included_in_toc; 51 - header_shown; 52 - metadata_shown; 53 - numbered; 54 - expanded 50 + | { 51 + hidden_when_empty; 52 + included_in_toc; 53 + header_shown; 54 + metadata_shown; 55 + numbered; 56 + expanded; 55 57 } -> 56 58 let to_header l t = 57 59 match t with 58 60 | Some v -> Some (l, `String (Bool.to_string v)) 59 61 | None -> None 60 62 in 61 - let headers = [ 62 - to_header "Hidden-When-Empty" hidden_when_empty; 63 - to_header "Included-In-Toc" included_in_toc; 64 - to_header "Header-Shown" header_shown; 65 - to_header "Metadata-Shown" metadata_shown; 66 - to_header "Numbered" numbered; 67 - to_header "Expanded" expanded; 68 - ] 63 + let headers = 64 + [ 65 + to_header "Hidden-When-Empty" hidden_when_empty; 66 + to_header "Included-In-Toc" included_in_toc; 67 + to_header "Header-Shown" header_shown; 68 + to_header "Metadata-Shown" metadata_shown; 69 + to_header "Numbered" numbered; 70 + to_header "Expanded" expanded; 71 + ] 69 72 in 70 73 `Assoc (List.filter_map Fun.id headers) 71 74 72 75 let content_target_to_http_header (target : T.content_target) = 73 76 match target with 74 77 | T.Full flags -> 75 - let `Assoc flags = section_flags_to_http_header flags in 78 + let (`Assoc flags) = section_flags_to_http_header flags in 76 79 `Assoc (("Full", `String "true") :: flags) 77 - | T.Mainmatter -> 78 - `Assoc ["Mainmatter", `String "true"] 80 + | T.Mainmatter -> `Assoc [("Mainmatter", `String "true")] 79 81 | T.Title flags -> 80 - let `Assoc flags = title_flags_to_http_header flags in 82 + let (`Assoc flags) = title_flags_to_http_header flags in 81 83 `Assoc (("Title", `String "true") :: flags) 82 - | T.Taxon -> 83 - `Assoc ["Taxon", `String "true"] 84 + | T.Taxon -> `Assoc [("Taxon", `String "true")] 84 85 85 86 let render_xml_qname = function 86 87 | {prefix = ""; uname; _} -> uname 87 88 | {prefix; uname; _} -> Format.sprintf "%s:%s" prefix uname 88 89 89 - let render_xml_attr 90 - : T.content T.xml_attr -> _ 91 - = fun T.{key; value = _} -> 92 - string_attr (render_xml_qname key) "todo" 90 + let render_xml_attr : T.content T.xml_attr -> _ = 91 + fun T.{key; value = _} -> string_attr (render_xml_qname key) "todo" 93 92 (* "%a" render_content value *) 94 93 95 - let render_xmlns_prefix ({prefix; xmlns}: xmlns_attr) = 94 + let render_xmlns_prefix ({prefix; xmlns} : xmlns_attr) = 96 95 let attr = match prefix with "" -> "xmlns" | _ -> "xmlns:" ^ prefix in 97 96 string_attr attr "%s" xmlns 98 97 ··· 101 100 let month = 102 101 match Human_datetime.month date with 103 102 | None -> None 104 - | Some i -> 103 + | Some i -> ( 105 104 match i with 106 105 | 1 -> Some (txt "January") 107 106 | 2 -> Some (txt "February") ··· 115 114 | 10 -> Some (txt "October") 116 115 | 11 -> Some (txt "November") 117 116 | 12 -> Some (txt "December") 118 - | _ -> assert false 117 + | _ -> assert false) 119 118 in 120 119 let day = 121 - match Human_datetime.day date with 122 - | None -> null [] 123 - | Some i -> txt "%i" i 120 + match Human_datetime.day date with None -> null [] | Some i -> txt "%i" i 124 121 in 125 122 li 126 123 [class_ "meta-item"] ··· 128 125 a 129 126 [class_ "link local"] 130 127 [ 131 - Option.value ~default: (null []) month; 132 - if Option.is_some month then txt " " else null []; 128 + Option.value ~default:(null []) month; 129 + (if Option.is_some month then txt " " else null []); 133 130 day; 134 - if Option.is_some month then txt ", " else null []; 135 - year 136 - ] 131 + (if Option.is_some month then txt ", " else null []); 132 + year; 133 + ]; 137 134 ] 138 135 139 136 (*This type is just temporary until I figure out the logic *) ··· 142 139 taxon: string; 143 140 number: string; 144 141 fallback_number: string; 145 - 146 142 (* In XSL, hese require querying the ancestors. We can't do this here, so we 147 - explicitly pass these parameters down*) 143 + explicitly pass these parameters down*) 148 144 in_backmatter: bool; 149 145 is_root: bool; 150 146 implicitly_unnumbered: bool; 151 147 } 152 148 153 - let default_toc_config 154 - ?(suffix = "") 155 - ?(taxon = "") 156 - ?(number = "") 157 - ?(fallback_number = "") 158 - ?(in_backmatter = false) 159 - () 160 - = { 161 - suffix; 162 - taxon; 163 - number; 164 - fallback_number; 165 - in_backmatter; 166 - is_root = false; 167 - implicitly_unnumbered = false; 168 - } 149 + let default_toc_config ?(suffix = "") ?(taxon = "") ?(number = "") 150 + ?(fallback_number = "") ?(in_backmatter = false) () = 151 + { 152 + suffix; 153 + taxon; 154 + number; 155 + fallback_number; 156 + in_backmatter; 157 + is_root = false; 158 + implicitly_unnumbered = false; 159 + } 169 160 170 - let rec render_article (forest : State.t) (article : T.content T.article) : node = 161 + let rec render_article (forest : State.t) (article : T.content T.article) : node 162 + = 171 163 (* FIXME: What should reserved be here? *) 172 - let@ () = Xmlns.run ~reserved: [] in 164 + let@ () = Xmlns.run ~reserved:[] in 173 165 HTML.article 174 - [id "tree-container";] 166 + [id "tree-container"] 175 167 [ 176 168 (* FIXME: Should be reusing render_section *) 177 169 HTML.section 178 170 [class_ "block"] 179 171 [ 180 - details 181 - [ 182 - (* TODO: check if expanded*) 183 - open_ 184 - ] @@ 185 - summary 186 - [] 187 - [render_frontmatter forest article.frontmatter] :: render_content forest article.mainmatter; 172 + details [(* TODO: check if expanded*) open_] 173 + @@ summary [] [render_frontmatter forest article.frontmatter] 174 + :: render_content forest article.mainmatter; 188 175 ]; 189 - match article.frontmatter.uri with 176 + (match article.frontmatter.uri with 190 177 | None -> footer [] @@ render_backmatter forest article.backmatter 191 178 | Some uri -> 192 179 if URI.equal (Config.home_uri forest.config) uri then null [] 193 - else footer [] @@ render_backmatter forest article.backmatter 180 + else footer [] @@ render_backmatter forest article.backmatter); 194 181 ] 195 182 196 183 and render_section (forest : State.t) (section : T.content T.section) : node = ··· 212 199 (* string_attr "data-taxon" () *) 213 200 null_ 214 201 in 215 - HTML.section 202 + HTML.section [class_; data_taxon] 216 203 [ 217 - class_; 218 - data_taxon; 219 - ] 220 - [ 221 - if test true flags.header_shown then 222 - details 223 - [if test true flags.expanded then open_ else null_] 224 - [ 225 - summary [] [render_frontmatter forest frontmatter]; 226 - null @@ render_content forest mainmatter; 227 - ] 228 - else null @@ render_content forest mainmatter; 204 + (if test true flags.header_shown then 205 + details 206 + [(if test true flags.expanded then open_ else null_)] 207 + [ 208 + summary [] [render_frontmatter forest frontmatter]; 209 + null @@ render_content forest mainmatter; 210 + ] 211 + else null @@ render_content forest mainmatter); 229 212 (* render_frontmatter forest frontmatter; *) 230 213 (* null @@ render_content forest mainmatter; *) 231 214 ] ··· 239 222 and render_attributions forest (attributions : T.content T.attribution list) = 240 223 let render_attribution attribution = 241 224 match attribution with 242 - | T.{vertex; _} -> 225 + | T.{vertex; _} -> ( 243 226 match vertex with 244 227 | T.Uri_vertex href -> 245 - let content = T.Content [T.Transclude {href; target = Title {empty_when_untitled = false}}] in 228 + let content = 229 + T.Content 230 + [T.Transclude {href; target = Title {empty_when_untitled = false}}] 231 + in 246 232 null @@ render_link forest T.{href; content} 247 - | T.Content_vertex content -> 248 - null @@ render_content forest content 233 + | T.Content_vertex content -> null @@ render_content forest content) 249 234 in 250 235 let authors, contributors = 251 236 attributions 252 237 |> List.partition_map @@ fun a -> 253 - match T.(a.role) with 254 - | T.Author -> Left a 255 - | Contributor -> Right a 238 + match T.(a.role) with T.Author -> Left a | Contributor -> Right a 256 239 in 257 240 li 258 241 [class_ "meta-item"] 259 242 [ 260 - address [class_ "author"] @@ 261 - List.map render_attribution authors @ 262 - begin 263 - if List.length contributors > 0 then 264 - [txt "with contributions from "] 265 - else [] 266 - end @ 267 - List.map render_attribution contributors 243 + address [class_ "author"] 244 + @@ List.map render_attribution authors 245 + @ begin if List.length contributors > 0 then 246 + [txt "with contributions from "] 247 + else [] 248 + end 249 + @ List.map render_attribution contributors; 268 250 ] 269 251 270 - and render_frontmatter (forest : State.t) (frontmatter : T.content T.frontmatter) : node = 252 + and render_frontmatter (forest : State.t) 253 + (frontmatter : T.content T.frontmatter) : node = 271 254 let taxon = 272 - Option.value ~default: [] @@ 273 - let@ c = Option.map @~ frontmatter.taxon in 274 - render_content forest c @ [txt ". "] 255 + Option.value ~default:[] 256 + @@ 257 + let@ c = Option.map @~ frontmatter.taxon in 258 + render_content forest c @ [txt ". "] 275 259 in 276 260 let title = 277 - Option.value ~default: [] @@ 278 - let@ c = Option.map @~ frontmatter.title in 279 - render_content forest c 261 + Option.value ~default:[] 262 + @@ 263 + let@ c = Option.map @~ frontmatter.title in 264 + render_content forest c 280 265 in 281 266 let uri = 282 267 match frontmatter.uri with ··· 286 271 (* TODO: replace with proper routing from legacy xml client *) 287 272 Format.asprintf "%a" URI.pp (route forest uri) 288 273 in 289 - a 290 - [class_ "slug"; href "%s" uri_str;] 291 - [txt "[%s]" uri_str] 274 + a [class_ "slug"; href "%s" uri_str] [txt "[%s]" uri_str] 292 275 in 293 276 let source_path = 294 277 match frontmatter.source_path with ··· 298 281 in 299 282 let find_meta key = 300 283 let@ str, content = List.find_map @~ frontmatter.metas in 301 - if str = key then Some content 302 - else None 284 + if str = key then Some content else None 303 285 in 304 286 let render_meta key f = 305 - Option.value 306 - ~default: (null []) 307 - (Option.map f (find_meta key)) 287 + Option.value ~default:(null []) (Option.map f (find_meta key)) 308 288 in 309 289 let default_meta_item content = 310 - li 311 - [class_ "meta-item"] 312 - (render_content forest content) 290 + li [class_ "meta-item"] (render_content forest content) 313 291 in 314 292 let labelled_external_link ~href ~label = 315 - li 316 - [class_ "meta-item"] 317 - [a [class_ "link external"; href] [txt "%s" label]] 293 + li [class_ "meta-item"] [a [class_ "link external"; href] [txt "%s" label]] 318 294 in 319 295 let to_string = 320 - Plain_text_client.string_of_content 321 - ~forest 322 - ~router: (Legacy_xml_client.route forest) 296 + Plain_text_client.string_of_content ~forest 297 + ~router:(Legacy_xml_client.route forest) 323 298 in 324 299 let position = render_meta "position" default_meta_item in 325 300 let institution = render_meta "institution" default_meta_item in ··· 333 308 [class_ "meta-item"] 334 309 [ 335 310 a 336 - [class_ "doi link"; href "https://www.doi.org/%s" content;] 337 - [txt "%s" content] 311 + [class_ "doi link"; href "https://www.doi.org/%s" content] 312 + [txt "%s" content]; 338 313 ] 339 314 in 340 315 let external_ = ··· 342 317 let content = to_string c in 343 318 li 344 319 [class_ "meta-item"] 345 - [ 346 - a 347 - [class_ "link external"; href "%s" content;] 348 - [txt "%s" content] 349 - ] 320 + [a [class_ "link external"; href "%s" content] [txt "%s" content]] 350 321 in 351 322 let slides = 352 323 render_meta "slides" @@ fun c -> 353 - labelled_external_link ~href: (href "%s" (to_string c)) ~label: "Slides" 324 + labelled_external_link ~href:(href "%s" (to_string c)) ~label:"Slides" 354 325 in 355 326 let video = 356 327 render_meta "video" @@ fun c -> 357 - labelled_external_link ~href: (href "%s" (to_string c)) ~label: "Video" 328 + labelled_external_link ~href:(href "%s" (to_string c)) ~label:"Video" 358 329 in 359 - header 360 - [] 330 + header [] 361 331 [ 362 - h1 [] @@ [span [class_ "taxon"] taxon] @ title @ [txt " "; uri] @ source_path; 332 + h1 [] 333 + @@ [span [class_ "taxon"] taxon] 334 + @ title 335 + @ [txt " "; uri] 336 + @ source_path; 363 337 div 364 338 [class_ "metadata"] 365 339 [ 366 - ul [] @@ 367 - List.map render_date frontmatter.dates @ 368 - [ 369 - render_attributions forest frontmatter.attributions; 370 - position; 371 - institution; 372 - venue; 373 - source; 374 - doi; 375 - orcid; 376 - external_; 377 - slides; 378 - video; 379 - ] 340 + ul [] 341 + @@ List.map render_date frontmatter.dates 342 + @ [ 343 + render_attributions forest frontmatter.attributions; 344 + position; 345 + institution; 346 + venue; 347 + source; 348 + doi; 349 + orcid; 350 + external_; 351 + slides; 352 + video; 353 + ]; 380 354 ]; 381 355 ] 382 356 383 357 and render_transclusion transclusion = 384 358 match transclusion with 385 359 | T.{href; target} -> 386 - let headers = Yojson.Safe.to_string @@ content_target_to_http_header target in 360 + let headers = 361 + Yojson.Safe.to_string @@ content_target_to_http_header target 362 + in 387 363 [ 388 364 span 389 365 [ ··· 393 369 Hx.swap "outerHTML"; 394 370 Hx.headers "%s" headers; 395 371 ] 396 - [txt "transclusion: %s" (Format.asprintf "%a" URI.pp href)] 372 + [txt "transclusion: %s" (Format.asprintf "%a" URI.pp href)]; 397 373 ] 398 374 399 - and render_content (forest : State.t) (Content content: T.content) : node list = 375 + and render_content (forest : State.t) (Content content : T.content) : node list 376 + = 400 377 List.concat_map (render_content_node forest) content 401 378 402 - and render_content_node (forest : State.t) (node : 'a T.content_node) : node list = 379 + and render_content_node (forest : State.t) (node : 'a T.content_node) : 380 + node list = 403 381 match node with 404 - | Text str -> 405 - [txt "%s" str] 406 - | CDATA str -> 407 - [txt ~raw: true "<![CDATA[%s]]>" str] 382 + | Text str -> [txt "%s" str] 383 + | CDATA str -> [txt ~raw:true "<![CDATA[%s]]>" str] 408 384 | Xml_elt elt -> 409 385 let prefixes_to_add, (name, attrs, content) = 410 386 let@ () = Xmlns.within_scope in 411 - render_xml_qname elt.name, 412 - List.map render_xml_attr elt.attrs, 413 - render_content forest elt.content 387 + ( render_xml_qname elt.name, 388 + List.map render_xml_attr elt.attrs, 389 + render_content forest elt.content ) 414 390 in 415 391 let attrs = 416 392 let xmlns_attrs = List.map render_xmlns_prefix prefixes_to_add in 417 393 attrs @ xmlns_attrs 418 394 in 419 395 [std_tag name attrs content] 420 - | Transclude transclusion -> 421 - render_transclusion transclusion 422 - | Contextual_number addr -> 423 - begin 424 - match (State.get_article addr) forest with 425 - | Some a -> 426 - [ 427 - contextual_number 428 - (T.article_to_section a) 429 - (default_toc_config ()) 430 - ] 431 - | None -> [] 432 - end 433 - 396 + | Transclude transclusion -> render_transclusion transclusion 397 + | Contextual_number addr -> begin 398 + match (State.get_article addr) forest with 399 + | Some a -> 400 + [contextual_number (T.article_to_section a) (default_toc_config ())] 401 + | None -> [] 402 + end 434 403 (* let custom_number = *) 435 404 (* article.frontmatter.number *) 436 405 (* in *) ··· 440 409 (* | Some num -> num *) 441 410 (* in *) 442 411 (* [txt "%s" num] *) 443 - | Link link -> 444 - render_link forest link 445 - | Section section -> 446 - [render_section forest section] 412 + | Link link -> render_link forest link 413 + | Section section -> [render_section forest section] 447 414 | KaTeX (mode, content) -> 448 415 let body = Plain_text_client.string_of_content ~forest content in 449 416 (* [txt ~raw: true "%s%s%s" l body r] *) 450 - begin 451 - match mode with 452 - | Inline -> 453 - [span [class_ "math"] [txt ~raw: true "%s" body]] 454 - | Display -> 455 - [div [class_ "math"] [txt ~raw: true "%s" body]] 417 + begin match mode with 418 + | Inline -> [span [class_ "math"] [txt ~raw:true "%s" body]] 419 + | Display -> [div [class_ "math"] [txt ~raw:true "%s" body]] 456 420 end 457 421 | Results_of_datalog_query q -> 458 422 (* We could just evaluate the query immediately. This is just experimental*) ··· 463 427 Hx.trigger "load"; 464 428 Hx.swap "outerHTML"; 465 429 Hx.target "this"; 466 - Hx.vals 467 - "%s" 468 - Repr.( 469 - to_json_string 470 - ~minify: true 471 - query_t 472 - {query = q} 473 - ) 430 + Hx.vals "%s" Repr.(to_json_string ~minify:true query_t {query = q}); 474 431 ] 475 - [] 432 + []; 476 433 ] 477 434 | T.Datalog_script _ -> [] 478 - | T.Artefact _ 479 - | T.Uri _ 480 - | T.Route_of_uri _ -> 481 - [txt "todo"] 435 + | T.Artefact _ | T.Uri _ | T.Route_of_uri _ -> [txt "todo"] 482 436 483 437 (* TODO: links need to be flattened in order to produce valid HTML. *) 484 438 and render_link (forest : State.t) (link : T.content T.link) : node list = ··· 486 440 match State.get_article link.href forest with 487 441 | None -> 488 442 (* TODO: rendering of hrefs is suboptimal... *) 489 - [ 490 - href "%s" (Format.asprintf "%a" URI.pp link.href); 491 - ] 492 - | Some article -> 493 - begin 494 - match article.frontmatter.uri with 495 - | Some _uri -> 496 - [ 497 - title_ "%s" @@ 498 - Option.value ~default: "" @@ 499 - Option.map 500 - ( 501 - Plain_text_client.string_of_content 502 - ~forest 503 - ~router: (Legacy_xml_client.route forest) 504 - ) 505 - article.frontmatter.title; 506 - href "/trees%s" (Format.asprintf "%s" (URI.path_string link.href)); 507 - Hx.target "#tree-container"; 508 - Hx.swap "innerHTML"; 509 - ] 510 - | None -> [HTML.null_] 511 - end; 443 + [href "%s" (Format.asprintf "%a" URI.pp link.href)] 444 + | Some article -> begin 445 + match article.frontmatter.uri with 446 + | Some _uri -> 447 + [ 448 + title_ "%s" @@ Option.value ~default:"" 449 + @@ Option.map 450 + (Plain_text_client.string_of_content ~forest 451 + ~router:(Legacy_xml_client.route forest)) 452 + article.frontmatter.title; 453 + href "/trees%s" (Format.asprintf "%s" (URI.path_string link.href)); 454 + Hx.target "#tree-container"; 455 + Hx.swap "innerHTML"; 456 + ] 457 + | None -> [HTML.null_] 458 + end 512 459 in 513 - [ 514 - span 515 - [class_ "link local"] 516 - [a attrs (render_content forest link.content)] 517 - ] 460 + [span [class_ "link local"] [a attrs (render_content forest link.content)]] 518 461 519 462 and contextual_number (_tree : T.content T.section) (cfg : toc_config) = 520 463 let should_number = 521 464 cfg.number <> "" 522 - || ( 523 - not cfg.in_backmatter 524 - && not cfg.is_root 525 - && not cfg.implicitly_unnumbered 526 - ) 465 + || (not cfg.in_backmatter) && (not cfg.is_root) 466 + && not cfg.implicitly_unnumbered 527 467 in 528 468 let taxon = 529 469 if cfg.taxon <> "" then 530 - cfg.taxon ^ 531 - if should_number || cfg.fallback_number <> "" then " " 532 - else "" 470 + cfg.taxon ^ if should_number || cfg.fallback_number <> "" then " " else "" 533 471 else "" 534 472 in 535 473 let number = 536 474 if should_number then 537 475 if cfg.number <> String.empty then cfg.number 538 476 else 539 - (* TODO: Implement this: 540 - <xsl:number format="1.1" count="f:tree[ancestor::f:tree and (not(@toc='false' or @numbered='false'))]" level="multiple" /> 477 + (* TODO: Implement this: <xsl:number format="1.1" 478 + count="f:tree[ancestor::f:tree and (not(@toc='false' or 479 + @numbered='false'))]" level="multiple" /> 541 480 *) 542 481 assert false 543 - else if cfg.fallback_number <> String.empty then 544 - cfg.fallback_number 482 + else if cfg.fallback_number <> String.empty then cfg.fallback_number 545 483 else "" 546 484 in 547 485 let suffix = 548 - if cfg.taxon <> String.empty 486 + if 487 + cfg.taxon <> String.empty 549 488 || cfg.fallback_number <> String.empty 550 - || should_number then cfg.suffix 489 + || should_number 490 + then cfg.suffix 551 491 else "" 552 492 in 553 493 null [txt "%s %s %s" taxon suffix number] ··· 557 497 contextual_number _tree cfg 558 498 559 499 and _render_toc_item (forest : State.t) (item : T.content T.section) = 560 - let to_str = Plain_text_client.string_of_content ~forest ~router: (Legacy_xml_client.route forest) in 500 + let to_str = 501 + Plain_text_client.string_of_content ~forest 502 + ~router:(Legacy_xml_client.route forest) 503 + in 561 504 null 562 505 [ 563 506 a 564 507 [ 565 508 class_ "bullet"; 566 509 href ""; 567 - title_ 568 - "%s%s" 569 - (Option.value ~default: "" @@ Option.map to_str item.frontmatter.title) 570 - ( 571 - Option.value ~default: "" @@ 572 - Option.map (Format.asprintf "[%a]" URI.pp) item.frontmatter.uri 573 - ) 510 + title_ "%s%s" 511 + (Option.value ~default:"" 512 + @@ Option.map to_str item.frontmatter.title) 513 + (Option.value ~default:"" 514 + @@ Option.map (Format.asprintf "[%a]" URI.pp) item.frontmatter.uri); 574 515 ] 575 516 [txt "■"]; 576 517 span ··· 581 522 [_tree_taxon_with_number item (default_toc_config ())]; 582 523 (* null @@ render_content forest item.mainmatter; *) 583 524 ]; 584 - ul [] (render_content forest item.mainmatter) 525 + ul [] (render_content forest item.mainmatter); 585 526 ] 586 527 587 528 and render_toc_mainmatter content = 588 - let T.Content nodes = content in 589 - ul [class_ "block"] @@ 590 - let@ node = List.filter_map @~ nodes in 591 - match node with 592 - | T.Section section -> 593 - Some (render_toc section) 594 - | _ -> None 529 + let (T.Content nodes) = content in 530 + ul [class_ "block"] 531 + @@ 532 + let@ node = List.filter_map @~ nodes in 533 + match node with T.Section section -> Some (render_toc section) | _ -> None 595 534 596 535 and render_toc (section : T.content T.section) = 597 - if Some false 536 + if 537 + Some false 598 538 = List.find_map 599 539 (fun (k, v) -> 600 - if k = "toc" && v = T.Content [T.Text "true"] then Some true 601 - else None 602 - ) 603 - section.frontmatter.metas then null [] 540 + if k = "toc" && v = T.Content [T.Text "true"] then Some true else None) 541 + section.frontmatter.metas 542 + then null [] 604 543 else 605 544 nav 606 545 [id "toc"; Hx.swap_oob "true"] ··· 610 549 [ 611 550 h1 [] [txt "Table of contents"]; 612 551 render_toc_mainmatter section.mainmatter; 613 - ] 552 + ]; 614 553 ] 615 554 616 555 let render_query_result (forest : State.t) (vs : Vertex_set.t) = 617 - let module C = Types.Comparators(struct 556 + let module C = Types.Comparators (struct 618 557 let string_of_content = 619 - Plain_text_client.string_of_content 620 - ~forest 621 - ~router: (route forest) 558 + Plain_text_client.string_of_content ~forest ~router:(route forest) 622 559 end) in 623 560 let make_section = 624 561 T.article_to_section 625 - ~flags: {T.default_section_flags with 626 - expanded = Some false; 627 - numbered = Some false; 628 - included_in_toc = Some false; 629 - metadata_shown = Some true 630 - } 562 + ~flags: 563 + { 564 + T.default_section_flags with 565 + expanded = Some false; 566 + numbered = Some false; 567 + included_in_toc = Some false; 568 + metadata_shown = Some true; 569 + } 631 570 in 632 571 let nodes = 633 - vs 634 - |> Vertex_set.to_seq 572 + vs |> Vertex_set.to_seq 635 573 |> Seq.filter_map Vertex.uri_of_vertex 636 574 |> Seq.filter_map (State.get_article @~ forest) 637 575 |> List.of_seq
+1 -5
lib/frontend/Htmx_client.mli
··· 6 6 7 7 open Forester_core 8 8 open Forester_compiler 9 - 10 9 module T := Types 11 10 12 11 type query = { 13 12 query: (string, T.content T.vertex) Forester_core.Datalog_expr.query; 14 13 } 15 - val query_t : query Repr.t 16 14 15 + val query_t : query Repr.t 17 16 val route : State.t -> URI.t -> URI.t 18 17 val render_article : State.t -> T.content T.article -> Pure_html.node 19 - 20 18 val render_content : State.t -> T.content -> Pure_html.node list 21 19 val render_frontmatter : State.t -> T.content T.frontmatter -> Pure_html.node 22 - 23 20 val render_query_result : State.t -> Vertex_set.t -> Pure_html.node option 24 - 25 21 val render_toc : T.content T.section -> Pure_html.node
+22 -19
lib/frontend/Json_manifest_client.ml
··· 13 13 module PT = Plain_text_client 14 14 end 15 15 16 - let render_tree ~dev ~(forest : State.t) (doc : T.content T.article) : Yojson.Safe.t option = 16 + let render_tree ~dev ~(forest : State.t) (doc : T.content T.article) : 17 + Yojson.Safe.t option = 17 18 let@ uri = Option.bind doc.frontmatter.uri in 18 19 (* TODO : Check routing *) 19 20 let route = Legacy_xml_client.route forest uri in 20 21 let title_string = 21 - PT.string_of_content ~forest @@ 22 - State.get_expanded_title doc.frontmatter forest 22 + PT.string_of_content ~forest 23 + @@ State.get_expanded_title doc.frontmatter forest 23 24 in 24 25 let title = `String title_string in 25 26 let taxon = 26 27 match doc.frontmatter.taxon with 27 28 | None -> `Null 28 - | Some content -> 29 - `String (PT.string_of_content ~forest content) 29 + | Some content -> `String (PT.string_of_content ~forest content) 30 30 in 31 31 let tags = 32 32 `List 33 33 begin 34 34 let@ tag = List.filter_map @~ doc.frontmatter.tags in 35 - let@ content = Option.map @~ State.get_title_or_content_of_vertex tag forest in 35 + let@ content = 36 + Option.map @~ State.get_title_or_content_of_vertex tag forest 37 + in 36 38 `String (PT.string_of_content ~forest content) 37 39 end 38 40 in ··· 50 52 else [] 51 53 in 52 54 (* TODO: filter out anonymous stuff *) 53 - Option.some @@ 54 - let fm = 55 - path @ 56 - [ 57 - ("title", title); 58 - ("uri", `String (URI.display_path_string ~base: forest.config.url uri)); 59 - ("taxon", taxon); 60 - ("tags", tags); 61 - ("route", route); 62 - ("metas", metas) 63 - ] 64 - in 65 - `Assoc fm 55 + Option.some 56 + @@ 57 + let fm = 58 + path 59 + @ [ 60 + ("title", title); 61 + ("uri", `String (URI.display_path_string ~base:forest.config.url uri)); 62 + ("taxon", taxon); 63 + ("tags", tags); 64 + ("route", route); 65 + ("metas", metas); 66 + ] 67 + in 68 + `Assoc fm
+1 -5
lib/frontend/Json_manifest_client.mli
··· 6 6 7 7 open Forester_core 8 8 open Forester_compiler 9 - 10 9 module T := Types 11 10 12 11 val render_tree : 13 - dev: bool -> 14 - forest: State.t -> 15 - T.content T.article -> 16 - Yojson.Safe.t option 12 + dev:bool -> forest:State.t -> T.content T.article -> Yojson.Safe.t option
+180 -153
lib/frontend/Legacy_xml_client.ml
··· 20 20 include Xmlns_effect.Make () 21 21 22 22 let run (k : xmlns_attr list -> 'a) = 23 - run ~reserved: X.reserved_xmlnss @@ fun () -> 24 - k X.reserved_xmlnss 23 + run ~reserved:X.reserved_xmlnss @@ fun () -> k X.reserved_xmlnss 25 24 end 26 25 27 - module In_backmatter = Algaeff.Reader.Make(struct type t = bool end) 26 + module In_backmatter = Algaeff.Reader.Make (struct 27 + type t = bool 28 + end) 28 29 29 30 let local_path_components (config : Config.t) (uri : URI.t) = 30 31 let host = Option.get @@ URI.host uri in 31 32 let base_host = Option.get @@ URI.host config.url in 32 - if host = base_host then 33 - URI.stripped_path_components uri 34 - else 35 - "foreign" :: host :: URI.stripped_path_components uri 33 + if host = base_host then URI.stripped_path_components uri 34 + else "foreign" :: host :: URI.stripped_path_components uri 36 35 37 36 let local_base_url_string (config : Config.t) = 38 37 let path = URI.path_components config.url in ··· 41 40 let route (forest : State.t) uri : URI.t = 42 41 match forest.={uri} with 43 42 | None -> uri 44 - | Some tree -> 43 + | Some tree -> ( 45 44 match Tree.to_evaluated tree with 46 45 | Some evaluated when evaluated.route_locally -> 47 46 let path = "" :: local_path_components forest.config uri in 48 47 URI.make ~path () 49 - | _ -> uri 48 + | _ -> uri) 50 49 51 50 module Scope = struct 52 - open struct module E = Algaeff.Reader.Make(struct type t = URI.t option end) end 51 + open struct 52 + module E = Algaeff.Reader.Make (struct 53 + type t = URI.t option 54 + end) 55 + end 56 + 53 57 let read = E.read 54 58 55 59 let run ~(forest : State.t) ~env kont = ··· 57 61 let loc_opt = 58 62 let@ uri = Option.bind env in 59 63 let@ path = Option.map @~ State.source_path_of_uri uri forest in 60 - let position = Range.{source = `File path; offset = 0; start_of_line = 0; line_num = 0} in 64 + let position = 65 + Range.{source = `File path; offset = 0; start_of_line = 0; line_num = 0} 66 + in 61 67 Range.make (position, position) 62 68 in 63 69 let@ () = Reporter.with_loc loc_opt in ··· 75 81 | _ -> Format.sprintf "%s:%s" qname.prefix qname.uname 76 82 77 83 let render_xml_attr (forest : State.t) T.{key; value} = 78 - let str_value = Plain_text_client.string_of_content ~forest ~router: (route forest) value in 84 + let str_value = 85 + Plain_text_client.string_of_content ~forest ~router:(route forest) value 86 + in 79 87 P.string_attr (render_xml_qname key) "%s" str_value 80 88 81 - let render_xmlns_prefix ({prefix; xmlns}: Forester_xml_names.xmlns_attr) = 89 + let render_xmlns_prefix ({prefix; xmlns} : Forester_xml_names.xmlns_attr) = 82 90 let attr = match prefix with "" -> "xmlns" | _ -> "xmlns:" ^ prefix in 83 91 P.string_attr attr "%s" xmlns 84 92 85 - let render_section_flags (dict : T.section_flags) = [ 86 - X.optional_ X.show_heading dict.header_shown; 87 - X.optional_ X.show_metadata dict.metadata_shown; 88 - X.optional_ X.hidden_when_empty dict.hidden_when_empty; 89 - X.optional_ X.expanded dict.expanded; 90 - X.optional_ X.toc dict.included_in_toc; 91 - X.optional_ X.numbered dict.numbered 92 - ] 93 + let render_section_flags (dict : T.section_flags) = 94 + [ 95 + X.optional_ X.show_heading dict.header_shown; 96 + X.optional_ X.show_metadata dict.metadata_shown; 97 + X.optional_ X.hidden_when_empty dict.hidden_when_empty; 98 + X.optional_ X.expanded dict.expanded; 99 + X.optional_ X.toc dict.included_in_toc; 100 + X.optional_ X.numbered dict.numbered; 101 + ] 93 102 94 103 let rec render_section forest (section : T.content T.section) : P.node = 95 104 let@ _ = Xmlns.run in ··· 97 106 (render_section_flags section.flags) 98 107 [ 99 108 render_frontmatter forest section.frontmatter; 100 - let@ () = Scope.run ~forest ~env: section.frontmatter.uri in 101 - X.mainmatter [] @@ 102 - if Loop_detection.have_seen_uri_opt section.frontmatter.uri then 103 - [X.info [] [P.txt "Transclusion loop detected, rendering stopped."]] 104 - else 105 - let@ () = Loop_detection.add_seen_uri_opt section.frontmatter.uri in 106 - render_mainmatter forest section 109 + (let@ () = Scope.run ~forest ~env:section.frontmatter.uri in 110 + X.mainmatter [] 111 + @@ 112 + if Loop_detection.have_seen_uri_opt section.frontmatter.uri then 113 + [X.info [] [P.txt "Transclusion loop detected, rendering stopped."]] 114 + else 115 + let@ () = Loop_detection.add_seen_uri_opt section.frontmatter.uri in 116 + render_mainmatter forest section); 107 117 ] 108 118 109 119 and render_mainmatter forest (section : T.content T.section) = 110 120 match section.frontmatter.uri with 111 121 | None -> render_content forest section.mainmatter 112 - | Some uri -> 122 + | Some uri -> ( 113 123 match Hashtbl.find_opt mainmatter_cache uri with 114 124 | None -> 115 125 let nodes = render_content forest section.mainmatter in 116 126 Hashtbl.add mainmatter_cache uri nodes; 117 127 nodes 118 - | Some nodes -> nodes 128 + | Some nodes -> nodes) 119 129 120 - and render_frontmatter (forest : State.t) (frontmatter : T.content T.frontmatter) : P.node = 130 + and render_frontmatter (forest : State.t) 131 + (frontmatter : T.content T.frontmatter) : P.node = 121 132 let result = 122 - X.frontmatter 123 - [] 133 + X.frontmatter [] 124 134 [ 125 135 render_attributions forest frontmatter.uri frontmatter.attributions; 126 136 render_dates forest frontmatter.dates; 127 - X.conditional forest.dev (X.optional (X.source_path [] "%s") frontmatter.source_path); 128 - X.optional (fun uri -> X.uri [] "%s" @@ URI.to_string uri) frontmatter.uri; 129 - X.optional (fun uri -> X.display_uri [] "%s" @@ URI.display_path_string ~base: forest.config.url uri) frontmatter.uri; 130 - X.optional (X.route [] "%s") @@ Option.map (Fun.compose URI.to_string (route forest)) frontmatter.uri; 131 - begin 132 - match frontmatter.title with 133 - | None -> X.null [] 134 - | Some _ -> 135 - let title = State.get_expanded_title ?scope: (Scope.read ()) frontmatter forest in 136 - X.title [X.text_ "%s" @@ Plain_text_client.string_of_content ~forest ~router: (route forest) title] @@ 137 - render_content forest title 137 + X.conditional forest.dev 138 + (X.optional (X.source_path [] "%s") frontmatter.source_path); 139 + X.optional 140 + (fun uri -> X.uri [] "%s" @@ URI.to_string uri) 141 + frontmatter.uri; 142 + X.optional 143 + (fun uri -> 144 + X.display_uri [] "%s" 145 + @@ URI.display_path_string ~base:forest.config.url uri) 146 + frontmatter.uri; 147 + X.optional (X.route [] "%s") 148 + @@ Option.map (Fun.compose URI.to_string (route forest)) frontmatter.uri; 149 + begin match frontmatter.title with 150 + | None -> X.null [] 151 + | Some _ -> 152 + let title = 153 + State.get_expanded_title ?scope:(Scope.read ()) frontmatter forest 154 + in 155 + X.title 156 + [ 157 + X.text_ "%s" 158 + @@ Plain_text_client.string_of_content ~forest 159 + ~router:(route forest) title; 160 + ] 161 + @@ render_content forest title 138 162 end; 139 - begin 140 - match frontmatter.taxon with 141 - | None -> X.null [] 142 - | Some taxon -> 143 - X.taxon [] @@ render_content forest taxon 163 + begin match frontmatter.taxon with 164 + | None -> X.null [] 165 + | Some taxon -> X.taxon [] @@ render_content forest taxon 144 166 end; 145 - X.null @@ List.map (render_meta forest) frontmatter.metas 167 + X.null @@ List.map (render_meta forest) frontmatter.metas; 146 168 ] 147 169 in 148 170 result 149 171 150 172 and render_meta forest (key, body) = 151 - X.meta [X.name "%s" key] @@ 152 - render_content forest body 173 + X.meta [X.name "%s" key] @@ render_content forest body 153 174 154 - and render_content (forest : State.t) (Content content: T.content) : P.node list = 175 + and render_content (forest : State.t) (Content content : T.content) : 176 + P.node list = 155 177 match content with 156 178 | T.Text txt0 :: T.Text txt1 :: content -> 157 179 render_content forest (Content (T.Text (txt0 ^ txt1) :: content)) ··· 161 183 xs @ ys 162 184 | [] -> [] 163 185 164 - and render_content_node (forest : State.t) (node : 'a T.content_node) : P.node list = 186 + and render_content_node (forest : State.t) (node : 'a T.content_node) : 187 + P.node list = 165 188 match node with 166 - | Text str -> 167 - [P.txt "%s" str] 168 - | CDATA str -> 169 - [P.txt ~raw: true "<![CDATA[%s]]>" str] 189 + | Text str -> [P.txt "%s" str] 190 + | CDATA str -> [P.txt ~raw:true "<![CDATA[%s]]>" str] 170 191 | Uri uri -> 171 - [P.txt "%s" (URI.display_path_string ~base: forest.config.url uri)] 172 - | Route_of_uri uri -> 173 - [P.txt "%s" (URI.to_string (route forest uri))] 192 + [P.txt "%s" (URI.display_path_string ~base:forest.config.url uri)] 193 + | Route_of_uri uri -> [P.txt "%s" (URI.to_string (route forest uri))] 174 194 | Xml_elt elt -> 175 195 let prefixes_to_add, (name, attrs, content) = 176 196 let@ () = Xmlns.within_scope in 177 - render_xml_qname elt.name, 178 - List.map (render_xml_attr forest) elt.attrs, 179 - render_content forest elt.content 197 + ( render_xml_qname elt.name, 198 + List.map (render_xml_attr forest) elt.attrs, 199 + render_content forest elt.content ) 180 200 in 181 201 let attrs = 182 202 let xmlns_attrs = List.map render_xmlns_prefix prefixes_to_add in 183 203 attrs @ xmlns_attrs 184 204 in 185 205 [P.std_tag name attrs content] 186 - | Transclude transclusion -> 187 - render_transclusion forest transclusion 206 + | Transclude transclusion -> render_transclusion forest transclusion 188 207 | Contextual_number uri -> 189 208 let custom_number = 190 209 let@ resource = Option.bind @@ forest.@{uri} in 191 210 match resource with 192 - | T.Article article -> 193 - article.frontmatter.number 211 + | T.Article article -> article.frontmatter.number 194 212 | _ -> None 195 213 in 196 - begin 197 - match custom_number with 198 - | None -> 199 - [ 200 - X.contextual_number 201 - [ 202 - X.uri_ "%s" @@ URI.to_string uri; 203 - X.display_uri_ "%s" @@ URI.display_path_string ~base: forest.config.url uri 204 - ] 205 - ] 206 - | Some num -> [P.txt "%s" num] 214 + begin match custom_number with 215 + | None -> 216 + [ 217 + X.contextual_number 218 + [ 219 + X.uri_ "%s" @@ URI.to_string uri; 220 + X.display_uri_ "%s" 221 + @@ URI.display_path_string ~base:forest.config.url uri; 222 + ]; 223 + ] 224 + | Some num -> [P.txt "%s" num] 207 225 end 208 - | Link link -> 209 - render_link forest link 226 + | Link link -> render_link forest link 210 227 | Results_of_datalog_query q -> 211 228 let article_to_section = 212 229 T.article_to_section 213 - ~flags: {T.default_section_flags with 214 - expanded = Some false; 215 - numbered = Some false; 216 - included_in_toc = Some false; 217 - metadata_shown = Some true 218 - } 230 + ~flags: 231 + { 232 + T.default_section_flags with 233 + expanded = Some false; 234 + numbered = Some false; 235 + included_in_toc = Some false; 236 + metadata_shown = Some true; 237 + } 219 238 in 220 239 let results = Forest.run_datalog_query forest.graphs q in 221 240 let@ article = List.map @~ Forest_util.get_sorted_articles forest results in 222 241 render_section forest @@ article_to_section article 223 - | Section section -> 224 - [render_section forest section] 242 + | Section section -> [render_section forest section] 225 243 | KaTeX (mode, content) -> 226 - let display = 227 - match mode with 228 - | Inline -> "inline" 229 - | Display -> "block" 230 - in 244 + let display = match mode with Inline -> "inline" | Display -> "block" in 231 245 let body = Format.asprintf "%a" TeX_like.pp_content content in 232 246 [X.tex [X.display "%s" display] "<![CDATA[%s]]>" body] 233 - | Artefact resource -> 234 - [render_artefact forest resource] 247 + | Artefact resource -> [render_artefact forest resource] 235 248 | Datalog_script _ -> [] 236 249 237 250 and render_artefact forest (resource : T.content T.artefact) = ··· 239 252 [X.hash "%s" resource.hash] 240 253 [ 241 254 X.resource_content [] @@ render_content forest resource.content; 242 - render_resource_sources resource.sources 255 + render_resource_sources resource.sources; 243 256 ] 244 257 245 258 and render_resource_sources sources = 246 259 X.null @@ List.map render_resource_source sources 247 260 248 261 and render_resource_source source = 249 - X.resource_source [X.type_ "%s" source.type_; X.resource_part "%s" source.part] "<![CDATA[%s]]>" source.source 262 + X.resource_source 263 + [X.type_ "%s" source.type_; X.resource_part "%s" source.part] 264 + "<![CDATA[%s]]>" source.source 250 265 251 - and render_transclusion (forest : State.t) (transclusion : T.transclusion) : P.node list = 266 + and render_transclusion (forest : State.t) (transclusion : T.transclusion) : 267 + P.node list = 252 268 match State.get_content_of_transclusion transclusion forest with 253 - | None -> 254 - Reporter.fatal (Resource_not_found transclusion.href) 255 - | Some content -> 256 - render_content forest content 269 + | None -> Reporter.fatal (Resource_not_found transclusion.href) 270 + | Some content -> render_content forest content 257 271 258 272 and render_link (forest : State.t) (link : T.content T.link) : P.node list = 259 273 let article_opt = State.get_article link.href forest in 260 274 let attrs = 261 275 match article_opt with 262 276 | None -> 263 - begin 264 - if not @@ In_backmatter.read () then 265 - match State.suggestion_for_uri link.href forest with 266 - | Ok -> () 267 - | Not_found {suggestion} -> Reporter.emit @@ Broken_link {uri = link.href; suggestion} 277 + begin if not @@ In_backmatter.read () then 278 + match State.suggestion_for_uri link.href forest with 279 + | Ok -> () 280 + | Not_found {suggestion} -> 281 + Reporter.emit @@ Broken_link {uri = link.href; suggestion} 268 282 end; 269 283 [ 270 284 X.href "%s" @@ URI.to_string @@ route forest link.href; 271 - X.type_ "external" 285 + X.type_ "external"; 272 286 ] 273 287 | Some article -> 274 288 [ 275 289 X.href "%s" @@ URI.to_string @@ route forest link.href; 276 - X.title_ "%s" @@ 277 - Plain_text_client.string_of_content ~forest: forest ~router: (route forest) @@ 278 - State.get_expanded_title ?scope: (Scope.read ()) article.frontmatter forest; 279 - X.optional_ (X.uri_ "%s") @@ Option.map URI.to_string article.frontmatter.uri; 280 - X.optional_ (X.display_uri_ "%s") @@ Option.map (URI.display_path_string ~base: forest.config.url) article.frontmatter.uri; 281 - X.type_ "local" 290 + X.title_ "%s" 291 + @@ Plain_text_client.string_of_content ~forest ~router:(route forest) 292 + @@ State.get_expanded_title ?scope:(Scope.read ()) article.frontmatter 293 + forest; 294 + X.optional_ (X.uri_ "%s") 295 + @@ Option.map URI.to_string article.frontmatter.uri; 296 + X.optional_ (X.display_uri_ "%s") 297 + @@ Option.map 298 + (URI.display_path_string ~base:forest.config.url) 299 + article.frontmatter.uri; 300 + X.type_ "local"; 282 301 ] 283 302 in 284 303 [X.link attrs @@ render_content forest link.content] 285 304 286 - and render_attributions (forest : State.t) (scope : URI.t option) (primary_attributions : _ T.attribution list) = 287 - X.authors [] @@ 288 - List.map (render_attribution forest) @@ 289 - Forest_util.collect_attributions forest scope primary_attributions 305 + and render_attributions (forest : State.t) (scope : URI.t option) 306 + (primary_attributions : _ T.attribution list) = 307 + X.authors [] 308 + @@ List.map (render_attribution forest) 309 + @@ Forest_util.collect_attributions forest scope primary_attributions 290 310 291 311 and render_attribution forest (attrib : _ T.attribution) = 292 312 let tag = 293 - match attrib.role with 294 - | Author -> X.author 295 - | Contributor -> X.contributor 313 + match attrib.role with Author -> X.author | Contributor -> X.contributor 296 314 in 297 315 tag [] @@ render_attribution_vertex forest attrib.vertex 298 316 299 317 and render_attribution_vertex (forest : State.t) vtx = 300 318 match vtx with 301 319 | T.Uri_vertex href -> 302 - let content = T.Content [T.Transclude {href; target = Title {empty_when_untitled = false}}] in 320 + let content = 321 + T.Content 322 + [T.Transclude {href; target = Title {empty_when_untitled = false}}] 323 + in 303 324 render_link forest T.{href; content} 304 - | T.Content_vertex content -> 305 - render_content forest content 325 + | T.Content_vertex content -> render_content forest content 306 326 307 - and render_dates forest dates = 308 - X.null @@ List.map (render_date forest) dates 327 + and render_dates forest dates = X.null @@ List.map (render_date forest) dates 309 328 310 329 and render_date forest (date : Human_datetime.t) = 311 330 let config = forest.config in 312 331 let href_attr = 313 - let str = Format.asprintf "%a" Human_datetime.pp (Human_datetime.drop_time date) in 314 - let uri = URI_scheme.named_uri ~base: config.url str in 332 + let str = 333 + Format.asprintf "%a" Human_datetime.pp (Human_datetime.drop_time date) 334 + in 335 + let uri = URI_scheme.named_uri ~base:config.url str in 315 336 match State.get_article uri forest with 316 337 | None -> X.null_ 317 338 | Some _ -> X.href "%s" @@ URI.to_string @@ route forest uri 318 339 in 319 - X.date 320 - [href_attr] 340 + X.date [href_attr] 321 341 [ 322 342 X.year [] "%i" (Human_datetime.year date); 323 343 Human_datetime.month date |> X.optional @@ X.month [] "%i"; 324 - Human_datetime.day date |> X.optional @@ X.day [] "%i" 344 + Human_datetime.day date |> X.optional @@ X.day [] "%i"; 325 345 ] 326 346 327 347 let render_article (forest : State.t) (article : T.content T.article) : P.node = 328 348 let before = Unix.gettimeofday () in 329 - let@ () = fun kont -> 349 + let@ () = 350 + fun kont -> 330 351 let result = kont () in 331 352 let after = Unix.gettimeofday () in 332 353 let elapsed = after -. before in 333 354 if elapsed > 0.1 then 334 - Logs.debug (fun m -> m "[Performance] rendering %a took %f seconds" Format.(pp_print_option URI.pp) article.frontmatter.uri elapsed); 355 + Logs.debug (fun m -> 356 + m "[Performance] rendering %a took %f seconds" 357 + Format.(pp_print_option URI.pp) 358 + article.frontmatter.uri elapsed); 335 359 result 336 360 in 337 361 let config = forest.config in 338 362 let@ () = Loop_detection.run in 339 - let@ () = Scope.run ~forest ~env: article.frontmatter.uri in 363 + let@ () = Scope.run ~forest ~env:article.frontmatter.uri in 340 364 let@ xmlnss = Xmlns.run in 341 - let@ () = In_backmatter.run ~env: false in 365 + let@ () = In_backmatter.run ~env:false in 342 366 X.tree 343 367 begin 344 - List.map render_xmlns_prefix xmlnss @ 345 - [ 346 - X.optional_ X.root @@ 347 - begin 348 - let@ uri = Option.map @~ article.frontmatter.uri in 349 - URI.equal (Config.home_uri config) uri 350 - end; 351 - P.string_attr "base-url" "%s" (local_base_url_string config) 368 + List.map render_xmlns_prefix xmlnss 369 + @ [ 370 + X.optional_ X.root 371 + @@ begin 372 + let@ uri = Option.map @~ article.frontmatter.uri in 373 + URI.equal (Config.home_uri config) uri 374 + end; 375 + P.string_attr "base-url" "%s" (local_base_url_string config); 352 376 ] 353 377 end 354 378 [ 355 379 render_frontmatter forest article.frontmatter; 356 - X.mainmatter [] @@ 357 - begin 358 - let@ () = Loop_detection.add_seen_uri_opt article.frontmatter.uri in 359 - render_mainmatter forest @@ T.article_to_section article 360 - end; 361 - X.backmatter [] @@ 362 - let@ () = In_backmatter.run ~env: true in 363 - render_content forest article.backmatter 380 + X.mainmatter [] 381 + @@ begin 382 + let@ () = Loop_detection.add_seen_uri_opt article.frontmatter.uri in 383 + render_mainmatter forest @@ T.article_to_section article 384 + end; 385 + (X.backmatter [] 386 + @@ 387 + let@ () = In_backmatter.run ~env:true in 388 + render_content forest article.backmatter); 364 389 ] 365 390 366 391 let pp_xml ~(forest : State.t) ?stylesheet fmt (article : _ T.article) = ··· 368 393 Format.pp_print_newline fmt (); 369 394 begin 370 395 let@ xsl_path = Option.iter @~ stylesheet in 371 - Format.fprintf fmt "<?xml-stylesheet type=\"text/xsl\" href=\"%s%s\"?>" (local_base_url_string forest.config) xsl_path 396 + Format.fprintf fmt "<?xml-stylesheet type=\"text/xsl\" href=\"%s%s\"?>" 397 + (local_base_url_string forest.config) 398 + xsl_path 372 399 end; 373 400 Format.pp_print_newline fmt (); 374 401 P.pp_xml fmt @@ render_article forest article
+7 -3
lib/frontend/Legacy_xml_client.mli
··· 6 6 7 7 open Forester_core 8 8 open Forester_compiler 9 - 10 9 module T := Types 11 10 module P := Pure_html 12 11 13 12 val local_path_components : Config.t -> URI.t -> string list 14 13 val route : State.t -> URI.t -> URI.t 15 - 16 14 val render_article : State.t -> T.content T.article -> P.node 17 - val pp_xml : forest: State.t -> ?stylesheet: string -> Format.formatter -> T.content T.article -> unit 15 + 16 + val pp_xml : 17 + forest:State.t -> 18 + ?stylesheet:string -> 19 + Format.formatter -> 20 + T.content T.article -> 21 + unit
+9 -12
lib/frontend/Loop_detection_effect.ml
··· 7 7 open Forester_core 8 8 9 9 module Make () = struct 10 - open Algaeff.Reader.Make(struct type t = URI.Set.t end) 11 - let add_seen_uri uri = 12 - scope @@ URI.Set.add uri 10 + open Algaeff.Reader.Make (struct 11 + type t = URI.Set.t 12 + end) 13 + 14 + let add_seen_uri uri = scope @@ URI.Set.add uri 13 15 14 16 let add_seen_uri_opt uri_opt kont = 15 - match uri_opt with 16 - | None -> kont () 17 - | Some uri -> add_seen_uri uri kont 17 + match uri_opt with None -> kont () | Some uri -> add_seen_uri uri kont 18 18 19 - let have_seen_uri uri = 20 - URI.Set.mem uri @@ read () 19 + let have_seen_uri uri = URI.Set.mem uri @@ read () 21 20 22 21 let have_seen_uri_opt uri_opt = 23 - match uri_opt with 24 - | None -> false 25 - | Some uri -> have_seen_uri uri 22 + match uri_opt with None -> false | Some uri -> have_seen_uri uri 26 23 27 - let run k = run ~env: URI.Set.empty k 24 + let run k = run ~env:URI.Set.empty k 28 25 end
+16 -6
lib/frontend/Plain_text_client.ml
··· 7 7 open Forester_core 8 8 open Forester_compiler 9 9 10 - open struct module T = Types end 10 + open struct 11 + module T = Types 12 + end 11 13 12 14 let rec pp_content ~forest ~router fmt = function 13 15 | T.Content c -> c |> List.iter @@ pp_content_node ~forest ~router fmt 14 16 15 - and pp_content_node ~forest ~(router : URI.t -> URI.t) fmt : 'a T.content_node -> unit = function 17 + and pp_content_node ~forest ~(router : URI.t -> URI.t) fmt : 18 + 'a T.content_node -> unit = function 16 19 | Text txt | CDATA txt -> Format.pp_print_string fmt txt 17 20 | Uri uri -> URI.pp fmt uri 18 21 | Route_of_uri uri -> Format.fprintf fmt "%a" URI.pp (router uri) ··· 24 27 | Link link -> pp_link ~forest ~router fmt link 25 28 | Results_of_datalog_query _ | Artefact _ | Datalog_script _ -> () 26 29 27 - and pp_transclusion ~forest ~(router : URI.t -> URI.t) fmt (transclusion : T.transclusion) = 30 + and pp_transclusion ~forest ~(router : URI.t -> URI.t) fmt 31 + (transclusion : T.transclusion) = 28 32 match State.get_content_of_transclusion transclusion forest with 29 - | None -> Format.fprintf fmt "<could not resolve transclusion of %a>" URI.pp transclusion.href 33 + | None -> 34 + Format.fprintf fmt "<could not resolve transclusion of %a>" URI.pp 35 + transclusion.href 30 36 | Some content -> pp_content ~forest ~router fmt content 31 37 32 38 and pp_link ~forest ~(router : URI.t -> URI.t) fmt (link : T.content T.link) = 33 39 pp_content ~forest ~router fmt link.content 34 40 35 - and pp_section ~forest ~(router : URI.t -> URI.t) fmt (section : T.content T.section) = 41 + and pp_section ~forest ~(router : URI.t -> URI.t) fmt 42 + (section : T.content T.section) = 36 43 match section.frontmatter.title with 37 44 | None -> Format.fprintf fmt "<omitted content>" 38 - | Some title -> Format.fprintf fmt "<omitted content: %a>" (pp_content ~forest ~router) title 45 + | Some title -> 46 + Format.fprintf fmt "<omitted content: %a>" 47 + (pp_content ~forest ~router) 48 + title 39 49 40 50 let string_of_content ~forest ?(router : URI.t -> URI.t = Fun.id) = 41 51 Format.asprintf "%a" (pp_content ~forest ~router)
+3 -7
lib/frontend/Plain_text_client.mli
··· 6 6 7 7 open Forester_core 8 8 open Forester_compiler 9 - 10 9 module T := Types 11 10 12 11 val string_of_content : 13 - forest: State.t -> 14 - ?router: (URI.t -> URI.t) -> 15 - Types.content -> 16 - string 12 + forest:State.t -> ?router:(URI.t -> URI.t) -> Types.content -> string 17 13 18 14 val pp_content : 19 - forest: State.t -> 20 - router: (URI.t -> URI.t) -> 15 + forest:State.t -> 16 + router:(URI.t -> URI.t) -> 21 17 Format.formatter -> 22 18 Types.content -> 23 19 unit
+77 -62
lib/frontend/test/Test_DSL.ml
··· 6 6 7 7 open Forester_frontend.DSL 8 8 open Forester_core 9 - open struct module T = Types end 9 + 10 + open struct 11 + module T = Types 12 + end 10 13 11 14 let content_node = 12 - (module struct 13 - type t = T.content T.content_node 14 - let equal = (=) 15 - let pp = T.pp_content_node T.pp_content 16 - end: Alcotest.TESTABLE with type t = T.content T.content_node) 15 + (module struct 16 + type t = T.content T.content_node 17 + 18 + let equal = ( = ) 19 + let pp = T.pp_content_node T.pp_content 20 + end : Alcotest.TESTABLE 21 + with type t = T.content T.content_node) 17 22 18 23 let content = 19 24 p 20 25 [ 21 - ol 22 - [ 23 - li [txt "First item"]; 24 - li [txt "Second item"] 25 - ]; 26 - ul 27 - [ 28 - li [txt "First item"]; 29 - li [txt "Second item"] 30 - ]; 31 - section ~mainmatter: ([p [txt "section"]]) (); 26 + ol [li [txt "First item"]; li [txt "Second item"]]; 27 + ul [li [txt "First item"]; li [txt "Second item"]]; 28 + section ~mainmatter:[p [txt "section"]] (); 32 29 em [txt "Emphasized item"]; 33 30 strong [txt "Strong text"]; 34 31 code [txt "fun _ -> ()"]; ··· 48 45 let test () = 49 46 Alcotest.(check @@ content_node) 50 47 "works" 51 - ( 52 - T.prim `P @@ 53 - T.Content 54 - [ 55 - T.prim `Ol @@ 56 - T.Content 48 + (T.prim `P 49 + @@ T.Content 50 + [ 51 + T.prim `Ol 52 + @@ T.Content 57 53 [ 58 54 T.prim `Li @@ T.Content [Text "First item"]; 59 - T.prim `Li @@ T.Content [Text "Second item"] 55 + T.prim `Li @@ T.Content [Text "Second item"]; 60 56 ]; 61 - T.prim `Ul @@ 62 - T.Content 57 + T.prim `Ul 58 + @@ T.Content 63 59 [ 64 60 T.prim `Li @@ T.Content [Text "First item"]; 65 - T.prim `Li @@ T.Content [Text "Second item"] 61 + T.prim `Li @@ T.Content [Text "Second item"]; 66 62 ]; 67 - Section 68 - { 69 - frontmatter = { 70 - uri = None; 71 - title = None; 72 - dates = []; 73 - attributions = []; 74 - taxon = None; 75 - number = None; 76 - designated_parent = None; 77 - source_path = None; 78 - tags = []; 79 - metas = []; 80 - last_changed = None 81 - }; 82 - mainmatter = Content [T.prim `P @@ T.Content [Text "section"]]; 83 - flags = {hidden_when_empty = None; included_in_toc = None; header_shown = None; metadata_shown = (Some false); numbered = None; expanded = None} 84 - }; 85 - T.prim `Em @@ T.Content [Text "Emphasized item"]; 86 - T.prim `Strong @@ T.Content [Text "Strong text"]; 87 - T.prim `Code @@ T.Content [Text "fun _ -> ()"]; 88 - T.prim `Blockquote @@ T.Content [Text "blockquote"]; 89 - T.prim `Pre @@ T.Content [Text "pre"]; 90 - T.prim `Figure @@ T.Content [Text "figure"]; 91 - T.prim `Figcaption @@ T.Content [Text "caption"]; 92 - CDATA "cdata"; 93 - Xml_elt {name = {prefix = ""; uname = "html"; xmlns = None}; attrs = []; content = (Content [])}; 94 - Transclude {href = URI.of_string_exn "foo-001"; target = Mainmatter}; 95 - Contextual_number (URI.of_string_exn "chapter-3"); 96 - KaTeX (Inline, Content [Text "a = b"]); 97 - Link {href = URI.of_string_exn "https://git.sr.ht/~jonsterling/ocaml-forester"; content = Content [Text "Forester"]}; 98 - Artefact {hash = ""; content = (Content [Text "res"]); sources = []} 99 - ] 100 - ) 63 + Section 64 + { 65 + frontmatter = 66 + { 67 + uri = None; 68 + title = None; 69 + dates = []; 70 + attributions = []; 71 + taxon = None; 72 + number = None; 73 + designated_parent = None; 74 + source_path = None; 75 + tags = []; 76 + metas = []; 77 + last_changed = None; 78 + }; 79 + mainmatter = Content [T.prim `P @@ T.Content [Text "section"]]; 80 + flags = 81 + { 82 + hidden_when_empty = None; 83 + included_in_toc = None; 84 + header_shown = None; 85 + metadata_shown = Some false; 86 + numbered = None; 87 + expanded = None; 88 + }; 89 + }; 90 + T.prim `Em @@ T.Content [Text "Emphasized item"]; 91 + T.prim `Strong @@ T.Content [Text "Strong text"]; 92 + T.prim `Code @@ T.Content [Text "fun _ -> ()"]; 93 + T.prim `Blockquote @@ T.Content [Text "blockquote"]; 94 + T.prim `Pre @@ T.Content [Text "pre"]; 95 + T.prim `Figure @@ T.Content [Text "figure"]; 96 + T.prim `Figcaption @@ T.Content [Text "caption"]; 97 + CDATA "cdata"; 98 + Xml_elt 99 + { 100 + name = {prefix = ""; uname = "html"; xmlns = None}; 101 + attrs = []; 102 + content = Content []; 103 + }; 104 + Transclude {href = URI.of_string_exn "foo-001"; target = Mainmatter}; 105 + Contextual_number (URI.of_string_exn "chapter-3"); 106 + KaTeX (Inline, Content [Text "a = b"]); 107 + Link 108 + { 109 + href = 110 + URI.of_string_exn 111 + "https://git.sr.ht/~jonsterling/ocaml-forester"; 112 + content = Content [Text "Forester"]; 113 + }; 114 + Artefact {hash = ""; content = Content [Text "res"]; sources = []}; 115 + ]) 101 116 content 102 117 103 118 let () = 104 119 let open Alcotest in 105 - run "DSL" ["works", [test_case "" `Quick test]] 120 + run "DSL" [("works", [test_case "" `Quick test])]
+29 -26
lib/frontend/test/Test_config.ml
··· 12 12 let test_parsing () = 13 13 Alcotest.(check config) 14 14 "is the same" 15 - Config.{ 16 - trees = ["trees"]; 17 - assets = []; 18 - url = URI.of_string_exn "https://www.forester-notes.org/"; 19 - home = URI.of_string_exn "https://www.forester-notes.org/index/"; 20 - foreign = [{path = "foreign/forest.json"; route_locally = true; include_in_manifest = true}]; 21 - } 15 + Config. 16 + { 17 + trees = ["trees"]; 18 + assets = []; 19 + url = URI.of_string_exn "https://www.forester-notes.org/"; 20 + home = URI.of_string_exn "https://www.forester-notes.org/index/"; 21 + foreign = 22 + [ 23 + { 24 + path = "foreign/forest.json"; 25 + route_locally = true; 26 + include_in_manifest = true; 27 + }; 28 + ]; 29 + } 22 30 begin 23 31 Forester_core.Reporter.easy_run @@ fun () -> 24 32 Config_parser.parse_forest_config_string ··· 34 42 let test_missing_fields () = 35 43 Alcotest.(check config) 36 44 "is the same" 37 - Config.{ 38 - trees = ["trees"]; 39 - assets = []; 40 - foreign = []; 41 - url = URI.of_string_exn "/"; 42 - home = URI.of_string_exn "/index/"; 43 - } 44 - ( 45 - Forester_core.Reporter.easy_run @@ fun () -> 45 + Config. 46 + { 47 + trees = ["trees"]; 48 + assets = []; 49 + foreign = []; 50 + url = URI.of_string_exn "/"; 51 + home = URI.of_string_exn "/index/"; 52 + } 53 + ( Forester_core.Reporter.easy_run @@ fun () -> 46 54 Config_parser.parse_forest_config_string 47 55 {| 48 56 [forest] ··· 55 63 let open Alcotest in 56 64 Logs.set_level (Some Debug); 57 65 Logs.set_reporter (Logs.format_reporter ()); 58 - run 59 - "Config parsing" 66 + run "Config parsing" 60 67 [ 61 - "example config works", 62 - [ 63 - test_case "it parses correctly" `Quick test_parsing; 64 - ]; 65 - "can parse config with missing fields", 66 - [ 67 - test_case "" `Quick test_missing_fields; 68 - ]; 68 + ( "example config works", 69 + [test_case "it parses correctly" `Quick test_parsing] ); 70 + ( "can parse config with missing fields", 71 + [test_case "" `Quick test_missing_fields] ); 69 72 ]
+31 -53
lib/frontend/test/Test_transclusion.ml
··· 22 22 module Transclusions = struct 23 23 (* It would be cool to use quickcheck here, but no good way to test the result*) 24 24 open T 25 - let full_default = { 26 - href; 27 - target = Full default_section_flags 28 - } 29 25 30 - let metadata_shown = {default_section_flags with 31 - metadata_shown = 32 - Some true 33 - } 26 + let full_default = {href; target = Full default_section_flags} 27 + let metadata_shown = {default_section_flags with metadata_shown = Some true} 34 28 end 35 29 36 30 let () = ··· 39 33 let@ () = Reporter.easy_run in 40 34 let uri = URI_scheme.named_uri ~base:config.url "transcludee" in 41 35 let index = URI.Tbl.create 10 in 42 - URI.Tbl.add index uri @@ 43 - Tree.Resource 44 - { 45 - resource = 46 - T.Article 47 - { 48 - frontmatter = 49 - T.default_frontmatter 50 - ~uri: (URI.of_string_exn "forest://test/transcludee") 51 - ~title: (T.Content [Text "I am being transcluded"]) 52 - (); 53 - mainmatter = Content [Text "Hello"]; 54 - backmatter = Content [] 55 - }; 56 - expanded = None; 57 - route_locally = true; 58 - include_in_manifest = true; 59 - }; 60 - let forest = {(State.make ~env ~config ~dev: false ()) with index} in 61 - let print_transclusion : T.transclusion -> unit = fun t -> 36 + URI.Tbl.add index uri 37 + @@ Tree.Resource 38 + { 39 + resource = 40 + T.Article 41 + { 42 + frontmatter = 43 + T.default_frontmatter 44 + ~uri:(URI.of_string_exn "forest://test/transcludee") 45 + ~title:(T.Content [Text "I am being transcluded"]) (); 46 + mainmatter = Content [Text "Hello"]; 47 + backmatter = Content []; 48 + }; 49 + expanded = None; 50 + route_locally = true; 51 + include_in_manifest = true; 52 + }; 53 + let forest = {(State.make ~env ~config ~dev:false ()) with index} in 54 + let print_transclusion : T.transclusion -> unit = 55 + fun t -> 62 56 let content = Option.get @@ State.get_content_of_transclusion t forest in 63 - Format.printf 64 - "%a" 57 + Format.printf "%a" 65 58 (Legacy_xml_client.pp_xml ~forest ?stylesheet:None) 66 - ( 67 - T.{ 68 - frontmatter = default_frontmatter ~uri: href (); 59 + T. 60 + { 61 + frontmatter = default_frontmatter ~uri:href (); 69 62 mainmatter = content; 70 - backmatter = Content [] 63 + backmatter = Content []; 71 64 } 72 - ) 73 65 in 74 - let test_full_default () = 75 - print_transclusion 76 - Transclusions.full_default 77 - in 66 + let test_full_default () = print_transclusion Transclusions.full_default in 78 67 let test_title_default () = 79 68 print_transclusion 80 - { 81 - href = uri; 82 - target = Title {empty_when_untitled = false} 83 - } 69 + {href = uri; target = Title {empty_when_untitled = false}} 84 70 in 85 71 let test_full_metadata () = 86 - print_transclusion 87 - { 88 - href = uri; 89 - target = Full Transclusions.metadata_shown 90 - } 72 + print_transclusion {href = uri; target = Full Transclusions.metadata_shown} 91 73 in 92 74 List.iter 93 75 (fun f -> f ()) 94 - [ 95 - test_full_default; 96 - test_title_default; 97 - test_full_metadata 98 - ] 76 + [test_full_default; test_title_default; test_full_metadata]
+16 -20
lib/human_datetime/Conversion.ml
··· 9 9 type ptime_time_state = { 10 10 mutable hour: int; 11 11 mutable minute: int; 12 - mutable second: int 12 + mutable second: int; 13 13 } 14 14 15 15 type ptime_date_state = { 16 16 mutable year: int; 17 17 mutable month: int; 18 - mutable day: int 18 + mutable day: int; 19 19 } 20 20 21 21 let ptime_time_state_to_seconds state = 22 - state.second + 60 * (state.minute + 60 * state.hour) 22 + state.second + (60 * (state.minute + (60 * state.hour))) 23 23 24 24 type ptime_date_time_state = { 25 25 date: ptime_date_state; 26 26 time: ptime_time_state; 27 - mutable tz_offset_s: int 27 + mutable tz_offset_s: int; 28 28 } 29 29 30 30 let init_ptime_time_state () = {hour = 0; minute = 0; second = 0} 31 - 32 31 let init_ptime_date_state () = {year = 0; month = 1; day = 1} 33 32 34 - let init_ptime_date_time_state () = { 35 - date = init_ptime_date_state (); 36 - time = init_ptime_time_state (); 37 - tz_offset_s = 0 38 - } 33 + let init_ptime_date_time_state () = 34 + { 35 + date = init_ptime_date_state (); 36 + time = init_ptime_time_state (); 37 + tz_offset_s = 0; 38 + } 39 39 40 40 let to_ptime datetime = 41 41 let go_void (x : void) = match x with _ -> . in 42 - let go_second state (Second s) = 43 - state.second <- s 44 - in 42 + let go_second state (Second s) = state.second <- s in 45 43 let go_minute state rest (Minute (m, rest_opt)) = 46 44 state.minute <- m; 47 45 Option.iter rest rest_opt ··· 56 54 let time_state = init_ptime_time_state () in 57 55 go_hour time_state (go_minute time_state go_void) time; 58 56 let offset = ptime_time_state_to_seconds time_state in 59 - let sign = 60 - match pm with 61 - | Plus -> 1 62 - | Minus -> -1 63 - in 57 + let sign = match pm with Plus -> 1 | Minus -> -1 in 64 58 state.tz_offset_s <- sign * offset 65 59 in 66 60 let go_time_with_offset state ((time, offset) : time_with_offset) = ··· 81 75 in 82 76 let state = init_ptime_date_time_state () in 83 77 go_year state datetime; 84 - let date = state.date.year, state.date.month, state.date.day in 85 - let time = ((state.time.hour, state.time.minute, state.time.second), state.tz_offset_s) in 78 + let date = (state.date.year, state.date.month, state.date.day) in 79 + let time = 80 + ((state.time.hour, state.time.minute, state.time.second), state.tz_offset_s) 81 + in 86 82 Ptime.of_date_time (date, time)
+3 -7
lib/human_datetime/Human_datetime.ml
··· 10 10 type t = datetime 11 11 12 12 let year = function Year (y, _) -> y 13 - 14 - let month = function 15 - | Year (_, Some (Month (m, _))) -> Some m 16 - | _ -> None 13 + let month = function Year (_, Some (Month (m, _))) -> Some m | _ -> None 17 14 18 15 let day = function 19 16 | Year (_, Some (Month (_, Some (Day (d, _))))) -> Some d ··· 27 24 let pp = pp_datetime 28 25 29 26 let compare dt0 dt1 = 30 - match to_ptime dt0, to_ptime dt1 with 27 + match (to_ptime dt0, to_ptime dt1) with 31 28 | Some x0, Some x1 -> Ptime.compare x0 x1 32 29 | None, None -> 0 33 30 | None, Some _ -> -1 ··· 36 33 let parse lexbuf = 37 34 match Grammar.datetime Lexer.token lexbuf with 38 35 | datetime -> Some datetime 39 - | exception Grammar.Error -> 40 - None 36 + | exception Grammar.Error -> None 41 37 42 38 let parse_string str = 43 39 let lexbuf = Lexing.from_string str in
+1 -5
lib/human_datetime/Human_datetime.mli
··· 5 5 *) 6 6 7 7 type t 8 - val t : t Repr.t 9 8 9 + val t : t Repr.t 10 10 val pp : Format.formatter -> t -> unit 11 11 val pp_rfc_3399 : Format.formatter -> t -> unit 12 - 13 12 val compare : t -> t -> int 14 - 15 13 val parse_string : string -> t option 16 14 val parse_string_exn : string -> t 17 - 18 15 val year : t -> int 19 16 val month : t -> int option 20 17 val day : t -> int option 21 - 22 18 val now : unit -> t 23 19 val drop_time : t -> t
+18 -27
lib/human_datetime/Types.ml
··· 5 5 *) 6 6 7 7 type void = | 8 - 9 8 type second = Second of int 10 9 type 'a minute = Minute of int * 'a option 11 10 type 'a hour = Hour of int * 'a option 12 - 13 11 type pm = Plus | Minus 14 12 type offset = Z | Offset of pm * void minute hour 15 - 16 13 type time_with_offset = second minute hour * offset 17 - 18 14 type day = Day of int * time_with_offset option 19 15 type month = Month of int * day option 20 16 type year = Year of int * month option 21 - 22 17 type datetime = year 23 18 24 - let pp_void _fmt (x : void) = 25 - match x with 26 - | _ -> . 27 - 28 - let pp_second fmt (Second s) = 29 - Format.fprintf fmt "%02d" s 19 + let pp_void _fmt (x : void) = match x with _ -> . 20 + let pp_second fmt (Second s) = Format.fprintf fmt "%02d" s 30 21 31 22 let pp_minute pp_rest fmt (Minute (m, rest_opt)) = 32 23 Format.fprintf fmt "%02d" m; 33 24 match rest_opt with 34 25 | None -> () 35 - | Some rest -> 36 - Format.fprintf fmt ":%a" pp_rest rest 26 + | Some rest -> Format.fprintf fmt ":%a" pp_rest rest 37 27 38 28 let pp_hour pp_rest fmt (Hour (h, rest_opt)) = 39 29 Format.fprintf fmt "%02d" h; 40 30 match rest_opt with 41 31 | None -> () 42 - | Some rest -> 43 - Format.fprintf fmt ":%a" pp_rest rest 32 + | Some rest -> Format.fprintf fmt ":%a" pp_rest rest 44 33 45 34 let pp_pm fmt = function 46 35 | Plus -> Format.fprintf fmt "+" ··· 67 56 Format.fprintf fmt "%02d" m; 68 57 match day_opt with 69 58 | None -> () 70 - | Some day -> 71 - Format.fprintf fmt "-%a" pp_day day 59 + | Some day -> Format.fprintf fmt "-%a" pp_day day 72 60 73 61 let pp_year fmt (Year (y, month_opt)) = 74 62 Format.fprintf fmt "%04d" y; 75 63 match month_opt with 76 64 | None -> () 77 - | Some month -> 78 - Format.fprintf fmt "-%a" pp_month month 65 + | Some month -> Format.fprintf fmt "-%a" pp_month month 79 66 80 67 let pp_datetime = pp_year 81 - 82 68 let zero_second = Second 0 83 69 let zero_minute = Minute (0, Some zero_second) 84 70 let zero_hms = Hour (0, Some zero_minute) 85 71 let zero_time_with_offset = (zero_hms, Z) 86 72 let zero_day = Day (1, Some zero_time_with_offset) 87 - 88 73 let zero_month = Month (1, Some zero_day) 89 74 90 75 let expand_minute (Minute (m, sec_opt)) = 91 - Minute (m, Option.some @@ Option.fold ~none: zero_second ~some: Fun.id sec_opt) 76 + Minute (m, Option.some @@ Option.fold ~none:zero_second ~some:Fun.id sec_opt) 92 77 93 78 let expand_hour (Hour (h, min_opt)) = 94 - Hour (h, Option.some @@ Option.fold ~none: zero_minute ~some: expand_minute min_opt) 79 + Hour 80 + (h, Option.some @@ Option.fold ~none:zero_minute ~some:expand_minute min_opt) 95 81 96 - let expand_time_with_offset (hms, offset) = expand_hour hms, offset 82 + let expand_time_with_offset (hms, offset) = (expand_hour hms, offset) 97 83 98 84 let expand_day (Day (d, time_with_offset_opt)) = 99 - Day (d, Option.some @@ Option.fold ~none: zero_time_with_offset ~some: expand_time_with_offset time_with_offset_opt) 85 + Day 86 + ( d, 87 + Option.some 88 + @@ Option.fold ~none:zero_time_with_offset ~some:expand_time_with_offset 89 + time_with_offset_opt ) 100 90 101 91 let expand_month (Month (m, day_opt)) = 102 - Month (m, Option.some @@ Option.fold ~none: zero_day ~some: expand_day day_opt) 92 + Month (m, Option.some @@ Option.fold ~none:zero_day ~some:expand_day day_opt) 103 93 104 94 let expand_year (Year (y, month_opt)) = 105 - Year (y, Option.some @@ Option.fold ~none: zero_month ~some: expand_month month_opt) 95 + Year 96 + (y, Option.some @@ Option.fold ~none:zero_month ~some:expand_month month_opt) 106 97 107 98 (* TODO *) 108 99 let pp_rfc_3399 fmt dt = pp_datetime fmt @@ expand_year dt
+129 -151
lib/language_server/Analysis.ml
··· 10 10 open Forester_core 11 11 12 12 module Item = struct 13 - type t = 14 - | Path of Trie.path 15 - | Addr of string 13 + type t = Path of Trie.path | Addr of string 14 + 16 15 let addr str = Addr str 17 16 let path p = Path p 18 17 end ··· 21 20 module R = Resolver 22 21 module Sc = R.Scope 23 22 module L = Lsp.Types 24 - module S = Algaeff.Sequencer.Make(struct 23 + 24 + module S = Algaeff.Sequencer.Make (struct 25 25 type t = Item.t Range.located 26 26 end) 27 27 end 28 28 29 - let flatten (tree : Code.t) : Code.t = 30 - List.concat_map Code.children tree 31 - 32 - let paths_in_bindings = 33 - List.map (fun (_, x) -> [x]) 29 + let flatten (tree : Code.t) : Code.t = List.concat_map Code.children tree 30 + let paths_in_bindings = List.map (fun (_, x) -> [x]) 34 31 35 32 (* This function should not descend into the nodes!*) 36 33 let paths : Code.node Range.located -> _ = function 37 - | {value; loc;} -> 34 + | {value; loc} -> ( 38 35 match value with 39 36 | Ident path 40 - | Open (path) 37 + | Open path 41 38 | Put (path, _) 42 39 | Default (path, _) 43 40 | Get path 44 41 | Alloc path 45 42 | Namespace (path, _) -> 46 43 Some ([path], loc) 47 - | Def (path, bindings, _) 48 - | Let (path, bindings, _) -> 44 + | Def (path, bindings, _) | Let (path, bindings, _) -> 49 45 Some (path :: paths_in_bindings bindings, loc) 50 - | Patch {self; _} 51 - | Object {self; _;} -> 52 - Option.map (fun x -> [[x]], loc) self 46 + | Patch {self; _} | Object {self; _} -> 47 + Option.map (fun x -> ([[x]], loc)) self 53 48 | Fun (bindings, _) -> Some (paths_in_bindings bindings, loc) 54 - | Subtree _ 55 - | Group _ 56 - | Scope _ 57 - | Math _ 58 - | Dx_sequent _ 59 - | Dx_const_uri _ 60 - | Dx_const_content _ 61 - | Dx_query _ 62 - | Dx_prop _ 63 - | Text _ 64 - | Verbatim _ 65 - | Hash_ident _ 66 - | Xml_ident _ 67 - | Call _ 68 - | Import _ 69 - | Decl_xmlns _ 70 - | Dx_var _ 71 - | Comment _ 72 - | Error _ -> 73 - None 49 + | Subtree _ | Group _ | Scope _ | Math _ | Dx_sequent _ | Dx_const_uri _ 50 + | Dx_const_content _ | Dx_query _ | Dx_prop _ | Text _ | Verbatim _ 51 + | Hash_ident _ | Xml_ident _ | Call _ | Import _ | Decl_xmlns _ | Dx_var _ 52 + | Comment _ | Error _ -> 53 + None) 74 54 75 55 let extract_addr (node : Code.node Range.located) = 76 56 match node.value with ··· 78 58 | Group (Parens, [{value = Text addr; _}]) 79 59 | Text addr (* SEEEMS DODGY!! *) 80 60 | Import (_, addr) -> 81 - Some (Range.{value = addr; loc = node.loc}) 61 + Some Range.{value = addr; loc = node.loc} 82 62 | Subtree (addr, _) -> 83 63 Option.map (fun s -> Range.{value = s; loc = node.loc}) addr 84 64 | _ -> None ··· 86 66 let rec analyse (node : Code.node Range.located) = 87 67 begin 88 68 let@ {value; loc} = Option.iter @~ extract_addr node in 89 - S.yield ({value = Item.addr value; loc}); 69 + S.yield {value = Item.addr value; loc} 90 70 end; 91 71 begin 92 72 let@ paths, loc = Option.iter @~ paths node in 93 73 let@ path = List.iter @~ paths in 94 - S.yield ({value = Item.path path; loc}); 74 + S.yield {value = Item.path path; loc} 95 75 end; 96 76 let children = Code.children node in 97 77 List.iter analyse children ··· 100 80 let@ () = S.run in 101 81 List.iter analyse nodes 102 82 103 - let contains = fun 104 - ~(position : Lsp.Types.Position.t) 105 - (loc : Range.t option) 106 - -> 107 - let L.Position.{line = cursor_line; character = cursor_character} = position in 83 + let contains = 84 + fun ~(position : Lsp.Types.Position.t) (loc : Range.t option) -> 85 + let L.Position.{line = cursor_line; character = cursor_character} = 86 + position 87 + in 108 88 match loc with 109 - | Some loc -> 110 - begin 111 - match Range.view loc with 112 - | `Range (start, end_) -> 113 - let start_pos = Lsp_shims.Loc.lsp_pos_of_pos start in 114 - let end_pos = Lsp_shims.Loc.lsp_pos_of_pos end_ in 115 - let at_or_after_start = 116 - cursor_line < end_pos.line 117 - || (cursor_line = start_pos.line && start_pos.character <= cursor_character) 118 - in 119 - let before_or_at_end = 120 - end_pos.line > cursor_line 121 - || (cursor_line = end_pos.line && cursor_character <= end_pos.character) 122 - in 123 - at_or_after_start && before_or_at_end 124 - | _ -> false 125 - end 89 + | Some loc -> begin 90 + match Range.view loc with 91 + | `Range (start, end_) -> 92 + let start_pos = Lsp_shims.Loc.lsp_pos_of_pos start in 93 + let end_pos = Lsp_shims.Loc.lsp_pos_of_pos end_ in 94 + let at_or_after_start = 95 + cursor_line < end_pos.line 96 + || cursor_line = start_pos.line 97 + && start_pos.character <= cursor_character 98 + in 99 + let before_or_at_end = 100 + end_pos.line > cursor_line 101 + || (cursor_line = end_pos.line && cursor_character <= end_pos.character) 102 + in 103 + at_or_after_start && before_or_at_end 104 + | _ -> false 105 + end 126 106 | None -> false 127 107 128 - let rec node_at 129 - : type a. position: L.Position.t -> children: (a Range.located -> a Range.located list) -> a Range.located list -> a Range.located option 130 - = fun ~position ~children code -> 108 + let rec node_at : type a. 109 + position:L.Position.t -> 110 + children:(a Range.located -> a Range.located list) -> 111 + a Range.located list -> 112 + a Range.located option = 113 + fun ~position ~children code -> 131 114 match List.find_opt (fun Range.{loc; _} -> contains ~position loc) code with 132 115 | None -> None 133 - | Some n -> 116 + | Some n -> ( 134 117 match (node_at ~position ~children) (children n) with 135 118 | Some inner -> Some inner 136 - | None -> Some n 119 + | None -> Some n) 137 120 138 121 let get_enclosing_code_group ~position tree = 139 122 let rec go ~position nodes = 140 - match List.find_opt (fun Range.{loc; _} -> contains ~position loc) nodes with 123 + match 124 + List.find_opt (fun Range.{loc; _} -> contains ~position loc) nodes 125 + with 141 126 | None -> None 142 - | Some n -> 127 + | Some n -> ( 143 128 match n.value with 144 - | (Code.Group (delim, t)) -> 145 - begin 146 - match go ~position t with 147 - | None -> Some Asai.Range.{value = (delim, t); loc = n.loc} 148 - | Some t -> Some t 149 - end 150 - | _ -> 151 - (go ~position) (Code.children n) 129 + | Code.Group (delim, t) -> begin 130 + match go ~position t with 131 + | None -> Some Asai.Range.{value = (delim, t); loc = n.loc} 132 + | Some t -> Some t 133 + end 134 + | _ -> (go ~position) (Code.children n)) 152 135 in 153 136 match Tree.to_code tree with 154 137 | None -> None 155 - | Some code -> 156 - go ~position code.nodes 138 + | Some code -> go ~position code.nodes 157 139 158 140 let get_enclosing_syn_group ~position tree = 159 141 let rec go ~position nodes = 160 - match List.find_opt (fun Range.{loc; _} -> contains ~position loc) nodes with 142 + match 143 + List.find_opt (fun Range.{loc; _} -> contains ~position loc) nodes 144 + with 161 145 | None -> None 162 - | Some n -> 146 + | Some n -> ( 163 147 match n.value with 164 - | (Syn.Group (delim, children)) -> 165 - begin 166 - match go ~position children with 167 - | None -> Some Asai.Range.{value = (delim, children); loc = n.loc} 168 - | Some t -> Some t 169 - end 170 - | _ -> 171 - go ~position (Syn.children n) 148 + | Syn.Group (delim, children) -> begin 149 + match go ~position children with 150 + | None -> Some Asai.Range.{value = (delim, children); loc = n.loc} 151 + | Some t -> Some t 152 + end 153 + | _ -> go ~position (Syn.children n)) 172 154 in 173 155 match Tree.to_syn tree with 174 156 | None -> None 175 - | Some syn -> 176 - go ~position syn.nodes 157 + | Some syn -> go ~position syn.nodes 177 158 178 - let enclosing_group_start 179 - ~position 180 - ~(enclosing_group : position: L.Position.t -> Tree.t -> (delim * 'a) Range.located option) 181 - (tree : Tree.t) 182 - = 159 + let enclosing_group_start ~position 160 + ~(enclosing_group : 161 + position:L.Position.t -> Tree.t -> (delim * 'a) Range.located option) 162 + (tree : Tree.t) = 183 163 match enclosing_group ~position tree with 184 164 | None -> Some position 185 165 | Some {loc; value = _} -> 186 166 let start = 187 167 Option.map (function 188 168 | `Range (start, _) -> start 189 - | `End_of_file pos -> pos 190 - ) @@ 191 - Option.map Range.view loc 169 + | `End_of_file pos -> pos) 170 + @@ Option.map Range.view loc 192 171 in 193 - Option.map 194 - (Lsp_shims.Loc.lsp_pos_of_pos) 195 - start 172 + Option.map Lsp_shims.Loc.lsp_pos_of_pos start 196 173 197 174 let find_with_prev ~position = 198 175 let rec go prev = function 199 176 | [] -> None 200 - | x :: xs -> if contains ~position Asai.Range.(x.loc) then Some (prev, x) else go (Some x) xs 177 + | x :: xs -> 178 + if contains ~position Asai.Range.(x.loc) then Some (prev, x) 179 + else go (Some x) xs 201 180 in 202 181 go None 203 182 204 183 module Context = struct 205 184 (* Kind of like a zipper where you can only go backwards? *) 206 - type 'a t = 207 - | Prev of 'a * 'a 208 - | Parent of 'a 209 - | Top of 'a 185 + type 'a t = Prev of 'a * 'a | Parent of 'a | Top of 'a 210 186 end 211 187 212 - let parent_or_prev_at 213 - : type a. position: L.Position.t -> 214 - children: (a Range.located -> a Range.located list) -> 215 - a Range.located list -> 216 - a Range.located Context.t option 217 - = fun ~position ~children code -> 188 + let parent_or_prev_at : type a. 189 + position:L.Position.t -> 190 + children:(a Range.located -> a Range.located list) -> 191 + a Range.located list -> 192 + a Range.located Context.t option = 193 + fun ~position ~children code -> 218 194 let go ~position ~children nodes = 219 195 match find_with_prev ~position nodes with 220 196 | None -> None 221 - | Some (None, node) -> 222 - begin 223 - match (node_at ~position ~children) (children node) with 224 - | Some inner -> 225 - (* go ~position ~children (children inner) *) 226 - Some (Context.Top inner) 227 - | None -> Some (Top node) 228 - end 229 - | Some (Some prev, node) -> 197 + | Some (None, node) -> begin 198 + match (node_at ~position ~children) (children node) with 199 + | Some inner -> 200 + (* go ~position ~children (children inner) *) 201 + Some (Context.Top inner) 202 + | None -> Some (Top node) 203 + end 204 + | Some (Some prev, node) -> ( 230 205 match (node_at ~position ~children) (children node) with 231 206 | None -> Some (Prev (prev, node)) 232 - | Some inner -> 233 - Some (Top inner) 207 + | Some inner -> Some (Top inner)) 234 208 in 235 209 go ~position ~children code 236 210 237 - let parent_or_prev_at_code ~position = parent_or_prev_at ~position ~children: Code.children 238 - let parent_or_prev_at_syn ~position = parent_or_prev_at ~position ~children: Syn.children 211 + let parent_or_prev_at_code ~position = 212 + parent_or_prev_at ~position ~children:Code.children 213 + 214 + let parent_or_prev_at_syn ~position = 215 + parent_or_prev_at ~position ~children:Syn.children 239 216 240 - let node_at_code ~position = node_at ~position ~children: Code.children 241 - let node_at_syn ~position = node_at ~position ~children: Syn.children 217 + let node_at_code ~position = node_at ~position ~children:Code.children 218 + let node_at_syn ~position = node_at ~position ~children:Syn.children 242 219 243 220 let get_visible ~forest ~position code = 244 - Sc.run ~init_visible: Expand.initial_visible_trie @@ fun () -> 221 + Sc.run ~init_visible:Expand.initial_visible_trie @@ fun () -> 245 222 let open Effect.Deep in 246 223 match_with 247 224 (Expand.expand_eff ~forest) ··· 249 226 { 250 227 retc = (fun _ -> Sc.get_visible ()); 251 228 exnc = raise; 252 - effc = fun (type a) (eff : a Effect.t) -> 253 - match eff with 254 - | Expand.Entered_range range -> 255 - Option.some @@ fun (k : (a, _) continuation) -> 256 - if contains ~position range then 257 - Sc.get_visible () 258 - else 259 - continue k () 260 - | _ -> None 229 + effc = 230 + (fun (type a) (eff : a Effect.t) -> 231 + match eff with 232 + | Expand.Entered_range range -> 233 + Option.some @@ fun (k : (a, _) continuation) -> 234 + if contains ~position range then Sc.get_visible () 235 + else continue k () 236 + | _ -> None); 261 237 } 262 238 263 - let addr_at ~(position : Lsp.Types.Position.t) (code : _ list) : _ Range.located option = 264 - Option.bind (node_at ~position ~children: Code.children code) extract_addr 239 + let addr_at ~(position : Lsp.Types.Position.t) (code : _ list) : 240 + _ Range.located option = 241 + Option.bind (node_at ~position ~children:Code.children code) extract_addr 265 242 266 243 exception Found of string 267 244 268 245 let word_at ~position (doc : Lsp.Text_document.t) = 269 - let L.Position.{line; character;} = position in 270 - let line = List.nth_opt (String.split_on_char '\n' (Lsp.Text_document.text doc)) line in 246 + let L.Position.{line; character} = position in 247 + let line = 248 + List.nth_opt (String.split_on_char '\n' (Lsp.Text_document.text doc)) line 249 + in 271 250 match line with 272 251 | None -> None 273 - | Some line -> 252 + | Some line -> ( 274 253 let words = String.split_on_char ' ' line in 275 254 try 276 255 let acc = ref 0 in ··· 278 257 (fun word -> 279 258 let length = String.length word in 280 259 if !acc + length + 1 > character then raise (Found word) 281 - else acc := !acc + length + 1 282 - ) 260 + else acc := !acc + length + 1) 283 261 words; 284 262 None 285 - with 286 - | Found str -> Some str 263 + with Found str -> Some str) 287 264 288 265 let word_before ~position (doc : Lsp.Text_document.t) = 289 - let L.Position.{line; character;} = position in 290 - let line = List.nth_opt (String.split_on_char '\n' (Lsp.Text_document.text doc)) line in 266 + let L.Position.{line; character} = position in 267 + let line = 268 + List.nth_opt (String.split_on_char '\n' (Lsp.Text_document.text doc)) line 269 + in 291 270 match line with 292 271 | None -> None 293 - | Some line -> 272 + | Some line -> ( 294 273 try 295 274 let until_cursor = String.sub line 0 character in 296 275 let words = List.rev @@ String.split_on_char ' ' until_cursor in 297 276 Some (List.hd words) 298 - with 299 - | _ -> None 277 + with _ -> None)
+32 -32
lib/language_server/Call_hierarchy.ml
··· 20 20 let config = forest.config in 21 21 let module G = (val forest.graphs) in 22 22 match params with 23 - | {item; _} -> 23 + | {item; _} -> ( 24 24 let vertex_to_item (v : _ T.vertex) = 25 25 let from = item in 26 26 let fromRanges = [] in 27 27 match v with 28 28 | T.Uri_vertex _ -> L.CallHierarchyIncomingCall.create ~from ~fromRanges 29 - | T.Content_vertex _ -> L.CallHierarchyIncomingCall.create ~from ~fromRanges 29 + | T.Content_vertex _ -> 30 + L.CallHierarchyIncomingCall.create ~from ~fromRanges 30 31 in 31 32 match item with 32 33 | {uri; _} -> 33 - let uri = URI_scheme.path_to_uri ~base: config.url (Lsp.Uri.to_path uri) in 34 + let uri = URI_scheme.path_to_uri ~base:config.url (Lsp.Uri.to_path uri) in 34 35 let vertex = T.Uri_vertex uri in 35 36 let run_query = Forest.run_datalog_query forest.graphs in 36 37 let fwdlinks = run_query @@ Builtin_queries.fwdlinks_datalog vertex in 37 38 Eio.traceln "got %i link items" (Vertex_set.cardinal fwdlinks); 38 39 let children = run_query @@ Builtin_queries.children_datalog vertex in 39 40 Eio.traceln "got %i transclusion items" (Vertex_set.cardinal children); 40 - let items = Vertex_set.union fwdlinks children |> Vertex_set.to_list |> List.map vertex_to_item in 41 - Some items 41 + let items = 42 + Vertex_set.union fwdlinks children 43 + |> Vertex_set.to_list |> List.map vertex_to_item 44 + in 45 + Some items) 42 46 43 47 let outgoing (params : L.CallHierarchyOutgoingCallsParams.t) = 44 48 let Lsp_state.{forest; _} = Lsp_state.get () in ··· 46 50 let module G = (val forest.graphs) in 47 51 Eio.traceln "computing outgoing calls"; 48 52 match params with 49 - | {item; _} -> 53 + | {item; _} -> ( 50 54 let vertex_to_item (v : _ T.vertex) = 51 55 let to_ = item in 52 56 let fromRanges = [] in 53 57 match v with 54 58 | T.Uri_vertex _ -> L.CallHierarchyOutgoingCall.create ~to_ ~fromRanges 55 - | T.Content_vertex _ -> L.CallHierarchyOutgoingCall.create ~to_ ~fromRanges 59 + | T.Content_vertex _ -> 60 + L.CallHierarchyOutgoingCall.create ~to_ ~fromRanges 56 61 in 57 62 match item with 58 63 | {uri; _} -> 59 - let uri = URI_scheme.path_to_uri ~base: config.url (Lsp.Uri.to_path uri) in 64 + let uri = URI_scheme.path_to_uri ~base:config.url (Lsp.Uri.to_path uri) in 60 65 let vertex = T.Uri_vertex uri in 61 66 let run_query = Forest.run_datalog_query forest.graphs in 62 67 let backlinks = run_query @@ Builtin_queries.backlinks_datalog vertex in 63 68 Eio.traceln "got %i link items" (Vertex_set.cardinal backlinks); 64 69 let parents = run_query @@ Builtin_queries.context_datalog vertex in 65 70 Eio.traceln "got %i transclusion items" (Vertex_set.cardinal parents); 66 - let items = Vertex_set.union backlinks parents |> Vertex_set.to_list |> List.map vertex_to_item in 67 - Some items 71 + let items = 72 + Vertex_set.union backlinks parents 73 + |> Vertex_set.to_list |> List.map vertex_to_item 74 + in 75 + Some items) 68 76 69 77 let compute (params : L.CallHierarchyPrepareParams.t) = 70 78 let Lsp_state.{forest; _} = Lsp_state.get () in 71 79 match params with 72 - | {position; textDocument; _} -> 73 - let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url textDocument.uri in 80 + | {position; textDocument; _} -> ( 81 + let uri = 82 + URI_scheme.lsp_uri_to_uri ~base:forest.config.url textDocument.uri 83 + in 74 84 match Imports.resolve_uri_to_code forest uri with 75 85 | None -> None 76 86 | Some tree -> 77 87 let item = 78 88 match Analysis.node_at_code ~position tree.nodes with 79 89 | None -> None 80 - | Some {loc = _; value} -> 90 + | Some {loc = _; value} -> ( 81 91 match value with 82 - | Def (_, _, _) 83 - | Fun (_, _) -> 84 - None 85 - | Text _ 86 - | Verbatim _ 92 + | Def (_, _, _) | Fun (_, _) -> None 93 + | Text _ | Verbatim _ 87 94 | Group (_, _) 88 95 | Math (_, _) 89 - | Ident _ 90 - | Hash_ident _ 96 + | Ident _ | Hash_ident _ 91 97 | Xml_ident (_, _) 92 98 | Subtree (_, _) 93 99 | Let (_, _, _) 94 - | Open _ 95 - | Scope _ 100 + | Open _ | Scope _ 96 101 | Put (_, _) 97 102 | Default (_, _) 98 - | Get _ 99 - | Object _ 100 - | Patch _ 103 + | Get _ | Object _ | Patch _ 101 104 | Call (_, _) 102 105 | Import (_, _) 103 106 | Decl_xmlns (_, _) ··· 106 109 | Dx_sequent (_, _) 107 110 | Dx_query (_, _, _) 108 111 | Dx_prop (_, _) 109 - | Dx_var _ 110 - | Dx_const_content _ 111 - | Dx_const_uri _ 112 - | Comment _ 113 - | Error _ -> 114 - None 112 + | Dx_var _ | Dx_const_content _ | Dx_const_uri _ | Comment _ | Error _ 113 + -> 114 + None) 115 115 in 116 - Option.map (fun item -> [item]) item 116 + Option.map (fun item -> [item]) item)
+17 -20
lib/language_server/Change_configuration.ml
··· 15 15 (* TODO: set up json conversions for forester config*) 16 16 let compute (params : L.DidChangeConfigurationParams.t) = 17 17 match params.settings with 18 - | `Assoc xs -> 19 - begin 20 - match List.assoc_opt "configuration_file" xs with 21 - | Some (`String f) -> 22 - begin 23 - try 24 - let config = Config_parser.parse_forest_config_file f in 25 - Lsp_state.modify @@ fun state -> 26 - {state with forest = {state.forest with config = config}} 27 - with 28 - | _ -> Eio.traceln "failed to parse configuration file" 29 - end 30 - | _ -> Eio.traceln "invalid value for configuration_file" 31 - (* RPC.Response.Error.raise *) 32 - (* ( *) 33 - (* RPC.Response.Error.make *) 34 - (* ~code: InvalidRequest *) 35 - (* ~message: "invalid value for configuration_file" *) 36 - (* () *) 37 - (* ) *) 18 + | `Assoc xs -> begin 19 + match List.assoc_opt "configuration_file" xs with 20 + | Some (`String f) -> begin 21 + try 22 + let config = Config_parser.parse_forest_config_file f in 23 + Lsp_state.modify @@ fun state -> 24 + {state with forest = {state.forest with config}} 25 + with _ -> Eio.traceln "failed to parse configuration file" 38 26 end 27 + | _ -> Eio.traceln "invalid value for configuration_file" 28 + (* RPC.Response.Error.raise *) 29 + (* ( *) 30 + (* RPC.Response.Error.make *) 31 + (* ~code: InvalidRequest *) 32 + (* ~message: "invalid value for configuration_file" *) 33 + (* () *) 34 + (* ) *) 35 + end 39 36 | json -> Eio.traceln "unknown configuration value %a" Yojson.Safe.pp json
+27 -23
lib/language_server/Code_action.ml
··· 7 7 8 8 open Forester_compiler 9 9 10 - open struct module L = Lsp.Types end 10 + open struct 11 + module L = Lsp.Types 12 + end 11 13 12 14 let resolve (params : L.CodeAction.t) = params 13 15 14 16 let next_addrs ~(forest : State.t) prefix = 15 - URI_util.next_uri ~prefix ~mode: `Sequential ~forest, URI_util.next_uri ~prefix ~mode: `Random ~forest 17 + ( URI_util.next_uri ~prefix ~mode:`Sequential ~forest, 18 + URI_util.next_uri ~prefix ~mode:`Random ~forest ) 16 19 17 20 let create_tree_edit ~range ~uri addr dir = 18 21 L.WorkspaceEdit.create 19 - ~documentChanges: [ 20 - `CreateFile 21 - ( 22 - L.CreateFile.create 23 - ~uri: (Lsp.Uri.of_path (Format.asprintf "%s/%s.tree" dir addr)) 24 - () 25 - ); 26 - `TextDocumentEdit 27 - ( 28 - L.TextDocumentEdit.create 29 - ~textDocument: {uri; version = None} 30 - ~edits: [`TextEdit {newText = Format.asprintf "\\transclude{%s}" addr; range}] 31 - ) 32 - ] 22 + ~documentChanges: 23 + [ 24 + `CreateFile 25 + (L.CreateFile.create 26 + ~uri:(Lsp.Uri.of_path (Format.asprintf "%s/%s.tree" dir addr)) 27 + ()); 28 + `TextDocumentEdit 29 + (L.TextDocumentEdit.create ~textDocument:{uri; version = None} 30 + ~edits: 31 + [ 32 + `TextEdit 33 + {newText = Format.asprintf "\\transclude{%s}" addr; range}; 34 + ]); 35 + ] 33 36 () 34 37 35 - let compute (L.CodeActionParams.{range; textDocument = {uri}; _;}) : L.CodeActionResult.t = 38 + let compute L.CodeActionParams.{range; textDocument = {uri}; _} : 39 + L.CodeActionResult.t = 36 40 let Lsp_state.{forest; _} = Lsp_state.get () in 37 41 let actions = 38 42 let next_sequential, next_random = next_addrs ~forest None in ··· 41 45 | dir :: _ -> 42 46 let sequential = 43 47 L.CodeAction.create 44 - ~title: (Format.asprintf "create new tree (sequential address)") 45 - ~kind: (L.CodeActionKind.Other "new tree") 46 - ~edit: (create_tree_edit ~range ~uri next_sequential dir) 48 + ~title:(Format.asprintf "create new tree (sequential address)") 49 + ~kind:(L.CodeActionKind.Other "new tree") 50 + ~edit:(create_tree_edit ~range ~uri next_sequential dir) 47 51 () 48 52 in 49 53 let random = 50 54 L.CodeAction.create 51 - ~title: (Format.asprintf "create new tree (random address)") 52 - ~kind: (L.CodeActionKind.Other "new tree") 53 - ~edit: (create_tree_edit ~range ~uri next_random dir) 55 + ~title:(Format.asprintf "create new tree (random address)") 56 + ~kind:(L.CodeActionKind.Other "new tree") 57 + ~edit:(create_tree_edit ~range ~uri next_random dir) 54 58 () 55 59 in 56 60 [`CodeAction sequential; `CodeAction random]
+4 -3
lib/language_server/Code_lens.ml
··· 5 5 * 6 6 *) 7 7 8 - open struct module L = Lsp.Types end 8 + open struct 9 + module L = Lsp.Types 10 + end 9 11 10 12 let compute (params : L.CodeLensParams.t) = 11 13 let _server = Lsp_state.get () in 12 - match params with 13 - | _ -> [] 14 + match params with _ -> []
+137 -161
lib/language_server/Completion.ml
··· 16 16 module L = Lsp.Types 17 17 end 18 18 19 - type completion = 20 - | Addrs 21 - | New_addr 22 - | Assets 23 - | Visible 24 - | Date 25 - [@@deriving show] 19 + type completion = Addrs | New_addr | Assets | Visible | Date [@@deriving show] 26 20 27 - module S = Set.Make(struct 21 + module S = Set.Make (struct 28 22 type t = completion 23 + 29 24 let compare = compare 30 25 end) 31 26 ··· 47 42 | Prev (_, Asai.Range.{value = Code.Subtree (_, _); _}) 48 43 | Parent {value = Code.Subtree (_, _); _} -> 49 44 Some New_addr 50 - | Parent _ 51 - | Prev (_, _) 52 - | Top _ -> 53 - None 45 + | Parent _ | Prev (_, _) | Top _ -> None 54 46 in 55 47 let syn (context : Syn.node Range.located Analysis.Context.t) = 56 48 match context with 57 - | (Top {value = Subtree _; _}) -> Some New_addr 58 - | (Prev (_, {value = Subtree _; _;})) -> Some New_addr 49 + | Top {value = Subtree _; _} -> Some New_addr 50 + | Prev (_, {value = Subtree _; _}) -> Some New_addr 59 51 | _ -> None 60 52 in 61 53 {text; code; syn} ··· 76 68 let syn (context : Syn.node Range.located Analysis.Context.t) = 77 69 match context with 78 70 | Top {value = Route_asset; _} -> Some Assets 79 - | Prev (_, {value = Route_asset; _;}) -> Some Assets 71 + | Prev (_, {value = Route_asset; _}) -> Some Assets 80 72 | _ -> None 81 73 in 82 74 {text; code; syn} 83 75 84 76 let date_completion : completion_kind = 85 77 let text word_before = 86 - if Str.(string_match (regexp {|.*date.*|}) word_before 0) then 87 - Some Date 78 + if Str.(string_match (regexp {|.*date.*|}) word_before 0) then Some Date 88 79 else None 89 80 in 90 81 let code (context : _ Analysis.Context.t) = ··· 99 90 100 91 let uri_completion : completion_kind = 101 92 let text word_before = 102 - if Str.(string_match (regexp {|.*]($|}) word_before 0) 93 + if 94 + Str.(string_match (regexp {|.*]($|}) word_before 0) 103 95 || Str.(string_match (regexp {|.*\[\[$|}) word_before 0) 104 - || Str.(string_match (regexp {|.*transclude.*|}) word_before 0) then 105 - Some Addrs 96 + || Str.(string_match (regexp {|.*transclude.*|}) word_before 0) 97 + then Some Addrs 106 98 else None 107 99 in 108 100 let code (_context : _ Analysis.Context.t) = None in ··· 111 103 112 104 let new_uri_completion : completion_kind = 113 105 let text context = 114 - if Str.(string_match (regexp {|.*subtree\[.*|}) context 0) then Some New_addr 106 + if Str.(string_match (regexp {|.*subtree\[.*|}) context 0) then 107 + Some New_addr 115 108 else None 116 109 in 117 - let code context = Option.map (Fun.const New_addr) (uri_completion.code context) in 118 - let syn context = Option.map (Fun.const New_addr) (uri_completion.syn context) in 110 + let code context = 111 + Option.map (Fun.const New_addr) (uri_completion.code context) 112 + in 113 + let syn context = 114 + Option.map (Fun.const New_addr) (uri_completion.syn context) 115 + in 119 116 {text; code; syn} 120 117 121 118 let completion_types (t : Tree.t) ~position = 122 - let completions : completion_kind list = [ 123 - uri_completion; 124 - asset_completion; 125 - subtree_completion; 126 - new_uri_completion; 127 - date_completion; 128 - ] 119 + let completions : completion_kind list = 120 + [ 121 + uri_completion; 122 + asset_completion; 123 + subtree_completion; 124 + new_uri_completion; 125 + date_completion; 126 + ] 129 127 in 130 128 let code_opt = Tree.to_code t in 131 129 let syn_opt = Tree.to_syn t in 132 130 let doc_opt = Tree.to_doc t in 133 131 let text_context = Option.bind doc_opt @@ Analysis.word_before ~position in 134 - Logs.debug (fun m -> m "Text_context: %a" Format.(pp_print_option pp_print_string) text_context); 132 + Logs.debug (fun m -> 133 + m "Text_context: %a" Format.(pp_print_option pp_print_string) text_context); 135 134 let code_context = 136 135 let enclosing_group = Analysis.get_enclosing_code_group in 137 - let@ position = Option.bind @@ Analysis.enclosing_group_start ~enclosing_group ~position t in 136 + let@ position = 137 + Option.bind @@ Analysis.enclosing_group_start ~enclosing_group ~position t 138 + in 138 139 let@ code = Option.bind code_opt in 139 140 Analysis.parent_or_prev_at_code ~position code.nodes 140 141 in 141 142 let syn_context = 142 143 let enclosing_group = Analysis.get_enclosing_syn_group in 143 - let@ position = Option.bind @@ Analysis.enclosing_group_start ~enclosing_group ~position t in 144 + let@ position = 145 + Option.bind @@ Analysis.enclosing_group_start ~enclosing_group ~position t 146 + in 144 147 let@ syn = Option.bind syn_opt in 145 148 Analysis.parent_or_prev_at_syn ~position syn.nodes 146 149 in 147 150 completions 148 151 |> List.fold_left 149 - begin 150 - fun acc completion_kind -> 151 - (* let module Kind = (val completion_kind : CompletionKind) in *) 152 - let compl = 153 - List.fold_left 154 - begin 155 - fun acc a -> 156 - match a with 157 - | None -> acc 158 - | Some compl -> S.add compl acc 159 - end 160 - S.empty 161 - [ 162 - Option.bind text_context completion_kind.text; 163 - Option.bind code_context completion_kind.code; 164 - Option.bind syn_context completion_kind.syn; 165 - ] 166 - in 167 - S.union compl acc 168 - end 169 - S.empty 152 + begin fun acc completion_kind -> 153 + (* let module Kind = (val completion_kind : CompletionKind) in *) 154 + let compl = 155 + List.fold_left 156 + begin fun acc a -> 157 + match a with None -> acc | Some compl -> S.add compl acc 158 + end 159 + S.empty 160 + [ 161 + Option.bind text_context completion_kind.text; 162 + Option.bind code_context completion_kind.code; 163 + Option.bind syn_context completion_kind.syn; 164 + ] 165 + in 166 + S.union compl acc 167 + end 168 + S.empty 170 169 171 - let kind 172 - : Syn.node -> L.CompletionItemKind.t option 173 - = function 170 + let kind : Syn.node -> L.CompletionItemKind.t option = function 174 171 | Fun (_, _) -> Some Function 175 172 | Text _ | Verbatim _ -> Some Text 176 173 | Meta -> Some Field 177 174 | Route_asset -> Some File 178 175 | Var _ -> Some Variable 179 - | Prim _ 180 - | Transclude 181 - | Embed_tex 182 - | Title 183 - | Parent 184 - | Taxon 176 + | Prim _ | Transclude | Embed_tex | Title | Parent | Taxon 185 177 | Attribution (_, _) 186 - | Tag _ 187 - | Date 188 - | Number -> 178 + | Tag _ | Date | Number -> 189 179 Some Keyword 190 180 | Ref -> Some Reference 191 181 | Group (_, _) ··· 197 187 | Default (_, _, _) 198 188 | Get _ 199 189 | Xml_tag (_, _, _) 200 - | TeX_cs _ 201 - | Unresolved_ident _ 202 - | Object _ 203 - | Patch _ 190 + | TeX_cs _ | Unresolved_ident _ | Object _ | Patch _ 204 191 | Call (_, _) 205 192 | Results_of_query 206 193 | Dx_sequent (_, _) ··· 208 195 | Dx_prop (_, _) 209 196 | Dx_var _ 210 197 | Dx_const (_, _) 211 - | Dx_execute 212 - | Syndicate_current_tree_as_atom_feed 213 - | Syndicate_query_as_json_blob 214 - | Current_tree -> 198 + | Dx_execute | Syndicate_current_tree_as_atom_feed 199 + | Syndicate_query_as_json_blob | Current_tree -> 215 200 None 216 201 217 202 let insert_text path = String.concat "/" path ··· 221 206 let paths = List.of_seq @@ Hashtbl.to_seq_keys Asset_router.router in 222 207 let@ asset_path = List.filter_map @~ paths in 223 208 let@ insertText = 224 - Option.map @~ 225 - List.find_map 226 - (fun dir -> 227 - let dir_path = Unix.realpath dir in 228 - if String.starts_with ~prefix: dir_path asset_path then 229 - try 230 - Some 231 - ( 232 - String.sub 233 - asset_path 209 + Option.map 210 + @~ List.find_map 211 + (fun dir -> 212 + let dir_path = Unix.realpath dir in 213 + if String.starts_with ~prefix:dir_path asset_path then 214 + try 215 + Some 216 + (String.sub asset_path 234 217 (String.length dir_path - String.length dir) 235 - (String.length asset_path - String.length dir_path + String.length dir) 236 - ) 237 - with 238 - | _ -> None 239 - else None 240 - ) 241 - asset_dirs 218 + (String.length asset_path - String.length dir_path 219 + + String.length dir)) 220 + with _ -> None 221 + else None) 222 + asset_dirs 242 223 in 243 - L.CompletionItem.create 244 - ~label: insertText 245 - ~kind: File 246 - ~insertText 247 - () 224 + L.CompletionItem.create ~label:insertText ~kind:File ~insertText () 248 225 249 - let make (path, (data, _): Yuujinchou.Trie.path * (Resolver.P.data * Asai.Range.t option)) = 226 + let make 227 + ((path, (data, _)) : 228 + Yuujinchou.Trie.path * (Resolver.P.data * Asai.Range.t option)) = 250 229 match data with 251 230 | Term [] -> None 252 231 | Term (node :: _) -> 253 - (* NOTE: Eventually we want to analyse the syntax so that, for example, 254 - you can tab through the snippet for a function of arity n*) 232 + (* NOTE: Eventually we want to analyse the syntax so that, for example, you 233 + can tab through the snippet for a function of arity n*) 255 234 let kind = kind node.value in 256 235 let insertText = insert_text path in 257 236 Some 258 - ( 259 - L.CompletionItem.create 260 - ?kind 261 - ~insertText 262 - ~label: (String.concat "/" path) 263 - () 264 - ) 265 - | Xmlns _ -> 266 - assert false 237 + (L.CompletionItem.create ?kind ~insertText ~label:(String.concat "/" path) 238 + ()) 239 + | Xmlns _ -> assert false 267 240 268 - (* These are useful completion items that are handled during parsing, not during expansion and are thus not "builtins"*) 241 + (* These are useful completion items that are handled during parsing, not during 242 + expansion and are thus not "builtins"*) 269 243 270 244 module Syntax = struct 271 245 let verb = 272 246 let insertText = 273 247 Lsp.Snippet.( 274 248 let open O in 275 - to_string @@ 276 - "\\startverb<<|\n" @+ tabstop 1 +@ "\n<<|" 277 - ) 249 + to_string @@ "\\startverb<<|\n" @+ (tabstop 1 +@ "\n<<|")) 278 250 in 279 - L.CompletionItem.create 280 - ~insertTextFormat: Snippet 281 - ~insertText 282 - ~label: "startverb" 283 - ~documentation: (`String "Create a verbatim block") 284 - () 251 + L.CompletionItem.create ~insertTextFormat:Snippet ~insertText 252 + ~label:"startverb" ~documentation:(`String "Create a verbatim block") () 285 253 end 286 254 287 - (* Incomplete. The idea here is to create clever snippets for specific syntax items. *) 255 + (* Incomplete. The idea here is to create clever snippets for specific syntax 256 + items. *) 288 257 let syntax_completions = 289 258 [ 290 259 ("startverb", "startverb"); ··· 308 277 ("xmlns", "xmlns"); 309 278 ] 310 279 |> List.map @@ fun (insertText, label) -> 311 - L.CompletionItem.create 312 - ~insertText 313 - ~label 314 - () 280 + L.CompletionItem.create ~insertText ~label () 315 281 316 282 let addr_completions ~(forest : State.t) : L.CompletionItem.t list = 317 283 let articles = List.of_seq @@ State.get_all_articles forest in ··· 323 289 let documentation = 324 290 let taxon = frontmatter.taxon in 325 291 let content = 326 - Format.asprintf 327 - "# %s\n %s\n " 328 - (render title) 329 - (Option.fold ~none: "" ~some: (fun s -> Format.asprintf "taxon: %s" (render s)) taxon) 292 + Format.asprintf "# %s\n %s\n " (render title) 293 + (Option.fold ~none:"" 294 + ~some:(fun s -> Format.asprintf "taxon: %s" (render s)) 295 + taxon) 330 296 in 331 297 Some (`String content) 332 298 in 333 299 let@ uri = Option.bind @@ frontmatter.uri in 334 300 let@ uri_name = Option.bind @@ URI_scheme.name uri in 335 301 let title_text = render title in 336 - Option.some @@ 337 - L.CompletionItem.create 338 - ?documentation 339 - ~label: (Format.(asprintf "%a (%s)" pp_print_string title_text uri_name)) 340 - ~insertText: uri_name 341 - ~filterText: (uri_name ^ " " ^ title_text) 342 - () 302 + Option.some 303 + @@ L.CompletionItem.create ?documentation 304 + ~label:Format.(asprintf "%a (%s)" pp_print_string title_text uri_name) 305 + ~insertText:uri_name 306 + ~filterText:(uri_name ^ " " ^ title_text) 307 + () 343 308 344 309 let new_addr_completions ~(forest : State.t) : L.CompletionItem.t list = 345 - let next mode = URI_util.next_uri ~prefix: None ~mode ~forest in 310 + let next mode = URI_util.next_uri ~prefix:None ~mode ~forest in 346 311 [ 347 - L.CompletionItem.create ~label: "random" ~insertText: (next `Random) (); 348 - L.CompletionItem.create ~label: "sequential" ~insertText: (next `Sequential) () 312 + L.CompletionItem.create ~label:"random" ~insertText:(next `Random) (); 313 + L.CompletionItem.create ~label:"sequential" ~insertText:(next `Sequential) 314 + (); 349 315 ] 350 316 351 - let visible_completions ~(forest : State.t) ~(position : L.Position.t) : Tree.code option -> L.CompletionItem.t list = function 317 + let visible_completions ~(forest : State.t) ~(position : L.Position.t) : 318 + Tree.code option -> L.CompletionItem.t list = function 352 319 | None -> 353 - List.append syntax_completions @@ 354 - let@ path, _ = List.map @~ List.of_seq @@ Trie.to_seq Expand.initial_visible_trie in 355 - L.CompletionItem.create 356 - ~insertText: "todo" 357 - ~label: (String.concat "/" path) 358 - () 320 + List.append syntax_completions 321 + @@ 322 + let@ path, _ = 323 + List.map @~ List.of_seq @@ Trie.to_seq Expand.initial_visible_trie 324 + in 325 + L.CompletionItem.create ~insertText:"todo" ~label:(String.concat "/" path) 326 + () 359 327 | Some {nodes; _} -> 360 328 Analysis.get_visible ~position ~forest nodes 361 - |> Trie.to_seq 362 - |> List.of_seq 363 - |> List.filter_map make 329 + |> Trie.to_seq |> List.of_seq |> List.filter_map make 364 330 |> List.append syntax_completions 365 331 366 332 let date_completions () : L.CompletionItem.t list = 367 333 let now = Human_datetime.now () in 368 334 let now_string = Format.asprintf "%a" Human_datetime.pp now in 369 - [ 370 - L.CompletionItem.create ~label: now_string ~insertText: now_string () 371 - ] 335 + [L.CompletionItem.create ~label:now_string ~insertText:now_string ()] 372 336 373 - let compute ({context; position; textDocument = {uri}; _;}: L.CompletionParams.t) = 374 - Logs.debug (fun m -> m "when computing completions for %s" (Lsp.Uri.to_string uri)); 337 + let compute 338 + ({context; position; textDocument = {uri}; _} : L.CompletionParams.t) = 339 + Logs.debug (fun m -> 340 + m "when computing completions for %s" (Lsp.Uri.to_string uri)); 375 341 let triggerCharacter = 376 342 match context with 377 - | Some {triggerCharacter; _} -> 378 - triggerCharacter 343 + | Some {triggerCharacter; _} -> triggerCharacter 379 344 | None -> None 380 345 in 381 346 let Lsp_state.{forest; _} = Lsp_state.get () in ··· 385 350 let tree = forest.={uri} in 386 351 match tree with 387 352 | None -> 388 - Reporter.fatal 389 - Internal_error 390 - ~backtrace: (Bwd.of_list [Asai.Diagnostic.loctextf "when computing completions for %a" URI.pp uri]) 391 - ~extra_remarks: [Asai.Diagnostic.loctextf "%a was not found in the index" URI.pp uri] 353 + Reporter.fatal Internal_error 354 + ~backtrace: 355 + (Bwd.of_list 356 + [ 357 + Asai.Diagnostic.loctextf "when computing completions for %a" URI.pp 358 + uri; 359 + ]) 360 + ~extra_remarks: 361 + [Asai.Diagnostic.loctextf "%a was not found in the index" URI.pp uri] 392 362 | Some tree -> 393 363 let code = Tree.to_code tree in 394 - Logs.debug (fun m -> m "Received completion request at %s" (Yojson.Safe.to_string (L.Position.yojson_of_t position))); 364 + Logs.debug (fun m -> 365 + m "Received completion request at %s" 366 + (Yojson.Safe.to_string (L.Position.yojson_of_t position))); 395 367 Logs.debug (fun m -> m "phase is %s" (Tree.show_phase tree)); 396 368 let completion_types = completion_types ~position tree in 397 - Logs.debug (fun m -> m "computed completion types: %a" (Format.pp_print_list pp_completion) (S.to_list completion_types)); 369 + Logs.debug (fun m -> 370 + m "computed completion types: %a" 371 + (Format.pp_print_list pp_completion) 372 + (S.to_list completion_types)); 398 373 let items = 399 374 let@ completion = List.concat_map @~ S.to_list completion_types in 400 375 match completion with ··· 405 380 | Date -> date_completions () 406 381 in 407 382 Logs.debug (fun m -> m "items: %d" (List.length items)); 408 - Option.some @@ `CompletionList (L.CompletionList.create ~isIncomplete: false ~items ()) 383 + Option.some 384 + @@ `CompletionList (L.CompletionList.create ~isIncomplete:false ~items ())
+15 -5
lib/language_server/Definitions.ml
··· 9 9 open Forester_core 10 10 open Forester_compiler 11 11 12 - open struct module L = Lsp.Types end 12 + open struct 13 + module L = Lsp.Types 14 + end 15 + 13 16 open State.Syntax 14 17 15 18 let compute (params : L.DefinitionParams.t) = 16 19 let Lsp_state.{forest; _} = Lsp_state.get () in 17 - let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url params.textDocument.uri in 20 + let uri = 21 + URI_scheme.lsp_uri_to_uri ~base:forest.config.url params.textDocument.uri 22 + in 18 23 let@ tree = Option.bind forest.={uri} in 19 24 let@ {nodes; _} = Option.bind @@ Tree.to_code tree in 20 - let@ {value = str; _} = Option.bind @@ Analysis.addr_at ~position: params.position nodes in 21 - let uri = URI_scheme.named_uri ~base: forest.config.url str in 25 + let@ {value = str; _} = 26 + Option.bind @@ Analysis.addr_at ~position:params.position nodes 27 + in 28 + let uri = URI_scheme.named_uri ~base:forest.config.url str in 22 29 let@ path = Option.map @~ URI.Tbl.find_opt forest.resolver uri in 23 30 let uri = Lsp.Uri.of_path path in 24 - let range = L.Range.create ~start: {character = 1; line = 0} ~end_: {character = 1; line = 0} in 31 + let range = 32 + L.Range.create ~start:{character = 1; line = 0} 33 + ~end_:{character = 1; line = 0} 34 + in 25 35 `Location [L.Location.{uri; range}]
+8 -4
lib/language_server/Diagnostics.ml
··· 7 7 8 8 (* When computing the diagnostics for a specific text document, do we know that 9 9 the emitted diagnostics should be reported to the same URI? 10 - *) 10 + *) 11 11 12 12 open Forester_core 13 13 open Forester_compiler 14 14 15 - open struct module L = Lsp.Types end 15 + open struct 16 + module L = Lsp.Types 17 + end 18 + 16 19 open State.Syntax 17 20 18 21 let compute (document : Lsp.Text_document.t) = 19 22 let Lsp_state.{forest; _} = Lsp_state.get () in 20 23 let lsp_uri = Lsp.Text_document.documentUri document in 21 - let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url lsp_uri in 24 + let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url lsp_uri in 22 25 match forest.?{uri} with 23 26 | [] -> 24 27 Eio.traceln "Clearing diagnostics for %s" (Lsp.Uri.to_path lsp_uri); 25 28 Publish.publish lsp_uri [] 26 29 | diagnostics -> 27 - Eio.traceln "publishing %i diagnostics to %s" (List.length diagnostics) (Lsp.Uri.to_path lsp_uri); 30 + Eio.traceln "publishing %i diagnostics to %s" (List.length diagnostics) 31 + (Lsp.Uri.to_path lsp_uri); 28 32 Publish.publish lsp_uri diagnostics
+16 -7
lib/language_server/Did_change.ml
··· 9 9 open Forester_core 10 10 open Forester_compiler 11 11 12 - open struct module L = Lsp.Types end 12 + open struct 13 + module L = Lsp.Types 14 + end 15 + 13 16 open State.Syntax 14 17 15 18 let compute (params : L.DidChangeTextDocumentParams.t) = 16 19 let Lsp_state.{forest; _} = Lsp_state.get () in 17 20 let lsp_uri = params.textDocument.uri in 18 - let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url lsp_uri in 21 + let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url lsp_uri in 19 22 let@ tree = Option.iter @~ forest.={uri} in 20 23 match Tree.to_doc tree with 21 24 | None -> 22 - Logs.debug (fun m -> m "Did_change.compute fatal error, could not find tree with uri %a from LSP uri %s" URI.pp uri (Lsp.Uri.to_string lsp_uri)); 25 + Logs.debug (fun m -> 26 + m 27 + "Did_change.compute fatal error, could not find tree with uri %a \ 28 + from LSP uri %s" 29 + URI.pp uri 30 + (Lsp.Uri.to_string lsp_uri)); 23 31 assert false 24 32 | Some doc -> 25 - let new_doc = Lsp.Text_document.apply_content_changes doc params.contentChanges in 33 + let new_doc = 34 + Lsp.Text_document.apply_content_changes doc params.contentChanges 35 + in 26 36 forest.={uri} <- Document new_doc; 27 37 Lsp_state.modify (fun ({forest; _} as lsp_state) -> 28 - let new_forest = Driver.run_until_done (Action.Parse lsp_uri) forest in 29 - {lsp_state with forest = new_forest} 30 - ); 38 + let new_forest = Driver.run_until_done (Action.Parse lsp_uri) forest in 39 + {lsp_state with forest = new_forest}); 31 40 Diagnostics.compute new_doc
+7 -5
lib/language_server/Did_create_files.ml
··· 7 7 open Forester_prelude 8 8 open Forester_core 9 9 open Forester_compiler 10 - 11 10 open State.Syntax 12 - open struct module L = Lsp.Types end 13 11 14 - let compute ({files}: L.CreateFilesParams.t) = 12 + open struct 13 + module L = Lsp.Types 14 + end 15 + 16 + let compute ({files} : L.CreateFilesParams.t) = 15 17 Eio.traceln "recieved DidCreateFiles notification"; 16 18 Lsp_state.modify @@ fun ({forest; _} as lsp_state) -> 17 19 let env = forest.env in ··· 19 21 begin 20 22 let@ {uri} = List.iter @~ files in 21 23 let lsp_uri = L.DocumentUri.of_string uri in 22 - let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url lsp_uri in 23 - let path = Eio.Path.(env#fs / (L.DocumentUri.to_path lsp_uri)) in 24 + let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url lsp_uri in 25 + let path = Eio.Path.(env#fs / L.DocumentUri.to_path lsp_uri) in 24 26 let doc = Imports.load_tree path in 25 27 forest.={uri} <- Document doc 26 28 end;
+8 -6
lib/language_server/Did_open.ml
··· 8 8 open Forester_core 9 9 open Forester_compiler 10 10 open State.Syntax 11 - open struct module L = Lsp.Types end 11 + 12 + open struct 13 + module L = Lsp.Types 14 + end 12 15 13 16 let compute (params : L.DidOpenTextDocumentParams.t) = 14 17 let lsp_uri = params.textDocument.uri in 15 18 let Lsp_state.{forest; _} = Lsp_state.get () in 16 - let document = Lsp.Text_document.make ~position_encoding: `UTF16 params in 17 - let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url lsp_uri in 19 + let document = Lsp.Text_document.make ~position_encoding:`UTF16 params in 20 + let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url lsp_uri in 18 21 forest.={uri} <- Document document; 19 22 Lsp_state.modify (fun ({forest; _} as lsp_state) -> 20 - let new_forest = Driver.run_until_done (Action.Parse lsp_uri) forest in 21 - {lsp_state with forest = new_forest} 22 - ); 23 + let new_forest = Driver.run_until_done (Action.Parse lsp_uri) forest in 24 + {lsp_state with forest = new_forest}); 23 25 Diagnostics.compute document
+12 -6
lib/language_server/Document_link.ml
··· 12 12 13 13 open struct 14 14 module L = Lsp.Types 15 - let (let*) = Option.bind 15 + 16 + let ( let* ) = Option.bind 16 17 end 18 + 17 19 open State.Syntax 18 20 19 21 (* TODO: handle external links as well? *) ··· 23 25 let config = forest.config in 24 26 let Lsp_state.{forest; _} = Lsp_state.get () in 25 27 let links = 26 - let uri = URI_scheme.lsp_uri_to_uri ~base: config.url params.textDocument.uri in 28 + let uri = 29 + URI_scheme.lsp_uri_to_uri ~base:config.url params.textDocument.uri 30 + in 27 31 (* match Imports.resolve_uri_to_code forest uri with *) 28 32 match Option.bind forest.={uri} Tree.to_code with 29 33 | None -> [] 30 - | Some tree -> 34 + | Some tree -> ( 31 35 let@ node = List.filter_map @~ tree.nodes in 32 36 match Range.(node.value) with 33 37 | Code.Group (Squares, [{value = Text addr; _}]) ··· 35 39 | Code.Group (Braces, [{value = Text addr; _}]) -> 36 40 (* TODO: Need to analyse syn *) 37 41 let range = Lsp_shims.Loc.lsp_range_of_range node.loc in 38 - let uri = URI_scheme.named_uri ~base: config.url addr in 39 - let* target = Option.map Lsp.Uri.of_path @@ URI.Tbl.find_opt forest.resolver uri in 42 + let uri = URI_scheme.named_uri ~base:config.url addr in 43 + let* target = 44 + Option.map Lsp.Uri.of_path @@ URI.Tbl.find_opt forest.resolver uri 45 + in 40 46 let* {frontmatter; _} = State.get_article uri forest in 41 47 let* tooltip = Option.map (fun c -> render c) frontmatter.title in 42 48 let link = L.DocumentLink.create ~range ~target ~tooltip () in 43 49 Some link 44 - | _ -> None 50 + | _ -> None) 45 51 in 46 52 Some links
+38 -22
lib/language_server/Document_symbols.ml
··· 11 11 12 12 open struct 13 13 module L = Lsp.Types 14 + 14 15 let pp_path = Resolver.Scope.pp_path 15 16 end 16 17 17 18 let compute (params : L.DocumentSymbolParams.t) = 18 19 let uri = params.textDocument.uri in 19 20 let Lsp_state.{forest; _} = Lsp_state.get () in 20 - match State.get_code forest @@ URI_scheme.lsp_uri_to_uri ~base: forest.config.url uri with 21 + match 22 + State.get_code forest 23 + @@ URI_scheme.lsp_uri_to_uri ~base:forest.config.url uri 24 + with 21 25 | None -> 22 - URI.Tbl.iter (fun uri _ -> Logs.debug (fun m -> m "%a" URI.pp uri)) forest.index; 26 + URI.Tbl.iter 27 + (fun uri _ -> Logs.debug (fun m -> m "%a" URI.pp uri)) 28 + forest.index; 23 29 Logs.debug (fun m -> m "%s" (Lsp.Uri.to_string uri)); 24 - Logs.debug (fun m -> m "%a" URI.pp (URI_scheme.lsp_uri_to_uri ~base: forest.config.url uri)); 30 + Logs.debug (fun m -> 31 + m "%a" URI.pp (URI_scheme.lsp_uri_to_uri ~base:forest.config.url uri)); 25 32 assert false 26 33 | Some {nodes; _} -> 27 34 let symbols = ··· 31 38 let selectionRange = range in 32 39 match value with 33 40 | Subtree (addr, _) -> 34 - let name = Option.value ~default: "anonymous" addr in 41 + let name = Option.value ~default:"anonymous" addr in 35 42 let range = Lsp_shims.Loc.lsp_range_of_range loc in 36 43 (* TODO: What should the symbol kind of a subtree be? *) 37 - Option.some @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind: Namespace () 44 + Option.some 45 + @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind:Namespace 46 + () 38 47 | Object {self; _} -> 39 - let name = Option.value ~default: "anonymous" self in 40 - Option.some @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind: Object () 48 + let name = Option.value ~default:"anonymous" self in 49 + Option.some 50 + @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind:Object () 41 51 | Def (name, _, _) -> 42 52 let name = Format.asprintf "%a" pp_path name in 43 - Option.some @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind: Function () 53 + Option.some 54 + @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind:Function 55 + () 44 56 | Namespace (name, _) -> 45 57 let name = Format.asprintf "%a" pp_path name in 46 - Option.some @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind: Namespace () 58 + Option.some 59 + @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind:Namespace 60 + () 47 61 | Ident path -> 48 62 let name = Format.asprintf "%a" pp_path path in 49 - Option.some @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind: Constructor () 63 + Option.some 64 + @@ L.DocumentSymbol.create ~name ~range ~selectionRange 65 + ~kind:Constructor () 50 66 | Let (path, _, _) -> 51 67 let name = Format.asprintf "%a" pp_path path in 52 - Option.some @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind: Constructor () 68 + Option.some 69 + @@ L.DocumentSymbol.create ~name ~range ~selectionRange 70 + ~kind:Constructor () 53 71 | Xml_ident (pfx, ident) -> 54 72 let name = 55 73 match pfx with 56 74 | None -> Format.asprintf "<%s>" ident 57 75 | Some pfx -> Format.asprintf "<%s:%s>" pfx ident 58 76 in 59 - Option.some @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind: Constructor () 77 + Option.some 78 + @@ L.DocumentSymbol.create ~name ~range ~selectionRange 79 + ~kind:Constructor () 60 80 | Hash_ident _ -> 61 - Option.some @@ L.DocumentSymbol.create ~name: "(hash)" ~range ~selectionRange ~kind: Constant () 62 - | Text _ 63 - | Verbatim _ 81 + Option.some 82 + @@ L.DocumentSymbol.create ~name:"(hash)" ~range ~selectionRange 83 + ~kind:Constant () 84 + | Text _ | Verbatim _ 64 85 | Group (_, _) 65 86 | Math (_, _) 66 - | Open _ 67 - | Scope _ 87 + | Open _ | Scope _ 68 88 | Put (_, _) 69 89 | Default (_, _) 70 90 | Get _ ··· 77 97 | Dx_sequent (_, _) 78 98 | Dx_query (_, _, _) 79 99 | Dx_prop (_, _) 80 - | Dx_var _ 81 - | Dx_const_content _ 82 - | Dx_const_uri _ 83 - | Comment _ 84 - | Error _ -> 100 + | Dx_var _ | Dx_const_content _ | Dx_const_uri _ | Comment _ | Error _ -> 85 101 None 86 102 in 87 103 Some (`DocumentSymbol symbols)
+97 -112
lib/language_server/Forester_lsp.ml
··· 12 12 module Lsp_state = Lsp_state 13 13 module LspEio = LspEio 14 14 module Lsp_shims = Lsp_shims 15 - 16 15 module Call_hierarchy = Call_hierarchy 17 16 module Change_configuration = Change_configuration 18 17 module Code_action = Code_action ··· 30 29 module Semantic_tokens = Semantic_tokens 31 30 module Workspace_symbols = Workspace_symbols 32 31 module Did_create_files = Did_create_files 33 - 34 32 open Forester_core 35 33 open Forester_compiler 36 - 37 34 open Server 38 35 open Lsp_error 39 36 40 37 let unwrap opt err = 41 - match opt with 42 - | Some opt -> opt 43 - | None -> raise @@ Lsp_error err 38 + match opt with Some opt -> opt | None -> raise @@ Lsp_error err 44 39 45 40 let print_exn exn = 46 - let msg = Printexc.to_string exn 47 - and stack = Printexc.get_backtrace () 48 - in 41 + let msg = Printexc.to_string exn and stack = Printexc.get_backtrace () in 49 42 Eio.traceln "%s\n%s" msg stack 50 43 51 44 let supported_code_actions = [L.CodeActionKind.Other "new tree"] ··· 54 47 let server_capabilities = 55 48 let textDocumentSync = 56 49 let opts = 57 - L.TextDocumentSyncOptions.create 58 - ~change: L.TextDocumentSyncKind.Full 59 - ~openClose: true 60 - ~save: (`SaveOptions (L.SaveOptions.create ~includeText: false ())) 50 + L.TextDocumentSyncOptions.create ~change:L.TextDocumentSyncKind.Full 51 + ~openClose:true 52 + ~save:(`SaveOptions (L.SaveOptions.create ~includeText:false ())) 61 53 () 62 54 in 63 55 `TextDocumentSyncOptions opts ··· 68 60 in 69 61 let codeActionProvider = 70 62 let opts = 71 - L.CodeActionOptions.create 72 - ~codeActionKinds: supported_code_actions 73 - () 63 + L.CodeActionOptions.create ~codeActionKinds:supported_code_actions () 74 64 in 75 65 `CodeActionOptions opts 76 66 in 77 67 let executeCommandProvider = 78 - L.ExecuteCommandOptions.create 79 - ~commands: supported_commands 80 - () 68 + L.ExecuteCommandOptions.create ~commands:supported_commands () 81 69 in 82 70 let inlayHintProvider = 83 71 let opts = L.InlayHintOptions.create () in ··· 85 73 in 86 74 let definitionProvider = `DefinitionOptions (L.DefinitionOptions.create ()) in 87 75 let completionProvider = 88 - L.CompletionOptions.create 89 - ~triggerCharacters: ["\\"; "{"; "("; "["] 90 - ~allCommitCharacters: ["}"; ")"; "]"] 91 - () 76 + L.CompletionOptions.create ~triggerCharacters:["\\"; "{"; "("; "["] 77 + ~allCommitCharacters:["}"; ")"; "]"] () 92 78 in 93 79 let documentLinkProvider = 94 - L.DocumentLinkOptions.create 95 - ~resolveProvider: true 96 - ~workDoneProgress: false 80 + L.DocumentLinkOptions.create ~resolveProvider:true ~workDoneProgress:false 97 81 () 98 82 in 99 - let workspaceSymbolProvider = `WorkspaceSymbolOptions (L.WorkspaceSymbolOptions.create ()) in 100 - let documentSymbolProvider = `DocumentSymbolOptions (L.DocumentSymbolOptions.create ()) in 83 + let workspaceSymbolProvider = 84 + `WorkspaceSymbolOptions (L.WorkspaceSymbolOptions.create ()) 85 + in 86 + let documentSymbolProvider = 87 + `DocumentSymbolOptions (L.DocumentSymbolOptions.create ()) 88 + in 101 89 let workspace = 102 90 L.ServerCapabilities.create_workspace 103 - ~fileOperations: ( 104 - L.FileOperationOptions.create 105 - ~didCreate: { 106 - filters = [ 107 - L.FileOperationFilter.create 108 - ~pattern: (L.FileOperationPattern.create ~glob: "**/*.tree" ()) 109 - () 110 - ] 111 - } 112 - () 113 - ) 91 + ~fileOperations: 92 + (L.FileOperationOptions.create 93 + ~didCreate: 94 + { 95 + filters = 96 + [ 97 + L.FileOperationFilter.create 98 + ~pattern: 99 + (L.FileOperationPattern.create ~glob:"**/*.tree" ()) 100 + (); 101 + ]; 102 + } 103 + ()) 114 104 () 115 105 in 116 106 117 - (* [NOTE: Position Encodings] 118 - For various historical reasons, the spec states that we are _required_ to support UTF-16. 119 - This causes more trouble than it's worth, so we always select UTF-8 as our encoding, even 120 - if the client doesn't support it. *) 107 + (* [NOTE: Position Encodings] For various historical reasons, the spec states 108 + that we are _required_ to support UTF-16. This causes more trouble than 109 + it's worth, so we always select UTF-8 as our encoding, even if the client 110 + doesn't support it. *) 121 111 let positionEncoding = L.PositionEncodingKind.UTF8 in 122 - (* [FIXME: Reed M, 09/06/2022] The current verison of the LSP library doesn't support 'positionEncoding' *) 123 - L.ServerCapabilities.create 124 - ~textDocumentSync 125 - ~hoverProvider 126 - ~codeActionProvider 127 - ~executeCommandProvider 128 - ~inlayHintProvider 129 - ~positionEncoding 130 - ~completionProvider 131 - ~definitionProvider 132 - ~documentSymbolProvider 133 - ~documentLinkProvider 134 - ~workspaceSymbolProvider 135 - ~workspace 136 - () 112 + (* [FIXME: Reed M, 09/06/2022] The current verison of the LSP library doesn't 113 + support 'positionEncoding' *) 114 + L.ServerCapabilities.create ~textDocumentSync ~hoverProvider 115 + ~codeActionProvider ~executeCommandProvider ~inlayHintProvider 116 + ~positionEncoding ~completionProvider ~definitionProvider 117 + ~documentSymbolProvider ~documentLinkProvider ~workspaceSymbolProvider 118 + ~workspace () 137 119 138 120 let supports_utf8_encoding (init_params : L.InitializeParams.t) = 139 121 let position_encodings = 140 - Option.value ~default: [] @@ 141 - Option.bind init_params.capabilities.general @@ fun gcap -> 142 - gcap.positionEncodings 122 + Option.value ~default:[] 123 + @@ Option.bind init_params.capabilities.general 124 + @@ fun gcap -> gcap.positionEncodings 143 125 in 144 126 List.mem L.PositionEncodingKind.UTF8 position_encodings 145 127 146 128 (** Perform the LSP initialization handshake. 147 - https://microsoft.github.io/language-server-protocol/specifications/specification-current/#initialize *) 129 + https://microsoft.github.io/language-server-protocol/specifications/specification-current/#initialize 130 + *) 148 131 let initialize () = 149 - let (id, req) = 150 - unwrap (Request.recv ()) @@ 151 - Handshake_error "Initialization must begin with a request." 132 + let id, req = 133 + unwrap (Request.recv ()) 134 + @@ Handshake_error "Initialization must begin with a request." 152 135 in 153 136 match req with 154 - | E (Initialize init_params as init_req) -> 155 - begin 156 - (* [HACK: Position Encodings] 157 - If the client doesn't support UTF-8, we shouldn't give up, as it might be using UTF-8 anyways... 158 - Therefore, we just produce a warning, and try to use UTF-8 regardless. *) 159 - if not (supports_utf8_encoding init_params) then 160 - Eio.traceln "Warning: client does not support UTF-8 encoding, which may lead to inconsistent positions."; 161 - let resp = L.InitializeResult.create ~capabilities: server_capabilities () in 162 - Request.respond id init_req resp; 163 - let notif = 164 - unwrap (Notification.recv ()) @@ 165 - Handshake_error "Initialization must complete with an initialized notification." 166 - in 167 - match notif with 168 - | Initialized -> 169 - Eio.traceln "Initialized!" 170 - | _ -> 171 - raise @@ Lsp_error (Handshake_error "Initialization must complete with an initialized notification.") 172 - end 173 - | (E _) -> 174 - raise @@ Lsp_error (Handshake_error "Initialization must begin with an initialize request.") 137 + | E (Initialize init_params as init_req) -> begin 138 + (* [HACK: Position Encodings] If the client doesn't support UTF-8, we 139 + shouldn't give up, as it might be using UTF-8 anyways... Therefore, we 140 + just produce a warning, and try to use UTF-8 regardless. *) 141 + if not (supports_utf8_encoding init_params) then 142 + Eio.traceln 143 + "Warning: client does not support UTF-8 encoding, which may lead to \ 144 + inconsistent positions."; 145 + let resp = L.InitializeResult.create ~capabilities:server_capabilities () in 146 + Request.respond id init_req resp; 147 + let notif = 148 + unwrap (Notification.recv ()) 149 + @@ Handshake_error 150 + "Initialization must complete with an initialized notification." 151 + in 152 + match notif with 153 + | Initialized -> Eio.traceln "Initialized!" 154 + | _ -> 155 + raise 156 + @@ Lsp_error 157 + (Handshake_error 158 + "Initialization must complete with an initialized notification.") 159 + end 160 + | E _ -> 161 + raise 162 + @@ Lsp_error 163 + (Handshake_error 164 + "Initialization must begin with an initialize request.") 175 165 176 - (** Perform the LSP shutdown sequence. 177 - See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#exit *) 166 + (** Perform the LSP shutdown sequence. See 167 + https://microsoft.github.io/language-server-protocol/specifications/specification-current/#exit 168 + *) 178 169 let shutdown () = 179 170 let notif = 180 - unwrap (Notification.recv ()) @@ 181 - Shutdown_error "No requests can be recieved after a shutdown request." 171 + unwrap (Notification.recv ()) 172 + @@ Shutdown_error "No requests can be recieved after a shutdown request." 182 173 in 183 174 match notif with 184 - | Exit -> 185 - () 175 + | Exit -> () 186 176 | _ -> 187 - raise @@ Lsp_error (Shutdown_error "The only notification that can be recieved after a shutdown request is exit.") 177 + raise 178 + @@ Lsp_error 179 + (Shutdown_error 180 + "The only notification that can be recieved after a shutdown \ 181 + request is exit.") 188 182 189 183 (** {1 Main Event Loop} *) 190 184 ··· 196 190 | RPC.Packet.Request req -> 197 191 let resp = Request.handle req in 198 192 send (RPC.Packet.Response resp) 199 - | RPC.Packet.Notification notif -> 200 - Notification.handle notif 201 - | _ -> 202 - Eio.traceln "Recieved unexpected packet type." 203 - | exception exn -> 204 - print_exn exn 193 + | RPC.Packet.Notification notif -> Notification.handle notif 194 + | _ -> Eio.traceln "Recieved unexpected packet type." 195 + | exception exn -> print_exn exn 205 196 in 206 - if should_shutdown () then 207 - shutdown () 208 - else 209 - event_loop () 210 - | None -> 211 - Eio.traceln "Recieved an invalid message. Shutting down...@." 197 + if should_shutdown () then shutdown () else event_loop () 198 + | None -> Eio.traceln "Recieved an invalid message. Shutting down...@." 212 199 213 200 let start ~env ~(config : Config.t) = 214 201 let lsp_io = LspEio.init env in 215 202 (* FIXME: A "batch run" should fail early. The lsp should start even when 216 203 there are errors *) 217 204 let forest = Driver.language_server ~env ~config in 218 - Server.run 219 - ~init: {forest; lsp_io; should_shutdown = false;} 220 - @@ fun () -> 221 - begin 222 - initialize (); 223 - event_loop () 224 - end 205 + Server.run ~init:{forest; lsp_io; should_shutdown = false} @@ fun () -> 206 + begin 207 + initialize (); 208 + event_loop () 209 + end
+9 -14
lib/language_server/Highlight.ml
··· 16 16 17 17 let compute (params : L.DocumentHighlightParams.t) = 18 18 let Lsp_state.{forest; _} = Lsp_state.get () in 19 - let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url params.textDocument.uri in 19 + let uri = 20 + URI_scheme.lsp_uri_to_uri ~base:forest.config.url params.textDocument.uri 21 + in 20 22 let@ tree = Option.map @~ State.get_code forest uri in 21 23 let@ Range.{loc; value} = List.map @~ tree.nodes in 22 24 let range = Lsp_shims.Loc.lsp_range_of_range loc in 23 25 let kind = 24 26 match value with 25 - | Code.Text _ 26 - | Code.Verbatim _ 27 + | Code.Text _ | Code.Verbatim _ 27 28 | Code.Group (_, _) 28 29 | Code.Math (_, _) 29 - | Code.Ident _ 30 - | Code.Hash_ident _ 30 + | Code.Ident _ | Code.Hash_ident _ 31 31 | Code.Xml_ident (_, _) 32 32 | Code.Subtree (_, _) 33 33 | Code.Let (_, _, _) 34 - | Code.Open _ 35 - | Code.Scope _ 34 + | Code.Open _ | Code.Scope _ 36 35 | Code.Put (_, _) 37 36 | Code.Default (_, _) 38 37 | Code.Get _ 39 38 | Code.Fun (_, _) 40 - | Code.Object _ 41 - | Code.Patch _ 39 + | Code.Object _ | Code.Patch _ 42 40 | Code.Call (_, _) 43 41 | Code.Import (_, _) 44 42 | Code.Def (_, _, _) ··· 48 46 | Code.Dx_sequent (_, _) 49 47 | Code.Dx_query (_, _, _) 50 48 | Code.Dx_prop (_, _) 51 - | Code.Dx_var _ 52 - | Code.Dx_const_content _ 53 - | Code.Dx_const_uri _ 54 - | Code.Comment _ 55 - | Code.Error _ -> 49 + | Code.Dx_var _ | Code.Dx_const_content _ | Code.Dx_const_uri _ 50 + | Code.Comment _ | Code.Error _ -> 56 51 None 57 52 in 58 53 L.DocumentHighlight.create ~range ?kind ()
+37 -21
lib/language_server/Hover.ml
··· 15 15 open struct 16 16 module L = Lsp.Types 17 17 module T = Types 18 - let (let*) = Option.bind 18 + 19 + let ( let* ) = Option.bind 19 20 end 20 21 21 - let compute ({position; textDocument; _}: L.HoverParams.t) = 22 + let compute ({position; textDocument; _} : L.HoverParams.t) = 22 23 let Lsp_state.{forest; _} = Lsp_state.get () in 23 24 let render = Plain_text_client.string_of_content ~forest in 24 - let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url textDocument.uri in 25 + let uri = 26 + URI_scheme.lsp_uri_to_uri ~base:forest.config.url textDocument.uri 27 + in 25 28 let@ content = 26 - Option.map @~ 27 - match forest.={uri} with 29 + Option.map 30 + @~ 31 + match forest.={uri} with 32 + | None -> 33 + Reporter.fatal Internal_error 34 + ~extra_remarks: 35 + [Asai.Diagnostic.loctextf "%a is not in the index" URI.pp uri] 36 + | Some tree -> ( 37 + let* {nodes; _} = Tree.to_code tree in 38 + let* node = Analysis.node_at_code ~position nodes in 39 + let tree_under_cursor = 40 + let* {value = addr; _} = Analysis.extract_addr node in 41 + let uri_under_cursor = 42 + URI_scheme.named_uri ~base:forest.config.url addr 43 + in 44 + State.get_article uri_under_cursor forest 45 + in 46 + match tree_under_cursor with 47 + | Some article -> Some (render article.mainmatter) 28 48 | None -> 29 - Reporter.fatal Internal_error ~extra_remarks: [Asai.Diagnostic.loctextf "%a is not in the index" URI.pp uri] 30 - | Some tree -> 31 - let* {nodes; _} = Tree.to_code tree in 32 - let* node = Analysis.node_at_code ~position nodes in 33 - let tree_under_cursor = 34 - let* {value = addr; _} = Analysis.extract_addr node in 35 - let uri_under_cursor = URI_scheme.named_uri ~base: forest.config.url addr in 36 - State.get_article uri_under_cursor forest 49 + let* doc = Tree.to_doc tree in 50 + let* search_term = Analysis.word_at ~position doc in 51 + let results = 52 + List.map snd @@ Index.search forest.search_index search_term 37 53 in 38 - match tree_under_cursor with 39 - | Some article -> Some (render article.mainmatter) 40 - | None -> 41 - let* doc = Tree.to_doc tree in 42 - let* search_term = Analysis.word_at ~position doc in 43 - let results = List.map snd @@ Index.search forest.search_index search_term in 44 - Some Format.(asprintf "Relevant results:@.%a@." (pp_print_list ~pp_sep: (fun out () -> fprintf out "@.") URI.pp) results) 54 + Some 55 + Format.( 56 + asprintf "Relevant results:@.%a@." 57 + (pp_print_list ~pp_sep:(fun out () -> fprintf out "@.") URI.pp) 58 + results)) 45 59 in 46 - L.Hover.create ~contents: (`MarkupContent {kind = L.MarkupKind.Markdown; value = content}) () 60 + L.Hover.create 61 + ~contents:(`MarkupContent {kind = L.MarkupKind.Markdown; value = content}) 62 + ()
+18 -12
lib/language_server/Inlay_hint.ml
··· 15 15 module L = Lsp.Types 16 16 end 17 17 18 - let list_of_option = function 19 - | Some x -> [x] 20 - | None -> [] 18 + let list_of_option = function Some x -> [x] | None -> [] 21 19 22 - let consume_addr_for_inlay ~(config : Config.t) ~(forest : State.t) (node : Syn.node Range.located) : string option * Syn.t = 20 + let consume_addr_for_inlay ~(config : Config.t) ~(forest : State.t) 21 + (node : Syn.node Range.located) : string option * Syn.t = 23 22 match node.value with 24 - | Link {title = None; dest = [{value = Text addr; _}]} -> Some addr, [] 25 - | Subtree (addr, nodes) -> addr, nodes 26 - | _ -> None, Syn.children node 23 + | Link {title = None; dest = [{value = Text addr; _}]} -> (Some addr, []) 24 + | Subtree (addr, nodes) -> (addr, nodes) 25 + | _ -> (None, Syn.children node) 27 26 28 - let inlay_hint_for_addr ~(config : Config.t) ~(forest : State.t) ~(pos : Range.position) (addr : string) : L.InlayHint.t option = 29 - let uri = URI_scheme.named_uri ~base: config.url addr in 27 + let inlay_hint_for_addr ~(config : Config.t) ~(forest : State.t) 28 + ~(pos : Range.position) (addr : string) : L.InlayHint.t option = 29 + let uri = URI_scheme.named_uri ~base:config.url addr in 30 30 let@ {frontmatter; _} = Option.bind @@ State.get_article uri forest in 31 31 let@ title = Option.bind frontmatter.title in 32 32 let content = " " ^ Plain_text_client.string_of_content ~forest title in 33 - Option.some @@ L.InlayHint.create ~position: (Lsp_shims.Loc.lsp_pos_of_pos pos) ~label: (`String content) () 33 + Option.some 34 + @@ L.InlayHint.create 35 + ~position:(Lsp_shims.Loc.lsp_pos_of_pos pos) 36 + ~label:(`String content) () 34 37 35 38 let pos_of_node (node : 'a Range.located) : Range.position option = 36 39 let@ loc = Option.bind node.loc in ··· 38 41 | `End_of_file _ -> None 39 42 | `Range (_, pos) -> Some pos 40 43 41 - let rec extract_inlayable_hints ~(config : Config.t) ~(forest : State.t) (nodes : Syn.t) : L.InlayHint.t list = 44 + let rec extract_inlayable_hints ~(config : Config.t) ~(forest : State.t) 45 + (nodes : Syn.t) : L.InlayHint.t list = 42 46 let@ node = List.concat_map @~ nodes in 43 47 let addr_opt, rest = consume_addr_for_inlay ~config ~forest node in 44 48 let hint_opt = ··· 52 56 let compute (params : L.InlayHintParams.t) : L.InlayHint.t list option = 53 57 let Lsp_state.{forest; _} = Lsp_state.get () in 54 58 let config = forest.config in 55 - let uri = URI_scheme.lsp_uri_to_uri ~base: config.url params.textDocument.uri in 59 + let uri = 60 + URI_scheme.lsp_uri_to_uri ~base:config.url params.textDocument.uri 61 + in 56 62 let@ {nodes; _} = Option.map @~ Option.bind forest.={uri} Tree.to_syn in 57 63 extract_inlayable_hints ~config ~forest nodes
+40 -50
lib/language_server/LspEio.ml
··· 7 7 8 8 open Eio 9 9 open Lsp.Import 10 - 11 10 module RPC = Jsonrpc 12 11 13 - type io = { 14 - input: Buf_read.t; 15 - output: Eio_unix.sink_ty Eio.Resource.t; 16 - } 12 + type io = {input: Buf_read.t; output: Eio_unix.sink_ty Eio.Resource.t} 17 13 18 - (** See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#headerPart *) 14 + (** See 15 + https://microsoft.github.io/language-server-protocol/specifications/specification-current/#headerPart 16 + *) 19 17 module Header = struct 20 - type t = { 21 - content_length: int; 22 - content_type: string 23 - } 18 + type t = {content_length: int; content_type: string} 24 19 25 - let empty = { 26 - content_length = -1; 27 - content_type = "application/vscode-jsonrpc; charset=utf-8" 28 - } 20 + let empty = 21 + { 22 + content_length = -1; 23 + content_type = "application/vscode-jsonrpc; charset=utf-8"; 24 + } 29 25 30 26 let create ~(content_length : int) : t = {empty with content_length} 31 27 ··· 35 31 let is_content_type key = 36 32 String.equal (String.lowercase_ascii @@ String.trim key) "content-type" 37 33 38 - (* NOTE: We should never really recieve an invalid header, as 39 - that would indicate a broken client implementation. Therefore, 40 - we just bail out when we see an invalid header, as there's 41 - no way we can really recover anyways. *) 42 - type header_error = 43 - | InvalidHeader of string 44 - | InvalidContentLength of string 34 + (* NOTE: We should never really recieve an invalid header, as that would 35 + indicate a broken client implementation. Therefore, we just bail out when 36 + we see an invalid header, as there's no way we can really recover anyways. *) 37 + type header_error = InvalidHeader of string | InvalidContentLength of string 45 38 46 39 exception HeaderError of header_error 47 40 48 - (* If we do see any random header messages, we want to at least print out a decent error message. *) 41 + (* If we do see any random header messages, we want to at least print out a 42 + decent error message. *) 49 43 let () = 50 44 Printexc.register_printer @@ function 51 - | HeaderError (InvalidHeader err) -> Some (Format.asprintf "HeaderError: Invalid Header %s" err) 52 - | HeaderError (InvalidContentLength n) -> Some (Format.asprintf "HeaderError: Invalid Content Length '%s'" n) 53 - | _ -> None 45 + | HeaderError (InvalidHeader err) -> 46 + Some (Format.asprintf "HeaderError: Invalid Header %s" err) 47 + | HeaderError (InvalidContentLength n) -> 48 + Some (Format.asprintf "HeaderError: Invalid Content Length '%s'" n) 49 + | _ -> None 54 50 55 - (* [TODO: Reed M, 09/06/2022] I could use some of the Buf_read parser module here, but this code works. *) 51 + (* [TODO: Reed M, 09/06/2022] I could use some of the Buf_read parser module 52 + here, but this code works. *) 56 53 let parse_header line headers = 57 - match String.split_on_char ~sep: ':' @@ String.trim line with 54 + match String.split_on_char ~sep:':' @@ String.trim line with 58 55 | [key; value] when is_content_length key -> 59 56 let content_length = 60 57 match int_of_string_opt (String.trim value) with ··· 68 65 | [_; _] -> 69 66 (* We skip any unknown headers. *) 70 67 headers 71 - | _ -> 72 - raise (HeaderError (InvalidHeader line)) 68 + | _ -> raise (HeaderError (InvalidHeader line)) 73 69 74 70 (** Read the header section of an LSP message. *) 75 71 let read io = ··· 80 76 in 81 77 let headers = loop empty in 82 78 if headers.content_length < 0 then 83 - raise (HeaderError (InvalidContentLength (string_of_int headers.content_length))) 84 - else 85 - headers 79 + raise 80 + (HeaderError 81 + (InvalidContentLength (string_of_int headers.content_length))) 82 + else headers 86 83 87 84 (** Write out the header section of an LSP message. *) 88 85 let write io headers = 89 86 let header_str = 90 - Format.asprintf 91 - "Content-Type: %s\r\nContent-Length: %d\r\n\r\n" 92 - headers.content_type 93 - headers.content_length 87 + Format.asprintf "Content-Type: %s\r\nContent-Length: %d\r\n\r\n" 88 + headers.content_type headers.content_length 94 89 in 95 90 Flow.copy_string header_str io.output 96 91 end ··· 102 97 let len = header.content_length in 103 98 let json = Json.of_string @@ Buf_read.take len io.input in 104 99 Some (RPC.Packet.t_of_yojson json) 105 - with 106 - | Sys_error _ 107 - | End_of_file -> 108 - None 100 + with Sys_error _ | End_of_file -> None 109 101 110 102 let write io packet = 111 103 let json = RPC.Packet.yojson_of_t packet in ··· 116 108 Flow.copy_string data io.output 117 109 end 118 110 119 - let init (env : Eio_unix.Stdenv.base) = { 120 - (* [TODO: Reed M, 09/06/2022] I should think about this buffer size... *) 121 - input = Buf_read.of_flow ~max_size: 1_000_000 @@ Eio.Stdenv.stdin env; 122 - output = Eio.Stdenv.stdout env 123 - } 124 - 125 - let recv io = 126 - Message.read io 111 + let init (env : Eio_unix.Stdenv.base) = 112 + { 113 + (* [TODO: Reed M, 09/06/2022] I should think about this buffer size... *) 114 + input = Buf_read.of_flow ~max_size:1_000_000 @@ Eio.Stdenv.stdin env; 115 + output = Eio.Stdenv.stdout env; 116 + } 127 117 128 - let send io packet = 129 - Message.write io packet 118 + let recv io = Message.read io 119 + let send io packet = Message.write io packet
+62 -70
lib/language_server/Lsp_server.ml
··· 18 18 19 19 let () = 20 20 Printexc.register_printer @@ function 21 - | Lsp_error (Decode_error err) -> 22 - Some (Format.asprintf "Lsp Error: Couldn't decode %s" err) 23 - | Lsp_error (Handshake_error err) -> 24 - Some (Format.asprintf "Lsp Error: Invalid initialization handshake %s" err) 25 - | Lsp_error (Shutdown_error err) -> 26 - Some (Format.asprintf "Lsp Error: Invalid shutdown sequence %s" err) 27 - | Lsp_error (Unknown_request err) -> 28 - Some (Format.asprintf "Lsp Error: Unknown request %s" err) 29 - | Lsp_error (Unknown_notification err) -> 30 - Some (Format.asprintf "Lsp Error: Unknown notification %s" err) 31 - | _ -> None 21 + | Lsp_error (Decode_error err) -> 22 + Some (Format.asprintf "Lsp Error: Couldn't decode %s" err) 23 + | Lsp_error (Handshake_error err) -> 24 + Some (Format.asprintf "Lsp Error: Invalid initialization handshake %s" err) 25 + | Lsp_error (Shutdown_error err) -> 26 + Some (Format.asprintf "Lsp Error: Invalid shutdown sequence %s" err) 27 + | Lsp_error (Unknown_request err) -> 28 + Some (Format.asprintf "Lsp Error: Unknown request %s" err) 29 + | Lsp_error (Unknown_notification err) -> 30 + Some (Format.asprintf "Lsp Error: Unknown notification %s" err) 31 + | _ -> None 32 32 33 33 let recv () = 34 34 let server = Lsp_state.get () in ··· 47 47 48 48 (* I don't understand this request...*) 49 49 let document_link_resolve (params : L.DocumentLink.t) = 50 - match params with 51 - | link -> link 50 + match params with link -> link 52 51 53 52 module Request = struct 54 53 type 'resp t = 'resp Lsp.Client_request.t 55 54 type packed = Lsp_Request.packed 56 55 57 - let dispatch : type resp. string -> resp Lsp.Client_request.t -> resp = fun mthd -> 58 - function 59 - | Initialize _ -> 60 - let err = "Server can only recieve a single initialization request." in 61 - raise @@ Lsp_error (Handshake_error err) 62 - | Shutdown -> initiate_shutdown () 63 - | CodeAction params -> Code_action.compute params 64 - | CodeActionResolve params -> Code_action.resolve params 65 - (* | ExecuteCommand params -> Code_action.execute params *) 66 - | TextDocumentHover params -> Hover.compute params 67 - | TextDocumentCompletion params -> Completion.compute params 68 - | InlayHint params -> Inlay_hint.compute params 69 - | TextDocumentDefinition params -> Definitions.compute params 70 - | DocumentSymbol params -> Document_symbols.compute params 71 - | TextDocumentLink params -> Document_link.compute params 72 - | TextDocumentLinkResolve params -> document_link_resolve params 73 - | WorkspaceSymbol params -> Workspace_symbols.compute params 74 - | TextDocumentPrepareCallHierarchy params -> Call_hierarchy.compute params 75 - | CallHierarchyIncomingCalls params -> Call_hierarchy.incoming params 76 - | CallHierarchyOutgoingCalls params -> Call_hierarchy.outgoing params 77 - | TextDocumentCodeLens params -> Code_lens.compute params 78 - | SemanticTokensFull params -> Semantic_tokens.on_full_request params 79 - | SemanticTokensDelta params -> Semantic_tokens.on_delta_request params 80 - | _ -> 81 - raise @@ Lsp_error (Unknown_request mthd) 56 + let dispatch : type resp. string -> resp Lsp.Client_request.t -> resp = 57 + fun mthd -> function 58 + | Initialize _ -> 59 + let err = "Server can only recieve a single initialization request." in 60 + raise @@ Lsp_error (Handshake_error err) 61 + | Shutdown -> initiate_shutdown () 62 + | CodeAction params -> Code_action.compute params 63 + | CodeActionResolve params -> Code_action.resolve params 64 + (* | ExecuteCommand params -> Code_action.execute params *) 65 + | TextDocumentHover params -> Hover.compute params 66 + | TextDocumentCompletion params -> Completion.compute params 67 + | InlayHint params -> Inlay_hint.compute params 68 + | TextDocumentDefinition params -> Definitions.compute params 69 + | DocumentSymbol params -> Document_symbols.compute params 70 + | TextDocumentLink params -> Document_link.compute params 71 + | TextDocumentLinkResolve params -> document_link_resolve params 72 + | WorkspaceSymbol params -> Workspace_symbols.compute params 73 + | TextDocumentPrepareCallHierarchy params -> Call_hierarchy.compute params 74 + | CallHierarchyIncomingCalls params -> Call_hierarchy.incoming params 75 + | CallHierarchyOutgoingCalls params -> Call_hierarchy.outgoing params 76 + | TextDocumentCodeLens params -> Code_lens.compute params 77 + | SemanticTokensFull params -> Semantic_tokens.on_full_request params 78 + | SemanticTokensDelta params -> Semantic_tokens.on_delta_request params 79 + | _ -> raise @@ Lsp_error (Unknown_request mthd) 82 80 83 81 let handle (msg : RPC.Request.t) = 84 82 Eio.traceln "Request: %s@." msg.method_; ··· 87 85 let resp = dispatch msg.method_ r in 88 86 let json = Lsp_Request.yojson_of_result r resp in 89 87 RPC.Response.ok msg.id json 90 - | Error err -> 91 - raise (Lsp_error (Decode_error err)) 88 + | Error err -> raise (Lsp_error (Decode_error err)) 92 89 93 90 let recv () = 94 91 Option.bind (recv ()) @@ function 95 - | RPC.Packet.Request req -> 96 - begin 97 - match Lsp_Request.of_jsonrpc req with 98 - | Ok packed -> Some (req.id, packed) 99 - | Error err -> raise @@ Lsp_error (Decode_error err) 100 - end 101 - | _ -> None 92 + | RPC.Packet.Request req -> begin 93 + match Lsp_Request.of_jsonrpc req with 94 + | Ok packed -> Some (req.id, packed) 95 + | Error err -> raise @@ Lsp_error (Decode_error err) 96 + end 97 + | _ -> None 102 98 103 99 let respond id req resp = 104 100 let json = Lsp_Request.yojson_of_result req resp in ··· 108 104 module Notification = struct 109 105 type t = Lsp.Client_notification.t 110 106 111 - let dispatch : string -> t -> unit = fun mthd -> 112 - function 113 - | TextDocumentDidOpen params -> Did_open.compute params 114 - | TextDocumentDidChange params -> Did_change.compute params 115 - | ChangeConfiguration params -> Change_configuration.compute params 116 - (* | DidCreateFiles params -> Did_create_files.compute params *) 117 - | DidSaveTextDocument _ -> () 118 - | TextDocumentDidClose _ -> () 119 - | CancelRequest _ -> () 120 - | _ -> raise @@ Lsp_error (Unknown_notification mthd) 107 + let dispatch : string -> t -> unit = 108 + fun mthd -> function 109 + | TextDocumentDidOpen params -> Did_open.compute params 110 + | TextDocumentDidChange params -> Did_change.compute params 111 + | ChangeConfiguration params -> Change_configuration.compute params 112 + (* | DidCreateFiles params -> Did_create_files.compute params *) 113 + | DidSaveTextDocument _ -> () 114 + | TextDocumentDidClose _ -> () 115 + | CancelRequest _ -> () 116 + | _ -> raise @@ Lsp_error (Unknown_notification mthd) 121 117 122 118 let handle (msg : RPC.Notification.t) = 123 119 Eio.traceln "Request: %s@." msg.method_; 124 120 match Lsp_Notification.of_jsonrpc msg with 125 - | Ok notif -> 126 - dispatch msg.method_ notif 127 - | Error err -> 128 - raise @@ Lsp_error (Decode_error err) 121 + | Ok notif -> dispatch msg.method_ notif 122 + | Error err -> raise @@ Lsp_error (Decode_error err) 129 123 130 124 let recv () = 131 125 Option.bind (recv ()) @@ function 132 - | RPC.Packet.Notification msg -> 133 - begin 134 - match Lsp_Notification.of_jsonrpc msg with 135 - | Ok notif -> Some notif 136 - | Error err -> raise @@ Lsp_error (Decode_error err) 137 - end 138 - | _ -> None 126 + | RPC.Packet.Notification msg -> begin 127 + match Lsp_Notification.of_jsonrpc msg with 128 + | Ok notif -> Some notif 129 + | Error err -> raise @@ Lsp_error (Decode_error err) 130 + end 131 + | _ -> None 139 132 end 140 133 141 - let run ~init k = 142 - Lsp_state.run ~init k 134 + let run ~init k = Lsp_state.run ~init k
+1 -3
lib/language_server/Lsp_server.mli
··· 9 9 10 10 val recv : unit -> Jsonrpc.Packet.t option 11 11 val send : Jsonrpc.Packet.t -> unit 12 - 13 12 val should_shutdown : unit -> bool 14 13 val initiate_shutdown : unit -> unit 15 - 16 - val run : init: Lsp_state.state -> (unit -> 'a) -> 'a 14 + val run : init:Lsp_state.state -> (unit -> 'a) -> 'a 17 15 18 16 module Request : sig 19 17 type packed = Lsp.Client_request.packed
+15 -16
lib/language_server/Lsp_shims.ml
··· 5 5 * 6 6 *) 7 7 8 - open struct module L = Lsp.Types end 8 + open struct 9 + module L = Lsp.Types 10 + end 9 11 10 12 module Loc = struct 11 13 let lsp_pos_of_pos (pos : Asai.Range.position) = 12 - L.Position.create 13 - ~line: (pos.line_num - 1) 14 - ~character: (pos.offset - pos.start_of_line) 14 + L.Position.create ~line:(pos.line_num - 1) 15 + ~character:(pos.offset - pos.start_of_line) 15 16 16 17 let lsp_range_of_range (r : Asai.Range.t option) = 17 18 match r with 18 19 | Some r -> 19 - let (start, stop) = 20 + let start, stop = 20 21 match Asai.Range.view r with 21 - | `Range (start, stop) -> start, stop 22 - | `End_of_file pos -> pos, pos 22 + | `Range (start, stop) -> (start, stop) 23 + | `End_of_file pos -> (pos, pos) 23 24 in 24 - L.Range.create 25 - ~start: (lsp_pos_of_pos start) 26 - ~end_: (lsp_pos_of_pos stop) 25 + L.Range.create ~start:(lsp_pos_of_pos start) ~end_:(lsp_pos_of_pos stop) 27 26 | None -> 28 - (* When we have a message without a location, 29 - we set it's location to the start of the file, 30 - as we don't have any better choices. *) 31 - let start_of_file = L.Position.create ~line: 0 ~character: 0 in 32 - L.Range.create ~start: start_of_file ~end_: start_of_file 27 + (* When we have a message without a location, we set it's location to the 28 + start of the file, as we don't have any better choices. *) 29 + let start_of_file = L.Position.create ~line:0 ~character:0 in 30 + L.Range.create ~start:start_of_file ~end_:start_of_file 33 31 end 34 32 35 33 module Diagnostic = struct 36 - let lsp_severity_of_severity : Asai.Diagnostic.severity -> L.DiagnosticSeverity.t = function 34 + let lsp_severity_of_severity : 35 + Asai.Diagnostic.severity -> L.DiagnosticSeverity.t = function 37 36 | Hint -> Hint 38 37 | Info -> Information 39 38 | Warning -> Warning
+5 -6
lib/language_server/Lsp_state.ml
··· 7 7 8 8 open Forester_compiler 9 9 10 - type state = { 11 - forest: State.t; 12 - should_shutdown: bool; 13 - lsp_io: LspEio.io; 14 - } 10 + type state = {forest: State.t; should_shutdown: bool; lsp_io: LspEio.io} 11 + 12 + module M = Algaeff.State.Make (struct 13 + type t = state 14 + end) 15 15 16 - module M = Algaeff.State.Make(struct type t = state end) 17 16 include M
+16 -8
lib/language_server/Publish.ml
··· 17 17 end 18 18 19 19 type diagnostic = Reporter.Message.t Asai.Diagnostic.t 20 - 21 20 type table = (Lsp.Uri.t, diagnostic list) Hashtbl.t 22 21 23 22 let send packet = 24 23 let server = Lsp_state.get () in 25 24 LspEio.send server.lsp_io packet 26 25 27 - let render_lsp_related_info (uri : L.DocumentUri.t) (message : Asai.Diagnostic.loctext) : L.DiagnosticRelatedInformation.t = 26 + let render_lsp_related_info (uri : L.DocumentUri.t) 27 + (message : Asai.Diagnostic.loctext) : L.DiagnosticRelatedInformation.t = 28 28 let range = Lsp_shims.Loc.lsp_range_of_range message.loc in 29 29 let location = L.Location.create ~uri ~range in 30 30 let message = Asai.Diagnostic.string_of_text message.value in 31 31 L.DiagnosticRelatedInformation.create ~location ~message 32 32 33 - let render_lsp_diagnostic (uri : L.DocumentUri.t) (diag : diagnostic) : Lsp_Diagnostic.t = 33 + let render_lsp_diagnostic (uri : L.DocumentUri.t) (diag : diagnostic) : 34 + Lsp_Diagnostic.t = 34 35 let range = Lsp_shims.Loc.lsp_range_of_range diag.explanation.loc in 35 - let severity = Lsp_shims.Diagnostic.lsp_severity_of_severity @@ diag.severity in 36 + let severity = 37 + Lsp_shims.Diagnostic.lsp_severity_of_severity @@ diag.severity 38 + in 36 39 let code = `String (Reporter.Message.short_code diag.message) in 37 40 let source = 38 41 let Lsp_state.{forest; _} = Lsp_state.get () in 39 - let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url uri in 40 - let@ doc = Option.map @~ Option.bind (State.find_opt forest uri) Tree.to_doc in 42 + let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url uri in 43 + let@ doc = 44 + Option.map @~ Option.bind (State.find_opt forest uri) Tree.to_doc 45 + in 41 46 Lsp.Text_document.text doc 42 47 in 43 48 let message = Asai.Diagnostic.string_of_text diag.explanation.value in 44 - let relatedInformation = Bwd.to_list @@ Bwd.map (render_lsp_related_info uri) diag.extra_remarks in 45 - Lsp_Diagnostic.create ~range ~severity ~code ?source ~message: (`String message) ~relatedInformation () 49 + let relatedInformation = 50 + Bwd.to_list @@ Bwd.map (render_lsp_related_info uri) diag.extra_remarks 51 + in 52 + Lsp_Diagnostic.create ~range ~severity ~code ?source 53 + ~message:(`String message) ~relatedInformation () 46 54 47 55 let broadcast notif = 48 56 let msg = Broadcast.to_jsonrpc notif in
+117 -122
lib/language_server/Semantic_tokens.ml
··· 9 9 open Forester_core 10 10 open Forester_compiler 11 11 12 - open struct module L = Lsp.Types end 12 + open struct 13 + module L = Lsp.Types 14 + end 13 15 14 16 let print_array = 15 - Format.( 16 - pp_print_array 17 - ~pp_sep: (fun out () -> fprintf out "; ") 18 - pp_print_int 19 - ) 17 + Format.(pp_print_array ~pp_sep:(fun out () -> fprintf out "; ") pp_print_int) 20 18 21 19 module Token_type = struct 22 20 type t = L.SemanticTokenTypes.t 23 - let legend : L.SemanticTokenTypes.t list = [ 24 - Namespace; 25 - Type; 26 - Class; 27 - Enum; 28 - Interface; 29 - Struct; 30 - TypeParameter; 31 - Parameter; 32 - Variable; 33 - Property; 34 - EnumMember; 35 - Event; 36 - Function; 37 - Method; 38 - Macro; 39 - Keyword; 40 - Modifier; 41 - Comment; 42 - String; 43 - Number; 44 - Regexp; 45 - Operator; 46 - Decorator 47 - ] 21 + 22 + let legend : L.SemanticTokenTypes.t list = 23 + [ 24 + Namespace; 25 + Type; 26 + Class; 27 + Enum; 28 + Interface; 29 + Struct; 30 + TypeParameter; 31 + Parameter; 32 + Variable; 33 + Property; 34 + EnumMember; 35 + Event; 36 + Function; 37 + Method; 38 + Macro; 39 + Keyword; 40 + Modifier; 41 + Comment; 42 + String; 43 + Number; 44 + Regexp; 45 + Operator; 46 + Decorator; 47 + ] 48 + 48 49 let of_builtin t = t 49 50 50 51 let token_types = ··· 52 53 (fun s -> 53 54 match L.SemanticTokenTypes.yojson_of_t s with 54 55 | `String s -> s 55 - | _ -> assert false 56 - ) 56 + | _ -> assert false) 57 57 legend 58 58 59 59 let to_int = 60 60 let module Table = MoreLabels.Hashtbl in 61 61 let table = 62 - lazy( 63 - let t = Table.create (List.length legend) in 64 - List.iteri (fun data key -> Table.add t ~key ~data) legend; 65 - t 66 - ) 62 + lazy 63 + (let t = Table.create (List.length legend) in 64 + List.iteri (fun data key -> Table.add t ~key ~data) legend; 65 + t) 67 66 in 68 67 fun t -> Table.find (Lazy.force table) t 69 68 ··· 74 73 end 75 74 76 75 module Token_modifiers_set = struct 77 - let list = [ 78 - "declaration"; 79 - "definition"; 80 - "readonly"; 81 - "static"; 82 - "deprecated"; 83 - "abstract"; 84 - "async"; 85 - "modification"; 86 - "documentation"; 87 - "defaultLibrary" 88 - ] 89 - ;; 76 + let list = 77 + [ 78 + "declaration"; 79 + "definition"; 80 + "readonly"; 81 + "static"; 82 + "deprecated"; 83 + "abstract"; 84 + "async"; 85 + "modification"; 86 + "documentation"; 87 + "defaultLibrary"; 88 + ] 90 89 end 91 90 92 91 let legend = 93 - L.SemanticTokensLegend.create 94 - ~tokenTypes: Token_type.token_types 95 - ~tokenModifiers: Token_modifiers_set.list 92 + L.SemanticTokensLegend.create ~tokenTypes:Token_type.token_types 93 + ~tokenModifiers:Token_modifiers_set.list 96 94 97 95 type token = { 98 96 (* node: string; *) ··· 134 132 let node_to_tokens (_ : Code.node Range.located) _ _list = [] 135 133 136 134 let tokenize_path ~(start : L.Position.t) (path : string list) : token list = 137 - let offset = ref (start.character) in 135 + let offset = ref start.character in 138 136 Eio.traceln "path has %i segments" (List.length path); 139 137 let@ segment = List.concat_map @~ path in 140 138 let length = String.length segment in ··· 150 148 token_type; 151 149 token_modifiers = 0; 152 150 (* node = segment *) 153 - } 151 + }; 154 152 ] 155 153 156 154 let shift offset = 157 - List.map @@ fun token -> 158 - {token with start_char = token.start_char + offset} 155 + List.map @@ fun token -> {token with start_char = token.start_char + offset} 159 156 160 157 let builtin ~(start : L.Position.t) str tks = 161 158 let offset = String.length str in ··· 165 162 start_char = start.character; 166 163 length = offset; 167 164 token_type = 5; 168 - token_modifiers = 0 169 - } :: shift offset tks 165 + token_modifiers = 0; 166 + } 167 + :: shift offset tks 170 168 171 169 let tokens (nodes : Code.t) : token list = 172 170 let@ Range.{loc; value} = List.concat_map @~ nodes in 173 171 let L.Range.{start; end_} = Lsp_shims.Loc.lsp_range_of_range loc in 174 172 (* Multiline tokens not supported*) 175 - if start.line <> end_.line then 176 - [] 173 + if start.line <> end_.line then [] 177 174 else 178 175 match value with 179 - | Code.Ident path -> 180 - tokenize_path ~start path 176 + | Code.Ident path -> tokenize_path ~start path 181 177 | Code.Text _ -> [] 182 178 | Code.Put (_path, _t) -> [] 183 179 (* -> *) ··· 194 190 | Code.Hash_ident _ 195 191 | Code.Xml_ident (_, _) 196 192 | Code.Subtree (_, _) 197 - | Code.Open _ 198 - | Code.Scope _ 193 + | Code.Open _ | Code.Scope _ 199 194 | Code.Default (_, _) 200 195 | Code.Get _ 201 196 | Code.Fun (_, _) 202 - | Code.Object _ 203 - | Code.Patch _ 197 + | Code.Object _ | Code.Patch _ 204 198 | Code.Call (_, _) 205 199 | Code.Decl_xmlns (_, _) 206 200 | Code.Alloc _ 207 201 | Code.Dx_sequent (_, _) 208 202 | Code.Dx_query (_, _, _) 209 203 | Code.Dx_prop (_, _) 210 - | Code.Dx_var _ 211 - | Code.Dx_const_content _ 212 - | Code.Dx_const_uri _ 213 - | Code.Error _ 214 - | Code.Comment _ 204 + | Code.Dx_var _ | Code.Dx_const_content _ | Code.Dx_const_uri _ 205 + | Code.Error _ | Code.Comment _ 215 206 | Code.Namespace (_, _) -> 216 207 [] 217 208 218 - let process_line_delta (index_of_last_line : int option) (tokens : token list) : int * delta_token list = 209 + let process_line_delta (index_of_last_line : int option) (tokens : token list) : 210 + int * delta_token list = 219 211 let line = (List.hd tokens).line in 220 212 let deltas = 221 213 List.fold_left 222 - (fun 223 - (last_token, acc) 224 - ({start_char; 225 - length; 226 - token_type; 227 - token_modifiers; 228 - line; 229 - _; 230 - } as current_token) 231 - -> 214 + (fun (last_token, acc) 215 + ({start_char; length; token_type; token_modifiers; line; _} as 216 + current_token) -> 232 217 match last_token with 233 218 | None -> 234 - let delta_line = match index_of_last_line with Some i -> i - line | None -> line in 219 + let delta_line = 220 + match index_of_last_line with Some i -> i - line | None -> line 221 + in 235 222 let delta_start_char = start_char in 236 - let t = {delta_line; delta_start_char; length; token_type; token_modifiers} in 223 + let t = 224 + {delta_line; delta_start_char; length; token_type; token_modifiers} 225 + in 237 226 (Some current_token, t :: acc) 238 227 | Some last_token -> 239 228 (*If there is a previous token, we know we are still on the same line*) 240 229 let delta_line = current_token.line - last_token.line in 241 - let delta_start_char = if delta_line > 0 then current_token.start_char else current_token.start_char - last_token.start_char in 242 - let delta = {delta_line; delta_start_char; length = current_token.length; token_type = current_token.token_type; token_modifiers;} in 243 - (Some current_token, delta :: acc) 244 - ) 245 - (None, []) 246 - tokens 230 + let delta_start_char = 231 + if delta_line > 0 then current_token.start_char 232 + else current_token.start_char - last_token.start_char 233 + in 234 + let delta = 235 + { 236 + delta_line; 237 + delta_start_char; 238 + length = current_token.length; 239 + token_type = current_token.token_type; 240 + token_modifiers; 241 + } 242 + in 243 + (Some current_token, delta :: acc)) 244 + (None, []) tokens 247 245 in 248 - line, snd deltas |> List.rev 246 + (line, snd deltas |> List.rev) 249 247 250 248 let delta_tokens (tokens : token list list) : int array = 251 249 tokens 252 250 |> List.fold_left 253 - (fun (last_line, acc) tokens_on_line -> 254 - let line, delta_tokens = process_line_delta last_line tokens_on_line in 255 - Some line, delta_tokens :: acc 256 - ) 257 - (None, []) 258 - |> snd 259 - |> List.rev 260 - |> List.concat 251 + (fun (last_line, acc) tokens_on_line -> 252 + let line, delta_tokens = process_line_delta last_line tokens_on_line in 253 + (Some line, delta_tokens :: acc)) 254 + (None, []) 255 + |> snd |> List.rev |> List.concat 261 256 |> List.concat_map encode_deltas 262 - |> List.rev 263 - |> Array.of_list 257 + |> List.rev |> Array.of_list 264 258 265 - let semantic_tokens_delta (_code : Code.node Range.located list) : L.SemanticTokensDelta.t = { 266 - L.SemanticTokensDelta.resultId = None; 267 - edits = []; 268 - } 259 + let semantic_tokens_delta (_code : Code.node Range.located list) : 260 + L.SemanticTokensDelta.t = 261 + {L.SemanticTokensDelta.resultId = None; edits = []} 269 262 270 - let tokenize_document (identifier : L.TextDocumentIdentifier.t) : L.SemanticTokens.t option = 263 + let tokenize_document (identifier : L.TextDocumentIdentifier.t) : 264 + L.SemanticTokens.t option = 271 265 let Lsp_state.{forest; _} = Lsp_state.get () in 272 - let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url identifier.uri in 266 + let uri = URI_scheme.lsp_uri_to_uri ~base:forest.config.url identifier.uri in 273 267 let@ {nodes; _} = Option.map @~ Imports.resolve_uri_to_code forest uri in 274 268 let tokens = tokens nodes in 275 269 Format.( 276 - Eio.traceln 277 - "%a" 278 - ( 279 - pp_print_list 280 - ~pp_sep: (fun out () -> fprintf out "; ") 281 - pp_token 282 - ) 283 - tokens 284 - ); 270 + Eio.traceln "%a" 271 + (pp_print_list ~pp_sep:(fun out () -> fprintf out "; ") pp_token) 272 + tokens); 285 273 let encoded = List.concat_map encode tokens in 286 274 let data = Array.of_list @@ encoded in 287 275 L.SemanticTokens.{data; resultId = None} 288 276 289 - let tokenize_document_delta (textDocument : L.TextDocumentIdentifier.t) : L.SemanticTokensDelta.t option = 277 + let tokenize_document_delta (textDocument : L.TextDocumentIdentifier.t) : 278 + L.SemanticTokensDelta.t option = 290 279 let Lsp_state.{forest; _} = Lsp_state.get () in 291 - let uri = URI_scheme.lsp_uri_to_uri ~base: forest.config.url textDocument.uri in 280 + let uri = 281 + URI_scheme.lsp_uri_to_uri ~base:forest.config.url textDocument.uri 282 + in 292 283 let@ tree = Option.map @~ Imports.resolve_uri_to_code forest uri in 293 284 semantic_tokens_delta tree.nodes 294 285 295 - let on_full_request (params : L.SemanticTokensParams.t) : L.SemanticTokens.t option = 286 + let on_full_request (params : L.SemanticTokensParams.t) : 287 + L.SemanticTokens.t option = 296 288 tokenize_document params.textDocument 297 289 298 - let on_delta_request (params : L.SemanticTokensDeltaParams.t) : [`SemanticTokens of L.SemanticTokens.t | `SemanticTokensDelta of L.SemanticTokensDelta.t] option = 290 + let on_delta_request (params : L.SemanticTokensDeltaParams.t) : 291 + [ `SemanticTokens of L.SemanticTokens.t 292 + | `SemanticTokensDelta of L.SemanticTokensDelta.t ] 293 + option = 299 294 let@ tokens = Option.map @~ tokenize_document_delta params.textDocument in 300 295 `SemanticTokensDelta tokens
+5 -3
lib/language_server/Util.ml
··· 4 4 * SPDX-License-Identifier: GPL-3.0-or-later 5 5 *) 6 6 7 - open struct module L = Lsp.Types end 7 + open struct 8 + module L = Lsp.Types 9 + end 8 10 9 11 let start_of_file = 10 - let beginning = L.Position.create ~character: 0 ~line: 0 in 11 - L.Range.create ~start: beginning ~end_: beginning 12 + let beginning = L.Position.create ~character:0 ~line:0 in 13 + L.Range.create ~start:beginning ~end_:beginning
+55 -66
lib/language_server/Workspace_symbols.ml
··· 13 13 open struct 14 14 module L = Lsp.Types 15 15 module Unit_map = Forester_compiler.Expand.Unit_map 16 - let (let*) = Option.bind 16 + 17 + let ( let* ) = Option.bind 17 18 end 18 19 19 20 let location_of_range loc = 20 21 let* view = Option.map Range.view loc in 21 22 match view with 22 - | `End_of_file {source; _} 23 - | `Range ({source; _}, _) -> 23 + | `End_of_file {source; _} | `Range ({source; _}, _) -> ( 24 24 match source with 25 25 | `String _ | `File "" -> None 26 26 | `File path -> 27 27 let uri = Lsp.Uri.of_path path in 28 - Option.some @@ L.Location.{range = Lsp_shims.Loc.lsp_range_of_range loc; uri;} 28 + Option.some 29 + @@ L.Location.{range = Lsp_shims.Loc.lsp_range_of_range loc; uri}) 29 30 30 31 let exports_to_symbols (exports : Tree.exports) = 31 - let@ path, (data, range) = List.filter_map @~ List.of_seq @@ Trie.to_seq exports in 32 + let@ path, (data, range) = 33 + List.filter_map @~ List.of_seq @@ Trie.to_seq exports 34 + in 32 35 let@ location = Option.map @~ location_of_range range in 33 36 match data with 34 37 | Xmlns _ -> 35 - L.SymbolInformation.create 36 - ~kind: Namespace 37 - ~location 38 - ~name: (Format.asprintf "%a" Resolver.Scope.pp_path path) 38 + L.SymbolInformation.create ~kind:Namespace ~location 39 + ~name:(Format.asprintf "%a" Resolver.Scope.pp_path path) 39 40 () 40 41 | Term syn -> 41 42 let kind = ··· 48 49 | Syn.Math (_, _) 49 50 | Syn.Link _ 50 51 | Syn.Subtree (_, _) 51 - | Syn.Var _ 52 - | Syn.Sym _ 52 + | Syn.Var _ | Syn.Sym _ 53 53 | Syn.Put (_, _, _) 54 54 | Syn.Default (_, _, _) 55 55 | Syn.Get _ 56 56 | Syn.Xml_tag (_, _, _) 57 - | Syn.TeX_cs _ 58 - | Syn.Unresolved_ident _ 59 - | Syn.Prim _ 60 - | Syn.Patch _ 57 + | Syn.TeX_cs _ | Syn.Unresolved_ident _ | Syn.Prim _ | Syn.Patch _ 61 58 | Syn.Call (_, _) 62 - | Syn.Results_of_query 63 - | Syn.Transclude 64 - | Syn.Embed_tex 65 - | Syn.Ref 66 - | Syn.Title 67 - | Syn.Parent 68 - | Syn.Taxon 69 - | Syn.Meta 59 + | Syn.Results_of_query | Syn.Transclude | Syn.Embed_tex | Syn.Ref 60 + | Syn.Title | Syn.Parent | Syn.Taxon | Syn.Meta 70 61 | Syn.Attribution (_, _) 71 - | Syn.Tag _ 72 - | Syn.Date 73 - | Syn.Number 62 + | Syn.Tag _ | Syn.Date | Syn.Number 74 63 | Syn.Dx_sequent (_, _) 75 64 | Syn.Dx_query (_, _, _) 76 65 | Syn.Dx_prop (_, _) 77 66 | Syn.Dx_var _ 78 67 | Syn.Dx_const (_, _) 79 - | Syn.Dx_execute 80 - | Syn.Route_asset 68 + | Syn.Dx_execute | Syn.Route_asset 81 69 | Syn.Syndicate_current_tree_as_atom_feed 82 - | Syn.Syndicate_query_as_json_blob 83 - | Syn.Current_tree -> 70 + | Syn.Syndicate_query_as_json_blob | Syn.Current_tree -> 84 71 Constant 85 72 in 86 - L.SymbolInformation.create 87 - ~kind 88 - ~location 89 - ~name: (Format.asprintf "%a" Resolver.Scope.pp_path path) 73 + L.SymbolInformation.create ~kind ~location 74 + ~name:(Format.asprintf "%a" Resolver.Scope.pp_path path) 90 75 () 91 76 92 77 let contains_substring_case_insensitive ~pattern text = 93 78 let text = String.lowercase_ascii text 94 - and pattern = String.lowercase_ascii pattern 95 - in 96 - let n = String.length text 97 - and m = String.length pattern 98 - in 79 + and pattern = String.lowercase_ascii pattern in 80 + let n = String.length text and m = String.length pattern in 99 81 let rec search i = 100 82 if i + m > n then false 101 83 else if String.sub text i m = pattern then true ··· 106 88 let fuzzy_match ~pattern text = 107 89 let pattern = String.lowercase_ascii pattern in 108 90 let text = String.lowercase_ascii text in 109 - let n = String.length text 110 - and m = String.length pattern 111 - in 91 + let n = String.length text and m = String.length pattern in 112 92 if n = 0 then false 113 93 else 114 94 let rec aux i j = 115 95 if j = m then true (* matched entire pattern *) 116 96 else if i = n then false (* text exhausted first *) 117 - else if text.[i] = pattern.[j] then 118 - aux (i + 1) (j + 1) (* match, advance both *) 119 - else 120 - aux (i + 1) j (* skip char in text *) 97 + else if text.[i] = pattern.[j] then aux (i + 1) (j + 1) 98 + (* match, advance both *) 99 + else aux (i + 1) j (* skip char in text *) 121 100 in 122 101 aux 0 0 123 102 124 - (* We no longer show exported functions, as this is really gumming up the editor interfaces. *) 103 + (* We no longer show exported functions, as this is really gumming up the editor 104 + interfaces. *) 125 105 let compute (params : L.WorkspaceSymbolParams.t) : _ = 126 106 Logs.debug (fun m -> m "QUERY: %s" params.query); 127 107 let Lsp_state.{forest; _} = Lsp_state.get () in 128 108 let render = Plain_text_client.string_of_content ~forest in 129 - Option.some @@ 130 - let@ uri, item = List.concat_map @~ List.of_seq @@ State.to_seq forest in 131 - let@ {frontmatter; _} = List.concat_map @~ Option.to_list (Tree.to_article item) in 132 - let title = render @@ State.get_expanded_title frontmatter forest in 133 - let@ () = List.concat_map @~ if fuzzy_match ~pattern: params.query title then [()] else [] in 134 - let@ file_symbol = 135 - List.concat_map @~ 136 - Option.to_list @@ 137 - let@ source_path = Option.map @~ State.source_path_of_uri uri forest in 138 - let lsp_uri = Lsp.Uri.of_string source_path in 139 - let location = 140 - L.Location.{ 141 - range = L.Range.{ 142 - end_ = {character = 0; line = 0;}; 143 - start = {character = 0; line = 0;}; 144 - }; 109 + Option.some 110 + @@ 111 + let@ uri, item = List.concat_map @~ List.of_seq @@ State.to_seq forest in 112 + let@ {frontmatter; _} = 113 + List.concat_map @~ Option.to_list (Tree.to_article item) 114 + in 115 + let title = render @@ State.get_expanded_title frontmatter forest in 116 + let@ () = 117 + List.concat_map 118 + @~ if fuzzy_match ~pattern:params.query title then [()] else [] 119 + in 120 + let@ file_symbol = 121 + List.concat_map @~ Option.to_list 122 + @@ 123 + let@ source_path = Option.map @~ State.source_path_of_uri uri forest in 124 + let lsp_uri = Lsp.Uri.of_string source_path in 125 + let location = 126 + L.Location. 127 + { 128 + range = 129 + L.Range. 130 + { 131 + end_ = {character = 0; line = 0}; 132 + start = {character = 0; line = 0}; 133 + }; 145 134 uri = lsp_uri; 146 135 } 147 - in 148 - L.SymbolInformation.create ~kind: File ~location ~name: title () 149 136 in 150 - [file_symbol] 137 + L.SymbolInformation.create ~kind:File ~location ~name:title () 138 + in 139 + [file_symbol]
+62 -87
lib/parser/Parse.ml
··· 7 7 open Forester_prelude 8 8 open Forester_core 9 9 open Lexing 10 - 11 10 module I = Grammar.MenhirInterpreter 12 11 13 12 let buffer_lexer lexer = ··· 15 14 let rec loop lexbuf = 16 15 match !buf with 17 16 | v :: vs -> 18 - buf := vs; v 19 - | [] -> 17 + buf := vs; 18 + v 19 + | [] -> ( 20 20 match lexer lexbuf with 21 - | v :: vs -> buf := vs @ !buf; v 22 - | [] -> loop lexbuf 21 + | v :: vs -> 22 + buf := vs @ !buf; 23 + v 24 + | [] -> loop lexbuf) 23 25 in 24 26 loop 25 27 ··· 31 33 | Ident_fragments -> Lexer.ident_fragments lexbuf 32 34 | Verbatim (herald, buffer) -> Lexer.verbatim herald buffer lexbuf 33 35 34 - let _get_range 35 - : I.element option -> (position * position) option 36 - = fun el -> 36 + let _get_range : I.element option -> (position * position) option = 37 + fun el -> 37 38 match el with 38 - | Some (I.Element (_, _, start_pos, end_pos)) -> 39 - Some (start_pos, end_pos) 39 + | Some (I.Element (_, _, start_pos, end_pos)) -> Some (start_pos, end_pos) 40 40 | None -> None 41 41 42 42 let closed_by c o = 43 43 match (o, c) with 44 - | (Grammar.LSQUARE, Grammar.RSQUARE) 45 - | (Grammar.LPAREN, Grammar.RPAREN) 46 - | (Grammar.LBRACE, Grammar.RBRACE) 47 - | (Grammar.HASH_LBRACE, Grammar.RBRACE) 48 - | (Grammar.HASH_HASH_LBRACE, Grammar.RBRACE) -> 44 + | Grammar.LSQUARE, Grammar.RSQUARE 45 + | Grammar.LPAREN, Grammar.RPAREN 46 + | Grammar.LBRACE, Grammar.RBRACE 47 + | Grammar.HASH_LBRACE, Grammar.RBRACE 48 + | Grammar.HASH_HASH_LBRACE, Grammar.RBRACE -> 49 49 true 50 50 | _ -> false 51 51 52 52 let is_opening_delim = function 53 - | Grammar.LSQUARE 54 - | Grammar.LPAREN 55 - | Grammar.LBRACE 56 - | Grammar.HASH_LBRACE 53 + | Grammar.LSQUARE | Grammar.LPAREN | Grammar.LBRACE | Grammar.HASH_LBRACE 57 54 | Grammar.HASH_HASH_LBRACE -> 58 55 true 59 56 | _ -> false 60 57 61 58 let is_closing_delim = function 62 - | Grammar.RSQUARE 63 - | Grammar.RPAREN 64 - | Grammar.RBRACE -> 65 - true 59 + | Grammar.RSQUARE | Grammar.RPAREN | Grammar.RBRACE -> true 66 60 | _ -> false 67 61 68 - let parse 69 - : ?stop_on_err: bool -> 70 - lexbuf -> 71 - (Code.t, Reporter.diagnostic) Result.t 72 - = fun ?(stop_on_err = true) lexbuf -> 73 - let initial_checkpoint = (Grammar.Incremental.main lexbuf.lex_curr_p) in 62 + let parse : 63 + ?stop_on_err:bool -> lexbuf -> (Code.t, Reporter.diagnostic) Result.t = 64 + fun ?(stop_on_err = true) lexbuf -> 65 + let initial_checkpoint = Grammar.Incremental.main lexbuf.lex_curr_p in 74 66 let delim_stack = Stack.create () in 75 - let rec run 76 - : _ I.checkpoint -> 77 - _ -> 78 - (Code.t, Reporter.diagnostic) Result.t 79 - = fun checkpoint supplier -> 67 + let rec run : _ I.checkpoint -> _ -> (Code.t, Reporter.diagnostic) Result.t = 68 + fun checkpoint supplier -> 80 69 match checkpoint with 81 70 | I.InputNeeded _env -> 82 - (* If the current token is an opening delimiter, save the 83 - token and its position on the stack.*) 71 + (* If the current token is an opening delimiter, save the token and its 72 + position on the stack.*) 84 73 let token, _, _ = supplier () in 85 74 let start_position = lexbuf.lex_start_p in 86 75 let end_position = lexbuf.lex_curr_p in 87 - if is_opening_delim token then 88 - let range = Range.of_lex_range (start_position, end_position) in 89 - Stack.push (token, range) delim_stack; ; 90 - if is_closing_delim token then 91 - begin 92 - match Stack.top_opt delim_stack with 93 - | Some (open_delim, _) -> 94 - if (open_delim |> closed_by token) then 95 - Stack.drop delim_stack 96 - | None -> () 97 - end; 98 - let checkpoint = I.offer checkpoint (token, start_position, end_position) in 76 + (if is_opening_delim token then 77 + let range = Range.of_lex_range (start_position, end_position) in 78 + Stack.push (token, range) delim_stack); 79 + if is_closing_delim token then begin 80 + match Stack.top_opt delim_stack with 81 + | Some (open_delim, _) -> 82 + if open_delim |> closed_by token then Stack.drop delim_stack 83 + | None -> () 84 + end; 85 + let checkpoint = 86 + I.offer checkpoint (token, start_position, end_position) 87 + in 99 88 run checkpoint supplier 100 - | I.Shifting((_, _, _): Code.t I.env * Code.t I.env * bool) -> 101 - let checkpoint = I.resume checkpoint ~strategy: `Simplified in 89 + | I.Shifting ((_, _, _) : Code.t I.env * Code.t I.env * bool) -> 90 + let checkpoint = I.resume checkpoint ~strategy:`Simplified in 102 91 run checkpoint supplier 103 92 | I.AboutToReduce (_, _) -> 104 - let checkpoint = I.resume checkpoint ~strategy: `Simplified in 93 + let checkpoint = I.resume checkpoint ~strategy:`Simplified in 105 94 run checkpoint supplier 106 95 | I.HandlingError _ -> 107 96 if not stop_on_err then 108 97 (* TODO: Don't error out here *) 109 98 Error 110 - ( 111 - Asai.Diagnostic.of_text 112 - ~loc: (Range.of_lexbuf lexbuf) 113 - Error 114 - Reporter.Message.Parse_error 115 - (Asai.Diagnostic.text "") 116 - ) 99 + (Asai.Diagnostic.of_text ~loc:(Range.of_lexbuf lexbuf) Error 100 + Reporter.Message.Parse_error (Asai.Diagnostic.text "")) 117 101 else 118 102 (* let range_of_last_unclosed = *) 119 103 (* Option.map snd @@ Stack.top_opt delim_stack *) ··· 129 113 (* else [] *) 130 114 (* in *) 131 115 Error 132 - ( 133 - Asai.Diagnostic.( 134 - of_loctext 135 - (* ~extra_remarks *) 136 - Error 137 - Forester_core.Reporter.Message.Parse_error 138 - (loctext ~loc Format.(sprintf "syntax error, unexpected %S" (Lexing.lexeme lexbuf))) 139 - ) 140 - ) 116 + Asai.Diagnostic.( 117 + of_loctext 118 + (* ~extra_remarks *) 119 + Error Forester_core.Reporter.Message.Parse_error 120 + (loctext ~loc 121 + Format.( 122 + sprintf "syntax error, unexpected %S" (Lexing.lexeme lexbuf)))) 141 123 | I.Accepted code -> Ok code 142 - | I.Rejected -> 143 - assert false 124 + | I.Rejected -> assert false 144 125 in 145 126 let supplier = I.lexer_lexbuf_to_supplier lexer lexbuf in 146 - try 147 - run initial_checkpoint supplier 127 + try run initial_checkpoint supplier 148 128 with 149 - (* NOTE: This should be the only exception we ever need to catch here: 150 - The parser is driven manually, so we are responsible for creating the 151 - diagnostics. This means we should not use `fatalf`! This also means 152 - that we can safely use the returned diagnostic without worrying that 153 - there might be an unhandled Asai effect. *) 154 - | Lexer.SyntaxError lexeme -> 155 - let loc = Range.of_lexbuf lexbuf in 156 - Error 157 - ( 158 - Asai.Diagnostic.( 159 - of_loctext 160 - Error 161 - Reporter.Message.Parse_error 162 - (loctext ~loc Format.(sprintf "syntax error, unexpected %S" lexeme)) 163 - ) 164 - ) 129 + (* NOTE: This should be the only exception we ever need to catch here: The 130 + parser is driven manually, so we are responsible for creating the 131 + diagnostics. This means we should not use `fatalf`! This also means that we 132 + can safely use the returned diagnostic without worrying that there might be 133 + an unhandled Asai effect. *) 134 + | Lexer.SyntaxError lexeme -> 135 + let loc = Range.of_lexbuf lexbuf in 136 + Error 137 + Asai.Diagnostic.( 138 + of_loctext Error Reporter.Message.Parse_error 139 + (loctext ~loc Format.(sprintf "syntax error, unexpected %S" lexeme)))
+1 -3
lib/parser/Parse.mli
··· 7 7 open Forester_core 8 8 9 9 val parse : 10 - ?stop_on_err: bool -> 11 - Lexing.lexbuf -> 12 - (Code.t, Reporter.diagnostic) result 10 + ?stop_on_err:bool -> Lexing.lexbuf -> (Code.t, Reporter.diagnostic) result
+49 -95
lib/parser/test/Test_parser.ml
··· 12 12 let test_prim () = 13 13 Alcotest.(check @@ result code diagnostic) 14 14 "same nodes" 15 - ( 16 - Ok 17 - [ 18 - ident ["p"]; 19 - braces 20 - [ 21 - ident ["ul"]; 22 - braces 23 - [ 24 - ident ["li"]; 25 - braces 26 - [text "foo"] 27 - ] 28 - ] 29 - ] 30 - ) 31 - ( 32 - parse_string_no_loc 33 - {|\p{\ul{\li{foo}}}|} 34 - ) 15 + (Ok 16 + [ 17 + ident ["p"]; 18 + braces [ident ["ul"]; braces [ident ["li"]; braces [text "foo"]]]; 19 + ]) 20 + (parse_string_no_loc {|\p{\ul{\li{foo}}}|}) 35 21 36 22 let test_open () = 37 23 Alcotest.(check @@ result code diagnostic) ··· 46 32 let test_scope () = 47 33 Alcotest.(check @@ result code diagnostic) 48 34 "same nodes" 49 - ( 50 - Ok 51 - [ 52 - scope 53 - [ 54 - ident ["p"]; 55 - braces [] 56 - ] 57 - ] 58 - ) 35 + (Ok [scope [ident ["p"]; braces []]]) 59 36 (parse_string_no_loc {|\scope{\p{}}|}) 60 37 61 38 let test_verbatim () = ··· 67 44 let test_math () = 68 45 Alcotest.(check @@ result code diagnostic) 69 46 "same nodes" 70 - ( 71 - Ok 72 - [ 73 - math 74 - Inline 75 - [ 76 - (text "a^2"); 77 - (text " "); 78 - (text "+"); 79 - (text " "); 80 - (text "b^2"); 81 - (text " "); 82 - (text "="); 83 - (text " "); 84 - (text "c^2") 85 - ] 86 - ] 87 - ) 47 + (Ok 48 + [ 49 + math Inline 50 + [ 51 + text "a^2"; 52 + text " "; 53 + text "+"; 54 + text " "; 55 + text "b^2"; 56 + text " "; 57 + text "="; 58 + text " "; 59 + text "c^2"; 60 + ]; 61 + ]) 88 62 (parse_string_no_loc {|#{a^2 + b^2 = c^2}|}); 89 63 Alcotest.(check @@ result code diagnostic) 90 64 "same nodes" 91 - ( 92 - Ok 93 - [ 94 - math 95 - Display 96 - [ 97 - (text "a^2"); 98 - (text " "); 99 - (text "+"); 100 - (text " "); 101 - (text "b^2"); 102 - (text " "); 103 - (text "="); 104 - (text " "); 105 - (text "c^2") 106 - ] 107 - ] 108 - ) 65 + (Ok 66 + [ 67 + math Display 68 + [ 69 + text "a^2"; 70 + text " "; 71 + text "+"; 72 + text " "; 73 + text "b^2"; 74 + text " "; 75 + text "="; 76 + text " "; 77 + text "c^2"; 78 + ]; 79 + ]) 109 80 (parse_string_no_loc {|##{a^2 + b^2 = c^2}|}) 110 81 111 82 let test_hashtag () = ··· 117 88 let test_object () = 118 89 Alcotest.(check @@ result code diagnostic) 119 90 "same nodes" 120 - ( 121 - Ok 122 - [ 123 - object_ 124 - { 125 - self = (Some "self"); 126 - methods = [ 127 - ( 128 - "foo", 129 - [] 130 - ) 131 - ] 132 - } 133 - ] 134 - ) 135 - ( 136 - parse_string_no_loc 137 - {| 91 + (Ok [object_ {self = Some "self"; methods = [("foo", [])]}]) 92 + (parse_string_no_loc 93 + {| 138 94 \object[self]{ 139 95 [foo]{} 140 - }|} 141 - ) 96 + }|}) 142 97 143 98 let () = 144 99 let open Alcotest in 145 - run 146 - "Parser" 100 + run "Parser" 147 101 [ 148 - "nodes", [test_case "open" `Quick test_open;]; 149 - "scope", [test_case "scope" `Quick test_scope;]; 150 - "text", [test_case "text" `Quick test_prim]; 151 - "verbatim", [test_case "verbatim" `Quick test_verbatim]; 152 - "math", [test_case "math" `Quick test_math]; 153 - "hashtag", [test_case "hashtag" `Quick test_hashtag]; 154 - "object", [test_case "object" `Quick test_object]; 102 + ("nodes", [test_case "open" `Quick test_open]); 103 + ("scope", [test_case "scope" `Quick test_scope]); 104 + ("text", [test_case "text" `Quick test_prim]); 105 + ("verbatim", [test_case "verbatim" `Quick test_verbatim]); 106 + ("math", [test_case "math" `Quick test_math]); 107 + ("hashtag", [test_case "hashtag" `Quick test_hashtag]); 108 + ("object", [test_case "object" `Quick test_object]); 155 109 ]
+5 -11
lib/prelude/BaseN.ml
··· 28 28 loop sum' place' (r - 1) 29 29 in 30 30 let len = String.length digits in 31 - match loop 0 1 (len - 1) with 32 - | sum -> Some sum 33 - | exception _ -> None 31 + match loop 0 1 (len - 1) with sum -> Some sum | exception _ -> None 34 32 35 33 let string_of_int n = 36 34 let len = 37 - max 4 @@ 38 - Int.succ @@ 39 - int_of_float @@ 40 - floor @@ 41 - log (float_of_int n) /. log (float_of_int base) 35 + max 4 @@ Int.succ @@ int_of_float @@ floor 36 + @@ (log (float_of_int n) /. log (float_of_int base)) 42 37 in 43 38 let bytes = Bytes.init len @@ fun _ -> '0' in 44 39 let rec loop r i = 45 - if i <= 0 then 46 - Bytes.unsafe_to_string bytes 40 + if i <= 0 then Bytes.unsafe_to_string bytes 47 41 else 48 42 let x = String.get I.alphabet (i mod base) in 49 43 Bytes.set bytes r x; ··· 52 46 loop (len - 1) n 53 47 end 54 48 55 - module Base36 = Make(struct 49 + module Base36 = Make (struct 56 50 let alphabet = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" 57 51 end)
+4 -9
lib/prelude/Compare.ml
··· 4 4 * SPDX-License-Identifier: GPL-3.0-or-later 5 5 *) 6 6 7 - let under f compare x y = 8 - compare (f x) (f y) 7 + let under f compare x y = compare (f x) (f y) 9 8 10 9 let cascade compare0 compare1 x y = 11 - match compare0 x y with 12 - | 0 -> compare1 x y 13 - | i -> i 10 + match compare0 x y with 0 -> compare1 x y | i -> i 14 11 15 12 let option compare x y = 16 - match x, y with 13 + match (x, y) with 17 14 | None, Some _ -> -1 18 15 | Some _, None -> 1 19 16 | None, None -> 0 20 17 | Some x, Some y -> compare x y 21 18 22 - let sort_map f compare xs = 23 - List.sort compare @@ List.map f xs 24 - 19 + let sort_map f compare xs = List.sort compare @@ List.map f xs 25 20 let invert compare x y = 0 - compare x y
-1
lib/prelude/Forester_prelude.ml
··· 8 8 9 9 include Fun_util 10 10 include Bwd 11 - 12 11 module String_util = String_util 13 12 module Option_util = Option_util 14 13 module List_util = List_util
+2 -2
lib/prelude/Fun_util.ml
··· 4 4 * SPDX-License-Identifier: GPL-3.0-or-later 5 5 *) 6 6 7 - let (let@) = (@@) 8 - let (@~) f x y = f y x 7 + let ( let@ ) = ( @@ ) 8 + let ( @~ ) f x y = f y x
+2 -7
lib/prelude/Option_util.ml
··· 4 4 * SPDX-License-Identifier: GPL-3.0-or-later 5 5 *) 6 6 7 - let override x y = 8 - match x with 9 - | Some _ -> x 10 - | None -> y 11 - 12 - let guard p x = 13 - if p x then Some x else None 7 + let override x y = match x with Some _ -> x | None -> y 8 + let guard p x = if p x then Some x else None
+19 -18
lib/prelude/String_util.ml
··· 6 6 7 7 open Bwd 8 8 9 - (* Based on cmap_utf_8 from https://erratique.ch/software/uucp/doc/Uucp/Case/index.html#caseexamples *) 9 + (* Based on cmap_utf_8 from 10 + https://erratique.ch/software/uucp/doc/Uucp/Case/index.html#caseexamples *) 10 11 let title_case_word s = 11 12 let did_uppercase = ref false in 12 13 let rec loop buf s i max = ··· 14 15 else 15 16 let dec = String.get_utf_8_uchar s i in 16 17 let u = Uchar.utf_decode_uchar dec in 17 - let should_ignore = Uucp.Case.is_case_ignorable u || not (Uucp.Case.is_cased u) in 18 + let should_ignore = 19 + Uucp.Case.is_case_ignorable u || not (Uucp.Case.is_cased u) 20 + in 18 21 let () = 19 22 match should_ignore || !did_uppercase with 20 - | true -> 21 - Buffer.add_utf_8_uchar buf u 22 - | false -> 23 + | true -> Buffer.add_utf_8_uchar buf u 24 + | false -> ( 23 25 did_uppercase := true; 24 26 match Uucp.Case.Map.to_upper u with 25 27 | `Self -> Buffer.add_utf_8_uchar buf u 26 - | `Uchars us -> List.iter (Buffer.add_utf_8_uchar buf) us 28 + | `Uchars us -> List.iter (Buffer.add_utf_8_uchar buf) us) 27 29 in 28 30 loop buf s (i + Uchar.utf_decode_length dec) max 29 31 in 30 - let buf = Buffer.create @@ String.length s * 2 in 31 - loop buf s 0 @@ String.length s - 1 32 + let buf = Buffer.create @@ (String.length s * 2) in 33 + loop buf s 0 @@ (String.length s - 1) 32 34 33 35 let sentence_case str = 34 36 let words = String.split_on_char ' ' str in 35 - String.concat " " @@ List.mapi (fun i word -> if i = 0 then title_case_word word else word) words 37 + String.concat " " 38 + @@ List.mapi 39 + (fun i word -> if i = 0 then title_case_word word else word) 40 + words 36 41 37 42 let trim_newlines str = 38 43 let rec process_lines lines = ··· 42 47 | _ -> lines 43 48 in 44 49 let lines = String.split_on_char '\n' str in 45 - String.concat "\n" @@ List.rev @@ process_lines @@ List.rev @@ process_lines lines 50 + String.concat "\n" @@ List.rev @@ process_lines @@ List.rev 51 + @@ process_lines lines 46 52 47 53 let trim_trailing_whitespace str = 48 54 let rec process_chars rstr = ··· 56 62 let chars = List.rev @@ List.init n (String.get str) in 57 63 String.of_seq @@ List.to_seq @@ process_chars @@ chars 58 64 59 - let explode str = 60 - List.init (String.length str) (String.get str) 61 - 62 - let implode chars = 63 - String.init (List.length chars) (List.nth chars) 64 - 65 - let implode_bwd chars = 66 - implode (Bwd.to_list chars) 65 + let explode str = List.init (String.length str) (String.get str) 66 + let implode chars = String.init (List.length chars) (List.nth chars) 67 + let implode_bwd chars = implode (Bwd.to_list chars)
-1
lib/prelude/String_util.mli
··· 9 9 val sentence_case : string -> string 10 10 val trim_newlines : string -> string 11 11 val trim_trailing_whitespace : string -> string 12 - 13 12 val explode : string -> char list 14 13 val implode : char list -> string 15 14 val implode_bwd : char bwd -> string
+68 -96
lib/search/Context.ml
··· 5 5 *) 6 6 7 7 open Forester_core 8 - open struct module T = Types end 8 + 9 + open struct 10 + module T = Types 11 + end 9 12 10 13 (* The idea is to render a search result with surrounding context, say 5 words 11 14 on each side. *) 12 15 13 16 type path = int list 14 17 15 - let show_leaf_node 16 - : T.content T.content_node -> string 17 - = fun node -> 18 + let show_leaf_node : T.content T.content_node -> string = 19 + fun node -> 18 20 match node with 19 21 | T.Text s -> s 20 22 | T.CDATA s -> s 21 - | T.Uri i 22 - | T.Route_of_uri i -> 23 - Format.asprintf "%a" URI.pp i 24 - | T.Xml_elt _ 25 - | T.Transclude _ 26 - | T.Contextual_number _ 27 - | T.Section _ 23 + | T.Uri i | T.Route_of_uri i -> Format.asprintf "%a" URI.pp i 24 + | T.Xml_elt _ | T.Transclude _ | T.Contextual_number _ | T.Section _ 28 25 | T.KaTeX (_, _) 29 - | T.Link _ 30 - | T.Artefact _ 31 - | T.Datalog_script _ 32 - | T.Results_of_datalog_query _ -> 33 - raise @@ 34 - Invalid_argument (Format.asprintf "%a is not a leaf node" T.(pp_content_node pp_content) node) 26 + | T.Link _ | T.Artefact _ | T.Datalog_script _ | T.Results_of_datalog_query _ 27 + -> 28 + raise 29 + @@ Invalid_argument 30 + (Format.asprintf "%a is not a leaf node" 31 + T.(pp_content_node pp_content) 32 + node) 35 33 36 34 let get_nth_word i string = 37 35 Str.(split @@ regexp "[^a-zA-Z0-9]+") string 38 - |> List.filter_map 39 - (fun s -> 40 - let lower = String.lowercase_ascii s in 41 - if not @@ Tokenizer.(Set.mem lower common_words) then 42 - Some lower 43 - else 44 - None 45 - ) 46 - |> (fun l -> List.nth l i) 36 + |> List.filter_map (fun s -> 37 + let lower = String.lowercase_ascii s in 38 + if not @@ Tokenizer.(Set.mem lower common_words) then Some lower else None) 39 + |> fun l -> List.nth l i 47 40 48 - let render_context_list 49 - : (path -> 'a -> string) -> path -> 'a list -> string 50 - = fun f path l -> 41 + let render_context_list : (path -> 'a -> string) -> path -> 'a list -> string = 42 + fun f path l -> 51 43 match path with 52 44 | [] -> String.concat "" @@ List.map (f []) l 53 45 | i :: path' -> 54 46 let n = List.nth l i in 55 47 f path' n 56 48 57 - let rec render_context_frontmatter 58 - : path -> T.content T.frontmatter -> string 59 - = fun path frontmatter -> 49 + let rec render_context_frontmatter : path -> T.content T.frontmatter -> string = 50 + fun path frontmatter -> 60 51 match path with 61 52 | [] -> raise (Invalid_argument "stopped on non-leaf node") 62 53 | 0 :: _path -> 63 54 Format.(asprintf "%a" (pp_print_option URI.pp) frontmatter.uri) 64 - | 1 :: path' -> 65 - begin 66 - match path' with 67 - | [] -> 68 - Option.value ~default: "" @@ 69 - Option.map T.show_content frontmatter.title 70 - | path -> 71 - Option.value ~default: "" @@ 72 - Option.map (render_context_content path) frontmatter.title 73 - end 55 + | 1 :: path' -> begin 56 + match path' with 57 + | [] -> 58 + Option.value ~default:"" @@ Option.map T.show_content frontmatter.title 59 + | path -> 60 + Option.value ~default:"" 61 + @@ Option.map (render_context_content path) frontmatter.title 62 + end 74 63 | 2 :: path' -> 75 - begin 76 - match path' with 77 - | [] -> assert false 78 - | _path -> assert false 79 - end (*frontmatter.dates*) 64 + (*frontmatter.dates*) 65 + begin match path' with [] -> assert false | _path -> assert false 66 + end 80 67 | 3 :: path' -> 81 - begin 82 - match path' with 83 - | [] -> assert false 84 - | _path -> assert false 85 - end (*frontmatter.attributions*) 68 + (*frontmatter.attributions*) 69 + begin match path' with [] -> assert false | _path -> assert false 70 + end 86 71 | 4 :: path' -> 87 - begin 88 - match path' with 89 - | [] -> assert false 90 - | path -> 91 - Option.value ~default: "" @@ 92 - Option.map (render_context_content path) frontmatter.taxon 93 - end (*frontmatter.taxon*) 72 + (*frontmatter.taxon*) 73 + begin match path' with 74 + | [] -> assert false 75 + | path -> 76 + Option.value ~default:"" 77 + @@ Option.map (render_context_content path) frontmatter.taxon 78 + end 94 79 | 5 :: path' -> 95 - begin 96 - match path' with 97 - | [] -> assert false 98 - | _path -> assert false 99 - end (*frontmatter.number*) 80 + (*frontmatter.number*) 81 + begin match path' with [] -> assert false | _path -> assert false 82 + end 100 83 | 6 :: path' -> 101 - begin 102 - match path' with 103 - | [] -> assert false 104 - | _path -> assert false 105 - end (*frontmatter.designated_parent*) 84 + (*frontmatter.designated_parent*) 85 + begin match path' with [] -> assert false | _path -> assert false 86 + end 106 87 | 7 :: path' -> 107 - begin 108 - match path' with 109 - | [] -> assert false 110 - | _path -> assert false 111 - end (*frontmatter.source_path*) 88 + (*frontmatter.source_path*) 89 + begin match path' with [] -> assert false | _path -> assert false 90 + end 112 91 | 8 :: path' -> 113 - begin 114 - match path' with 115 - | [] -> assert false 116 - | _path -> assert false 117 - end (*frontmatter.tags*) 92 + (*frontmatter.tags*) 93 + begin match path' with [] -> assert false | _path -> assert false 94 + end 118 95 | 9 :: path' -> 119 - begin 120 - match path' with 121 - | [] -> assert false 122 - | _path -> assert false 123 - end (*frontmatter.metas*) 96 + (*frontmatter.metas*) 97 + begin match path' with [] -> assert false | _path -> assert false 98 + end 124 99 | _ -> raise (Invalid_argument "out of bound index") 125 100 126 - and render_context_node 127 - : path -> T.content T.content_node -> string 128 - = fun path node -> 101 + and render_context_node : path -> T.content T.content_node -> string = 102 + fun path node -> 129 103 match path with 130 104 | [] -> show_leaf_node node 131 - | i :: path' -> 105 + | i :: path' -> ( 132 106 match node with 133 107 | T.Text s -> get_nth_word i s 134 108 | T.CDATA _ -> raise @@ Invalid_argument "can't descend into CDATA node" ··· 142 116 | T.Uri _ -> assert false 143 117 | T.Route_of_uri _ -> assert false 144 118 | T.Datalog_script _ -> assert false 145 - | T.Results_of_datalog_query _ -> assert false 119 + | T.Results_of_datalog_query _ -> assert false) 146 120 147 - and render_context_content 148 - : path -> T.content -> string 149 - = fun path content -> 150 - let T.Content c = content in 121 + and render_context_content : path -> T.content -> string = 122 + fun path content -> 123 + let (T.Content c) = content in 151 124 match path with 152 125 | [] -> T.show_content content 153 126 | i :: path' -> ··· 155 128 (* render_context_node in *) 156 129 render_context_node path' node 157 130 158 - and render_context_article 159 - : path -> T.content T.article -> string 160 - = fun path article -> 131 + and render_context_article : path -> T.content T.article -> string = 132 + fun path article -> 161 133 match path with 162 134 | [] -> "" 163 135 | 0 :: path' -> render_context_frontmatter path' article.frontmatter
+46 -53
lib/search/Index.ml
··· 8 8 open Forester_core 9 9 open Spelll 10 10 11 - open struct module T = Forester_core.Types end 11 + open struct 12 + module T = Forester_core.Types 13 + end 12 14 13 - module Ocurrences = Set.Make(struct 15 + module Ocurrences = Set.Make (struct 14 16 type t = int list list * URI.t 17 + 15 18 (* FIXME: *) 16 19 let compare (_i, x) (_j, y) = URI.compare x y 17 20 end) ··· 25 28 let average_doc_length {number_of_tokens; number_of_docs; _} : float = 26 29 Float.of_int number_of_tokens /. Float.of_int number_of_docs 27 30 28 - let add_one (article : T.content T.article) ({index; number_of_tokens; number_of_docs;} as t) : t = 31 + let add_one (article : T.content T.article) 32 + ({index; number_of_tokens; number_of_docs} as t) : t = 29 33 if Option.is_none T.(article.frontmatter.uri) then t 30 34 else 31 35 let tokens_in_article = Tokenizer.tokenize_article article in ··· 33 37 let new_tokens = ref 0 in 34 38 let new_index = 35 39 List.fold_left 36 - begin 37 - fun index (ocurrences, token) -> 38 - match Index.retrieve_l ~limit: 0 index token with 39 - | [] -> 40 - (* Unseen token*) 41 - (* TODO: add to list of ocurrences*) 42 - let ocurrence = Ocurrences.singleton ([ocurrences], uri) in 43 - new_tokens := !new_tokens + 1; 44 - Index.add index token ocurrence 45 - | ids :: [] -> 46 - Index.add index token (Ocurrences.add ([ocurrences], uri) ids) 47 - | _ -> 48 - (* We are using limit=0, so this shouldn't happen*) 49 - assert false 40 + begin fun index (ocurrences, token) -> 41 + match Index.retrieve_l ~limit:0 index token with 42 + | [] -> 43 + (* Unseen token*) 44 + (* TODO: add to list of ocurrences*) 45 + let ocurrence = Ocurrences.singleton ([ocurrences], uri) in 46 + new_tokens := !new_tokens + 1; 47 + Index.add index token ocurrence 48 + | ids :: [] -> 49 + Index.add index token (Ocurrences.add ([ocurrences], uri) ids) 50 + | _ -> 51 + (* We are using limit=0, so this shouldn't happen*) 52 + assert false 50 53 end 51 - index 52 - tokens_in_article 54 + index tokens_in_article 53 55 in 54 56 { 55 57 index = new_index; 56 58 number_of_docs = number_of_docs + 1; 57 - number_of_tokens = number_of_tokens + !new_tokens 59 + number_of_tokens = number_of_tokens + !new_tokens; 58 60 } 59 61 60 - let add : T.content T.article list -> t -> t = 61 - List.fold_right add_one 62 + let add : T.content T.article list -> t -> t = List.fold_right add_one 62 63 63 - let search ?(fuzz = 0) (index : t) (term : string) : (int list list * URI.t) list = 64 + let search ?(fuzz = 0) (index : t) (term : string) : 65 + (int list list * URI.t) list = 64 66 let@ str = List.concat_map @~ Tokenizer.tokenize term in 65 - List.concat_map Ocurrences.to_list @@ 66 - Index.retrieve_l ~limit: fuzz index.index str 67 + List.concat_map Ocurrences.to_list 68 + @@ Index.retrieve_l ~limit:fuzz index.index str 67 69 68 70 module BM_25 = struct 69 - let sum = List.fold_left (+.) 0. 71 + let sum = List.fold_left ( +. ) 0. 70 72 71 73 (* Inverse document frequency *) 72 74 let idf q (index : t) = 73 - let n = Float.of_int @@ List.length @@ search ~fuzz: 0 index q in 74 - log @@ ((Float.of_int index.number_of_docs -. n +. 0.5) /. n +. 0.5) +. 1. 75 + let n = Float.of_int @@ List.length @@ search ~fuzz:0 index q in 76 + log @@ (((Float.of_int index.number_of_docs -. n +. 0.5) /. n) +. 0.5 +. 1.) 75 77 76 - let doc_length d = 77 - Float.of_int @@ 78 - List.length @@ 79 - Tokenizer.tokenize_article d 78 + let doc_length d = Float.of_int @@ List.length @@ Tokenizer.tokenize_article d 80 79 81 80 let score (d : T.content T.article) (q : string) (index : t) : float = 82 81 let tokens = Tokenizer.tokenize q in ··· 84 83 let avg_len = average_doc_length index in 85 84 let k_1 = 1.5 in 86 85 let b = 0.75 in 87 - sum @@ 88 - let@ q_i = List.map @~ tokens in 89 - let num_occurrences = 90 - Float.of_int @@ 91 - List.length @@ search index q_i 92 - in 93 - (* Format.printf "num_occurrences: %f" num_occurrences; *) 94 - idf q index *. 95 - begin 96 - (num_occurrences *. k_1 +. 1.) /. 97 - (num_occurrences +. k_1 *. (1. -. b +. (b *. doc_length d /. avg_len))) +. 98 - 1. 99 - end 86 + sum 87 + @@ 88 + let@ q_i = List.map @~ tokens in 89 + let num_occurrences = Float.of_int @@ List.length @@ search index q_i in 90 + (* Format.printf "num_occurrences: %f" num_occurrences; *) 91 + idf q index 92 + *. begin 93 + ((num_occurrences *. k_1) +. 1.) 94 + /. (num_occurrences 95 + +. (k_1 *. (1. -. b +. (b *. doc_length d /. avg_len)))) 96 + +. 1. 97 + end 100 98 end 101 99 102 100 let create articles = 103 - let index = { 104 - index = Index.empty; 105 - number_of_docs = 0; 106 - number_of_tokens = 0 107 - } 108 - in 101 + let index = {index = Index.empty; number_of_docs = 0; number_of_tokens = 0} in 109 102 add articles index 110 103 111 104 let marshal (v : t) filename = 112 105 let oc = open_out_bin filename in 113 - let@ () = Fun.protect ~finally: (fun () -> close_out oc) in 106 + let@ () = Fun.protect ~finally:(fun () -> close_out oc) in 114 107 Marshal.to_channel oc v [] 115 108 116 109 let unmarshal filename : t = 117 110 let ic = open_in_bin filename in 118 - let@ () = Fun.protect ~finally: (fun () -> close_in ic) in 111 + let@ () = Fun.protect ~finally:(fun () -> close_in ic) in 119 112 Marshal.from_channel ic
+28 -33
lib/search/Search_engine.ml
··· 10 10 open Forester_search 11 11 open Forester_frontend 12 12 13 - open struct module T = Types end 13 + open struct 14 + module T = Types 15 + end 14 16 15 - let ranked_search 16 - : ?fuzz: int -> State.t -> string -> (URI.t * float) list 17 - = fun ?fuzz: _ forest terms -> 17 + let ranked_search : ?fuzz:int -> State.t -> string -> (URI.t * float) list = 18 + fun ?fuzz:_ forest terms -> 18 19 Tokenizer.tokenize terms |> function 19 - | tokens -> 20 - (* In order to rank documents, I search for the first token and then 21 - rank the returned documents according to all tokens. This duplicates the 22 - search for the first token, so this should be changed.*) 23 - let first_token = List.hd tokens in 24 - let matches = Index.search ~fuzz: 1 forest.search_index first_token in 25 - let uris = 26 - List.filter_map 27 - (fun (_, uri) -> 28 - match URI.Tbl.find_opt forest.index uri with 29 - | Some (Resource ({resource = T.Article a; _})) -> 30 - Some (uri, Index.BM_25.score a terms forest.search_index) 31 - | None -> assert false 32 - | _ -> None 33 - ) 34 - matches 35 - in 36 - List.sort 37 - (fun (_, score_a) (_, score_b) -> Float.compare score_a score_b) 38 - uris 20 + | tokens -> 21 + (* In order to rank documents, I search for the first token and then rank 22 + the returned documents according to all tokens. This duplicates the 23 + search for the first token, so this should be changed.*) 24 + let first_token = List.hd tokens in 25 + let matches = Index.search ~fuzz:1 forest.search_index first_token in 26 + let uris = 27 + List.filter_map 28 + (fun (_, uri) -> 29 + match URI.Tbl.find_opt forest.index uri with 30 + | Some (Resource {resource = T.Article a; _}) -> 31 + Some (uri, Index.BM_25.score a terms forest.search_index) 32 + | None -> assert false 33 + | _ -> None) 34 + matches 35 + in 36 + List.sort 37 + (fun (_, score_a) (_, score_b) -> Float.compare score_a score_b) 38 + uris 39 39 40 40 let test_ranked (forest : State.t) = 41 41 let ranked_results = 42 42 Reporter.profile "Ranked search" @@ fun () -> 43 - ranked_search 44 - ~fuzz: 2 45 - forest 46 - "hyprtext format" 43 + ranked_search ~fuzz:2 forest "hyprtext format" 47 44 in 48 45 Format.printf "got %i ranked results.@." (List.length ranked_results); 49 46 List.iter 50 47 (fun (uri, score) -> 51 48 match State.get_article uri forest with 52 - | Some _article -> 53 - Format.printf "%a, %f@." URI.pp uri score; 54 - | None -> assert false 55 - ) 49 + | Some _article -> Format.printf "%a, %f@." URI.pp uri score 50 + | None -> assert false) 56 51 ranked_results 57 52 58 53 let test_search (forest : State.t) = 59 54 let s = read_line () in 60 55 let results = 61 56 (* Reporter.profile "Searching" @@ fun () -> *) 62 - Index.search ~fuzz: 1 forest.search_index s 57 + Index.search ~fuzz:1 forest.search_index s 63 58 in 64 59 Format.printf "got %i results@." (List.length results) 65 60
+124 -128
lib/search/Stemming.ml
··· 7 7 exception No_stem of string 8 8 9 9 (* Now for the native OCaml port *) 10 - let rule_list_1a = [ 11 - (101, "sses", "ss", -1); 12 - (102, "ies", "i", -1); 13 - (103, "ss", "ss", -1); 14 - (104, "s", "", -1) 15 - ] 10 + let rule_list_1a = 11 + [ 12 + (101, "sses", "ss", -1); 13 + (102, "ies", "i", -1); 14 + (103, "ss", "ss", -1); 15 + (104, "s", "", -1); 16 + ] 16 17 17 - let rule_list_1b = [(105, "eed", "ee", 0); (106, "ed", "", -1); (107, "ing", "", -1)] 18 + let rule_list_1b = 19 + [(105, "eed", "ee", 0); (106, "ed", "", -1); (107, "ing", "", -1)] 18 20 19 - let rule_list_1b1 = [ 20 - (108, "at", "ate", -1); 21 - (109, "bl", "ble", -1); 22 - (110, "iz", "ize", -1); 23 - (111, "bb", "b", -1); 24 - (112, "dd", "d", -1); 25 - (113, "ff", "f", -1); 26 - (114, "gg", "g", -1); 27 - (115, "mm", "m", -1); 28 - (116, "nn", "n", -1); 29 - (117, "pp", "p", -1); 30 - (118, "rr", "r", -1); 31 - (119, "tt", "t", -1); 32 - (120, "ww", "w", -1); 33 - (121, "xx", "x", -1); 34 - (122, "", "e", -1) 35 - ] 21 + let rule_list_1b1 = 22 + [ 23 + (108, "at", "ate", -1); 24 + (109, "bl", "ble", -1); 25 + (110, "iz", "ize", -1); 26 + (111, "bb", "b", -1); 27 + (112, "dd", "d", -1); 28 + (113, "ff", "f", -1); 29 + (114, "gg", "g", -1); 30 + (115, "mm", "m", -1); 31 + (116, "nn", "n", -1); 32 + (117, "pp", "p", -1); 33 + (118, "rr", "r", -1); 34 + (119, "tt", "t", -1); 35 + (120, "ww", "w", -1); 36 + (121, "xx", "x", -1); 37 + (122, "", "e", -1); 38 + ] 36 39 37 40 let rule_list_1c = [(123, "y", "i", -1)] 38 41 39 - let rule_list_2 = [ 40 - (203, "ational", "ate", 0); 41 - (204, "tional", "tion", 0); 42 - (205, "enci", "ence", 0); 43 - (206, "anci", "ance", 0); 44 - (207, "izer", "ize", 0); 45 - (208, "abli", "able", 0); 46 - (209, "alli", "al", 0); 47 - (210, "entli", "ent", 0); 48 - (211, "eli", "e", 0); 49 - (213, "ousli", "ous", 0); 50 - (214, "ization", "ize", 0); 51 - (215, "ation", "ate", 0); 52 - (216, "ator", "ate", 0); 53 - (217, "alism", "al", 0); 54 - (218, "iveness", "ive", 0); 55 - (219, "fulnes", "ful", 0); 56 - (220, "ousness", "ous", 0); 57 - (221, "aliti", "al", 0); 58 - (222, "iviti", "ive", 0); 59 - (223, "biliti", "ble", 0) 60 - ] 42 + let rule_list_2 = 43 + [ 44 + (203, "ational", "ate", 0); 45 + (204, "tional", "tion", 0); 46 + (205, "enci", "ence", 0); 47 + (206, "anci", "ance", 0); 48 + (207, "izer", "ize", 0); 49 + (208, "abli", "able", 0); 50 + (209, "alli", "al", 0); 51 + (210, "entli", "ent", 0); 52 + (211, "eli", "e", 0); 53 + (213, "ousli", "ous", 0); 54 + (214, "ization", "ize", 0); 55 + (215, "ation", "ate", 0); 56 + (216, "ator", "ate", 0); 57 + (217, "alism", "al", 0); 58 + (218, "iveness", "ive", 0); 59 + (219, "fulnes", "ful", 0); 60 + (220, "ousness", "ous", 0); 61 + (221, "aliti", "al", 0); 62 + (222, "iviti", "ive", 0); 63 + (223, "biliti", "ble", 0); 64 + ] 61 65 62 - let rule_list_3 = [ 63 - (301, "icate", "ic", 0); 64 - (302, "ative", "", 0); 65 - (303, "alize", "al", 0); 66 - (304, "iciti", "ic", 0); 67 - (305, "ical", "ic", 0); 68 - (308, "ful", "", 0); 69 - (309, "ness", "", 0) 70 - ] 66 + let rule_list_3 = 67 + [ 68 + (301, "icate", "ic", 0); 69 + (302, "ative", "", 0); 70 + (303, "alize", "al", 0); 71 + (304, "iciti", "ic", 0); 72 + (305, "ical", "ic", 0); 73 + (308, "ful", "", 0); 74 + (309, "ness", "", 0); 75 + ] 71 76 72 - let rule_list_4 = [ 73 - (401, "al", "", 1); 74 - (402, "ance", "", 1); 75 - (403, "ence", "", 1); 76 - (405, "er", "", 1); 77 - (406, "ic", "", 1); 78 - (407, "able", "", 1); 79 - (408, "ible", "", 1); 80 - (409, "ant", "", 1); 81 - (410, "ement", "", 1); 82 - (411, "ment", "", 1); 83 - (412, "ent", "", 1); 84 - (423, "sion", "s", 1); 85 - (424, "tion", "t", 1); 86 - (415, "ou", "", 1); 87 - (416, "ism", "", 1); 88 - (417, "ate", "", 1); 89 - (418, "iti", "", 1); 90 - (419, "ous", "", 1); 91 - (420, "ive", "", 1); 92 - (421, "ize", "", 1) 93 - ] 77 + let rule_list_4 = 78 + [ 79 + (401, "al", "", 1); 80 + (402, "ance", "", 1); 81 + (403, "ence", "", 1); 82 + (405, "er", "", 1); 83 + (406, "ic", "", 1); 84 + (407, "able", "", 1); 85 + (408, "ible", "", 1); 86 + (409, "ant", "", 1); 87 + (410, "ement", "", 1); 88 + (411, "ment", "", 1); 89 + (412, "ent", "", 1); 90 + (423, "sion", "s", 1); 91 + (424, "tion", "t", 1); 92 + (415, "ou", "", 1); 93 + (416, "ism", "", 1); 94 + (417, "ate", "", 1); 95 + (418, "iti", "", 1); 96 + (419, "ous", "", 1); 97 + (420, "ive", "", 1); 98 + (421, "ize", "", 1); 99 + ] 94 100 95 101 let rule_list_5a = [(501, "e", "", 1); (502, "e", "", -1)] 96 - 97 102 let rule_list_5b = [(503, "ll", "l", 1)] 98 103 99 - let all_rules = [ 100 - rule_list_1a; 101 - rule_list_1b; (* rule_list_1b1 is conditionally applied below *) 102 - rule_list_1c; 103 - rule_list_2; 104 - rule_list_3; 105 - rule_list_4; 106 - rule_list_5a; 107 - rule_list_5b 108 - ] 104 + let all_rules = 105 + [ 106 + rule_list_1a; 107 + rule_list_1b; 108 + (* rule_list_1b1 is conditionally applied below *) 109 + rule_list_1c; 110 + rule_list_2; 111 + rule_list_3; 112 + rule_list_4; 113 + rule_list_5a; 114 + rule_list_5b; 115 + ] 109 116 110 117 (* Returns boolean based on vowel-ness of a character *) 111 - let is_vowel c = 112 - match c with 'a' | 'e' | 'i' | 'o' | 'u' -> true | _ -> false 118 + let is_vowel c = match c with 'a' | 'e' | 'i' | 'o' | 'u' -> true | _ -> false 113 119 114 120 (* Computes a weird word count number based on syllabels and such. *) 115 121 let word_size word = ··· 118 124 if idx < wordlen then 119 125 let call = aux (succ idx) in 120 126 match state with 121 - | 0 -> 122 - if is_vowel word.[idx] then call count 1 else call count 2 123 - | 1 -> 124 - if is_vowel word.[idx] then call count 1 else call (succ count) 2 127 + | 0 -> if is_vowel word.[idx] then call count 1 else call count 2 128 + | 1 -> if is_vowel word.[idx] then call count 1 else call (succ count) 2 125 129 | 2 -> 126 130 if is_vowel word.[idx] || word.[idx] = 'y' then call count 1 127 131 else call count 2 128 - | _ -> 129 - failwith "Impossible state" 132 + | _ -> failwith "Impossible state" 130 133 else count 131 134 in 132 135 aux 0 0 0 ··· 137 140 let vowel_or_y c = is_vowel c || c = 'y' in 138 141 let vowel_or_wxy c = vowel_or_y c || c = 'x' || c = 'w' in 139 142 if len < 3 then false 140 - else if (not (vowel_or_wxy str.[len - 1])) 143 + else if 144 + (not (vowel_or_wxy str.[len - 1])) 141 145 && vowel_or_y str.[len - 2] 142 - && not (is_vowel str.[len - 3]) then true 146 + && not (is_vowel str.[len - 3]) 147 + then true 143 148 else false 144 149 145 150 let add_an_e word = ··· 158 163 is_vowel str.[0] || aux 1 159 164 160 165 (* Some rules have additional criteria added to them *) 161 - let rules_criteria = [([106; 107; 123], contains_vowel); ([122], add_an_e); ([502], remove_an_e)] 166 + let rules_criteria = 167 + [([106; 107; 123], contains_vowel); ([122], add_an_e); ([502], remove_an_e)] 162 168 163 - let match_rule word ((num, orig, _, min_root): int * string * string * int) = 169 + let match_rule word ((num, orig, _, min_root) : int * string * string * int) = 164 170 let orig_len = String.length orig and word_len = String.length word in 165 171 let rec aux_rule word num lst = 166 172 match lst with 167 173 | (rules, fn) :: tl -> 168 174 if List.mem num rules then fn word else aux_rule word num tl 169 - | [] -> 170 - true 175 + | [] -> true 171 176 in 172 177 if word_len > orig_len then 173 178 let word_end = String.sub word (word_len - orig_len) orig_len 174 - and word_root = String.sub word 0 (word_len - orig_len) 175 - in 176 - if word_end = orig 179 + and word_root = String.sub word 0 (word_len - orig_len) in 180 + if 181 + word_end = orig 177 182 && min_root < word_size word_root 178 - && aux_rule word_root num rules_criteria then 179 - (*print_int num; 180 - print_string (" ("^word^") "^word_end^" matches "^orig^"\n");*) 183 + && aux_rule word_root num rules_criteria 184 + then 185 + (*print_int num; print_string (" ("^word^") "^word_end^" matches 186 + "^orig^"\n");*) 181 187 true 182 188 else false 183 189 else false 184 190 185 - let apply_rule word ((_, orig, rep, _): int * string * string * int) = 191 + let apply_rule word ((_, orig, rep, _) : int * string * string * int) = 186 192 let orig_len = String.length orig and word_len = String.length word in 187 193 let orig_word = word 188 - and new_word = String.sub word 0 (word_len - orig_len) ^ rep 189 - in 194 + and new_word = String.sub word 0 (word_len - orig_len) ^ rep in 190 195 (* The new stem must be 2 or more characters in length *) 191 196 if String.length new_word < 2 then orig_word else new_word 192 197 ··· 197 202 let rule, _, _, _ = hd in 198 203 (rule, apply_rule word hd) 199 204 else replace_end word tl 200 - | [] -> 201 - (0, word) 205 + | [] -> (0, word) 202 206 203 207 let stem in_word = 204 208 let word = String.lowercase_ascii in_word in 205 209 let rec aux aux_word list = 206 210 match list with 207 - | hd :: tl -> 208 - ( 209 - match replace_end aux_word hd with 210 - | 106, out | 107, out -> 211 - let _, out2 = replace_end out rule_list_1b1 in 212 - aux out2 tl 213 - | _, out -> 214 - aux out tl 215 - ) 216 - | [] -> 217 - aux_word 211 + | hd :: tl -> ( 212 + match replace_end aux_word hd with 213 + | 106, out | 107, out -> 214 + let _, out2 = replace_end out rule_list_1b1 in 215 + aux out2 tl 216 + | _, out -> aux out tl) 217 + | [] -> aux_word 218 218 in 219 219 (* This is a really stupid hack. Why do I need it? *) 220 220 (* if 0 = String.compare "'s" (String.sub word (-2) 2) then word *) ··· 222 222 aux word all_rules 223 223 224 224 let stem_cmp s1 s2 = stem s1 = stem s2 225 - 226 225 let stem_gt s1 s2 = stem s1 > stem s2 227 - 228 226 let stem_gte s1 s2 = stem s1 >= stem s2 229 - 230 227 let stem_lt s1 s2 = stem s1 < stem s2 231 - 232 228 let stem_lte s1 s2 = stem s1 <= stem s2
+77 -135
lib/search/Tokenizer.ml
··· 4 4 * SPDX-License-Identifier: GPL-3.0-or-later 5 5 *) 6 6 7 - open struct module T = Forester_core.Types end 7 + open struct 8 + module T = Forester_core.Types 9 + end 8 10 9 - module Set = Set.Make(String) 11 + module Set = Set.Make (String) 10 12 11 - type loc = 12 - | In_frontmatter 13 - | In_mainmatter 13 + type loc = In_frontmatter | In_mainmatter 14 14 15 - let int_of_field_frontmatter 16 - = function 15 + let int_of_field_frontmatter = function 17 16 | `uri -> 0 18 17 | `title -> 1 19 18 | `dates -> 2 ··· 25 24 | `tags -> 8 26 25 | `metas -> 9 27 26 28 - let int_of_field_article 29 - = function 27 + let int_of_field_article = function 30 28 | `frontmatter -> 0 31 29 | `mainmatter -> 1 32 30 | `backmatter -> 2 ··· 34 32 type token = {v: string; loc: loc} 35 33 36 34 let common_words = 37 - Set.of_list 38 - [ 39 - "a"; 40 - "and"; 41 - "be"; 42 - "have"; 43 - "i"; 44 - "in"; 45 - "of"; 46 - "that"; 47 - "the"; 48 - "to"; 49 - ] 35 + Set.of_list ["a"; "and"; "be"; "have"; "i"; "in"; "of"; "that"; "the"; "to"] 50 36 51 37 let tokenize string = 52 38 Str.(split @@ regexp "[^a-zA-Z0-9]+") string 53 - |> List.filter_map 54 - (fun s -> 55 - let lower = String.lowercase_ascii s in 56 - if not @@ Set.mem lower common_words then 57 - Some (Stemming.stem lower) 58 - else 59 - None 60 - ) 39 + |> List.filter_map (fun s -> 40 + let lower = String.lowercase_ascii s in 41 + if not @@ Set.mem lower common_words then Some (Stemming.stem lower) 42 + else None) 61 43 62 - let rec tokenize_content 63 - : int list -> loc -> T.content -> (int list * string) list 64 - = fun path loc node -> 44 + let rec tokenize_content : 45 + int list -> loc -> T.content -> (int list * string) list = 46 + fun path loc node -> 65 47 match node with 66 48 | T.Content nodes -> 67 - List.concat @@ 68 - List.mapi 69 - (fun i node -> 70 - match node with 71 - | T.Text s -> 72 - List.mapi 73 - (fun j token -> j :: i :: path, token) 74 - (tokenize s) 75 - (* i :: path, token *) 76 - | T.CDATA s -> 77 - List.mapi 78 - (fun j token -> j :: i :: path, token) 79 - (tokenize s) 80 - | T.Xml_elt {content; _} -> 81 - (* TODO: Consider tokenizing xml_qname *) 82 - tokenize_content 83 - (i :: path) 84 - loc 85 - content 86 - | T.Section {frontmatter; mainmatter; _} -> 87 - tokenize_frontmatter 88 - (int_of_field_article `frontmatter :: path) 89 - frontmatter @ 90 - tokenize_content path loc mainmatter 91 - | T.Link {content; _} -> tokenize_content (i :: path) loc content 92 - | T.KaTeX (_, _) -> 93 - (* NOTE: 94 - In order to properly search math, we need to revamp the 95 - architecture and add more features...*) 96 - [] 97 - | T.Transclude _ 98 - | T.Contextual_number _ 99 - | T.Artefact _ 100 - | T.Uri _ 101 - | T.Route_of_uri _ 102 - | T.Datalog_script _ 103 - | T.Results_of_datalog_query _ -> 104 - [] 105 - ) 106 - nodes 49 + List.concat 50 + @@ List.mapi 51 + (fun i node -> 52 + match node with 53 + | T.Text s -> 54 + List.mapi (fun j token -> (j :: i :: path, token)) (tokenize s) 55 + (* i :: path, token *) 56 + | T.CDATA s -> 57 + List.mapi (fun j token -> (j :: i :: path, token)) (tokenize s) 58 + | T.Xml_elt {content; _} -> 59 + (* TODO: Consider tokenizing xml_qname *) 60 + tokenize_content (i :: path) loc content 61 + | T.Section {frontmatter; mainmatter; _} -> 62 + tokenize_frontmatter 63 + (int_of_field_article `frontmatter :: path) 64 + frontmatter 65 + @ tokenize_content path loc mainmatter 66 + | T.Link {content; _} -> tokenize_content (i :: path) loc content 67 + | T.KaTeX (_, _) -> 68 + (* NOTE: In order to properly search math, we need to revamp the 69 + architecture and add more features...*) 70 + [] 71 + | T.Transclude _ | T.Contextual_number _ | T.Artefact _ | T.Uri _ 72 + | T.Route_of_uri _ | T.Datalog_script _ 73 + | T.Results_of_datalog_query _ -> 74 + []) 75 + nodes 107 76 108 - and tokenize_vertex 109 - : int list -> 110 - loc -> 111 - T.content T.vertex -> 112 - (int list * string) list 113 - = fun path loc v -> 77 + and tokenize_vertex : 78 + int list -> loc -> T.content T.vertex -> (int list * string) list = 79 + fun path loc v -> 114 80 match v with 115 81 | T.Uri_vertex _ -> [] 116 - | T.Content_vertex c -> 117 - tokenize_content path loc c 82 + | T.Content_vertex c -> tokenize_content path loc c 118 83 119 - and tokenize_attribution 120 - : int list -> 121 - loc -> 122 - T.content T.attribution -> 123 - (int list * string) list 124 - = fun path loc v -> 125 - match v with 126 - | T.{vertex; _} -> 127 - tokenize_vertex path loc vertex 84 + and tokenize_attribution : 85 + int list -> loc -> T.content T.attribution -> (int list * string) list = 86 + fun path loc v -> 87 + match v with T.{vertex; _} -> tokenize_vertex path loc vertex 128 88 129 - and tokenize_frontmatter 130 - : int list -> 131 - T.content T.frontmatter -> 132 - (int list * string) list 133 - = fun path fm -> 89 + and tokenize_frontmatter : 90 + int list -> T.content T.frontmatter -> (int list * string) list = 91 + fun path fm -> 134 92 match fm with 135 - | {title; 136 - attributions; 137 - taxon; 138 - tags; 139 - metas; 140 - _; 141 - } -> 93 + | {title; attributions; taxon; tags; metas; _} -> 142 94 List.concat 143 95 [ 144 - Option.value 145 - ~default: [] 146 - ( 147 - Option.map 148 - ( 149 - tokenize_content 150 - (int_of_field_frontmatter `title :: path) 151 - In_frontmatter 152 - ) 153 - title 154 - ); 155 - Option.value 156 - ~default: [] 157 - ( 158 - Option.map 159 - ( 160 - tokenize_content 161 - (int_of_field_frontmatter `taxon :: path) 162 - In_frontmatter 163 - ) 164 - taxon 165 - ); 96 + Option.value ~default:[] 97 + (Option.map 98 + (tokenize_content 99 + (int_of_field_frontmatter `title :: path) 100 + In_frontmatter) 101 + title); 102 + Option.value ~default:[] 103 + (Option.map 104 + (tokenize_content 105 + (int_of_field_frontmatter `taxon :: path) 106 + In_frontmatter) 107 + taxon); 166 108 List.concat_map (tokenize_attribution path In_frontmatter) attributions; 167 109 List.concat_map (tokenize_vertex path In_frontmatter) tags; 168 - List.concat @@ 169 - List.mapi 170 - (fun _i (s, c) -> 171 - (List.mapi (fun i t -> i :: path, t) @@ tokenize s) @ 172 - tokenize_content path In_frontmatter c 173 - ) 174 - metas; 110 + List.concat 111 + @@ List.mapi 112 + (fun _i (s, c) -> 113 + (List.mapi (fun i t -> (i :: path, t)) @@ tokenize s) 114 + @ tokenize_content path In_frontmatter c) 115 + metas; 175 116 ] 176 117 177 - let tokenize_article : T.content T.article -> (int list * string) list = function 118 + let tokenize_article : T.content T.article -> (int list * string) list = 119 + function 178 120 | {frontmatter; mainmatter; _} -> 179 - tokenize_frontmatter [0] frontmatter @ 180 - tokenize_content [1] In_mainmatter mainmatter 181 - |> List.map (fun (x, y) -> List.rev x, y) 121 + tokenize_frontmatter [0] frontmatter 122 + @ tokenize_content [1] In_mainmatter mainmatter 123 + |> List.map (fun (x, y) -> (List.rev x, y))
+74 -70
lib/search/test/Test_forester_search.ml
··· 6 6 7 7 open Forester_core 8 8 open Forester_search 9 + 9 10 open struct 10 11 module T = Forester_core.Types 11 12 module Trie = Yuujinchou.Trie 12 13 end 13 14 14 15 let doc1 = 15 - T.{ 16 - frontmatter = 17 - default_frontmatter 18 - ~uri: (URI.of_string_exn "forest://doc1") 19 - ~title: (T.Content [T.Text "Title of tremendous importance"]) 20 - (); 21 - mainmatter = 22 - T.Content [T.Text "A donut on a glass plate. Only the donuts."]; 23 - backmatter = T.Content []; 24 - } 16 + T. 17 + { 18 + frontmatter = 19 + default_frontmatter 20 + ~uri:(URI.of_string_exn "forest://doc1") 21 + ~title:(T.Content [T.Text "Title of tremendous importance"]) (); 22 + mainmatter = 23 + T.Content [T.Text "A donut on a glass plate. Only the donuts."]; 24 + backmatter = T.Content []; 25 + } 25 26 26 27 let doc2 = 27 - T.{ 28 - frontmatter = default_frontmatter ~uri: (URI.of_string_exn "forest://doc2") (); 29 - mainmatter = 30 - T.Content [T.Text "donut is a donut"]; 31 - backmatter = T.Content []; 32 - } 28 + T. 29 + { 30 + frontmatter = 31 + default_frontmatter ~uri:(URI.of_string_exn "forest://doc2") (); 32 + mainmatter = T.Content [T.Text "donut is a donut"]; 33 + backmatter = T.Content []; 34 + } 33 35 34 36 let pp_pair pp_fst pp_snd out (x, y) = 35 37 Format.fprintf out "(%a, %a)" pp_fst x pp_snd y 36 38 37 39 let test_context path doc = 38 40 Format.( 39 - printf 40 - "word at path %a: %s@." 41 + printf "word at path %a: %s@." 41 42 (pp_print_list pp_print_int) 42 43 path 43 - (Context.render_context_article path doc) 44 - ) 44 + (Context.render_context_article path doc)) 45 45 46 46 let test_nth_word () = 47 47 let corpus = 48 - "Far far away, behind the word mountains, far from the countries Vokalia and Consonantia, there live the blind texts. Separated they live in Bookmarksgrove right at the coast of the Semantics, a large language ocean. A small river named Duden flows by their place and supplies it with the necessary regelialia. It is a paradisematic country, in which roasted parts of sentences fly into your mouth. Even the all-powerful Pointing has no control about the blind texts it is an almost unorthographic life One day however a small line of blind text by the name of Lorem Ipsum decided to leave for the far World of Grammar. The Big Oxmox advised her not to do so, because there were thousands of bad Commas, wild Question Marks and devious Semikoli, but the Little Blind Text didn’t listen. She packed her seven versalia, put her initial into the belt and made herself on the way. When she reached the first hills of the Italic Mountains, she had a last view back on the skyline of her hometown Bookmarksgrove, the headline of Alphabet Village and the subline of her own road, the Line Lane. Pityful a rethoric question ran over her cheek, then" 48 + "Far far away, behind the word mountains, far from the countries Vokalia \ 49 + and Consonantia, there live the blind texts. Separated they live in \ 50 + Bookmarksgrove right at the coast of the Semantics, a large language \ 51 + ocean. A small river named Duden flows by their place and supplies it \ 52 + with the necessary regelialia. It is a paradisematic country, in which \ 53 + roasted parts of sentences fly into your mouth. Even the all-powerful \ 54 + Pointing has no control about the blind texts it is an almost \ 55 + unorthographic life One day however a small line of blind text by the \ 56 + name of Lorem Ipsum decided to leave for the far World of Grammar. The \ 57 + Big Oxmox advised her not to do so, because there were thousands of bad \ 58 + Commas, wild Question Marks and devious Semikoli, but the Little Blind \ 59 + Text didn’t listen. She packed her seven versalia, put her initial into \ 60 + the belt and made herself on the way. When she reached the first hills of \ 61 + the Italic Mountains, she had a last view back on the skyline of her \ 62 + hometown Bookmarksgrove, the headline of Alphabet Village and the subline \ 63 + of her own road, the Line Lane. Pityful a rethoric question ran over her \ 64 + cheek, then" 49 65 in 50 66 let tokens = Tokenizer.tokenize corpus in 51 67 List.iteri 52 68 (fun i token -> 53 69 Alcotest.(check string) 54 - "Using get_nth_word and stemming the word should be the same as the nth 55 - element of tokens. Will be used to render the context of a token." 56 - ( 57 - Context.get_nth_word i corpus 58 - |> String.lowercase_ascii 59 - |> Stemming.stem 60 - ) 61 - token 62 - ) 70 + "Using get_nth_word and stemming the word should be the same as the nth\n\ 71 + \ element of tokens. Will be used to render the context of a \ 72 + token." 73 + (Context.get_nth_word i corpus 74 + |> String.lowercase_ascii |> Stemming.stem) 75 + token) 63 76 tokens 64 77 65 78 let test_tokenize_content () = ··· 69 82 [ 70 83 p 71 84 [ 72 - ol 73 - [ 74 - li [txt "First item"]; 75 - li [txt "Second item"] 76 - ]; 85 + ol [li [txt "First item"]; li [txt "Second item"]]; 77 86 ul 78 87 [ 79 88 li [txt "First item in second list"]; 80 - li [txt "Second item in second list"] 89 + li [txt "Second item in second list"]; 81 90 ]; 82 - ] 91 + ]; 83 92 ] 84 93 in 85 94 let tokens = Tokenizer.tokenize_content [] In_mainmatter content in ··· 99 108 "second"; 100 109 "item"; 101 110 "second"; 102 - "list" 111 + "list"; 103 112 ] 104 113 (List.map render locations) 105 114 ··· 107 116 let open Forester_frontend.DSL in 108 117 let frontmatter = 109 118 T.default_frontmatter 110 - ~uri: (URI.of_string_exn "forest://test/asdf") 111 - ~source_path: "/foo/bar" 112 - ~taxon: (T.Content [T.Text "Hello"]) 113 - ~title: (T.Content [txt "title"; katex Display [txt "a=b"]]) 114 - ~attributions: [ 115 - { 116 - role = T.Author; 117 - vertex = Uri_vertex (URI.of_string_exn "forest://test/kentookura"); 118 - }; 119 - { 120 - role = T.Contributor; 121 - vertex = Uri_vertex (URI.of_string_exn "forest://test/jonmsterling") 122 - } 123 - ] 119 + ~uri:(URI.of_string_exn "forest://test/asdf") 120 + ~source_path:"/foo/bar" ~taxon:(T.Content [T.Text "Hello"]) 121 + ~title:(T.Content [txt "title"; katex Display [txt "a=b"]]) 122 + ~attributions: 123 + [ 124 + { 125 + role = T.Author; 126 + vertex = Uri_vertex (URI.of_string_exn "forest://test/kentookura"); 127 + }; 128 + { 129 + role = T.Contributor; 130 + vertex = Uri_vertex (URI.of_string_exn "forest://test/jonmsterling"); 131 + }; 132 + ] 124 133 () 125 134 in 126 135 let tokens = Tokenizer.tokenize_frontmatter [] frontmatter in 127 136 let locations = List.map (fun (x, _) -> List.rev x) tokens in 128 137 let render path = Context.render_context_frontmatter path frontmatter in 129 138 Alcotest.(check @@ list string) 130 - "" 131 - ["title"; "hello"] 139 + "" ["title"; "hello"] 132 140 (List.map render locations) 133 141 134 - let test_ranking () = 135 - Alcotest.(check string) 136 - "" 137 - "" 138 - "" 142 + let test_ranking () = Alcotest.(check string) "" "" "" 139 143 140 144 let () = 141 145 let open Alcotest in 142 - run 143 - "Test_forester_search" 146 + run "Test_forester_search" 144 147 [ 145 - "tokenizer", 146 - [ 147 - test_case "get_nth_word" `Quick test_nth_word; 148 - test_case "tokenize_content" `Quick test_tokenize_content; 149 - ]; 150 - "context", 151 - [ 152 - test_case "render_context_frontmatter" `Quick test_render_context_frontmatter; 153 - ]; 148 + ( "tokenizer", 149 + [ 150 + test_case "get_nth_word" `Quick test_nth_word; 151 + test_case "tokenize_content" `Quick test_tokenize_content; 152 + ] ); 153 + ( "context", 154 + [ 155 + test_case "render_context_frontmatter" `Quick 156 + test_render_context_frontmatter; 157 + ] ); 154 158 ] 155 159 156 160 (* let () = *)
+7 -5
lib/server/Headers.ml
··· 7 7 open Forester_prelude 8 8 open Forester_core 9 9 10 - open struct module T = Types end 10 + open struct 11 + module T = Types 12 + end 11 13 12 14 let parse_flag field header = 13 15 match Http.Header.get header field with ··· 34 36 header_shown; 35 37 metadata_shown; 36 38 numbered; 37 - expanded 39 + expanded; 38 40 } 39 41 40 42 let parse_content_target (header : Http.Header.t) : T.content_target option = 41 43 let open Http in 42 44 match Header.get header "Taxon" with 43 45 | Some _ -> Some T.Taxon 44 - | None -> 46 + | None -> ( 45 47 match Header.get header "Mainmatter" with 46 48 | Some _ -> Some T.Mainmatter 47 - | None -> 49 + | None -> ( 48 50 match Header.get header "Full" with 49 51 | Some _ -> 50 52 let@ flags = Option.map @~ parse_section_flags header in ··· 52 54 | None -> 53 55 let@ _ = Option.bind @@ Header.get header "Title" in 54 56 let@ flags = Option.map @~ parse_title_flags header in 55 - T.Title flags 57 + T.Title flags))
+28 -15
lib/server/Index.ml
··· 8 8 open HTML 9 9 10 10 let v ?c () = 11 - html 12 - [] 11 + html [] 13 12 [ 14 - head 15 - [] 13 + head [] 16 14 [ 17 - meta [name "viewport"; content "width=device-width";]; 18 - link [rel "stylesheet"; href "/style.css";]; 19 - link [rel "icon"; type_ "image/x-icon"; href "/favicon.ico";]; 20 - script [type_ "module"; src "/min.js";] ""; 15 + meta [name "viewport"; content "width=device-width"]; 16 + link [rel "stylesheet"; href "/style.css"]; 17 + link [rel "icon"; type_ "image/x-icon"; href "/favicon.ico"]; 18 + script [type_ "module"; src "/min.js"] ""; 21 19 script [src "/htmx.js"] ""; 22 - link [rel "stylesheet"; href "https://cdn.jsdelivr.net/npm/katex@0.16.21/dist/katex.min.css"; integrity "sha384-zh0CIslj+VczCZtlzBcjt5ppRcsAmDnRem7ESsYwWwg3m/OaJ2l4x7YBZl9Kxxib"; crossorigin `anonymous;]; 23 - script [src "https://cdn.jsdelivr.net/npm/katex@0.16.21/dist/katex.js"; integrity "sha384-CAltQiu9myJj3FAllEacN6FT+rOyXo+hFZKGuR2p4HB8JvJlyUHm31eLfL4eEiJL"; crossorigin `anonymous;] ""; 20 + link 21 + [ 22 + rel "stylesheet"; 23 + href 24 + "https://cdn.jsdelivr.net/npm/katex@0.16.21/dist/katex.min.css"; 25 + integrity 26 + "sha384-zh0CIslj+VczCZtlzBcjt5ppRcsAmDnRem7ESsYwWwg3m/OaJ2l4x7YBZl9Kxxib"; 27 + crossorigin `anonymous; 28 + ]; 29 + script 30 + [ 31 + src "https://cdn.jsdelivr.net/npm/katex@0.16.21/dist/katex.js"; 32 + integrity 33 + "sha384-CAltQiu9myJj3FAllEacN6FT+rOyXo+hFZKGuR2p4HB8JvJlyUHm31eLfL4eEiJL"; 34 + crossorigin `anonymous; 35 + ] 36 + ""; 24 37 title [] ""; 25 38 ]; 26 39 body 27 - [Hx.boost true;] 40 + [Hx.boost true] 28 41 [ 29 42 header [] []; 30 43 div 31 - [id "grid-wrapper";] 44 + [id "grid-wrapper"] 32 45 [ 33 - match c with 46 + (match c with 34 47 | Some stuff -> stuff 35 48 | None -> 36 49 article ··· 41 54 Hx.target "this"; 42 55 Hx.swap "outerHTML"; 43 56 ] 44 - []; 57 + []); 45 58 ]; 46 - div [id "modal-container";] []; 59 + div [id "modal-container"] []; 47 60 ]; 48 61 ]
+1 -1
lib/server/Router.ml
··· 23 23 let routes : route router = 24 24 one_of 25 25 [ 26 - route (Routes.nil) Index; 26 + route Routes.nil Index; 27 27 route (s "fonts" / str /? nil) (fun s -> Font s); 28 28 route (s "style.css" /? nil) Stylesheet; 29 29 route (s "min.js" /? nil) Js_bundle;
+19 -23
lib/server/Search_menu.ml
··· 7 7 open Forester_core 8 8 open Forester_compiler 9 9 open Forester_frontend 10 - 11 10 open Pure_html 12 11 open HTML 13 12 ··· 22 21 ] 23 22 [ 24 23 div 25 - [class_ "modal-content";] 24 + [class_ "modal-content"] 26 25 [ 27 26 form 28 27 [ 29 28 class_ "search-form"; 30 29 Hx.post "/search"; 31 - Hx.trigger "input changed delay:500ms, keyup[key=='Enter'], load"; 30 + Hx.trigger 31 + "input changed delay:500ms, keyup[key=='Enter'], load"; 32 32 Hx.target "#search-results"; 33 33 ] 34 34 [ ··· 40 40 name "search"; 41 41 placeholder "Start typing a note title or ID"; 42 42 ]; 43 - span 44 - [] 43 + span [] 45 44 [ 46 45 input [type_ "radio"; name "search-for"; value "full-text"]; 47 46 label [for_ "full-text"] [txt "Full text"]; 48 47 ]; 49 - span 50 - [] 48 + span [] 51 49 [ 52 50 input [type_ "radio"; name "search-for"; value "title"]; 53 51 label [for_ "title-text"] [txt "title"]; 54 52 ]; 55 53 ]; 56 - ul 57 - [id "search-results";] 58 - []; 54 + ul [id "search-results"] []; 59 55 ]; 60 56 ] 61 57 in 62 58 Pure_html.to_string markup 63 59 64 60 let results (forest : State.t) (links : URI.t list) = 65 - Pure_html.to_string @@ 66 - ul 67 - [id "search-results"] 68 - ( 69 - List.filter_map 61 + Pure_html.to_string 62 + @@ ul 63 + [id "search-results"] 64 + (List.filter_map 70 65 (fun uri -> 71 - let title = State.get_content_of_transclusion {href = uri; target = Title {empty_when_untitled = false}} forest in 66 + let title = 67 + State.get_content_of_transclusion 68 + {href = uri; target = Title {empty_when_untitled = false}} 69 + forest 70 + in 72 71 Option.map 73 72 (fun t -> 74 73 a ··· 77 76 href "/trees%s" (URI.path_string uri); 78 77 Hx.target "#tree-container"; 79 78 Hx.swap "outerHTML"; 80 - ] @@ 81 - Htmx_client.render_content forest t 82 - ) 83 - title 84 - ) 85 - links 86 - ) 79 + ] 80 + @@ Htmx_client.render_content forest t) 81 + title) 82 + links)
+196 -213
lib/server/Server.ml
··· 31 31 let htmx = load_file "htmx.js" in 32 32 let favicon = load_file "favicon.ico" in 33 33 let js_bundle = EP.(load (env#fs / base_dir / "min.js")) in 34 - let font_dir = EP.(native_exn @@ theme_dir / "fonts") in 35 - {stylesheet; htmx; js_bundle; font_dir; favicon;} 34 + let font_dir = EP.(native_exn @@ (theme_dir / "fonts")) in 35 + {stylesheet; htmx; js_bundle; font_dir; favicon} 36 36 37 37 let lookup_font ~env theme font = 38 38 Eio.Path.(load (env#fs / theme.font_dir / font)) 39 39 40 - let handler 41 - : env: < fs: [> Eio.Fs.dir_ty] Eio.Path.t; .. > -> 42 - theme: theme -> 43 - forest: State.t -> 44 - Cohttp_eio.Server.conn -> 45 - Http.Request.t -> 46 - Cohttp_eio.Body.t -> 47 - Cohttp_eio.Server.response 48 - = fun 49 - ~env 50 - ~theme 51 - ~(forest : State.t) 52 - _socket 53 - request 54 - body 55 - -> 40 + let handler : 41 + env:< fs : [> Eio.Fs.dir_ty] Eio.Path.t ; .. > -> 42 + theme:theme -> 43 + forest:State.t -> 44 + Cohttp_eio.Server.conn -> 45 + Http.Request.t -> 46 + Cohttp_eio.Body.t -> 47 + Cohttp_eio.Server.response = 48 + fun ~env ~theme ~(forest : State.t) _socket request body -> 56 49 let resource = Uri.of_string request.resource in 57 50 let path = Uri.path resource in 58 - match Routes.match' ~target: path Router.routes with 59 - | Routes.FullMatch r 60 - | Routes.MatchWithTrailingSlash r -> 61 - begin 62 - match r with 63 - | Font fontname -> 64 - let body = lookup_font ~env theme fontname in 65 - let headers = 66 - let ext = Filename.extension fontname in 67 - let mimetype = 68 - match ext with 69 - | ".ttf" -> "font/ttf" 70 - | ".woff" -> "font/woff" 71 - | ".woff2" -> "font/woff2" 72 - | _ -> assert false 51 + match Routes.match' ~target:path Router.routes with 52 + | Routes.FullMatch r | Routes.MatchWithTrailingSlash r -> begin 53 + match r with 54 + | Font fontname -> 55 + let body = lookup_font ~env theme fontname in 56 + let headers = 57 + let ext = Filename.extension fontname in 58 + let mimetype = 59 + match ext with 60 + | ".ttf" -> "font/ttf" 61 + | ".woff" -> "font/woff" 62 + | ".woff2" -> "font/woff2" 63 + | _ -> assert false 64 + in 65 + Http.Header.of_list [("Content-Type", mimetype)] 66 + in 67 + Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body () 68 + | Stylesheet -> 69 + let headers = 70 + Http.Header.of_list [("Content-Type", "text/css"); ("charset", "utf-8")] 71 + in 72 + Cohttp_eio.Server.respond_string ~headers ~status:`OK 73 + ~body:theme.stylesheet () 74 + | Js_bundle -> 75 + let headers = 76 + Http.Header.of_list [("Content-Type", "application/javascript")] 77 + in 78 + Cohttp_eio.Server.respond_string ~headers ~status:`OK 79 + ~body:theme.js_bundle () 80 + | Index -> 81 + let headers = Http.Header.of_list [("Content-Type", "text/html")] in 82 + Cohttp_eio.Server.respond_string ~headers ~status:`OK 83 + ~body:(Pure_html.to_string (Index.v ())) 84 + () 85 + | Favicon -> 86 + let headers = Http.Header.of_list [("Content-Type", "image/x-icon")] in 87 + Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body:theme.favicon 88 + () 89 + | Tree s -> 90 + let href = URI_scheme.named_uri ~base:forest.config.url s in 91 + let request_headers = Http.Request.headers request in 92 + let is_htmx = 93 + (*If it is an HTMX request, we just send a fragment. If it is not an 94 + HTMX request, we need to send the whole page. This happens for example 95 + when the user opens a link via the URL bar of the browser. 96 + *) 97 + Option.is_some @@ Http.Header.get request_headers "Hx-Request" 98 + in 99 + begin if is_htmx then begin 100 + (* We use custom headers to configure the transclusion. *) 101 + match Headers.parse_content_target request_headers with 102 + (* If we fail to parse a target, just render the article.*) 103 + | None -> begin 104 + match State.get_article href forest with 105 + | None -> 106 + (* TODO: Some sort of 404 template *) 107 + Cohttp_eio.Server.respond_string ~status:`Not_found ~body:"" () 108 + | Some content -> 109 + let response = 110 + Pure_html.to_string @@ Htmx_client.render_article forest content 111 + in 112 + Cohttp_eio.Server.respond_string ~status:`OK ~body:response () 113 + end 114 + | Some target -> ( 115 + match State.get_content_of_transclusion {target; href} forest with 116 + | None -> 117 + Cohttp_eio.Server.respond_string ~status:`Not_found ~body:"" () 118 + | Some content -> 119 + (* TODO: Remove any sort of HTML generation from the handler. *) 120 + let response = 121 + Pure_html.( 122 + to_string 123 + @@ HTML.span [] (Htmx_client.render_content forest content)) 124 + in 125 + Cohttp_eio.Server.respond_string ~status:`OK ~body:response ()) 126 + end 127 + else 128 + match State.get_article href forest with 129 + | Some article -> 130 + let content = 131 + Pure_html.to_string 132 + @@ Index.v ~c:(Htmx_client.render_article forest article) () 73 133 in 74 - Http.Header.of_list ["Content-Type", mimetype] 134 + let headers = Http.Header.of_list [("Content-Type", "text/html")] in 135 + Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body:content () 136 + | None -> 137 + Cohttp_eio.Server.respond_string ~status:`Not_found ~body:"" () 138 + end 139 + | Search -> 140 + if request.meth = `POST then 141 + let body = Eio.Flow.read_all body in 142 + let get_param key = 143 + Option.map (String.concat "") 144 + @@ Option.map snd 145 + @@ List.find_opt (fun (s, _) -> s = key) (Uri.query_of_encoded body) 75 146 in 76 - Cohttp_eio.Server.respond_string ~headers ~status: `OK ~body () 77 - | Stylesheet -> 78 - let headers = Http.Header.of_list ["Content-Type", "text/css"; "charset", "utf-8"] in 79 - Cohttp_eio.Server.respond_string ~headers ~status: `OK ~body: theme.stylesheet () 80 - | Js_bundle -> 81 - let headers = Http.Header.of_list ["Content-Type", "application/javascript"] in 82 - Cohttp_eio.Server.respond_string ~headers ~status: `OK ~body: theme.js_bundle () 83 - | Index -> 84 - let headers = Http.Header.of_list ["Content-Type", "text/html"] in 85 - Cohttp_eio.Server.respond_string ~headers ~status: `OK ~body: (Pure_html.to_string (Index.v ())) () 86 - | Favicon -> 87 - let headers = Http.Header.of_list ["Content-Type", "image/x-icon"] in 88 - Cohttp_eio.Server.respond_string ~headers ~status: `OK ~body: theme.favicon () 89 - | Tree s -> 90 - let href = URI_scheme.named_uri ~base: forest.config.url s in 91 - let request_headers = Http.Request.headers request in 92 - let is_htmx = 93 - (*If it is an HTMX request, we just send a fragment. 94 - If it is not an HTMX request, we need to send the whole page. This 95 - happens for example when the user opens a link via the URL bar of 96 - the browser. 97 - *) 98 - Option.is_some @@ Http.Header.get request_headers "Hx-Request" 147 + let _search_term = Option.value ~default:"" @@ get_param "search" in 148 + let search_for = get_param "search-for" in 149 + let search_results = 150 + match search_for with 151 + | None -> [] 152 + | Some "title-text" -> 153 + (* Forester_search.Index.search *) 154 + (* forest.search_index *) 155 + (* search_term *) 156 + [] 157 + | Some "full-text" -> 158 + (* Forester_search.Index.search *) 159 + (* forest.search_index *) 160 + (* search_term *) 161 + [] 162 + | Some _ -> assert false 99 163 in 100 - begin 101 - if is_htmx then 102 - begin 103 - (* We use custom headers to configure the transclusion. *) 104 - match Headers.parse_content_target request_headers with 105 - (* If we fail to parse a target, just render the article.*) 106 - | None -> 107 - begin 108 - match State.get_article href forest with 109 - | None -> 110 - (* TODO: Some sort of 404 template *) 111 - Cohttp_eio.Server.respond_string ~status: `Not_found ~body: "" () 112 - | Some content -> 113 - let response = Pure_html.to_string @@ Htmx_client.render_article forest content in 114 - Cohttp_eio.Server.respond_string ~status: `OK ~body: response () 115 - end 116 - | Some target -> 117 - match State.get_content_of_transclusion {target; href} forest with 118 - | None -> Cohttp_eio.Server.respond_string ~status: `Not_found ~body: "" () 119 - | Some content -> 120 - (* TODO: Remove any sort of HTML generation from the handler. *) 121 - let response = Pure_html.(to_string @@ HTML.span [] (Htmx_client.render_content forest content)) in 122 - Cohttp_eio.Server.respond_string ~status: `OK ~body: response () 123 - end 124 - else 125 - match State.get_article href forest with 126 - | Some article -> 127 - let content = Pure_html.to_string @@ Index.v ~c: (Htmx_client.render_article forest article) () in 128 - let headers = Http.Header.of_list ["Content-Type", "text/html"] in 129 - Cohttp_eio.Server.respond_string ~headers ~status: `OK ~body: content () 130 - | None -> Cohttp_eio.Server.respond_string ~status: `Not_found ~body: "" () 131 - end 132 - | Search -> 133 - if request.meth = `POST then 134 - let body = Eio.Flow.read_all body in 135 - let get_param key = 136 - Option.map (String.concat "") @@ 137 - Option.map snd @@ 138 - List.find_opt 139 - (fun (s, _) -> 140 - s = key 141 - ) 142 - (Uri.query_of_encoded body) 143 - in 144 - let _search_term = Option.value ~default: "" @@ get_param "search" in 145 - let search_for = get_param "search-for" in 146 - let search_results = 147 - match search_for with 148 - | None -> [] 149 - | Some "title-text" -> 150 - (* Forester_search.Index.search *) 151 - (* forest.search_index *) 152 - (* search_term *) 153 - [] 154 - | Some "full-text" -> 155 - (* Forester_search.Index.search *) 156 - (* forest.search_index *) 157 - (* search_term *) 158 - [] 159 - | Some _ -> assert false 160 - in 161 - let response 162 - = 163 - Search_menu.results 164 - forest 165 - (List.map snd search_results) 166 - in 167 - Cohttp_eio.Server.respond_string 168 - ~status: `OK 169 - ~body: response 170 - () 171 - else 172 - Cohttp_eio.Server.respond_string ~status: `Method_not_allowed ~body: "" () 173 - | Searchmenu -> 174 - Cohttp_eio.Server.respond_string ~status: `OK ~body: Search_menu.v () 175 - | Nil -> 176 - Cohttp_eio.Server.respond_string ~status: `OK ~body: "" () 177 - | Home -> 178 - begin 179 - let home = URI_scheme.named_uri ~base: forest.config.url "index" in 180 - match State.get_article home forest with 181 - | None -> 182 - Cohttp_eio.Server.respond_string ~status: `OK ~body: "" () 183 - | Some home_tree -> 184 - let content = Pure_html.to_string @@ Htmx_client.render_article forest home_tree in 185 - let headers = Http.Header.of_list ["Content-Type", "text/html"] in 186 - Cohttp_eio.Server.respond_string ~headers ~status: `OK ~body: content () 187 - end 188 - | Query -> 189 - let q = Uri.get_query_param resource "query" in 190 164 let response = 191 - q 192 - |> Option.get 193 - |> Uri.pct_decode 194 - |> Repr.of_json_string 195 - Datalog_expr.(query_t Repr.string (T.vertex_t T.content_t)) |> function 196 - | Ok _q -> 197 - Logs.app (fun m -> m "parsed successfully"); 198 - (* let _, _, result = Driver.update (Query q) forest in *) 199 - begin 200 - match None with 201 - (* FIXME :*) 202 - (* | `Vertex_set(vs : Vertex_set.t) -> Htmx_client.render_query_result forest vs *) 203 - | Some (`Vertex_set vs) -> Htmx_client.render_query_result forest vs 204 - | _ -> None 205 - end 206 - | Error (`Msg str) -> 207 - Logs.app (fun m -> m "failed to parse: %s" str); 208 - (* Pure_html.txt "failed to parse: %s" str *) 209 - None 165 + Search_menu.results forest (List.map snd search_results) 210 166 in 211 - begin 212 - match response with 213 - | Some nodes -> 214 - Cohttp_eio.Server.respond_string 215 - ~status: `OK 216 - ~body: (Format.asprintf "%a" Pure_html.pp nodes) 217 - () 218 - | None -> 219 - (* If result is empty, use 220 - [hx-retarget](https://htmx.org/reference/#response_headers) to 221 - hide the entire section. Right now I am just trying to get the 222 - backmatter to render correctly, I don't know if this is 223 - compatible with the other use cases of queries. I can think of 224 - multiple ways to work around this. We could use a separate 225 - endpoint to get the backmatter, or we could do some more 226 - HTMXing. I guess the question boils down to which approach is 227 - more in line with our overarching goal of making forester a 228 - genuine hypermedia format 229 - *) 230 - let headers = 231 - Http.Header.of_list 232 - [ 233 - "Hx-Retarget", "closest section.backmatter-section"; 234 - "Hx-Swap", "delete" 235 - ] 236 - in 237 - Cohttp_eio.Server.respond_string 238 - ~headers 239 - ~status: `OK 240 - ~body: "" 241 - () 242 - end 243 - | Htmx -> 244 - let headers = Http.Header.of_list ["Content-Type", "application/javascript"] in 245 - Cohttp_eio.Server.respond_string ~headers ~status: `OK ~body: theme.htmx () 167 + Cohttp_eio.Server.respond_string ~status:`OK ~body:response () 168 + else 169 + Cohttp_eio.Server.respond_string ~status:`Method_not_allowed ~body:"" () 170 + | Searchmenu -> 171 + Cohttp_eio.Server.respond_string ~status:`OK ~body:Search_menu.v () 172 + | Nil -> Cohttp_eio.Server.respond_string ~status:`OK ~body:"" () 173 + | Home -> begin 174 + let home = URI_scheme.named_uri ~base:forest.config.url "index" in 175 + match State.get_article home forest with 176 + | None -> Cohttp_eio.Server.respond_string ~status:`OK ~body:"" () 177 + | Some home_tree -> 178 + let content = 179 + Pure_html.to_string @@ Htmx_client.render_article forest home_tree 180 + in 181 + let headers = Http.Header.of_list [("Content-Type", "text/html")] in 182 + Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body:content () 246 183 end 184 + | Query -> 185 + let q = Uri.get_query_param resource "query" in 186 + let response = 187 + q |> Option.get |> Uri.pct_decode 188 + |> Repr.of_json_string 189 + Datalog_expr.(query_t Repr.string (T.vertex_t T.content_t)) 190 + |> function 191 + | Ok _q -> 192 + Logs.app (fun m -> m "parsed successfully"); 193 + (* let _, _, result = Driver.update (Query q) forest in *) 194 + begin match None with 195 + (* FIXME :*) 196 + (* | `Vertex_set(vs : Vertex_set.t) -> Htmx_client.render_query_result forest vs *) 197 + | Some (`Vertex_set vs) -> Htmx_client.render_query_result forest vs 198 + | _ -> None 199 + end 200 + | Error (`Msg str) -> 201 + Logs.app (fun m -> m "failed to parse: %s" str); 202 + (* Pure_html.txt "failed to parse: %s" str *) 203 + None 204 + in 205 + begin match response with 206 + | Some nodes -> 207 + Cohttp_eio.Server.respond_string ~status:`OK 208 + ~body:(Format.asprintf "%a" Pure_html.pp nodes) 209 + () 210 + | None -> 211 + (* If result is empty, use 212 + [hx-retarget](https://htmx.org/reference/#response_headers) to hide 213 + the entire section. Right now I am just trying to get the backmatter 214 + to render correctly, I don't know if this is compatible with the 215 + other use cases of queries. I can think of multiple ways to work 216 + around this. We could use a separate endpoint to get the backmatter, 217 + or we could do some more HTMXing. I guess the question boils down to 218 + which approach is more in line with our overarching goal of making 219 + forester a genuine hypermedia format 220 + *) 221 + let headers = 222 + Http.Header.of_list 223 + [ 224 + ("Hx-Retarget", "closest section.backmatter-section"); 225 + ("Hx-Swap", "delete"); 226 + ] 227 + in 228 + Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body:"" () 229 + end 230 + | Htmx -> 231 + let headers = 232 + Http.Header.of_list [("Content-Type", "application/javascript")] 233 + in 234 + Cohttp_eio.Server.respond_string ~headers ~status:`OK ~body:theme.htmx () 235 + end 247 236 | Routes.NoMatch -> 248 - Cohttp_eio.Server.respond_string ~status: `Not_found ~body: "" () 237 + Cohttp_eio.Server.respond_string ~status:`Not_found ~body:"" () 249 238 250 239 let log_warning ex = Logs.warn (fun f -> f "%a" Eio.Exn.pp ex) 251 240 252 241 let run ~env ~port ~forest theme_location = 253 - let@ sw = Eio.Switch.run ?name: None in 242 + let@ sw = Eio.Switch.run ?name:None in 254 243 let port = ref port in 255 244 let theme = load_theme ~env theme_location in 256 245 let socket = 257 - Eio.Net.listen 258 - env#net 259 - ~sw 260 - ~backlog: 128 261 - ~reuse_addr: true 246 + Eio.Net.listen env#net ~sw ~backlog:128 ~reuse_addr:true 262 247 (`Tcp (Eio.Net.Ipaddr.V4.loopback, !port)) 263 - and server = Cohttp_eio.Server.make ~callback: (handler ~env ~theme ~forest) () 248 + and server = 249 + Cohttp_eio.Server.make ~callback:(handler ~env ~theme ~forest) () 264 250 in 265 - Cohttp_eio.Server.run 266 - socket 267 - server 268 - ~on_error: log_warning 251 + Cohttp_eio.Server.run socket server ~on_error:log_warning
-1
lib/xml_names/Forester_xml_names.ml
··· 5 5 *) 6 6 7 7 include Types 8 - 9 8 module Xmlns_effect = Xmlns_effect
+2 -2
lib/xml_names/Types.ml
··· 11 11 12 12 let split_xml_qname str = 13 13 match String.split_on_char ':' str with 14 - | [prefix; uname] -> Some prefix, uname 15 - | [uname] -> None, uname 14 + | [prefix; uname] -> (Some prefix, uname) 15 + | [uname] -> (None, uname) 16 16 | _ -> failwith "split_xml_qname"
+68 -52
lib/xml_names/Xmlns_effect.ml
··· 5 5 *) 6 6 7 7 open Types 8 - 9 - module String_map = Map.Make(String) 8 + module String_map = Map.Make (String) 10 9 11 10 module Xmlns_map = struct 12 11 type t = { 13 12 prefix_to_xmlns: string String_map.t; 14 - xmlns_to_prefixes: string list String_map.t 13 + xmlns_to_prefixes: string list String_map.t; 15 14 } 16 15 17 - let empty = { 18 - prefix_to_xmlns = String_map.empty; 19 - xmlns_to_prefixes = String_map.empty 20 - } 16 + let empty = 17 + {prefix_to_xmlns = String_map.empty; xmlns_to_prefixes = String_map.empty} 21 18 22 - let assoc ~prefix ~xmlns env = { 23 - prefix_to_xmlns = String_map.add prefix xmlns env.prefix_to_xmlns; 24 - xmlns_to_prefixes = String_map.add_to_list xmlns prefix env.xmlns_to_prefixes 25 - } 19 + let assoc ~prefix ~xmlns env = 20 + { 21 + prefix_to_xmlns = String_map.add prefix xmlns env.prefix_to_xmlns; 22 + xmlns_to_prefixes = 23 + String_map.add_to_list xmlns prefix env.xmlns_to_prefixes; 24 + } 26 25 end 27 26 28 - module Make_writer (Elt : sig type t end) = struct 27 + module Make_writer (Elt : sig 28 + type t 29 + end) = 30 + struct 29 31 type _ Effect.t += Yield : Elt.t -> unit Effect.t 30 32 31 33 let yield x = Effect.perform (Yield x) ··· 33 35 let run f = 34 36 let open Effect.Deep in 35 37 try_with 36 - (fun () -> let r = f () in [], r) 38 + (fun () -> 39 + let r = f () in 40 + ([], r)) 37 41 () 38 42 { 39 - effc = fun (type a) (eff : a Effect.t) -> 40 - match eff with 41 - | Yield x -> 42 - Option.some @@ fun (k : (a, _) continuation) -> 43 - let xs, r = continue k () in 44 - x :: xs, r 45 - | _ -> None 43 + effc = 44 + (fun (type a) (eff : a Effect.t) -> 45 + match eff with 46 + | Yield x -> 47 + Option.some @@ fun (k : (a, _) continuation) -> 48 + let xs, r = continue k () in 49 + (x :: xs, r) 50 + | _ -> None); 46 51 } 47 52 48 53 let register_printer f = 49 54 Printexc.register_printer @@ function 50 - | Effect.Unhandled (Yield elt) -> f (`Yield elt) 51 - | _ -> None 55 + | Effect.Unhandled (Yield elt) -> f (`Yield elt) 56 + | _ -> None 52 57 53 - let () = register_printer @@ fun _ -> Some "Unhandled effect; use Make_writer.run" 58 + let () = 59 + register_printer @@ fun _ -> Some "Unhandled effect; use Make_writer.run" 54 60 end 55 61 56 62 module Make () = struct 57 - module E = Algaeff.State.Make(Xmlns_map) 58 - module Decls = Make_writer(struct type t = xmlns_attr end) 63 + module E = Algaeff.State.Make (Xmlns_map) 64 + 65 + module Decls = Make_writer (struct 66 + type t = xmlns_attr 67 + end) 59 68 60 69 let find_xmlns_for_prefix prefix = 61 70 let env = E.get () in 62 71 String_map.find_opt prefix env.prefix_to_xmlns 63 72 64 73 let smallest_string strings = 65 - List.hd @@ List.sort (fun s1 s2 -> compare (String.length s1) (String.length s2)) strings 74 + List.hd 75 + @@ List.sort 76 + (fun s1 s2 -> compare (String.length s1) (String.length s2)) 77 + strings 66 78 67 79 let rec normalise_qname (qname : xml_qname) = 68 80 let scope = E.get () in 69 81 match qname.xmlns with 70 - | None -> 71 - begin 72 - match String_map.find_opt qname.prefix scope.prefix_to_xmlns with 73 - | None -> qname 74 - | Some xmlns -> {qname with xmlns = Some xmlns} 75 - end 76 - | Some xmlns -> 77 - begin 78 - match String_map.find_opt qname.prefix scope.prefix_to_xmlns, 79 - String_map.find_opt xmlns scope.xmlns_to_prefixes with 80 - | None, (None | Some []) -> 81 - E.modify (Xmlns_map.assoc ~prefix: qname.prefix ~xmlns); 82 - Decls.yield {prefix = qname.prefix; xmlns}; 83 - qname 84 - | Some xmlns', Some prefixes -> 85 - if xmlns' = xmlns && List.mem qname.prefix prefixes then 86 - {qname with prefix = try smallest_string prefixes with _ -> qname.prefix} 87 - else 88 - normalise_qname {qname with prefix = qname.prefix ^ "_"} 89 - | None, Some prefixes -> 90 - {qname with prefix = try smallest_string prefixes with _ -> qname.prefix} 91 - | Some _, None -> 92 - normalise_qname {qname with prefix = qname.prefix ^ "_"} 93 - end 82 + | None -> begin 83 + match String_map.find_opt qname.prefix scope.prefix_to_xmlns with 84 + | None -> qname 85 + | Some xmlns -> {qname with xmlns = Some xmlns} 86 + end 87 + | Some xmlns -> begin 88 + match 89 + ( String_map.find_opt qname.prefix scope.prefix_to_xmlns, 90 + String_map.find_opt xmlns scope.xmlns_to_prefixes ) 91 + with 92 + | None, (None | Some []) -> 93 + E.modify (Xmlns_map.assoc ~prefix:qname.prefix ~xmlns); 94 + Decls.yield {prefix = qname.prefix; xmlns}; 95 + qname 96 + | Some xmlns', Some prefixes -> 97 + if xmlns' = xmlns && List.mem qname.prefix prefixes then 98 + { 99 + qname with 100 + prefix = (try smallest_string prefixes with _ -> qname.prefix); 101 + } 102 + else normalise_qname {qname with prefix = qname.prefix ^ "_"} 103 + | None, Some prefixes -> 104 + { 105 + qname with 106 + prefix = (try smallest_string prefixes with _ -> qname.prefix); 107 + } 108 + | Some _, None -> normalise_qname {qname with prefix = qname.prefix ^ "_"} 109 + end 94 110 95 111 let within_scope kont = 96 112 let old_scope = E.get () in 97 113 let added, r = Decls.run kont in 98 114 E.set old_scope; 99 - added, r 115 + (added, r) 100 116 101 117 let run ~reserved kont = 102 118 let init = 103 - let alg env ({prefix; xmlns}: xmlns_attr) = 119 + let alg env ({prefix; xmlns} : xmlns_attr) = 104 120 Xmlns_map.assoc ~prefix ~xmlns env 105 121 in 106 122 List.fold_left alg Xmlns_map.empty reserved
+1 -2
lib/xml_names/Xmlns_effect.mli
··· 10 10 val normalise_qname : xml_qname -> xml_qname 11 11 val within_scope : (unit -> 'a) -> xmlns_attr list * 'a 12 12 val find_xmlns_for_prefix : string -> string option 13 - 14 - val run : reserved: xmlns_attr list -> (unit -> 'a) -> 'a 13 + val run : reserved:xmlns_attr list -> (unit -> 'a) -> 'a 15 14 end
+26 -44
test/Prelude.ml
··· 8 8 open Forester_core 9 9 open Forester_compiler 10 10 11 - open struct module L = Lsp.Types end 11 + open struct 12 + module L = Lsp.Types 13 + end 12 14 13 15 let rec strip_syn (syn : Syn.t) : Syn.t = 14 16 let@ Asai.Range.{value; _} = List.map @~ syn in ··· 24 26 let lexbuf = Lexing.from_string str in 25 27 Parse.parse lexbuf 26 28 27 - let parse_string_no_loc str = 28 - Result.map strip_code @@ 29 - parse_string str 29 + let parse_string_no_loc str = Result.map strip_code @@ parse_string str 30 30 31 31 let with_open_tmp_dir ~env kont = 32 32 let open Eio in 33 33 let cwd = Eio.Stdenv.cwd env in 34 34 let tmp = "_tmp" in 35 - Path.mkdirs ~exists_ok: true ~perm: 0o755 Path.(cwd / tmp); 36 - let tmp_dir = 37 - Filename.temp_dir 38 - ~temp_dir: tmp 39 - ~perms: 0o755 40 - "" 41 - "" 42 - in 35 + Path.mkdirs ~exists_ok:true ~perm:0o755 Path.(cwd / tmp); 36 + let tmp_dir = Filename.temp_dir ~temp_dir:tmp ~perms:0o755 "" "" in 43 37 Logs.app (fun m -> m "%s" tmp_dir); 44 38 let tmp_path = Eio.Path.(cwd / tmp_dir) in 45 39 let result = kont tmp_path in 46 - Path.rmtree ~missing_ok: true tmp_path; 40 + Path.rmtree ~missing_ok:true tmp_path; 47 41 result 48 42 49 43 let with_test_forest ~env ~raw_trees ~(config : Config.t) kont = ··· 54 48 (fun dir_name -> 55 49 let dir = EP.(tmp / dir_name) in 56 50 Eio.traceln "mkdir: %s" dir_name; 57 - EP.(mkdir ~perm: 0o755 dir); 58 - dir 59 - ) 51 + EP.(mkdir ~perm:0o755 dir); 52 + dir) 60 53 config.trees 61 54 in 62 55 let create = `Exclusive 0o644 in ··· 64 57 List.iter 65 58 (fun tree -> 66 59 match Filename.dirname tree.path with 67 - | "." -> 68 - EP.( 69 - save 70 - ~create 71 - (first_tree_dir / tree.path) 72 - tree.content 73 - ) 60 + | "." -> EP.(save ~create (first_tree_dir / tree.path) tree.content) 74 61 | dir -> 75 62 Eio.traceln "%s" dir; 76 - EP.( 77 - save 78 - ~create 79 - (tmp / dir / Filename.basename tree.path) 80 - tree.content 81 - ) 82 - ) 63 + EP.(save ~create (tmp / dir / Filename.basename tree.path) tree.content)) 83 64 raw_trees; 84 65 kont tmp 85 66 ··· 89 70 nodes = expanded; 90 71 identity = URI uri; 91 72 units = Trie.empty; 92 - code = { 93 - nodes = code; 94 - identity = URI uri; 95 - origin = Subtree {parent = Anonymous}; 96 - timestamp = None; 97 - } 73 + code = 74 + { 75 + nodes = code; 76 + identity = URI uri; 77 + origin = Subtree {parent = Anonymous}; 78 + timestamp = None; 79 + }; 98 80 } 99 81 100 82 type test_env = { ··· 103 85 position: L.Position.t; 104 86 } 105 87 106 - module Test_env = Algaeff.State.Make(struct type t = test_env end) 88 + module Test_env = Algaeff.State.Make (struct 89 + type t = test_env 90 + end) 107 91 108 92 let find_tree addr = 109 93 let env = Test_env.get () in 110 94 let dirs = env.dirs in 111 - Eio.Path.native_exn @@ 112 - Option.get @@ 113 - Dir_scanner.find_tree dirs @@ 114 - URI_scheme.named_uri ~base: env.config.url addr 95 + Eio.Path.native_exn @@ Option.get @@ Dir_scanner.find_tree dirs 96 + @@ URI_scheme.named_uri ~base:env.config.url addr 115 97 116 98 let find_doc (env : test_env) addr : L.TextDocumentIdentifier.t = 117 99 let path = 118 - Eio.Path.native_exn @@ 119 - Option.get @@ 120 - Dir_scanner.find_tree env.dirs (URI_scheme.named_uri ~base: env.config.url addr) 100 + Eio.Path.native_exn @@ Option.get 101 + @@ Dir_scanner.find_tree env.dirs 102 + (URI_scheme.named_uri ~base:env.config.url addr) 121 103 in 122 104 {uri = Lsp.Uri.of_path path}
+25 -37
test/Testables.ml
··· 8 8 open Forester_compiler 9 9 open Alcotest 10 10 11 - type 'a bwd = 'a Bwd.bwd = 12 - | Emp 13 - | Snoc of 'a bwd * 'a 14 - [@@deriving show] 15 - 16 - type backtrace = Asai.Diagnostic.backtrace Bwd.bwd 17 - [@printer pp_bwd] 11 + type 'a bwd = 'a Bwd.bwd = Emp | Snoc of 'a bwd * 'a [@@deriving show] 12 + type backtrace = (Asai.Diagnostic.backtrace Bwd.bwd[@printer pp_bwd]) 18 13 19 - type severity = Asai.Diagnostic.severity = 20 - | Hint 21 - | Info 22 - | Warning 23 - | Error 24 - | Bug 14 + type severity = Asai.Diagnostic.severity = Hint | Info | Warning | Error | Bug 25 15 [@@deriving show] 26 16 27 - let pp_loctext = fun fmt text -> Format.pp_print_string fmt (Asai.Diagnostic.string_of_text Asai.Range.(text.value)) 17 + let pp_loctext = 18 + fun fmt text -> 19 + Format.pp_print_string fmt 20 + (Asai.Diagnostic.string_of_text Asai.Range.(text.value)) 28 21 29 - type 'a diagnostic = 30 - 'a Asai.Diagnostic.t = { 22 + type 'a diagnostic = 'a Asai.Diagnostic.t = { 31 23 severity: Asai.Diagnostic.severity; [@printer pp_severity] 32 24 message: 'a; 33 25 explanation: Asai.Diagnostic.loctext; [@printer pp_loctext] ··· 36 28 } 37 29 [@@deriving show] 38 30 39 - let message = testable Reporter.Message.pp (=) 31 + let message = testable Reporter.Message.pp ( = ) 32 + let delim = testable Forester_core.pp_delim ( = ) 33 + let code = testable Forester_core.Code.pp ( = ) 34 + let code_node = testable Forester_core.Code.pp_node ( = ) 35 + let syn_node = testable Forester_core.Syn.pp_node ( = ) 36 + let syn = testable Syn.pp ( = ) 37 + let eval_result = testable Eval.pp_result ( = ) 38 + let path = testable Trie.pp_path ( = ) 39 + let data = testable Syn.pp_resolver_data ( = ) 40 40 41 - let delim = testable Forester_core.pp_delim (=) 42 - let code = testable Forester_core.Code.pp (=) 43 - let code_node = testable Forester_core.Code.pp_node (=) 44 - let syn_node = testable Forester_core.Syn.pp_node (=) 45 - let syn = testable Syn.pp (=) 46 - let eval_result = testable Eval.pp_result (=) 47 - let path = testable Trie.pp_path (=) 48 - let data = testable Syn.pp_resolver_data (=) 49 41 let diagnostic = 50 42 let pp = pp_diagnostic Reporter.Message.pp in 51 - testable pp (=) 43 + testable pp ( = ) 52 44 53 45 let uri = testable URI.pp URI.equal 54 - 55 - let config = Alcotest.testable Config.pp (=) 46 + let config = Alcotest.testable Config.pp ( = ) 56 47 57 48 let document = 58 49 let pp fmt t = Format.pp_print_string fmt (Lsp.Text_document.text t) in 59 - testable pp (=) 50 + testable pp ( = ) 60 51 61 - let tree = testable Code.pp_tree (=) 62 - 63 - let result = testable Eval.pp_result (=) 64 - let content = testable Types.pp_content (=) 65 - 66 - let action = testable Action.pp (=) 67 - 68 - let completion_type = testable Forester_lsp.Completion.pp_completion (=) 52 + let tree = testable Code.pp_tree ( = ) 53 + let result = testable Eval.pp_result ( = ) 54 + let content = testable Types.pp_content ( = ) 55 + let action = testable Action.pp ( = ) 56 + let completion_type = testable Forester_lsp.Completion.pp_completion ( = )