From 07f964801e06f62f23755aa0576e59fb77bbc6fe Mon Sep 17 00:00:00 2001 From: Kento Okura Date: Wed, 1 Apr 2026 16:37:05 +0200 Subject: [PATCH] Further improve error reporting Before the big refactor, the user was warned about unlinked attributions and tags at evaluation time. I remember this working but at the present time I have a hard time reasoning about it: It works by using `extract_vertex`, which calls `extract_uri`. `extract_uri` is an *extremely* resilient function, in the sense that almost any string parses successfully. Because of this, I have a hard time seeing how that `Type_warning` was ever emitted. With this commit, we are now verifying links and transclusions at render time. It only makes sense to do this at render time, since we don't have access to the rest of the forest when evaluating. This change implies that we will need to augment the driver to run the renderer so that the lsp reports these errors as well. In order to report these errors at the appropriate location, some types have been augmented with an optional range. Other improvements: - Restore warning when using default config options - Report date parsing errors TODOs: Get rid of mentions of Collect_errors outside of Error.ml --- lib/compiler/Action.ml | 2 +- lib/compiler/Config_error.ml | 15 --- lib/compiler/Config_parser.ml | 41 ++++-- lib/compiler/Error.ml | 107 +++++++++++++--- lib/compiler/Eval.ml | 42 +++--- lib/compiler/Eval.mli | 18 --- lib/compiler/Eval_error.ml | 10 +- lib/compiler/Expand.ml | 5 +- lib/compiler/Expand_error.ml | 25 ++-- lib/compiler/Forester_compiler.ml | 2 + lib/core/Types.ml | 26 +++- lib/frontend/Forest_util.ml | 6 +- lib/frontend/Forester.ml | 22 +++- lib/frontend/Html_client.ml | 163 +++++++++++++----------- lib/frontend/Html_client.mli | 2 +- lib/frontend/Legacy_xml_client.ml | 3 +- lib/frontend/test/config.t | 4 +- lib/frontend/test/dune | 2 +- lib/human_datetime/Human_datetime.ml | 9 +- lib/human_datetime/Human_datetime.mli | 2 +- lib/search/test/Test_forester_search.ml | 2 + test/errors.t | 70 ++++++++++ 22 files changed, 379 insertions(+), 199 deletions(-) delete mode 100644 lib/compiler/Eval.mli diff --git a/lib/compiler/Action.ml b/lib/compiler/Action.ml index b0032e5..6f90880 100644 --- a/lib/compiler/Action.ml +++ b/lib/compiler/Action.ml @@ -26,7 +26,7 @@ type t = | Eval of URI.t | Query of (string, Vertex.t) Datalog_expr.query | Query_results of (Vertex_set.t[@opaque]) - | Report_errors of (Error.t list * t) + | Report_errors of ((Error.t[@opaque]) list * t) | Run_jobs of Job.job Range.located list [@@deriving show] diff --git a/lib/compiler/Config_error.ml b/lib/compiler/Config_error.ml index 1cae439..617c722 100644 --- a/lib/compiler/Config_error.ml +++ b/lib/compiler/Config_error.ml @@ -14,18 +14,3 @@ let severity = function | Missing_dir _ | Missing_file _ | No_path_in_foreign_table | Invalid_url _ | Todo | Parse_error _ -> Error - -(* -Diagnostic.createf Warning "option [%a] not set, using default %a" - Format.( - pp_print_list - ~pp_sep:(fun fmt () -> fprintf fmt ".") - pp_print_string) - k pp_value value; -*) - -let pp_dirlist fmt key = - Format.( - fprintf fmt "[%a]" - (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "; ") pp_print_string) - key) diff --git a/lib/compiler/Config_parser.ml b/lib/compiler/Config_parser.ml index 38e74f7..2974785 100644 --- a/lib/compiler/Config_parser.ml +++ b/lib/compiler/Config_parser.ml @@ -8,6 +8,12 @@ open Forester_core open Config_error open Result.Syntax +let pp_dirlist fmt key = + Format.( + fprintf fmt "[%a]" + (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "; ") pp_print_string) + key) + (** In order to warn the user about unrecognized configuration options, we construct the set of keys and remove them when they are read. *) module Key_set = struct @@ -46,11 +52,20 @@ let parse lexbuf filename : (Config.t, _ Config_error.t) result = | `Ok tbl -> let open Toml.Lenses in let keys = ref (keys tbl) in - let with_default ~value k lens = + let with_default ~value ~pp_value k lens = let open Toml.Lenses in match get tbl lens with | None -> - ignore @@ error @@ Using_default (k, value); + Format.printf "%a@." + Grace_ansi_renderer.(pp_diagnostic ?config:None ?code_to_string:None) + Diagnostic.( + createf Warning "option [%a] not set, using default %a" + Format.( + pp_print_list + ~pp_sep:(fun fmt () -> fprintf fmt ".") + pp_print_string) + k pp_value value); + value | Some v -> keys := Key_set.remove k !keys; @@ -74,7 +89,7 @@ let parse lexbuf filename : (Config.t, _ Config_error.t) result = let default = Config.default ~url () in let trees = let k = ["forest"; "trees"] in - with_default ~value:default.trees k + with_default ~value:default.trees ~pp_value:pp_dirlist k (forest |-- key "trees" |-- array |-- strings) in let errors, foreign = @@ -99,13 +114,15 @@ let parse lexbuf filename : (Config.t, _ Config_error.t) result = | Some path -> ok Config.{path; route_locally; include_in_manifest}) in let assets = - with_default ~value:default.assets ["forest"; "assets"] + with_default ~value:default.assets ~pp_value:pp_dirlist + ["forest"; "assets"] (forest |-- key "assets" |-- array |-- strings) in let home = let k = ["forest"; "home"] in URI.named_uri ~base:url - @@ with_default ~value:"index" k (forest |-- key "home" |-- string) + @@ with_default ~value:"index" ~pp_value:Format.pp_print_string k + (forest |-- key "home" |-- string) in let theme = get tbl (forest |-- key "theme" |-- string) in (if not (Key_set.is_empty !keys) then @@ -155,12 +172,12 @@ let validate ~env config = if List.is_empty @@ errs then ok config else error errs let parse_forest_config_file ~env filename = - let ch = open_in filename in + let* ch = + try ok @@ open_in filename + with Sys_error _exn -> error @@ [Missing_file filename] + in let@ () = Fun.protect ~finally:(fun _ -> close_in ch) in let lexbuf = Lexing.from_channel ch in - try - let result = Result.map_error List.singleton @@ parse lexbuf filename in - Sys.chdir @@ Filename.dirname filename; - Result.bind result (validate ~env) - with Sys_error _exn -> - error @@ [Parse_error {range = Range.of_lexbuf lexbuf; msg = ""}] + let result = Result.map_error List.singleton @@ parse lexbuf filename in + Sys.chdir @@ Filename.dirname filename; + Result.bind result (validate ~env) diff --git a/lib/compiler/Error.ml b/lib/compiler/Error.ml index 30daeb0..5bcd41d 100644 --- a/lib/compiler/Error.ml +++ b/lib/compiler/Error.ml @@ -1,6 +1,10 @@ open Forester_core open Forester_parser +open struct + module T = Types +end + (* TODO: This just exists while the refactor is WIP *) type flex_error = [ `Has_no_code of URI.t @@ -9,11 +13,8 @@ type flex_error = | `Failed_to_parse_foreign_blob of string | `Failed_to_add_edge of (exn[@printer Eio.Exn.pp]) | `Unknown_error of string ] -[@@deriving show] - -type rendering_error = Broken_link of URI.t option -type latex_error = {range: Grace.Range.t option; msg: string} [@@deriving show] +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: @@ -21,7 +22,7 @@ type latex_error = {range: Grace.Range.t option; msg: string} [@@deriving show] - 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} [@@deriving show] +type resource_not_found = {uri: URI.t; range: Range.t option} type t = | Eval_error of Eval_error.t @@ -33,7 +34,22 @@ type t = | Configuration_error of string list Config_error.t | LaTeX_error of latex_error | Duplicate_tree of URI.t -[@@deriving show] + | Literal_attribution_warning + | Unlinked_attribution_warning of { + role: T.attribution_role; + range: Range.t option; + } + | Broken_link of T.(content link) + | Broken_transclusion of T.transclusion + +module Collect_errors = Algaeff.Sequencer.Make (struct + (* hack to avoid cyclic type error *) + type error = t + type t = error +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 @@ -47,6 +63,14 @@ open Diagnostic let empty_label ~range = Diagnostic.Label.createf ~range ~priority:Primary "" +let fold_range ~range msg = + Option.fold range + ~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 @@ -86,22 +110,22 @@ let render_type_error ~range Eval_error.{got; expected} = *) let render_eval_error Eval_error.{error; range} = + let default_labels = + Option.fold ~none:[] ~some:(fun range -> [empty_label ~range]) range + in match error with | Type_error err -> render_type_error ~range err | Invalid_URI _ -> Diagnostic.createf Error ~labels:[] ~notes:[] "" - | Invalid_date _ | Unbound_variable _ | No_current_uri | Missing_arguments _ - | Unbound_method _ | Unbound_fluid_symbol _ | Literal_attribution_warning - | Unlinked_attribution_warning | Asset_error _ | Unresolved_identifier _ - | Broken_transclusion _ -> - Diagnostic.createf Error ~labels:[] ~notes:[] "" - -(* - let corrected = "\\tag/content" in - Diagnostic.createf Error ~code:Type_warning - "Expected valid URI in tag. Use `%s` instead if you intend an unlinked \ - attribution." - corrected - *) + | Invalid_date _ -> + Diagnostic.createf ~labels:default_labels Error "Invalid date" + | Unbound_variable _ | No_current_uri | Missing_arguments _ | Unbound_method _ + | Unbound_fluid_symbol _ | Asset_error _ | Broken_transclusion _ -> + Diagnostic.createf Error ~labels:[] ~notes:[] "todo: render_eval_error" + | Unresolved_identifier {suggestions; path} -> + Diagnostic.createf Error + ~labels: + (Option.fold ~none:[] ~some:(fun range -> [empty_label ~range]) range) + ~notes:suggestions "unresolved identifier %a" Trie.pp_path path (* let corrected_attribution_code = @@ -148,6 +172,22 @@ let render_config_error (error : string list Config_error.t) = let render_latex_error _ = Diagnostic.createf Error "todo" let duplicate_tree _ = Diagnostic.createf Error "todo" +let broken_transclusion (t : T.transclusion) = + Diagnostic.( + createf Warning + ~labels: + (Option.fold t.range ~none:[] ~some:(fun range -> + [Label.createf ~range ~priority:Primary "This tree was not found"])) + "Broken transclusion %a" URI.pp t.href) + +let broken_link (link : _ T.link) = + Diagnostic.( + createf Warning + ~labels: + (Option.fold link.range ~none:[] ~some:(fun range -> + [Label.createf ~range ~priority:Primary "This tree was not found"])) + "Broken link %a" URI.pp link.href) + let render = function | Eval_error error -> render_eval_error error | Expand_error error -> Expand_error.render error @@ -158,6 +198,33 @@ let render = function | 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" + +(* + let corrected = "\\tag/content" in + Diagnostic.createf Error + "Expected valid URI in tag. Use `%s` instead if you intend an unlinked \ + attribution." + corrected + *) + (* let severity = function | Eval_error _ -> Diagnostic.Severity.Error @@ -182,8 +249,10 @@ let print error = (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 _ -> true diff --git a/lib/compiler/Eval.ml b/lib/compiler/Eval.ml index 02d483e..c116ea7 100644 --- a/lib/compiler/Eval.ml +++ b/lib/compiler/Eval.ml @@ -224,14 +224,14 @@ let extract_dx_sequent ({value; range} : located) = let got = Some other in type_error ~got ~expected ~range -let extract_vertex ~env ~type_ (node : located) = +let extract_vertex ~env ~type_ ({range; _} as node : located) = match type_ with | `Content -> let* node = extract_content node in - ok (T.Content_vertex node) + ok Range.{value = T.Content_vertex node; range} | `Uri -> - let@ {value = uri; _} = Result.map @~ extract_uri ~env node in - T.Uri_vertex uri + let@ {value = uri; range} = Result.map @~ extract_uri ~env node in + Range.{value = T.Uri_vertex uri; range} let pp_tex_cs fmt = function | TeX_cs.Symbol x -> Format.fprintf fmt "\\%c" x @@ -308,7 +308,15 @@ and eval_node ~env ({value; range} as node) : (Value.t, Eval_error.t) result = let* value = eval_tape ~env title in {node with value} |> extract_content in - emit_content_node ~env ~range @@ Link {href; content; range} + emit_content_node ~env ~range + @@ Link + { + href; + content; + range = + (assert (Option.is_some range); + range); + } | Math (mode, body) -> let* content = let* value = eval_tape ~env:{env with mode = TeX_mode} body in @@ -351,7 +359,8 @@ and eval_node ~env ({value; range} as node) : (Value.t, Eval_error.t) result = @@ T.Text (Format.asprintf "%a%s" pp_tex_cs cs rest) | _, _ -> let suggestions = Suggestions.create_suggestions ~visible path in - Collect_errors.yield @@ {error = Unresolved_identifier suggestions; range}; + Collect_errors.yield + @@ {error = Unresolved_identifier {suggestions; path}; range}; emit_content_node ~env ~range @@ T.Text (Format.asprintf "\\%a" Resolver.Scope.pp_path path) end @@ -593,16 +602,14 @@ and eval_node ~env ({value; range} as node) : (Value.t, Eval_error.t) result = process_tape ~env | Attribution (role, type_) -> let* arg = eval_pop_arg ~env ~range in - let* vertex = + let* {value = vertex; _} = match extract_vertex ~env ~type_ arg with | Ok vtx -> ok vtx | Error _ -> - Collect_errors.yield - {error = Literal_attribution_warning; range = arg.range}; - let* content = extract_content arg in - ok @@ T.Content_vertex content + (* The URI parser is "too resilient", extracting vertices can't fail*) + assert false in - let attribution = T.{role; vertex} in + let attribution = T.{role; vertex; range = arg.range} in env.frontmatter := { env.frontmatter.contents with @@ -611,12 +618,7 @@ and eval_node ~env ({value; range} as node) : (Value.t, Eval_error.t) result = process_tape ~env | Tag type_ -> let* arg = eval_pop_arg ~env ~range in - let* vertex = - let _ = failwith "todo" in - let* _content = ok @@ T.Content_vertex (extract_content arg) in - let@ _error = Result.map_error @~ extract_vertex ~env ~type_ arg in - unlinked_attribution_warning ~range - in + let* {value = vertex; range = _} = extract_vertex ~env ~type_ arg in env.frontmatter := { env.frontmatter.contents with @@ -626,9 +628,9 @@ and eval_node ~env ({value; range} as node) : (Value.t, Eval_error.t) result = | Date -> let* {value = date_str; range} = pop_text_arg ~env ~range in begin match Human_datetime.parse_string date_str with - | None -> + | Error _ -> invalid_date ~range date_str (*"Invalid date string `%s`" date_str*) - | Some date -> + | Ok date -> env.frontmatter := { env.frontmatter.contents with diff --git a/lib/compiler/Eval.mli b/lib/compiler/Eval.mli deleted file mode 100644 index 4bb4d0e..0000000 --- a/lib/compiler/Eval.mli +++ /dev/null @@ -1,18 +0,0 @@ -(* - * SPDX-FileCopyrightText: 2024 The Forester Project Contributors - * - * SPDX-License-Identifier: GPL-3.0-or-later - *) - -open Forester_core -module T := Types - -type eval_result = {articles: T.content T.article list; jobs: Job.t list} -[@@deriving show] - -val eval_tree : - config:Config.t -> - uri:URI.t -> - source_path:string option -> - Syn.t -> - eval_result option * Eval_error.t list diff --git a/lib/compiler/Eval_error.ml b/lib/compiler/Eval_error.ml index 90be48d..45c3ba5 100644 --- a/lib/compiler/Eval_error.ml +++ b/lib/compiler/Eval_error.ml @@ -39,9 +39,10 @@ type error = | Missing_arguments of int | Unbound_method of string | Unbound_fluid_symbol of Symbol.t - | Unresolved_identifier of Diagnostic.Message.t list - | Literal_attribution_warning - | Unlinked_attribution_warning + | Unresolved_identifier of { + path: string list; + suggestions: Diagnostic.Message.t list; + } | Asset_error of Asset_router.Error.error | Broken_transclusion of Types.transclusion [@@deriving show] @@ -65,7 +66,10 @@ let missing_argument ~range i = error @@ {range; error = Missing_arguments i} let unbound_method ~range str = error @@ {range; error = Unbound_method str} let unbound_fluid_symbol ~range sym = error @@ {range; error = Unbound_fluid_symbol sym} + +(* let literal_attribution_warning ~range = {range; error = Literal_attribution_warning} let unlinked_attribution_warning ~range = {range; error = Unlinked_attribution_warning} + *) diff --git a/lib/compiler/Expand.ml b/lib/compiler/Expand.ml index 90a70b9..f98a275 100644 --- a/lib/compiler/Expand.ml +++ b/lib/compiler/Expand.ml @@ -69,6 +69,7 @@ let rec expand_eff ~(forest : State.t) : Code.t -> Syn.t = function entered_range yrange; let y = expand_eff ~forest y in (* TODO: merge the ranges *) + (* Done? *) { value = Link {dest = y; title = Some x}; range = Range.merge_opt node.range yrange; @@ -251,7 +252,7 @@ and expand_ident range path : Syn.t = Sc.pp_path path xmlns prefix in (* Should this be a type error? *) - Collect_errors.yield Expand_error.(unresolved_identifier ~range); + Collect_errors.yield Expand_error.(unresolved_xmlns ~range prefix); [] and expand_xml_ident range (prefix, uname) : T.xml_qname = @@ -261,7 +262,7 @@ and expand_xml_ident range (prefix, uname) : T.xml_qname = match Sc.resolve ["xmlns"; prefix] with | Some (Xmlns {xmlns; prefix}, _) -> T.{xmlns = Some xmlns; prefix; uname} | _ -> - Collect_errors.yield Expand_error.(unresolved_identifier ~range); + Collect_errors.yield Expand_error.(unresolved_xmlns ~range prefix); T.{xmlns = None; prefix; uname}) and expand_method ~forest (key, body) = (key, expand_eff ~forest body) diff --git a/lib/compiler/Expand_error.ml b/lib/compiler/Expand_error.ml index 14b9bcd..47af482 100644 --- a/lib/compiler/Expand_error.ml +++ b/lib/compiler/Expand_error.ml @@ -3,27 +3,36 @@ open Forester_core type error = | Import_not_found of URI.t | Unresolved_identifier - | Unresolved_xmlns + | Unresolved_xmlns of string [@@deriving show] type t = {range: Range.t option; error: error} [@@deriving show] let import_not_found ~range uri = {range; error = Import_not_found uri} let unresolved_identifier ~range = {range; error = Unresolved_identifier} -let unresolved_xmlns ~range = {range; error = Unresolved_xmlns} +let unresolved_xmlns ~range prefix = {range; error = Unresolved_xmlns prefix} open Grace open Diagnostic -let render {range; error} = - let msg = - match error with - | Import_not_found _uri -> Message.createf {|import not found |} - | _ -> Message.createf "" +let render_unresolved_xmlns ~range prefix = + let notes = + [ + Message.createf "expected %S to resolve to an XML namespace" prefix; + Message.createf + "You may fix this by defining an XML namespace:@.\\xmlns:%s{...}" prefix; + ] in let labels = Option.fold ~none:[] ~some:(fun range -> [Label.createf ~range ~priority:Primary ""]) range in - Diagnostic.create Error ~labels msg + Diagnostic.createf Error ~labels ~notes "Unresolved XML namespace" + +let render {range; error} = + match error with + | Import_not_found _uri -> Diagnostic.createf Error {|import not found |} + | Unresolved_identifier -> + Diagnostic.createf Error "todo: Expand_error.render" + | Unresolved_xmlns prefix -> render_unresolved_xmlns ~range prefix diff --git a/lib/compiler/Forester_compiler.ml b/lib/compiler/Forester_compiler.ml index d4d2c4b..78ace80 100644 --- a/lib/compiler/Forester_compiler.ml +++ b/lib/compiler/Forester_compiler.ml @@ -32,6 +32,8 @@ module Expand = Expand module Eval = Eval (** Transform {!Syn.tree}s into {{!Forester_core.Types.article}[articles]}.*) +module Eval_error = Eval_error + (** {1 High-level architecture} The compiler needs to support both batch-style and incremental compilation. diff --git a/lib/core/Types.ml b/lib/core/Types.ml index 8fc95cf..5e0cc80 100644 --- a/lib/core/Types.ml +++ b/lib/core/Types.ml @@ -54,7 +54,11 @@ type 'content xml_elt = 'content Forester_xml_names.xml_elt = { type attribution_role = Author | Contributor [@@deriving show, repr] -type 'content attribution = {role: attribution_role; vertex: 'content vertex} +type 'content attribution = { + role: attribution_role; + vertex: 'content vertex; + range: Range.t option; +} [@@deriving show, repr] type 'content frontmatter = { @@ -209,9 +213,19 @@ let trim_whitespace xs = and trim_back xs = List.rev @@ trim_front @@ List.rev xs in trim_back @@ trim_front xs -let default_frontmatter ?uri ?source_path ?designated_parent ?(dates = []) - ?(attributions = []) ?taxon ?number ?(metas = []) ?(tags = []) ?title - ?last_changed () = +let default_frontmatter + ?uri + ?source_path + ?designated_parent + ?(dates = []) + ?(attributions = []) + ?taxon + ?number + ?(metas = []) + ?(tags = []) + ?title + ?last_changed + () = { uri; source_path; @@ -226,7 +240,9 @@ let default_frontmatter ?uri ?source_path ?designated_parent ?(dates = []) last_changed; } -let article_to_section ?(flags = default_section_flags) ?range +let article_to_section + ?(flags = default_section_flags) + ?range (article : 'a article) = let mainmatter = match article.frontmatter.uri with diff --git a/lib/frontend/Forest_util.ml b/lib/frontend/Forest_util.ml index e2b27a5..4ea9419 100644 --- a/lib/frontend/Forest_util.ml +++ b/lib/frontend/Forest_util.ml @@ -24,7 +24,9 @@ let get_sorted_articles ~(forest : State.t) addrs = |> List.of_seq |> List.sort (compare_article ~forest) -let collect_attributions (forest : State.t) (uri_opt : URI.t option) +let collect_attributions + (forest : State.t) + (uri_opt : URI.t option) (primary_attributions : _ T.attribution list) = match uri_opt with | None -> primary_attributions @@ -46,7 +48,7 @@ let collect_attributions (forest : State.t) (uri_opt : URI.t option) in let@ biotree : _ T.article = List.filter_map @~ articles in let@ uri = Option.map @~ biotree.frontmatter.uri in - T.{vertex = T.Uri_vertex uri; role = Contributor} + T.{vertex = T.Uri_vertex uri; role = Contributor; range = None} in primary_attributions @ diff --git a/lib/frontend/Forester.ml b/lib/frontend/Forester.ml index 4bec7f2..c5c7c0c 100644 --- a/lib/frontend/Forester.ml +++ b/lib/frontend/Forester.ml @@ -91,20 +91,24 @@ let json_manifest ~dev ~(forest : State.t) : string = let@ evaluated = Option.bind @@ Tree.to_evaluated tree in if evaluated.include_in_manifest then Tree.to_article tree else None in - articles - |> List.of_seq + articles |> List.of_seq |> List.sort (Forest_util.compare_article ~forest) |> List.filter_map (fun tree -> render ~dev tree) |> (fun t -> `List t) |> Yojson.Safe.to_string -let outputs_for_article ~(forest : State.t) ~emit_legacy_xml +let outputs_for_article + ~(forest : State.t) + ~emit_legacy_xml (article : _ T.article) = match article.frontmatter.uri with | None -> [] | Some uri -> let html_route = URI.append_path_component uri "index.html" in - let html_content = P.to_string @@ Html_client.render_page ~forest article in + let html_content = + let node, _ = Html_client.render_page ~forest article in + P.to_string node + in let debug_route = URI.append_path_component uri "index.tree" in let debug_content = Format.asprintf "%a" Types.(pp_article pp_content) article @@ -124,7 +128,8 @@ let outputs_for_asset (asset : T.asset) = let route = asset.uri in [(route, asset.content)] -let outputs_for_json_blob_syndication ~(forest : State.t) +let outputs_for_json_blob_syndication + ~(forest : State.t) (syndication : _ T.json_blob_syndication) = if URI.host syndication.blob_uri = URI.host forest.config.url then let vertices = Forest.run_datalog_query forest.graphs syndication.query in @@ -140,7 +145,8 @@ let outputs_for_json_blob_syndication ~(forest : State.t) [(syndication.blob_uri, json_content)] else [] -let outputs_for_atom_feed_syndication ~(forest : State.t) +let outputs_for_atom_feed_syndication + ~(forest : State.t) (syndication : T.atom_feed_syndication) = let* atom_nodes = Atom_client.render_feed forest ~source_uri:syndication.source_uri @@ -155,7 +161,9 @@ let outputs_for_syndication ~(forest : State.t) = function | T.Atom_feed syndication -> outputs_for_atom_feed_syndication ~forest syndication -let outputs_for_resource ~(forest : State.t) ~emit_legacy_xml +let outputs_for_resource + ~(forest : State.t) + ~emit_legacy_xml (evaluated : Tree.evaluated) = if not evaluated.route_locally then ok [] else diff --git a/lib/frontend/Html_client.ml b/lib/frontend/Html_client.ml index 73e4dc3..c13ee1e 100644 --- a/lib/frontend/Html_client.ml +++ b/lib/frontend/Html_client.ml @@ -91,6 +91,11 @@ let route ~env uri = Format.asprintf "/foreign/docs%sindex.html" (URI.path_string uri) else Format.asprintf "%a" URI.pp uri +let verify_local_link ~env (link : _ T.link) = + match env.forest.@{link.href} with + | None -> error @@ `Broken_link link + | Some _ -> ok () + let render_date ~env (date : Human_datetime.t) = let href_attr = let str = @@ -202,20 +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 -> - (* TODO: yield error instead of immediately printing *) - Format.printf "%a@." - Grace_ansi_renderer.(pp_diagnostic ?config:None ?code_to_string:None) - Diagnostic.( - createf Warning - ~labels: - (Option.fold ~none:[] - ~some:(fun range -> - [ - Label.createf ~range ~priority:Primary - "This tree was not found"; - ]) - t.range) - "Broken transclusion %a" URI.pp t.href); + Error.yield (Error.Broken_transclusion t); H.null [ P.txt "failed to render transclusion %s" @@ -223,7 +215,13 @@ let rec render_control : type a. env:env -> a client = ] | Some content -> H.null @@ render_content ~env content end - | Link link -> render_link ~env link + | Link link -> begin + match render_link ~env link with + | Ok node -> node + | Error (node, `Broken_link link) -> + Error.yield (Broken_link link); + node + end | Query q -> H.null @@ render_query_result ~env q in fun ~env -> match env.mode with Static -> html ~env | Dynamic -> htmx ~env @@ -308,36 +306,23 @@ and render_query_result ~env q = in render_section ~env @@ to_section article -and render_link ~env (link : T.content T.link) : P.node = - let verify_local_link () = - match env.forest.@{link.href} with - | None -> - Format.printf "%a@." - Grace_ansi_renderer.(pp_diagnostic ?config:None ?code_to_string:None) - Diagnostic.( - createf Warning - ~labels: - (Option.fold ~none:[] - ~some:(fun range -> - [ - Label.createf ~range ~priority:Primary - "This tree was not found"; - ]) - link.range) - "Broken link") - | Some _ -> () - in +and render_link ~env (link : T.content T.link) = let is_local = URI.host link.href = URI.host env.forest.config.url in - let href = + let href, error = if is_local then begin - verify_local_link (); - H.href "%sindex.html" (URI.path_string link.href) + match verify_local_link ~env link with + | Ok () -> (H.href "%sindex.html" (URI.path_string link.href), None) + | Error err -> + (H.href "%sindex.html" (URI.path_string link.href), Some err) end - else H.href "%s" (Format.asprintf "%a" URI.pp link.href) + else (H.href "%s" (Format.asprintf "%a" URI.pp link.href), None) + in + let link = + H.span + [(if is_local then H.class_ "link local" else H.class_ "link external")] + [H.a [href] @@ render_content ~env link.content] in - H.span - [(if is_local then H.class_ "link local" else H.class_ "link external")] - [H.a [href] @@ render_content ~env link.content] + match error with None -> ok link | Some error -> Error (link, error) and _render_section_for_atom_client ~env (section : T.content T.section) : P.node list = @@ -371,10 +356,10 @@ and default_meta_item ~env frontmatter meta = optional (get_meta frontmatter meta) (fun content -> H.li [H.class_ "meta-item"] (render_content ~env content)) -and render_attribution_vertex ~env vtx = - match vtx with +and render_attribution_vertex ~env (attribution : T.(content attribution)) = + match attribution.vertex with | T.Content_vertex content -> H.null (render_content ~env content) - | T.Uri_vertex href -> + | T.Uri_vertex href -> begin let content = T.Content [ @@ -382,12 +367,21 @@ and render_attribution_vertex ~env vtx = {href; target = Title {empty_when_untitled = false}; range = None}; ] in - render_link ~env T.{href; content; range = None} + match render_link ~env T.{href; content; range = attribution.range} with + | Ok node -> node + | Error (node, error) -> begin + match error with + | `Broken_link {range; _} -> + Error.yield + @@ Error.Unlinked_attribution_warning {range; role = attribution.role}; + node + end + end and render_authors ~env (frontmatter : T.(content frontmatter)) = let authors, contributors = - List.partition_map (function T.{role; vertex} -> - (match role with Author -> Left vertex | Contributor -> Right vertex)) + List.partition_map (function T.({role; _} as v) -> + (match role with Author -> Left v | Contributor -> Right v)) @@ Forest_util.collect_attributions env.forest frontmatter.uri frontmatter.attributions in @@ -469,7 +463,9 @@ and render_bibtex ~env frontmatter = optional (get_meta frontmatter "bibtex") (fun c -> H.pre [] (render_content ~env c)) -and render_tree_taxon_with_number ~env ~suffix +and render_tree_taxon_with_number + ~env + ~suffix (T.{taxon; _} : T.(content frontmatter)) = optional taxon (fun content -> H.null @@ render_content ~env content @ [suffix]) @@ -720,37 +716,50 @@ let render_article_as_div ~(forest : State.t) (article : T.content T.article) : (List.map render_xmlns_prefix reserved) [H.null @@ render_content ~env article.mainmatter] -let render_page ~forest ?(mode = Static) +let render_page + ~forest + ?(mode = Static) ({frontmatter; mainmatter = T.Content mainmatter; _} as tree : _ T.article) - : P.node = - let env = {(default_env ~forest) with scope = frontmatter.uri; mode} in - let ttl = - match frontmatter.title with - | None -> (* FIXME: *) "" - | Some _ -> - let title = - State.get_expanded_title ?scope:env.scope frontmatter env.forest - in - PT.string_of_content ~forest:env.forest title - in - let is_home = is_home ~env frontmatter.uri in - let dev = forest.dev in - let content = - [ - render_article ~env tree; - (conditional (should_render_toc tree) - @@ H.( - nav - [id "toc"] - [ - div - [class_ "block"] - [h1 [] [P.txt "Table of Contents"]; render_toc ~env mainmatter]; - ])); - ] + : P.node * Error.t list = + let result = ref None in + let errors = + let@ () = Error.collect in + let env = {(default_env ~forest) with scope = frontmatter.uri; mode} in + let ttl = + match frontmatter.title with + | None -> (* FIXME: *) "" + | Some _ -> + let title = + State.get_expanded_title ?scope:env.scope frontmatter env.forest + in + PT.string_of_content ~forest:env.forest title + in + let is_home = is_home ~env frontmatter.uri in + let dev = forest.dev in + let content = + [ + render_article ~env tree; + (conditional (should_render_toc tree) + @@ H.( + nav + [id "toc"] + [ + div + [class_ "block"] + [ + h1 [] [P.txt "Table of Contents"]; + render_toc ~env mainmatter; + ]; + ])); + ] + in + result := + Option.some + @@ Templates.page ~render_header:true ~dev ~is_home ~title_string:ttl + ~source_path:frontmatter.source_path ~mode content in - Templates.page ~render_header:true ~dev ~is_home ~title_string:ttl - ~source_path:frontmatter.source_path ~mode content + Seq.iter Error.print errors; + (Option.get !result, List.of_seq errors) let html_redirect ~path = H.html [] diff --git a/lib/frontend/Html_client.mli b/lib/frontend/Html_client.mli index ab9d3db..ba8df63 100644 --- a/lib/frontend/Html_client.mli +++ b/lib/frontend/Html_client.mli @@ -31,7 +31,7 @@ val render_page : forest:Forester_compiler.State.t -> ?mode:Forester_core.mode -> T.content T.article -> - P.node + P.node * Forester_compiler.Error.t list val html_redirect : path:string -> Pure_html.node diff --git a/lib/frontend/Legacy_xml_client.ml b/lib/frontend/Legacy_xml_client.ml index 18db644..e548e98 100644 --- a/lib/frontend/Legacy_xml_client.ml +++ b/lib/frontend/Legacy_xml_client.ml @@ -268,7 +268,8 @@ 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 suggestion + | Not_found {suggestion = _} -> error @@ Error.Broken_link link + (*suggestion*) else ok () end; [ diff --git a/lib/frontend/test/config.t b/lib/frontend/test/config.t index 8966c73..a1bf37b 100644 --- a/lib/frontend/test/config.t +++ b/lib/frontend/test/config.t @@ -6,7 +6,7 @@ warning: option [forest.home] not set, using default index $ parse_forester_config configs/uninterpreted-fields.toml - warning: These configuration options are unknown: forest.unknown + warning[config_error]: unknown options forest.unknown $ parse_forester_config configs/nonexistent.toml - error[io_error]: configs/nonexistent.toml: No such file or directory + error[config_error]: file configs/nonexistent.toml does not exist diff --git a/lib/frontend/test/dune b/lib/frontend/test/dune index 8480e32..cd312a5 100644 --- a/lib/frontend/test/dune +++ b/lib/frontend/test/dune @@ -55,4 +55,4 @@ (cram (deps %{bin:parse_forester_config} - (glob_files configs/*))) + (glob_files_rec configs/*))) diff --git a/lib/human_datetime/Human_datetime.ml b/lib/human_datetime/Human_datetime.ml index ae23a8e..1980200 100644 --- a/lib/human_datetime/Human_datetime.ml +++ b/lib/human_datetime/Human_datetime.ml @@ -32,8 +32,9 @@ let compare dt0 dt1 = let parse lexbuf = match Grammar.datetime Lexer.token lexbuf with - | datetime -> Some datetime - | exception Grammar.Error -> None + | datetime -> Ok datetime + | exception Grammar.Error -> Error () + | exception Failure _ -> Error () let parse_string str = let lexbuf = Lexing.from_string str in @@ -41,8 +42,8 @@ let parse_string str = let parse_string_exn str = match parse_string str with - | None -> failwith "human datetime: parse error" - | Some dt -> dt + | Error _ -> failwith "human datetime: parse error" + | Ok dt -> dt let t = let of_string str = parse_string_exn str in diff --git a/lib/human_datetime/Human_datetime.mli b/lib/human_datetime/Human_datetime.mli index 7d4ab1a..09958ea 100644 --- a/lib/human_datetime/Human_datetime.mli +++ b/lib/human_datetime/Human_datetime.mli @@ -10,7 +10,7 @@ val t : t Repr.t val pp : Format.formatter -> t -> unit val pp_rfc_3399 : Format.formatter -> t -> unit val compare : t -> t -> int -val parse_string : string -> t option +val parse_string : string -> (t, unit) result val parse_string_exn : string -> t val year : t -> int val month : t -> int option diff --git a/lib/search/test/Test_forester_search.ml b/lib/search/test/Test_forester_search.ml index 7a4f664..bd3558d 100644 --- a/lib/search/test/Test_forester_search.ml +++ b/lib/search/test/Test_forester_search.ml @@ -124,10 +124,12 @@ let test_render_context_frontmatter () = { role = T.Author; vertex = Uri_vertex (URI.of_string_exn "forest://test/kentookura"); + range = None; }; { role = T.Contributor; vertex = Uri_vertex (URI.of_string_exn "forest://test/jonmsterling"); + range = None; }; ] () diff --git a/test/errors.t b/test/errors.t index 08f6d61..687e4ba 100644 --- a/test/errors.t +++ b/test/errors.t @@ -1,7 +1,77 @@ $ cd forests + $ forester build + warning: option [forest.assets] not set, using default [] + warning: option [forest.home] not set, using default index + Success! + $ forester build eval-errors.toml + error[type_error]: mismatched type + ┌─ $TESTCASE_ROOT/forests/eval-errors/index.tree:2:3 + 1 │ \def\hello[name]{Hello, \name!} + 2 │ \p{ + │ ╭────^ + 3 │ │ \hello + 4 │ │ } + │ ╰──^ This is a function. Did you forget to provide some arguments? + 5 │ + = expected some content + error: Invalid date + ┌─ $TESTCASE_ROOT/forests/eval-errors/invalid-date.tree:1:6 + 1 │ \date{asdf} + │ ^^^^^^ + error: unresolved identifier foobar + ┌─ $TESTCASE_ROOT/forests/eval-errors/unresolved-ident.tree:2:4 + 2 │ \foobar + │ ^^^^^^ + = Did you mean ⋃? + [1] + $ forester build missing-tree-dir.toml + error[config_error]: directory nonexistent does not exist + $ forester build missing-foreign-blob.toml + error[config_error]: file nonexistent does not exist + $ forester build parse-errors.toml + warning: option [forest.assets] not set, using default [] + warning: option [forest.home] not set, using default index + error[parse_error]: parse error + ┌─ $TESTCASE_ROOT/forests/parse-errors/index.tree:4:1 + 4 │ + │ ^ + [1] + $ forester build transclusion-errors.toml + warning: option [forest.assets] not set, using default [] + warning: option [forest.home] not set, using default index + warning: Broken transclusion http://forest.local/foo/ + ┌─ $TESTCASE_ROOT/forests/transclusion-errors/index.tree:1:12 + 1 │ \transclude{foo} + │ ^^^^^ This tree was not found + warning: Broken link http://forest.local/foo/ + ┌─ $TESTCASE_ROOT/forests/transclusion-errors/broken-link.tree:2:3 + 2 │ [I am pointing nowhere](foo) + │ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ This tree was not found + Success! + + $ forester build xml-errors.toml + warning: option [forest.assets] not set, using default [] + warning: option [forest.home] not set, using default index + error: Unresolved XML namespace + ┌─ $TESTCASE_ROOT/forests/xml-errors/index.tree:2:4 + 2 │ \ + │ ^^^^^^^^^ + = expected "foo" to resolve to an XML namespace + = You may fix this by defining an XML namespace: + \xmlns:foo{...} + [1] + + $ forester build unlinked-attributions.toml + warning: option [forest.assets] not set, using default [] + warning: option [forest.home] not set, using default index + error: Unlinked attribution + ┌─ $TESTCASE_ROOT/forests/unlinked-attributions/index.tree:1:8 + 1 │ \author{unknown} + │ ^^^^^^^^^ Expected valid URI in attribution. Use `\author/literal` instead if you intend an unlinked attribution. + Success! -- 2.51.2