From bd214359190642dbba94718ac0b2e00a9311e87d Mon Sep 17 00:00:00 2001 From: Kento Okura Date: Sat, 4 Apr 2026 11:17:58 +0200 Subject: [PATCH] Add Error.mli interface --- bin/forester/main.ml | 2 +- lib/compiler/Config_error.ml | 6 +- lib/compiler/Config_parser.ml | 15 +- lib/compiler/Driver.ml | 12 +- lib/compiler/Error.ml | 186 ++++++++++++------------ lib/compiler/Error.mli | 42 ++++++ lib/compiler/Eval.ml | 4 +- lib/compiler/Eval_error.ml | 18 +-- lib/compiler/Forester_compiler.ml | 1 + lib/compiler/Imports.ml | 24 +-- lib/compiler/LaTeX_pipeline.ml | 4 +- lib/compiler/Phases.ml | 39 +++-- lib/compiler/State.ml | 22 +-- lib/frontend/Html_client.ml | 7 +- lib/frontend/Legacy_xml_client.ml | 5 +- lib/frontend/test/Test_config_parser.ml | 2 +- lib/parser/Parse.ml | 2 +- lib/parser/Parse.mli | 8 +- lib/server/Server.ml | 2 +- test/errors.t | 2 + 20 files changed, 223 insertions(+), 180 deletions(-) create mode 100644 lib/compiler/Error.mli diff --git a/bin/forester/main.ml b/bin/forester/main.ml index af74fa8..43fc2d9 100644 --- a/bin/forester/main.ml +++ b/bin/forester/main.ml @@ -71,7 +71,7 @@ let build ~env _ config_path dev no_theme emit_legacy_xml = in match Eio_util.path_of_dir ~env theme_dir with | Ok path -> Forester.copy_contents_of_dir ~env ~forest path - | Error exn -> Error.(print @@ of_io_error exn) + | Error exn -> Error.(print @@ io_error exn) end; Forester.render_forest ~dev ~forest ~emit_legacy_xml; Logs.app (fun m -> m "Success!") diff --git a/lib/compiler/Config_error.ml b/lib/compiler/Config_error.ml index 617c722..89585eb 100644 --- a/lib/compiler/Config_error.ml +++ b/lib/compiler/Config_error.ml @@ -1,7 +1,7 @@ type 'a t = | Parse_error of {range: Grace.Range.t; msg: string} | Using_default of string list * 'a - | Unknown_options of string list + | Unknown_option of string list | Invalid_url of string | No_path_in_foreign_table | Missing_dir of string @@ -9,8 +9,10 @@ type 'a t = | Todo [@@deriving show] +let unknown_options opts = Unknown_option opts + let severity = function - | Using_default _ | Unknown_options _ -> Grace.Diagnostic.Severity.Warning + | Using_default _ | Unknown_option _ -> Grace.Diagnostic.Severity.Warning | Missing_dir _ | Missing_file _ | No_path_in_foreign_table | Invalid_url _ | Todo | Parse_error _ -> Error diff --git a/lib/compiler/Config_parser.ml b/lib/compiler/Config_parser.ml index 2974785..d0f20fa 100644 --- a/lib/compiler/Config_parser.ml +++ b/lib/compiler/Config_parser.ml @@ -125,14 +125,13 @@ let parse lexbuf filename : (Config.t, _ Config_error.t) result = (forest |-- key "home" |-- string) in let theme = get tbl (forest |-- key "theme" |-- string) in - (if not (Key_set.is_empty !keys) then - let unused_keys = - !keys |> Key_set.to_list - |> List.map - (List.map Toml.Types.Table.Key.to_string >>> String.concat ".") - in - Error.(print @@ of_config_error @@ Unknown_options unused_keys)); - List.iter Error.(of_config_error >>> print) errors; + let unused_keys = + !keys |> Key_set.to_list + |> List.map + (List.map Toml.Types.Table.Key.to_string + >>> Config_error.unknown_options) + in + List.iter Error.print_config_error (errors @ unused_keys); ok @@ Config.{url; assets; trees; foreign; home; theme} let parse_forest_config_string str = diff --git a/lib/compiler/Driver.ml b/lib/compiler/Driver.ml index e070f19..310152d 100644 --- a/lib/compiler/Driver.ml +++ b/lib/compiler/Driver.ml @@ -58,10 +58,10 @@ let update (action : Action.t) (forest : State.t) = (URI_scheme.lsp_uri_to_uri ~base:forest.config.url) (Phases.guess_uri error.range) in - forest.?{uri} <- [Error.of_parse_error error] + forest.?{uri} <- [Error.parse_error error] in ( report - ~errors:(List.map Error.of_parse_error errors) + ~errors:(List.map Error.parse_error errors) ~and_then:Build_import_graph, forest ) | Build_import_graph -> @@ -75,9 +75,7 @@ let update (action : Action.t) (forest : State.t) = (report ~errors ~and_then:Eval_all, forest) | Expand uri -> begin match Option.bind forest.={uri} Tree.to_code with - | None -> - assert false - (*(Action.report ~errors:[Resource_not_found uri] ~and_then:Done, forest)*) + | None -> assert false | Some code -> let result, errors = Phases.expand forest code in forest.={uri} <- Expanded result; @@ -118,7 +116,7 @@ let update (action : Action.t) (forest : State.t) = Logs.debug (fun m -> m "Installed %s at %a" source_path URI.pp uri); State.plant_resource ~forest (T.Asset {uri; content}) end; - (report ~errors:(List.map Error.of_io_error errors) ~and_then:Done, forest) + (report ~errors:(List.map Error.io_error errors) ~and_then:Done, forest) | Plant_foreign -> Logs.debug (fun m -> m "Planting foreign forests"); let errors = Phases.implant_foreign ~forest in @@ -145,7 +143,7 @@ let update (action : Action.t) (forest : State.t) = Imports.fixup code forest; (Expand uri, forest) | Error parse_error -> - let errors = [Error.of_parse_error parse_error] in + let errors = [Error.parse_error parse_error] in forest.?{uri} <- errors; (report ~errors ~and_then:Done, forest) end diff --git a/lib/compiler/Error.ml b/lib/compiler/Error.ml index b03440d..49edb04 100644 --- a/lib/compiler/Error.ml +++ b/lib/compiler/Error.ml @@ -5,42 +5,54 @@ open struct module T = Types end -(* TODO: This just exists while the refactor is WIP *) -type flex_error = - [ `Has_no_code of URI.t - | `Cant_eval_anonymous_tree - | `Failed_to_load_foreign_blob of string - | `Failed_to_parse_foreign_blob of string - | `Failed_to_add_edge of (exn[@printer Eio.Exn.pp]) - | `Unknown_error of string ] - -type latex_error = {range: Grace.Range.t option; msg: string} - -(* There are only a couple of situations I can think of where it makes sense to - have this error without a range: - - In the server, if the user enters a nonexistent link via the url bar. - - The case of a typo should actually be covered by the Broken_link error. - - ... any others? - *) -type resource_not_found = {uri: URI.t; range: Range.t option} - type t = | Eval_error of Eval_error.t | Expand_error of Expand_error.t - | Parse_error of Parse.parse_error - | Internal_error of flex_error + | Parse_error of Parse.error | Resource_not_found of resource_not_found | Io_error of Eio_util.IO_error.t | Configuration_error of string list Config_error.t | LaTeX_error of latex_error | Duplicate_tree of URI.t - | Literal_attribution_warning - | Unlinked_attribution_warning of { - role: T.attribution_role; - range: Range.t option; - } + | Unlinked_attribution_warning of unlinked_attribution_warning | Broken_link of T.(content link) | Broken_transclusion of T.transclusion + | Cant_eval_anonymous_tree + | Failed_to_load_foreign_blob of string + | Failed_to_parse_foreign_blob of string + | Failed_to_add_edge of Vertex.t * Vertex.t + | Unknown_error of string + +and latex_error = {range: Grace.Range.t; msg: string} + +(* There are only a couple of situations I can think of where it makes sense to + have this error without a range: + - In the server, if the user enters a nonexistent link via the url bar. + - The case of a typo should actually be covered by the Broken_link error. + - ... any others? + *) +and resource_not_found = {uri: URI.t; range: Range.t option} + +and unlinked_attribution_warning = { + role: T.attribution_role; + range: Range.t option; +} + +let tex_range {range; _} = range +let latex_error ~range msg = {range; msg} +let of_tex_error e = LaTeX_error e + +let unlinked_attribution_warning ~range role = + Unlinked_attribution_warning {range; role} +let resource_not_found ~range uri = Resource_not_found {uri; range} +let broken_transclusion t = Broken_transclusion t +let broken_link t = Broken_link t +let duplicate_tree ~uri = Duplicate_tree uri +let failed_to_add_edge v w = Failed_to_add_edge (v, w) +let cant_eval_anonymous_tree = Cant_eval_anonymous_tree +let unknown_error str = Unknown_error str +let failed_to_load_foreign_blob str = Failed_to_load_foreign_blob str +let failed_to_parse_foreign_blob str = Failed_to_parse_foreign_blob str module Collect_errors = Algaeff.Sequencer.Make (struct (* hack to avoid cyclic type error *) @@ -51,15 +63,14 @@ end) let collect = Collect_errors.run let yield = Collect_errors.yield -let of_parse_error err = Parse_error err -let of_expand_error err = Expand_error err -let of_eval_error err = Eval_error err -let of_io_error exn = Io_error exn -let of_internal_error exn = Internal_error exn -let of_config_error exn = Configuration_error exn +let parse_error err = Parse_error err +let expand_error err = Expand_error err +let eval_error err = Eval_error err +let io_error exn = Io_error exn +let config_error exn = Configuration_error exn -let yield_eval_error = of_eval_error >>> Collect_errors.yield -let yield_expand_error = of_expand_error >>> Collect_errors.yield +let yield_eval_error = eval_error >>> Collect_errors.yield +let yield_expand_error = expand_error >>> Collect_errors.yield open Grace open Diagnostic @@ -71,9 +82,6 @@ let fold_range ~range msg = ~some:(fun range -> [Label.create ~priority:Primary ~range msg]) ~none:[] -let fold_empty_label ~range = - Option.fold range ~some:(fun range -> [empty_label ~range]) ~none:[] - let render_type_error ~range Eval_error.{got; expected} = let labels = range @@ -130,24 +138,11 @@ let render_eval_error Eval_error.{error; range} = (Option.fold ~none:[] ~some:(fun range -> [empty_label ~range]) range) ~notes:suggestions "unresolved identifier %a" Trie.pp_path path -(* - let corrected_attribution_code = - match role with - | Author -> "\\author/literal" - | Contributor -> "\\contributor/literal" - in - *) - let render_parse_error Parse.{range; msg} = let labels = [empty_label ~range] in Diagnostic.createf Error ~code:`Parse_error ~labels "%s" msg -let render_internal_error _ = - ignore @@ failwith "todo: internal error"; - Diagnostic.createf Bug - "Please report this bug at <~jonsterling/forester-discuss@lists.sr.ht>" - -let resource_not_found {range; _} = +let render_resource_not_found ({range; _} : resource_not_found) = let labels = Option.fold ~none:[] ~some:(fun range -> [empty_label ~range]) range in @@ -159,10 +154,10 @@ let render_config_error (error : string list Config_error.t) = match error with | Parse_error {range = _; msg = _} -> Diagnostic.createf Error "parse_error" | Using_default (_, _) -> Diagnostic.createf Error "using default" - | Unknown_options options -> + | Unknown_option option -> Diagnostic.createf Warning ~code:`Config_error "unknown options %a" Format.(pp_print_list pp_print_string) - options + option | Invalid_url _ -> Diagnostic.createf Error "invalid url" | No_path_in_foreign_table -> Diagnostic.createf Error "no path in foreign table" @@ -172,10 +167,12 @@ let render_config_error (error : string list Config_error.t) = Diagnostic.createf ~code:`Config_error Error "file %s does not exist" s | Todo -> Diagnostic.createf Error "todo" -let render_latex_error _ = Diagnostic.createf Error "todo" -let duplicate_tree _ = Diagnostic.createf Error "todo" +let render_latex_error ({range; msg} : latex_error) = + Diagnostic.create Error + ~labels:[Label.createf ~range ~priority:Primary ""] + Message.(create msg) -let broken_transclusion (t : T.transclusion) = +let render_broken_transclusion (t : T.transclusion) = Diagnostic.( createf Warning ~labels: @@ -183,7 +180,7 @@ let broken_transclusion (t : T.transclusion) = [Label.createf ~range ~priority:Primary "This tree was not found"])) "Broken transclusion %a" URI.pp t.href) -let broken_link (link : _ T.link) = +let render_broken_link (link : _ T.link) = Diagnostic.( createf Warning ~labels: @@ -191,34 +188,40 @@ let broken_link (link : _ T.link) = [Label.createf ~range ~priority:Primary "This tree was not found"])) "Broken link %a" URI.pp link.href) +let render_unlinked_attribution_warning + ({range; role} : unlinked_attribution_warning) = + let corrected_attribution_code = + match role with + | Author -> "\\author/literal" + | Contributor -> "\\contributor/literal" + in + Diagnostic.createf Error + ~labels: + (fold_range ~range + Message.( + createf + "Expected valid URI in attribution. Use `%s` instead if you \ + intend an unlinked attribution." + corrected_attribution_code)) + "Unlinked attribution" + let render = function + | Cant_eval_anonymous_tree -> failwith "todo: can't eval" | Eval_error error -> render_eval_error error | Expand_error error -> Expand_error.render error | Parse_error error -> render_parse_error error - | Internal_error error -> render_internal_error error - | Resource_not_found uri -> resource_not_found uri + | Resource_not_found uri -> render_resource_not_found uri | Io_error error -> render_io_error error | Configuration_error error -> render_config_error error | LaTeX_error error -> render_latex_error error - | Duplicate_tree uri -> duplicate_tree uri - | Broken_link link -> broken_link link - | Broken_transclusion t -> broken_transclusion t - | Unlinked_attribution_warning {range; role} -> - let corrected_attribution_code = - match role with - | Author -> "\\author/literal" - | Contributor -> "\\contributor/literal" - in - Diagnostic.createf Error - ~labels: - (fold_range ~range - Message.( - createf - "Expected valid URI in attribution. Use `%s` instead if you \ - intend an unlinked attribution." - corrected_attribution_code)) - "Unlinked attribution" - | Literal_attribution_warning -> Diagnostic.createf Error "todo" + | Duplicate_tree _uri -> Diagnostic.createf Error "todo" + | Broken_link link -> render_broken_link link + | Broken_transclusion t -> render_broken_transclusion t + | Unlinked_attribution_warning w -> render_unlinked_attribution_warning w + | Failed_to_load_foreign_blob _ -> failwith "todo" + | Failed_to_parse_foreign_blob _ -> failwith "todo" + | Failed_to_add_edge (_, _) -> failwith "todo" + | Unknown_error _ -> failwith "todo" (* let corrected = "\\tag/content" in @@ -228,17 +231,7 @@ let render = function corrected *) -(* - let severity = function - | Eval_error _ -> Diagnostic.Severity.Error - | _ -> Error - in - let msg = Diagnostic.Message.createf "Hello" in - let severity = severity err in - Diagnostic.create ~code:err severity msg - *) - -let print error = +let print_diagnostic = let config = Grace_ansi_renderer.Config.{default with num_contextual_lines = 3} in @@ -249,14 +242,17 @@ let print error = in Format.printf "%a@." Grace_ansi_renderer.(pp_diagnostic ~config ~code_to_string) - (render error) + +let print error = print_diagnostic (render error) let is_fatal = function | Broken_link _ | Broken_transclusion _ -> false - | Eval_error _ | Expand_error _ | Parse_error _ | Internal_error _ - | Resource_not_found _ | Io_error _ | Configuration_error _ | LaTeX_error _ - | Unlinked_attribution_warning _ | Literal_attribution_warning - | Duplicate_tree _ -> + | Eval_error _ | Expand_error _ | Parse_error _ | Resource_not_found _ + | Io_error _ | Configuration_error _ | LaTeX_error _ + | Unlinked_attribution_warning _ | Cant_eval_anonymous_tree | Duplicate_tree _ + | Failed_to_load_foreign_blob _ | Failed_to_parse_foreign_blob _ + | Failed_to_add_edge (_, _) + | Unknown_error _ -> true -let print_config_error error = print @@ of_config_error error +let print_config_error error = print @@ config_error error diff --git a/lib/compiler/Error.mli b/lib/compiler/Error.mli new file mode 100644 index 0000000..adb8943 --- /dev/null +++ b/lib/compiler/Error.mli @@ -0,0 +1,42 @@ +open Forester_core +open Forester_parser + +module T := Types + +type t + +val is_fatal : t -> bool + +type latex_error +val tex_range : latex_error -> Range.t +val latex_error : range:Grace.Range.t -> string -> latex_error + +val unlinked_attribution_warning : + range:Range.t option -> T.attribution_role -> t +val resource_not_found : range:Range.t option -> URI.t -> t +val broken_transclusion : T.transclusion -> t +val broken_link : T.(content link) -> t +val cant_eval_anonymous_tree : t +val failed_to_load_foreign_blob : string -> t +val failed_to_parse_foreign_blob : string -> t +val unknown_error : string -> t + +val print : t -> unit +val config_error : string list Config_error.t -> t +val parse_error : Parse.error -> t +val io_error : Eio_util.IO_error.t -> t +val duplicate_tree : uri:URI.t -> t +val of_tex_error : latex_error -> t + +val failed_to_add_edge : Vertex.t -> Vertex.t -> t + +val collect : (unit -> unit) -> t Seq.t +val yield : t -> unit +val yield_eval_error : Eval_error.t -> unit +val yield_expand_error : Expand_error.t -> unit + +val render : t -> [`Type_error | `Config_error | `Parse_error] Diagnostic.t +val print_diagnostic : + [`Type_error | `Config_error | `Parse_error] Diagnostic.t -> unit + +val print_config_error : string list Config_error.t -> unit diff --git a/lib/compiler/Eval.ml b/lib/compiler/Eval.ml index 8352202..4bc756a 100644 --- a/lib/compiler/Eval.ml +++ b/lib/compiler/Eval.ml @@ -107,7 +107,7 @@ type eval_env = { config: Config.t; lex_env: Value.t String_map.t; dyn_env: Value.t Symbol_map.t; - jobs: Job.job Range.located Stack.t; + jobs: Job.t Stack.t; emitted_trees: T.content T.article Stack.t; heap: Value.obj Symbol_table.t; frontmatter: T.content T.frontmatter ref; @@ -410,6 +410,8 @@ and eval_node ~env ({value; range} as node) : (Value.t, Eval_error.t) result = begin match value with | Dx_query query -> let job = Job.Syndicate (Json_blob {blob_uri; query}) in + (* TODO: *) + let range = Some (Option.get range) in Stack.push (Range.locate_opt range job) env.jobs; process_tape ~env | other -> diff --git a/lib/compiler/Eval_error.ml b/lib/compiler/Eval_error.ml index 55c82a5..0a25c85 100644 --- a/lib/compiler/Eval_error.ml +++ b/lib/compiler/Eval_error.ml @@ -20,15 +20,15 @@ let show_expectation = function | Content -> "some content" | Text -> "some text" | Obj -> "an object" - | Bool -> "" - | Sym -> "" - | Dx_query -> "" - | Dx_sequent -> "" - | Dx_prop -> "" - | Datalog_term -> "" - | Node -> "" - | URI -> "" - | Argument -> "" + | Bool -> "a boolean" + | Sym -> "todo: expect sym" + | Dx_query -> "a datalog query" + | Dx_sequent -> "a datalog sequent" + | Dx_prop -> "a datalog proposition" + | Datalog_term -> "a datalog term" + | Node -> "a node" + | URI -> "a valid URI" + | Argument -> "an argument" type error = | Type_error of type_error diff --git a/lib/compiler/Forester_compiler.ml b/lib/compiler/Forester_compiler.ml index 78ace80..2d6d3de 100644 --- a/lib/compiler/Forester_compiler.ml +++ b/lib/compiler/Forester_compiler.ml @@ -72,5 +72,6 @@ module Eio_util = Eio_util module Export_for_test = Export_for_test module Cache = Cache module Dir_scanner = Dir_scanner +module Suggestions = Suggestions (**/**) diff --git a/lib/compiler/Imports.ml b/lib/compiler/Imports.ml index b83522e..284555b 100644 --- a/lib/compiler/Imports.ml +++ b/lib/compiler/Imports.ml @@ -32,34 +32,38 @@ let add_edge g v w = assert (Forest_graph.mem_vertex g v); assert (Forest_graph.mem_vertex g w); ok @@ Forest_graph.add_edge g v w - with exn -> error @@ Error.Internal_error (`Failed_to_add_edge exn) + with Assert_failure _ -> error @@ Error.failed_to_add_edge v w let resolve_uri_to_code (forest : State.t) (uri : URI.t) : (Tree.code, Error.t list) Result.t = let errors, dirs = - Pair.map_fst (List.map Error.of_io_error) + Pair.map_fst (List.map Error.io_error) @@ Eio_util.paths_of_dirs ~env:forest.env forest.config.trees in + (* In principle it is possible for the user delete a folder which would + result in some errors.*) assert (List.is_empty errors); match Forest.find_opt forest.index uri with - | Some tree -> - Tree.to_code tree - |> Option.to_result ~none:[Error.Internal_error (`Has_no_code uri)] - | None -> ( + | Some tree -> begin + match Tree.to_code tree with None -> assert false | Some code -> ok code + end + | None -> begin match URI.Tbl.find_opt forest.resolver uri with | Some path -> let doc = load_tree Eio.Path.(forest.env#fs / path) in - Result.map_error (Error.of_parse_error >>> List.singleton) + Result.map_error (Error.parse_error >>> List.singleton) @@ Parse.parse_document ~config:forest.config doc - | None -> ( + | None -> begin match Dir_scanner.find_tree dirs uri with | Some path -> let native = Eio.Path.native_exn path in URI.Tbl.add forest.resolver uri native; let doc = load_tree path in - Result.map_error (Error.of_parse_error >>> List.singleton) + Result.map_error (Error.parse_error >>> List.singleton) @@ Parse.parse_document ~config:forest.config doc - | None -> assert false)) + | None -> assert false + end + end let rec analyse_tree ~env (tree : Tree.code) = let@ root = Option.iter @~ identity_to_uri tree.identity in diff --git a/lib/compiler/LaTeX_pipeline.ml b/lib/compiler/LaTeX_pipeline.ml index b006e9d..c36ecac 100644 --- a/lib/compiler/LaTeX_pipeline.ml +++ b/lib/compiler/LaTeX_pipeline.ml @@ -44,7 +44,7 @@ let pipe_latex_dvi ~env ~tex_source ~range kont = directory `%s`." formatted_output (String.concat " " cmd) (Eio.Path.native_exn tmp) in - error @@ ({range = Some range; msg} : Error.latex_error) + error @@ Error.latex_error ~range msg in EP.with_open_in EP.(tmp / "job.dvi") kont @@ -72,7 +72,7 @@ let pipe_dvi_svg ~env ~range ~dvi_source ~svg_sink () = Format.asprintf "Encountered fatal error running `dvisvgm`: %s" (Buffer.contents err_buf) in - error @@ ({range = Some range; msg} : Error.latex_error) + error @@ Error.latex_error ~range msg let pipe_latex_svg ~env ~range ~tex_source ~svg_sink () = let@ dvi_source = pipe_latex_dvi ~env ~tex_source ~range in diff --git a/lib/compiler/Phases.ml b/lib/compiler/Phases.ml index 113a5fb..8810a23 100644 --- a/lib/compiler/Phases.ml +++ b/lib/compiler/Phases.ml @@ -17,8 +17,8 @@ end let guess_uri (d : Range.t) = match Range.source d with | `File filename -> Some (Lsp.Uri.of_path filename) - | `Reader _ -> None - | `String _ -> None + | `Reader _ -> assert false + | `String {name; _} -> Option.map Lsp.Uri.of_path name let load (tree_dir : Eio.Fs.dir_ty Eio.Path.t) = Dir_scanner.scan_directory tree_dir |> Seq.map Imports.load_tree @@ -44,7 +44,7 @@ let reparse (doc : Lsp.Text_document.t) (forest : State.t) = | Ok code -> forest.={uri} <- Parsed code; Imports.fixup code forest - | Error d -> forest.?{uri} <- [Parse_error d] + | Error d -> forest.?{uri} <- [Error.parse_error d] end; forest @@ -87,8 +87,8 @@ let run_jobs (forest : State.t) jobs = | Job.LaTeX_to_svg job -> let* svg = Build_latex.latex_to_svg ~env:forest.env ~range job.source in let uri = Job.uri_for_latex_to_svg_job ~base:forest.config.url job in - Ok (T.Asset {uri; content = svg}) - | Job.Syndicate syndication -> Ok (T.Syndication syndication) + ok (T.Asset {uri; content = svg}) + | Job.Syndicate syndication -> ok (T.Syndication syndication) in begin (* It is probably not save to plant the articles in parallel, so this is @@ -96,15 +96,13 @@ let run_jobs (forest : State.t) jobs = let@ result = List.iter @~ resources_to_plant in match result with | Ok resource -> State.plant_resource ~forest resource - | Error ({range; _} as diagnostic) -> - Option.fold range - ~none:(assert false) - ~some:(fun range -> - match guess_uri range with - | None -> assert false - | Some uri -> - let uri = Tree.of_lsp_uri ~base:forest.config.url uri in - forest.?{uri} <- [Error.LaTeX_error diagnostic]) + | Error tex_error -> begin + match guess_uri (Error.tex_range tex_error) with + | None -> assert false + | Some uri -> + let uri = Tree.of_lsp_uri ~base:forest.config.url uri in + forest.?{uri} <- [Error.of_tex_error tex_error] + end end let eval (forest : State.t) = @@ -117,7 +115,7 @@ let eval (forest : State.t) = let@ expanded = List.partition_map @~ expanded_trees in let tree = Option.get @@ Tree.to_syn expanded in match identity_to_uri tree.identity with - | None -> left [Error.Internal_error `Cant_eval_anonymous_tree] + | None -> left [Error.cant_eval_anonymous_tree] | Some uri -> let source_path = if forest.dev then URI.Tbl.find_opt forest.resolver uri else None @@ -152,14 +150,13 @@ let eval_only (uri : URI.t) (forest : State.t) = let implant ~(forest : State.t) (foreign : Config.foreign) = let* path = - Result.map_error Error.of_io_error + Result.map_error Error.io_error @@ Eio_util.path_of_file ~env:forest.env foreign.path in let path_str = EP.native_exn path in let* blob = try ok (EP.load path) - with _ -> - error @@ Error.Internal_error (`Failed_to_load_foreign_blob path_str) + with _ -> error @@ Error.failed_to_load_foreign_blob path_str in match Repr.of_json_string (T.forest_t T.content_t) blob with | Ok foreign_forest -> @@ -169,10 +166,10 @@ let implant ~(forest : State.t) (foreign : Config.foreign) = ~include_in_manifest:foreign.include_in_manifest r end; ok () - | Error (`Msg err) -> - error (Error.Internal_error (`Failed_to_parse_foreign_blob err)) + | Error (`Msg err) -> error @@ Error.failed_to_parse_foreign_blob err | exception exn -> - error @@ Error.Internal_error (`Unknown_error (Printexc.to_string exn)) + let msg = Printexc.to_string exn in + error @@ Error.unknown_error msg let implant_foreign ~(forest : State.t) : _ = Logs.debug (fun m -> diff --git a/lib/compiler/State.ml b/lib/compiler/State.ml index 5aa1d72..41db3c5 100644 --- a/lib/compiler/State.ml +++ b/lib/compiler/State.ml @@ -60,6 +60,16 @@ let make ~(env : Eio_unix.Stdenv.base) ~(config : Config.t) ~(dev : bool) } module Syntax = struct + (* ? for diagnostics*) + let ( .?{} ) state uri = + Option.value ~default:[] (URI.Tbl.find_opt state.diagnostics uri) + + let ( .?{}<- ) state uri diagnostics = + URI.Tbl.add state.diagnostics uri diagnostics + + let ( .?+{}<- ) state uri diagnostics = + URI.Tbl.add state.diagnostics uri diagnostics + let ( .={} ) state uri = URI.Tbl.find_opt state.index uri let ( .={}<- ) state uri tree = @@ -67,7 +77,7 @@ module Syntax = struct | None -> URI.Tbl.replace state.index uri tree | Some existing -> if Tree.origin tree <> Tree.origin existing then - let _ = error (Error.Duplicate_tree uri) in + let () = state.?{uri} <- [Error.duplicate_tree ~uri] in URI.Tbl.replace state.index uri tree else URI.Tbl.replace state.index uri tree (* URI.Tbl.replace state.index uri item *) @@ -91,16 +101,6 @@ module Syntax = struct ok @@ URI.Tbl.replace state.index uri (Expanded {expanded with units}) | Some (Resource _) -> Ok () - (* ? for diagnostics*) - let ( .?{} ) state uri = - Option.value ~default:[] (URI.Tbl.find_opt state.diagnostics uri) - - let ( .?{}<- ) state uri diagnostics = - URI.Tbl.add state.diagnostics uri diagnostics - - let ( .?+{}<- ) state uri diagnostics = - URI.Tbl.add state.diagnostics uri diagnostics - (* @ for article/resource *) let ( .@{} ) state uri = match URI.Tbl.find_opt state.index uri with diff --git a/lib/frontend/Html_client.ml b/lib/frontend/Html_client.ml index 49a36bf..744c0d1 100644 --- a/lib/frontend/Html_client.ml +++ b/lib/frontend/Html_client.ml @@ -207,7 +207,7 @@ let rec render_control : type a. env:env -> a client = | Transclusion t -> begin match State.get_content_of_transclusion ~forest:env.forest t with | None -> - Error.yield (Error.Broken_transclusion t); + Error.(yield @@ broken_transclusion t); H.null [ P.txt "failed to render transclusion %s" @@ -219,7 +219,7 @@ let rec render_control : type a. env:env -> a client = match render_link ~env link with | Ok node -> node | Error (node, `Broken_link link) -> - Error.yield (Broken_link link); + Error.(yield @@ broken_link link); node end | Query q -> H.null @@ render_query_result ~env q @@ -372,8 +372,7 @@ and render_attribution_vertex ~env (attribution : T.(content attribution)) = | Error (node, error) -> begin match error with | `Broken_link {range; _} -> - Error.yield - @@ Error.Unlinked_attribution_warning {range; role = attribution.role}; + Error.(yield @@ unlinked_attribution_warning ~range attribution.role); node end end diff --git a/lib/frontend/Legacy_xml_client.ml b/lib/frontend/Legacy_xml_client.ml index e548e98..13e5451 100644 --- a/lib/frontend/Legacy_xml_client.ml +++ b/lib/frontend/Legacy_xml_client.ml @@ -252,7 +252,8 @@ and render_transclusion ~env (transclusion : T.transclusion) : P.node list = match State.get_content_of_transclusion ~forest:env.forest transclusion with | None -> let range = range ~env in - let _warning = Error.Resource_not_found {uri = transclusion.href; range} in + let warning = Error.resource_not_found ~range transclusion.href in + Error.print warning; [] | Some content -> render_content ~env content @@ -268,7 +269,7 @@ and render_link ~env (link : T.content T.link) : P.node list = if not env.in_backmatter then match State.suggestion_for_uri link.href env.forest with | Ok -> ok () - | Not_found {suggestion = _} -> error @@ Error.Broken_link link + | Not_found {suggestion = _} -> error @@ Error.broken_link link (*suggestion*) else ok () end; diff --git a/lib/frontend/test/Test_config_parser.ml b/lib/frontend/test/Test_config_parser.ml index fb69bae..cc95a98 100644 --- a/lib/frontend/test/Test_config_parser.ml +++ b/lib/frontend/test/Test_config_parser.ml @@ -5,4 +5,4 @@ let () = let@ env = Eio_main.run in match Config_parser.parse_forest_config_file ~env Sys.argv.(1) with | Ok _ -> () - | Error d -> List.iter Error.(of_config_error >>> print) d + | Error d -> List.iter Error.print_config_error d diff --git a/lib/parser/Parse.ml b/lib/parser/Parse.ml index dab1e1e..1afdc7d 100644 --- a/lib/parser/Parse.ml +++ b/lib/parser/Parse.ml @@ -6,7 +6,7 @@ open Forester_core -type parse_error = {range: Grace.Range.t; msg: string} [@@deriving show] +type error = {range: Grace.Range.t; msg: string} [@@deriving show] let buffer_lexer lexer = let buf = ref [] in diff --git a/lib/parser/Parse.mli b/lib/parser/Parse.mli index c0974ed..79ce654 100644 --- a/lib/parser/Parse.mli +++ b/lib/parser/Parse.mli @@ -6,11 +6,11 @@ open Forester_core -type parse_error = {range: Grace.Range.t; msg: string} [@@deriving show] +type error = {range: Grace.Range.t; msg: string} [@@deriving show] -val parse : Grace.Source.t -> Lexing.lexbuf -> (Code.t, parse_error) Result.t +val parse : Grace.Source.t -> Lexing.lexbuf -> (Code.t, error) Result.t val parse_document : - config:Config.t -> Lsp.Text_document.t -> (Tree.code, parse_error) result + config:Config.t -> Lsp.Text_document.t -> (Tree.code, error) result -val parse_file : string -> (Code.t, parse_error) result +val parse_file : string -> (Code.t, error) result diff --git a/lib/server/Server.ml b/lib/server/Server.ml index e17dbdf..2bb3ab3 100644 --- a/lib/server/Server.ml +++ b/lib/server/Server.ml @@ -192,7 +192,7 @@ let config_handler ~env request_headers request_body forest = the user enters ~/forest/forest.toml *) match Config_parser.parse_forest_config_file ~env filename with | Error errs -> - let errors = List.map Error.(of_config_error >>> render) errs in + let errors = List.map Error.(config_error >>> render) errs in let errors = List.map (Format.asprintf "%a@." diff --git a/test/errors.t b/test/errors.t index 918d636..8ea1ccd 100644 --- a/test/errors.t +++ b/test/errors.t @@ -75,3 +75,5 @@ 1 │ \author{unknown} │ ^^^^^^^^^ Expected valid URI in attribution. Use `\author/literal` instead if you intend an unlinked attribution. Success! + + $ forester build latex-errors.toml -- 2.51.2