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!