~jonsterling: 1 New query infrastructure; generalised backmatter computed from queries 38 files changed, 686 insertions(+), 679 deletions(-)
Copy & paste the following snippet into your terminal to import this patchset into git:
curl -s https://lists.sr.ht/~jonsterling/forester-devel/patches/53404/mbox | git am -3Learn more about email & git
From: Jon Sterling <jon@jonmsterling.com>
1. Improved querying
This patch improves the querying infrastucture to be strong enough to
compute the existing backmatter, as well as a few other things (like
computing the hereditary contributors to a given tree).
One breaking change is that I now want to support only "graph-related"
queries: previously, there was `\query/meta{key}{body}`, which would do
a structural equality match on the provided Forester content `body`. I
think queries like this are brittle and not too useful, and should be
replaced (in the future) with usage of the impending custom graph
support. Ideally, most queries should be able to start by reading a
small fraction of the forest from the graph and intersecting it with
things --- rather than walking the entire forest again and again.
2. Generalised backmatter
The backmatter is now generalised to support arbitrary queries (but this
doesn't yet have a user interface).This impacts the XML format of the
backmatter: previously it was something like:
<backmatter>
<context> ... </context>
<references> ... </references>
<related> ... </related>
<backlinks> ... </backlinks>
</backmatter>
Now, the backmatter element contains arbitrary trees. For example:
<backmatter>
<tree ...>
<frontmatter>
<title>Context</title>
...
</frontmatter>
...
</tree>
...
</backmatter>
Addendum: to test this out, you can use the `generalised-backmatter` branch of the forester-base-theme.
3. Miscellaneous I have also disentangled and simplified much of the architecture. Here are some of the additional changes. + The graph analysis is computed on the fly during evaluation rather than in a second pass. + The Render_effect thing is excised, and appropriate parameters are passed to modules where needed. + Previously the Xml_tree representation held routes for internal links, etc. I have removed this data from the representation because this is meant to be a source of truth for plenty of output formats, not all of which will route trees to the same locations as the built-in XML output format. Therefore, routing should in fact be computed during serialisation. --- bin/forester/main.ml | 11 +- lib/core/Base.ml | 10 +- lib/core/Eval.ml | 223 ++++++++++++++++++-- lib/core/Eval.mli | 9 + lib/core/Query.ml | 91 ++++++-- lib/core/Reporter.ml | 2 + lib/core/Sem.ml | 64 +++--- lib/core/Xml_tree.ml | 36 +--- lib/core/dune | 2 +- lib/frontend/Analysis.ml | 151 ------------- lib/frontend/Analysis.mli | 30 --- lib/frontend/Config.ml | 5 +- lib/frontend/Config.mli | 1 - lib/frontend/Forest.ml | 156 +++----------- lib/frontend/Forest.mli | 10 +- lib/frontend/Grammar.mly | 15 +- lib/frontend/Import_graph.ml | 37 ++++ lib/frontend/Import_graph.mli | 13 ++ lib/frontend/Lexer.mll | 1 - lib/{frontend => render}/Build_latex.ml | 2 - lib/{frontend => render}/Build_latex.mli | 0 lib/render/Compile.ml | 178 +++++++++++----- lib/render/Compile.mli | 10 +- lib/{frontend => render}/LaTeX_queue.ml | 6 +- lib/{frontend => render}/LaTeX_queue.mli | 2 +- lib/{frontend => render}/LaTeX_template.ml | 0 lib/{frontend => render}/LaTeX_template.mli | 0 lib/render/Render_effect.ml | 87 -------- lib/render/Render_effect.mli | 25 --- lib/render/Render_json.ml | 22 +- lib/render/Render_json.mli | 2 +- lib/render/Render_text.ml | 24 +-- lib/render/Render_text.mli | 2 +- lib/render/Render_util.ml | 12 +- lib/render/Serialise_xml_tree.ml | 104 +++++---- lib/render/Serialise_xml_tree.mli | 9 +- lib/render/Xml_forester.ml | 8 +- lib/render/Xml_forester.mli | 5 - 38 files changed, 686 insertions(+), 679 deletions(-) delete mode 100644 lib/frontend/Analysis.ml delete mode 100644 lib/frontend/Analysis.mli create mode 100644 lib/frontend/Import_graph.ml create mode 100644 lib/frontend/Import_graph.mli rename lib/{frontend => render}/Build_latex.ml (98%) rename lib/{frontend => render}/Build_latex.mli (100%) rename lib/{frontend => render}/LaTeX_queue.ml (68%) rename lib/{frontend => render}/LaTeX_queue.mli (50%) rename lib/{frontend => render}/LaTeX_template.ml (100%) rename lib/{frontend => render}/LaTeX_template.mli (100%) delete mode 100644 lib/render/Render_effect.ml delete mode 100644 lib/render/Render_effect.mli diff --git a/bin/forester/main.ml b/bin/forester/main.ml index a8c7d7d..ad72395 100644 --- a/bin/forester/main.ml @@ -15,11 +15,9 @@ let internal_config_from_config ~env (config : Forester_frontend.Config.Forest_c Forest. {env; root = config.root; - base_url = config.base_url; assets_dirs = make_dirs ~env config.assets; theme_dir = make_dir ~env config.theme; stylesheet = config.stylesheet; - max_fibers = 20; ignore_tex_cache = false; no_assets = false; no_theme = false} @@ -73,7 +71,7 @@ let new_tree ~env config_filename dest_dir prefix template random = Process.read_trees_in_dirs ~dev:true ~ignore_malformed:true input_dirs in let addrs = - Analysis.Map.bindings forest.trees + Addr_map.bindings forest.trees |> List.to_seq |> Seq.map fst |> Seq.filter_map Addr.to_user_addr @@ -126,12 +124,8 @@ let query_all ~env config_filename = Process.read_trees_in_dirs ~dev:true ~ignore_malformed:true @@ make_dirs ~env config.trees in - let internal_config = internal_config_from_config ~env config in - Forest.run_renderer ~cfg:internal_config forest @@ fun () -> forest.trees - |> Analysis.Map.to_list - |> List.map snd - |> Forester_render.Render_json.render_trees ~dev:true + |> Forester_render.Render_json.render_trees ~root:config.root ~dev:true |> Yojson.Basic.to_string |> Format.printf "%s" @@ -155,7 +149,6 @@ let init ~env () = trees = ["trees" ] # The directories in which your trees are stored assets = ["assets"] # The directories in which your assets are stored theme = "theme" # The directory in which your theme is stored -base_url = "https://www.example.com" # The base URL of your site |} in diff --git a/lib/core/Base.ml b/lib/core/Base.ml index 408dd80..2c89bb2 100644 --- a/lib/core/Base.ml +++ b/lib/core/Base.ml @@ -1,4 +1,9 @@ -type addr = User_addr of string | Machine_addr of int +type addr = + | User_addr of string + (** The address of a tree that can be referenced from user text. *) + + | Machine_addr of int + (** The address of an anonymous tree.*) let pp_addr fmt = function @@ -18,6 +23,9 @@ struct | _ -> None end +module Addr_map = Map.Make (Addr) +module Addr_set = Set.Make (Addr) + type delim = Braces | Squares | Parens [@@deriving show] diff --git a/lib/core/Eval.ml b/lib/core/Eval.ml index 7f197f7..cff741f 100644 --- a/lib/core/Eval.ml +++ b/lib/core/Eval.ml @@ -7,6 +7,172 @@ module Dyn_env = Algaeff.Reader.Make (struct type t = Sem.t Env.t end) module Heap = Algaeff.State.Make (struct type t = Sem.obj Env.t end) module Emitted_trees = Algaeff.State.Make (struct type t = Sem.tree list end) module Fm = Algaeff.State.Make (struct type t = Sem.frontmatter end) +module Scope = Algaeff.State.Make (Addr) + +module G = +struct + module G = Graph.Imperative.Digraph.Concrete (Addr) + include G + include Graph.Oper.I (G) + + let safe_succ g x = + if mem_vertex g x then succ g x else [] + + let safe_fold_succ f g x acc = + if mem_vertex g x then + fold_succ f g x acc + else + acc + + let safe_pred g x = + if mem_vertex g x then pred g x else [] +end + +module Gphs = +struct + type t = { + all_addrs : (addr, unit) Hashtbl.t; + graphs : (Query.rel_name, G.t) Hashtbl.t; + } + + + let graph rel tbl = + match Hashtbl.find_opt tbl.graphs rel with + | None -> + let gph = G.create () in + Hashtbl.add tbl.graphs rel gph; + gph + | Some gph -> gph + + let init () : t = + let all_addrs = Hashtbl.create 1000 in + let graphs = Hashtbl.create 20 in + {graphs; all_addrs} + + let register_addr addr tbl = + Hashtbl.add tbl.all_addrs addr () + + let add rel ~source ~target tbl = + let gph = graph rel tbl in + G.add_edge gph source target + + let all_addrs tbl = + tbl.all_addrs + |> Hashtbl.to_seq + |> Seq.map fst + |> Addr_set.of_seq + +end + +module Analysis = +struct + module Q = Query + + type t = { + basis : Gphs.t; + rtgraphs : (Query.rel_name, G.t) Hashtbl.t + } + + let init (basis : Gphs.t) = + let rtgraphs = Hashtbl.create @@ Hashtbl.length basis.graphs in + {basis; rtgraphs = rtgraphs} + + let graph rel analysis = + Gphs.graph rel analysis.basis + + let rtgraph rel analysis = + match Hashtbl.find_opt analysis.rtgraphs rel with + | None -> + let gph = G.transitive_closure ~reflexive:true @@ graph rel analysis in + Hashtbl.add analysis.rtgraphs rel gph; + gph + | Some rtgph -> rtgph + + let query_rel analysis pol rel addr = + let fn = + match pol with + | `Incoming -> G.safe_pred + | `Outgoing -> G.safe_succ + in + let gph = graph rel analysis in + Addr_set.of_list @@ fn gph addr + + let check_rel analysis pol rel addr addr' = + let gph = graph rel analysis in + match pol with + | `Incoming -> G.mem_edge gph addr' addr + | `Outgoing -> G.mem_edge gph addr addr' + + let rec check_query analysis q addr = + match q with + | Q.Tree_under root -> + G.mem_edge (rtgraph `Transclusion analysis) root addr + | Q.Rel (pol, rel, addr') -> + check_rel analysis pol rel addr' addr + | Q.Isect qs -> + qs |> List.for_all @@ fun q -> + check_query analysis q addr + | Q.Union qs -> + qs |> List.exists @@ fun q -> + check_query analysis q addr + | Q.Complement q -> + not @@ check_query analysis q addr + | Q.Isect_fam (q, (pol, rel)) -> + let xs = Addr_set.to_list @@ run_query analysis q in + xs |> List.for_all @@ fun x -> + check_rel analysis pol rel x addr + | Q.Union_fam (q, (pol, rel)) -> + let xs = Addr_set.to_list @@ run_query analysis q in + xs |> List.exists @@ fun x -> + check_rel analysis pol rel x addr + + and run_query analysis = + function + | Q.Tree_under addr -> + G.safe_fold_succ + Addr_set.add + (rtgraph `Transclusion analysis) + addr + Addr_set.empty + | Q.Rel (pol, rel, addr) -> + query_rel analysis pol rel addr + | Q.Isect qs -> run_isect analysis qs + | Q.Union qs -> run_union analysis qs + | Q.Complement q -> + Addr_set.diff (Gphs.all_addrs analysis.basis) @@ run_query analysis q + | Q.Isect_fam (q, (pol, rel)) -> + let xs = Addr_set.to_list @@ run_query analysis q in + run_isect analysis @@ List.map (fun x -> Q.Rel (pol, rel, x)) xs + | Q.Union_fam (q, (pol, rel)) -> + let xs = Addr_set.to_list @@ run_query analysis q in + run_union analysis @@ List.map (fun x -> Q.Rel (pol, rel, x)) xs + + and run_isect analysis = + function + | [] -> Gphs.all_addrs analysis.basis + | q :: qs -> + let s = run_query analysis q in + s |> Addr_set.filter @@ check_query analysis @@ Q.Isect qs + + and run_union analysis = + fold_set_operation Addr_set.union analysis Addr_set.empty + + and fold_set_operation opr analysis running = + function + | [] -> running + | q :: qs -> + let s = run_query analysis q in + fold_set_operation opr analysis (opr running s) qs +end + +module Gphs_env = +struct + include Algaeff.Reader.Make (struct type t = Gphs.t end) + + let call f = + let tbl = read () in + f tbl +end let get_transclusion_opts () = let dynenv = Dyn_env.read () in @@ -39,12 +205,17 @@ and eval_node : Syn.node Range.located -> Syn.t -> Sem.t = fun node rest -> match node.value with | Link {title; dest} -> + let scope = Scope.get () in + let dest = eval_addr dest in + Gphs_env.call @@ Gphs.add `Links ~source:scope ~target:dest; let title = Option.map eval title in - {node with value = Sem.Link (eval_addr dest, title, Identity)} :: eval rest + {node with value = Sem.Link (dest, title, Identity)} :: eval rest | Ref dest -> - let addr = eval_addr dest in - {node with value = Sem.Ref addr} :: eval rest + let scope = Scope.get () in + let dest = eval_addr dest in + Gphs_env.call @@ Gphs.add `Links ~source:scope ~target:dest; + {node with value = Sem.Ref dest} :: eval rest | Math (mmode, e) -> {node with value = Sem.Math (mmode, eval e)} :: eval rest @@ -70,8 +241,10 @@ and eval_node : Syn.node Range.located -> Syn.t -> Sem.t = {node with value = Sem.TeX_cs cs} :: eval rest | Transclude addr -> - let opts = get_transclusion_opts () in let addr = eval_addr addr in + let scope = Scope.get () in + Gphs_env.call @@ Gphs.add `Transclusion ~source:scope ~target:addr; + let opts = get_transclusion_opts () in {node with value = Sem.Transclude (opts, addr)} :: eval rest | Subtree (addr, nodes) -> @@ -80,6 +253,8 @@ and eval_node : Syn.node Range.located -> Syn.t -> Sem.t = | Some addr -> User_addr addr | None -> Machine_addr (Oo.id (object end)) in + let scope = Scope.get () in + Gphs_env.call @@ Gphs.add `Transclusion ~source:scope ~target:addr; let opts = get_transclusion_opts () in let subtree = eval_tree_inner ~addr nodes in let fm = Fm.get () in @@ -102,7 +277,7 @@ and eval_node : Syn.node Range.located -> Syn.t -> Sem.t = | None -> {opts with show_heading = false; toc = false} | Some _ -> opts in - let query = Query.map eval query in + let query = Query.map eval_addr query in {node with value = Sem.Query (opts, query)} :: eval rest | Embed_tex {preamble; source} -> @@ -223,7 +398,7 @@ and eval_node : Syn.node Range.located -> Syn.t -> Sem.t = | Get key -> begin let env = Dyn_env.read () in - match Env.find_opt key @@ Dyn_env.read () with + match Env.find_opt key env with | None -> Eio.traceln "getting %a from %a" Symbol.pp key (Env.pp Sem.pp) env; Reporter.fatalf ?loc:node.loc Resolution_error @@ -253,14 +428,22 @@ and eval_node : Syn.node Range.located -> Syn.t -> Sem.t = eval rest | Author author -> - Fm.modify (fun fm -> {fm with authors = fm.authors @ [User_addr author]}); + let scope = Scope.get () in + let addr = User_addr author in + Gphs_env.call @@ Gphs.add `Authorship ~source:scope ~target:addr; + Fm.modify (fun fm -> {fm with authors = fm.authors @ [addr]}); eval rest | Contributor author -> - Fm.modify (fun fm -> {fm with contributors = fm.contributors @ [User_addr author]}); + let scope = Scope.get () in + let addr = User_addr author in + Gphs_env.call @@ Gphs.add `Contributorship ~source:scope ~target:addr; + Fm.modify (fun fm -> {fm with contributors = fm.contributors @ [addr]}); eval rest | Tag tag -> + let scope = Scope.get () in + Gphs_env.call @@ Gphs.add `Tags ~source:scope ~target:(User_addr tag); Fm.modify (fun fm -> {fm with tags = fm.tags @ [tag]}); eval rest @@ -279,10 +462,9 @@ and eval_node : Syn.node Range.located -> Syn.t -> Sem.t = eval rest | Taxon taxon -> - begin - Fm.modify @@ fun fm -> - {fm with taxon = Some taxon} - end; + let scope = Scope.get () in + Gphs_env.call @@ Gphs.add `Taxa ~source:scope ~target:(User_addr taxon); + Fm.modify (fun fm -> {fm with taxon = Some taxon}); eval rest and eval_strip xs = Sem.strip_whitespace @@ eval xs @@ -312,6 +494,13 @@ and eval_addr xs = User_addr (eval_as_string xs) and eval_tree_inner ~addr (tree : Syn.tree) : Sem.tree = + Gphs_env.call @@ Gphs.register_addr addr; + let scope = + match addr with + | User_addr _ -> addr + | _ -> Scope.get () + in + Scope.run ~init:scope @@ fun () -> let outer_fm = Fm.get () in let fm = {(Sem.empty_frontmatter ~addr) with @@ -320,15 +509,17 @@ and eval_tree_inner ~addr (tree : Syn.tree) : Sem.tree = dates = outer_fm.dates} in Fm.run ~init:fm @@ fun () -> + let bm = Sem.default_backmatter ~addr in (*TODO*) let body = eval tree in let fm = Fm.get () in let open Sem in - {fm; body} + {fm; body; bm} let eval_tree ~addr ~source_path (tree : Syn.tree) : Sem.tree * Sem.tree list = let fm = {(Sem.empty_frontmatter ~addr) with source_path} in Fm.run ~init:fm @@ fun () -> + Scope.run ~init:addr @@ fun () -> Emitted_trees.run ~init:[] @@ fun () -> Heap.run ~init:Env.empty @@ fun () -> Lex_env.run ~env:Env.empty @@ fun () -> @@ -336,3 +527,9 @@ let eval_tree ~addr ~source_path (tree : Syn.tree) : Sem.tree * Sem.tree list = let tree = eval_tree_inner ~addr tree in let emitted = Emitted_trees.get () in tree, emitted + +let run (k : unit -> 'a) : Analysis.t * 'a = + let env = Gphs.init () in + Gphs_env.run ~env @@ fun () -> + let x = k () in + Analysis.init (Gphs_env.read ()), x diff --git a/lib/core/Eval.mli b/lib/core/Eval.mli index 34a483f..4522ca8 100644 --- a/lib/core/Eval.mli +++ b/lib/core/Eval.mli @@ -1,3 +1,12 @@ open Base +module Analysis : sig + type t + val run_query : t -> addr Query.t -> Addr_set.t +end + +val run : (unit -> 'a) -> Analysis.t * 'a +(** Runs a computation with a fresh graph analysis *) + val eval_tree : addr:addr -> source_path:string option -> Syn.tree -> Sem.tree * Sem.tree list +(** Must be called in the scope of {!run}. *) diff --git a/lib/core/Query.ml b/lib/core/Query.ml index 25913dd..f7d9ed0 100644 --- a/lib/core/Query.ml +++ b/lib/core/Query.ml @@ -1,22 +1,79 @@ -type 'a t = - | Author of 'a - | Tag of 'a - | Taxon of 'a - | Meta of string * 'a - | Or of 'a t list - | And of 'a t list - | Not of 'a t - | True +open Base + +type rel_name = [`Links | `Transclusion | `Authorship | `Contributorship | `Tags | `Taxa ] +[@@deriving show] + +type rel_query = [`Incoming | `Outgoing] * rel_name +[@@deriving show] + +type 'addr t = + | Rel of [`Incoming | `Outgoing] * rel_name * 'addr + | Tree_under of 'addr + | Isect of 'addr t list + | Union of 'addr t list + | Complement of 'addr t + | Isect_fam of 'addr t * rel_query + | Union_fam of 'addr t * rel_query [@@deriving show] let rec map f = function - | Author x -> Author (f x) - | Tag x -> Tag (f x) - | Taxon x -> Taxon (f x ) - | Meta (k, v) -> Meta (k, f v) - | Or qs -> Or (List.map (map f) qs) - | And qs -> And (List.map (map f) qs) - | Not q -> Not (map f q) - | True -> True + | Rel (pol, rel, x) -> Rel (pol, rel, f x) + | Tree_under x -> Tree_under (f x) + | Isect qs -> Isect (List.map (map f) qs) + | Union qs -> Union (List.map (map f) qs) + | Isect_fam (q, rq) -> Isect_fam (map f q, rq) + | Union_fam (q, rq) -> Union_fam (map f q, rq) + | Complement q -> Complement (map f q) + + +(** A heuristic for computing an intersection of queries. *) +let rec query_cost = + function + | Tree_under _ -> 100 + | Rel _ -> 200 + | Isect qs -> + List.fold_left (fun i q -> min (query_cost q) i) 1000 qs + | Union qs -> + List.fold_left (fun i q -> max (query_cost q) i) 0 qs + | Isect_fam (q, k) -> query_cost q + | Union_fam (q, k) -> query_cost q + | Complement _ -> 900 + +let sort_by_ascending_cost qs = + qs |> List.sort @@ fun q0 q1 -> + compare (query_cost q0) (query_cost q1) + +let sort_by_descending_cost qs = + qs |> List.sort @@ fun q0 q1 -> + compare (query_cost q1) (query_cost q0) + + +let rec isect qs = + match sort_by_ascending_cost qs with + | Isect qs :: qs' -> isect @@ qs @ qs' + | qs -> Isect qs + +and union qs = + match sort_by_descending_cost qs with + | Union qs :: qs' -> union @@ qs @ qs' + | qs -> Union qs + +let rec complement = + function + | Union qs -> isect @@ List.map complement qs + | Complement q -> q + | q -> Complement q + +let rel pol rel addr = + Rel (pol, rel, addr) + +let tree_under x = Tree_under x +let isect_fam q pol rel = + Isect_fam (q, (pol, rel)) + +let union_fam q pol rel = + Union_fam (q, (pol, rel)) +let has_taxon taxon = + rel `Incoming `Taxa @@ User_addr taxon diff --git a/lib/core/Reporter.ml b/lib/core/Reporter.ml index 7c5c9c5..8d5c04b 100644 --- a/lib/core/Reporter.ml +++ b/lib/core/Reporter.ml @@ -14,6 +14,7 @@ struct | Internal_error | Configuration_error | Initialization_warning + | Routing_error | Profiling [@@deriving show] @@ -32,6 +33,7 @@ struct | Internal_error -> Bug | Configuration_error -> Error | Initialization_warning -> Warning + | Routing_error -> Error | Profiling -> Info let short_code : t -> string = diff --git a/lib/core/Sem.ml b/lib/core/Sem.ml index 18a4778..53f1682 100644 --- a/lib/core/Sem.ml +++ b/lib/core/Sem.ml @@ -17,7 +17,7 @@ type node = | Verbatim of string | Transclude of transclusion_opts * addr | Subtree of transclusion_opts * tree - | Query of transclusion_opts * t Query.t + | Query of transclusion_opts * addr Query.t | Link of addr * t option * modifier | Xml_tag of xml_resolved_qname * (xml_resolved_qname * t) list * t | TeX_cs of TeX_cs.t @@ -50,6 +50,7 @@ and env = t Env.t and tree = {fm : frontmatter; + bm : backmatter_section list; body : t} [@@deriving show] @@ -66,7 +67,10 @@ and frontmatter = designated_parent : addr option; source_path : string option; number : string option} +[@@deriving show] +and backmatter_section = + | Backmatter_section of {title: t; query : addr Query.t} type obj_method = {body : Syn.t; @@ -179,30 +183,6 @@ struct end -module Query = -struct - let rec test query (doc : tree) = - match query with - | Query.Author [Range.{value = Text addr; _}] -> - List.mem (User_addr addr) doc.fm.authors - | Query.Tag [{value = Text addr; _}] -> - List.mem addr doc.fm.tags - | Query.Meta (key, value) -> - List.mem (key, value) doc.fm.metas - | Query.Taxon [{value = Text taxon; _}] -> - doc.fm.taxon = Some taxon - | Query.Or qs -> - qs |> List.exists @@ fun q -> test q doc - | Query.And qs -> - qs |> List.for_all @@ fun q -> test q doc - | Query.Not q -> - not @@ test q doc - | Query.True -> - true - | _ -> false - -end - let empty_frontmatter ~addr = {addr; title = None; @@ -217,9 +197,41 @@ let empty_frontmatter ~addr = source_path = None; number = None} +let default_backmatter ~addr = + let make_section title query = + let title = [Range.locate_opt None @@ Text title] in + Backmatter_section {title; query} + in + [ + make_section "references" @@ + Query.isect [ + Query.union_fam (Query.tree_under addr) `Outgoing `Links; + Query.has_taxon "reference" + ]; + + make_section "context" @@ + Query.rel `Incoming `Transclusion addr; + + make_section "backlinks" @@ + Query.rel `Incoming `Links addr; + + make_section "related" @@ + Query.isect [ + Query.rel `Outgoing `Links addr; + Query.complement @@ Query.has_taxon "reference" + ]; + + make_section "contributions" @@ + Query.union [ + Query.rel `Incoming `Authorship addr; + Query.rel `Incoming `Contributorship addr + ] + ] + let empty_tree ~addr = {fm = empty_frontmatter ~addr; - body = []} + body = []; + bm = default_backmatter ~addr} let default_transclusion_opts : transclusion_opts = {title_override = None; diff --git a/lib/core/Xml_tree.ml b/lib/core/Xml_tree.ml index d5de848..33729d4 100644 --- a/lib/core/Xml_tree.ml +++ b/lib/core/Xml_tree.ml @@ -1,4 +1,5 @@ open Forester_prelude +open Base type xml_qname = { prefix : string; @@ -19,7 +20,7 @@ type 'content attribution = type date = | Date of { - href : string option; + addr : addr option; year : int; month : int option; day : int option @@ -31,8 +32,6 @@ type 'content meta = body : 'content } -type link_type = [`Local | `External] - type ('content, 'tree) content_node = | Text of string | CDATA of string @@ -44,18 +43,12 @@ type ('content, 'tree) content_node = | Prim of Prim.t * 'content | Subtree of 'tree | Ref of { - addr : string; - href : string; + addr : addr; taxon : string option; number : string option } - | Link of { - type_ : link_type; - href : string; - title : string option; - addr : string option; - content : 'content - } + | Local_link of {addr : addr; content : 'content; title : string option} + | External_link of {href : string; content : 'content; title : string option} | TeX of { display : [`Inline | `Block]; body : string @@ -71,29 +64,18 @@ type ('content, 'tree) content_node = type 'content frontmatter = { title : 'content option; - anchor : string; + anchor : string option; number : string option; taxon : string option; designated_parent : string option; metas : 'content meta list; - route : string; - addr : string; + addr : addr option; source_path : string option; dates : date list; last_changed : date option; attributions : 'content attribution list } -(* TODO: generalise *) -type 'tree backmatter_elt = - | Contributions of 'tree list - | Related of 'tree list - | Backlinks of 'tree list - | Context of 'tree list - | References of 'tree list - -type 'tree backmatter = 'tree backmatter_elt list - type tree_options = { toc : bool; numbered : bool; @@ -107,7 +89,7 @@ type 'content tree = { options : tree_options; frontmatter : 'content frontmatter; mainmatter : 'content; - backmatter : 'content tree backmatter option + backmatter : 'content tree list } (* Tie the knot *) @@ -115,4 +97,4 @@ type tree_ = Tree of content tree and content = Content of (content, tree_) content_node list let splice (Content xs) = xs -let splice_tree (Tree tree) = tree \ No newline at end of file +let splice_tree (Tree tree) = tree diff --git a/lib/core/dune b/lib/core/dune index 7804226..2c36b04 100644 --- a/lib/core/dune +++ b/lib/core/dune @@ -2,7 +2,7 @@ (name Forester_core) (preprocess (pps ppx_deriving.show)) - (libraries forester.prelude yuujinchou asai repr) + (libraries forester.prelude yuujinchou asai repr ocamlgraph) (public_name forester.core)) (env diff --git a/lib/frontend/Analysis.ml b/lib/frontend/Analysis.ml deleted file mode 100644 index 6f5c454..0000000 --- a/lib/frontend/Analysis.ml @@ -1,151 +0,0 @@ -open Forester_core - -module Map = Map.Make (Addr) -module Gph = Graph.Imperative.Digraph.Concrete (Addr) -module Topo = Graph.Topological.Make (Gph) - -module Tbl = Hashtbl.Make (Addr) - -let build_import_graph (trees : Code.tree list) = - let import_graph = Gph.create () in - - let rec analyse_tree roots (tree : Code.tree) = - let roots = Option.fold ~none:roots ~some:(fun x -> x :: roots) tree.addr in - begin - tree.addr |> Option.iter @@ fun addr -> - Gph.add_vertex import_graph @@ User_addr addr - end; - tree.code |> List.iter @@ fun node -> - match Asai.Range.(node.value) with - | Code.Import (_, dep) -> - roots |> List.iter @@ fun addr -> Gph.add_edge import_graph (User_addr dep) (User_addr addr) - | Code.Subtree (addr, code) -> - analyse_tree roots @@ Code.{tree with addr; code} - | _ -> () - in - - trees |> List.iter (analyse_tree []); - import_graph - -type analysis = - {transclusion_graph : Gph.t; - link_graph : Gph.t; - contributors : addr Tbl.t; - author_pages : addr Tbl.t; - bibliography : addr Tbl.t} - - -let new_analysis () = - let size = 100 in - {transclusion_graph = Gph.create (); - link_graph = Gph.create (); - author_pages = Tbl.create size; - contributors = Tbl.create size; - bibliography = Tbl.create size} - -let rec analyze_nodes ~analysis scope : Sem.t -> unit = - List.iter @@ fun located -> - match Range.(located.value) with - | Sem.Transclude (opts, addr) -> - analyze_transclusion_opts ~analysis scope opts; - Gph.add_edge analysis.transclusion_graph addr scope - | Sem.Subtree (opts, subtree) -> - analyze_transclusion_opts ~analysis scope opts; - Gph.add_edge analysis.transclusion_graph subtree.fm.addr scope; - begin - match subtree.fm.addr with - | Machine_addr _ -> - analyze_nodes ~analysis scope subtree.body - | _ -> () - end - | Sem.Link (addr, title, _) -> - Option.iter (analyze_nodes ~analysis scope) title; - Gph.add_edge analysis.link_graph addr scope - | Sem.Ref addr -> - Gph.add_edge analysis.link_graph addr scope - | Sem.Xml_tag (_, attrs, xs) -> - begin - attrs |> List.iter @@ fun (k, v) -> - analyze_nodes ~analysis scope v - end; - analyze_nodes ~analysis scope xs - | Sem.Math (_, x) -> - analyze_nodes ~analysis scope x - | Sem.Embed_tex {source; _} -> - analyze_nodes ~analysis scope source - | Sem.Query (opts, _) -> - analyze_transclusion_opts ~analysis scope opts - | Sem.If_tex (_, y) -> - analyze_nodes ~analysis scope y - | Sem.Prim (_, x) -> - analyze_nodes ~analysis scope x - | Sem.Object _ | Sem.TeX_cs _ | Sem.Img _ | Sem.Text _ | Sem.Verbatim _ -> - () - -and analyze_transclusion_opts ~analysis scope : Sem.transclusion_opts -> unit = - function Sem.{title_override; _} -> - title_override |> Option.iter @@ analyze_nodes ~analysis scope - -let analyze_doc ~analysis scope (doc : Sem.tree) = - analyze_nodes ~analysis scope doc.body; - doc.fm.title |> Option.iter @@ analyze_nodes ~analysis scope; - begin - doc.fm.designated_parent |> Option.iter @@ fun parent -> - if doc.fm.physical_parent = Some parent then () else - Gph.add_edge analysis.link_graph parent scope - end; - begin - doc.fm.authors |> List.iter @@ fun author -> - Tbl.add analysis.author_pages author scope - end; - begin - doc.fm.contributors |> List.iter @@ fun author -> - Tbl.add analysis.author_pages author scope - end; - begin - doc.fm.metas |> List.iter @@ fun (_, meta) -> - analyze_nodes ~analysis scope meta - end - -let merge_bibliography ~analysis ~from_addr ~to_addr = - Tbl.find_all analysis.bibliography from_addr |> List.iter @@ fun ref -> - Tbl.add analysis.bibliography to_addr ref - -let analyze_trees (trees : Sem.tree Map.t) : analysis = - let analysis = new_analysis () in - begin - trees |> Map.iter @@ fun addr doc -> - Gph.add_vertex analysis.transclusion_graph addr; - Gph.add_vertex analysis.link_graph addr; - - analyze_doc ~analysis addr doc; - let task ref = - match Map.find_opt ref trees with - | Some (ref_doc : Sem.tree) when ref_doc.fm.taxon = Some "reference" -> - Tbl.add analysis.bibliography addr ref - | _ -> () - in - Gph.iter_pred task analysis.link_graph addr; - end; - - begin - analysis.transclusion_graph |> Topo.iter @@ fun child_addr -> - - let handle_parent parent_addr = - Map.find_opt child_addr trees |> Option.iter @@ fun (parent_doc : Sem.tree) -> - match parent_doc.fm.taxon with - | Some "reference" -> () - | _ -> - begin - parent_doc.fm.authors - @ parent_doc.fm.contributors - @ Tbl.find_all analysis.contributors child_addr - |> List.iter @@ fun contributor -> - Tbl.add analysis.contributors parent_addr contributor - end; - merge_bibliography ~analysis ~from_addr:child_addr ~to_addr:parent_addr - in - Gph.iter_succ handle_parent analysis.transclusion_graph child_addr - end; - - analysis diff --git a/lib/frontend/Analysis.mli b/lib/frontend/Analysis.mli deleted file mode 100644 index 03c6f6b..0000000 --- a/lib/frontend/Analysis.mli @@ -1,30 +0,0 @@ -open Forester_core - -module Gph : sig - type t - val succ : t -> addr -> addr list - val pred : t -> addr -> addr list -end - -module Tbl : sig - type 'a t - val find_all : 'a t -> addr -> 'a list -end - -module Map : Map.S with type key = addr - -module Topo : sig - val fold : (addr -> 'a -> 'a) -> Gph.t -> 'a -> 'a -end - -val build_import_graph : Code.tree list -> Gph.t - -type analysis = - {transclusion_graph : Gph.t; - link_graph : Gph.t; - contributors : addr Tbl.t; - author_pages : addr Tbl.t; - bibliography : addr Tbl.t} - -(** Populating all the graphs and tables by inspecting evaluated trees *) -val analyze_trees : Sem.tree Map.t -> analysis diff --git a/lib/frontend/Config.ml b/lib/frontend/Config.ml index 3fac302..88eac95 100644 --- a/lib/frontend/Config.ml +++ b/lib/frontend/Config.ml @@ -6,7 +6,6 @@ struct {trees : string list; assets : string list; theme : string; - base_url : string option; root : string option; stylesheet : string} [@@deriving show] @@ -16,7 +15,6 @@ let default_forest_config : Forest_config.t = {trees = ["trees"]; assets = []; theme = "theme"; - base_url = None; root = None; stylesheet = "default.xsl"} @@ -48,7 +46,6 @@ let parse_forest_config_file filename = Option.value ~default:default_forest_config.stylesheet @@ get tbl (forest |-- key "stylesheet" |-- string) in - let base_url = get tbl (forest |-- key "base_url" |-- string) in let root = get tbl (forest |-- key "root" |-- string) in - Forest_config.{assets; trees; theme; base_url; root; stylesheet} + Forest_config.{assets; trees; theme; root; stylesheet} diff --git a/lib/frontend/Config.mli b/lib/frontend/Config.mli index a9e0114..057a067 100644 --- a/lib/frontend/Config.mli +++ b/lib/frontend/Config.mli @@ -3,7 +3,6 @@ module Forest_config : sig {trees : string list; assets : string list; theme : string; - base_url : string option; root : string option; stylesheet : string} end diff --git a/lib/frontend/Forest.ml b/lib/frontend/Forest.ml index 4b5fdb5..6d9e69f 100644 --- a/lib/frontend/Forest.ml +++ b/lib/frontend/Forest.ml @@ -3,129 +3,26 @@ open Forester_prelude open Forester_core open Forester_render -module A = Analysis -module M = A.Map -module Tbl = A.Tbl -module Gph = A.Gph +module M = Addr_map type config = {env : Eio_unix.Stdenv.base; assets_dirs : Eio.Fs.dir_ty Eio.Path.t list; theme_dir : Eio.Fs.dir_ty Eio.Path.t; root : string option; - base_url : string option; stylesheet : string; ignore_tex_cache : bool; no_assets: bool; - no_theme: bool; - max_fibers : int} + no_theme: bool} type raw_forest = Code.tree list type forest = - {trees : Sem.tree Analysis.Map.t; - analysis : Analysis.analysis} + {trees : Sem.tree M.t; + analysis : Eval.Analysis.t} module LaTeX_queue = LaTeX_queue.Make () -let run_renderer ~cfg (forest : forest) (body : unit -> 'a) : 'a = - let module S = Set.Make (Addr) in - let module H : Render_effect.Handler = - struct - let analysis = forest.analysis - - let is_root addr = - Option.map (fun x -> User_addr x) cfg.root = Some addr - - let route addr = - let ext = "xml" in - let base = - match is_root addr with - | true -> "index" - | false -> - match addr with - | User_addr addr -> addr - | Machine_addr ix -> Format.sprintf "unstable-%i" ix - in - Format.asprintf "%s.%s" base ext - - let get_doc addr = - M.find_opt addr forest.trees - - let enqueue_latex ~name ~preamble ~source = - LaTeX_queue.enqueue ~name ~preamble ~source - - let addr_peek_title scope = - Option.bind (M.find_opt scope forest.trees) Sem.Util.peek_title - - let get_sorted_trees addrs : Sem.tree list = - let find addr = - match M.find_opt addr forest.trees with - | None -> [] - | Some doc -> [doc] - in - Sem.Util.sort @@ List.concat_map find @@ S.elements addrs - - let is_user_addr = - function - | User_addr _ -> true - | _ -> false - - let get_all_links scope = - get_sorted_trees @@ S.filter is_user_addr @@ S.of_list @@ Gph.pred analysis.link_graph scope - - let backlinks scope = - get_sorted_trees @@ S.filter is_user_addr @@ S.of_list @@ Gph.succ analysis.link_graph scope - - let related scope = - get_all_links scope |> List.filter @@ fun (doc : Sem.tree) -> - doc.fm.taxon <> Some "reference" - - let bibliography scope = - get_sorted_trees @@ - S.of_list @@ A.Tbl.find_all analysis.bibliography scope - - let parents scope = - get_sorted_trees @@ S.of_list @@ Gph.succ analysis.transclusion_graph scope - - let contributions scope = - get_sorted_trees @@ S.of_list @@ Tbl.find_all analysis.author_pages scope - - let contributors scope = - try - let tree = M.find scope forest.trees in - let authors = S.of_list tree.fm.authors in - let contributors = S.union (S.of_list tree.fm.contributors) @@ S.of_list @@ Tbl.find_all analysis.contributors scope in - let proper_contributors = - contributors |> S.filter @@ fun contr -> - not @@ S.mem contr authors - in - let by_title = Compare.under addr_peek_title @@ Compare.option String.compare in - (* let compare = Compare.cascade by_title String.compare in *) - List.sort by_title @@ S.elements proper_contributors - with Not_found -> [] - - let run_query query = - get_sorted_trees @@ S.of_seq @@ Seq.map fst @@ M.to_seq @@ - M.filter (fun _ -> Sem.Query.test query) forest.trees - - let last_changed scope = - let (let*) = Option.bind in - let* tree = M.find_opt scope forest.trees in - let* source_path = tree.fm.source_path in - let env = cfg.env in - let path = Eio.Path.(Eio.Stdenv.fs env / source_path) in - let stat = Eio.Path.stat ~follow:true path in - let* mtime = Some stat.mtime in - let* ptime = Ptime.of_float_s mtime in - let (yyyy, mm, dd) = ptime |> Ptime.to_date_time |> fst in - Some (Date.{yyyy; mm = Some mm; dd = Some dd}) - end - in - let module Run = Render_effect.Run (H) in - Run.run body - - let plant_forest (trees : raw_forest) : forest = let add_tree addr tree trees = if M.mem addr trees then @@ -146,8 +43,8 @@ let plant_forest (trees : raw_forest) : forest = List.fold_left alg M.empty trees in - let _, trees = - let import_graph = A.build_import_graph trees in + let analysis, (_, trees) = + let import_graph = Import_graph.build_import_graph trees in let task addr (units, trees) = let tree = M.find_opt addr unexpanded_trees in match tree with @@ -160,10 +57,11 @@ let plant_forest (trees : raw_forest) : forest = in units, List.fold_left add trees @@ tree :: emitted_trees in - A.Topo.fold task import_graph (Expand.UnitMap.empty, M.empty) + Eval.run @@ fun () -> + Import_graph.Topo.fold task import_graph (Expand.UnitMap.empty, M.empty) in - {trees; analysis = A.analyze_trees trees} + {trees; analysis} let rec random_not_in keys = let attempt = Random.int (36*36*36*36 - 1) in @@ -253,14 +151,11 @@ let tags ~forest = |> Seq.filter_map (fun (addr, x) -> Addr.to_user_addr addr |> Option.map (fun s -> s, x)) -module E = Render_effect.Perform - let render_tree ~cfg ~cwd (tree : Sem.tree) = let addr = tree.fm.addr in let create = `Or_truncate 0o644 in - let base_url = cfg.base_url in begin - let path = Eio.Path.(cwd / "output" / E.route addr) in + let path = Eio.Path.(cwd / "output" / Serialise_xml_tree.route addr) in Eio.Path.with_open_out ~create path @@ fun flow -> Eio.Buf_write.with_flow flow @@ fun writer -> let fmt = Eio_util.formatter_of_writer writer in @@ -268,10 +163,10 @@ let render_tree ~cfg ~cwd (tree : Sem.tree) = Compile.compile_tree_top tree end -let render_json ~cwd docs = - let docs = Sem.Util.sort_for_index @@ List.of_seq @@ Seq.map snd @@ M.to_seq docs in +let render_json ~cfg ~cwd docs = + let root = cfg.root in Yojson.Basic.to_file "./output/forest.json" @@ - Render_json.render_trees ~dev:false docs + Render_json.render_trees ~dev:false ~root docs let is_hidden_file fname = String.starts_with ~prefix:"." fname @@ -308,16 +203,29 @@ let copy_resources ~env = if not @@ Eio_util.file_exists Eio.Path.(cwd / dest_dir / fname) then Eio_util.copy_to_dir ~cwd ~env ~source:fp ~dest_dir -let render_trees ~cfg ~forest ~render_only : unit = +let last_changed env forest scope = + let (let*) = Option.bind in + let* tree = M.find_opt scope forest.trees in + let* source_path = tree.fm.source_path in + let path = Eio.Path.(Eio.Stdenv.fs env / source_path) in + let stat = Eio.Path.stat ~follow:true path in + let* mtime = Some stat.mtime in + let* ptime = Ptime.of_float_s mtime in + let (yyyy, mm, dd) = ptime |> Ptime.to_date_time |> fst in + Some (Date.{yyyy; mm = Some mm; dd = Some dd}) + +let render_trees ~cfg ~(forest : forest) ~render_only : unit = let env = cfg.env in let cwd = Eio.Stdenv.cwd env in Eio_util.ensure_dir @@ Eio.Path.(cwd / "build"); Eio_util.ensure_dir_path cwd ["output"; "resources"]; - run_renderer ~cfg forest @@ fun () -> - Compile.run @@ fun () -> - Serialise_xml_tree.run @@ fun () -> + let enqueue_latex = LaTeX_queue.enqueue in + let compile_env = Compile.{root = cfg.root; trees = forest.trees; analysis = forest.analysis; last_changed = last_changed env forest; enqueue_latex} in + let serialise_env = Serialise_xml_tree.{root = cfg.root} in + Compile.run ~env:compile_env ~tex_env:env @@ fun () -> + Serialise_xml_tree.run ~env:serialise_env @@ fun () -> let trees = match render_only with | None -> forest.trees |> M.to_seq |> Seq.map snd |> List.of_seq @@ -331,10 +239,10 @@ let render_trees ~cfg ~forest ~render_only : unit = trees |> Sem.Util.sort |> List.iter (render_tree ~cfg ~cwd); - render_json ~cwd forest.trees; + render_json ~cfg ~cwd forest.trees; if not cfg.no_assets then copy_assets ~env ~assets_dirs:cfg.assets_dirs; if not cfg.no_theme then copy_theme ~env ~theme_dir:cfg.theme_dir; - let _ = LaTeX_queue.process ~env ~max_fibers:cfg.max_fibers ~ignore_tex_cache:cfg.ignore_tex_cache in + let _ = LaTeX_queue.process ~env ~ignore_tex_cache:cfg.ignore_tex_cache in copy_resources ~env diff --git a/lib/frontend/Forest.mli b/lib/frontend/Forest.mli index 191e49e..91a641e 100644 --- a/lib/frontend/Forest.mli +++ b/lib/frontend/Forest.mli @@ -5,18 +5,16 @@ type config = assets_dirs : Eio.Fs.dir_ty Eio.Path.t list; theme_dir : Eio.Fs.dir_ty Eio.Path.t; root : string option; - base_url : string option; stylesheet : string; ignore_tex_cache : bool; no_assets: bool; - no_theme: bool; - max_fibers : int} + no_theme: bool} type raw_forest = Code.tree list type forest = - {trees : Sem.tree Analysis.Map.t; - analysis : Analysis.analysis} + {trees : Sem.tree Addr_map.t; + analysis : Eval.Analysis.t} val plant_forest : raw_forest -> forest val render_trees : cfg:config -> forest:forest -> render_only:addr list option -> unit @@ -26,5 +24,3 @@ val complete : forest:forest -> string -> (string * string) Seq.t val taxa : forest:forest-> (string * string) Seq.t val tags : forest:forest -> (string * string list) Seq.t -val run_renderer : cfg:config -> forest -> ( unit -> 'a) -> 'a -val render_json : cwd:[> Eio__.Fs.dir_ty ] Eio.Path.t -> Forester_core.Sem.tree Analysis.Map.t -> unit diff --git a/lib/frontend/Grammar.mly b/lib/frontend/Grammar.mly index 348056d..5c8277f 100644 --- a/lib/frontend/Grammar.mly +++ b/lib/frontend/Grammar.mly @@ -19,7 +19,7 @@ %token OBJECT PATCH CALL %token TRANSCLUDE SUBTREE SCOPE PUT GET DEFAULT ALLOC REF %token LBRACE RBRACE LSQUARE RSQUARE LPAREN RPAREN HASH_LBRACE HASH_HASH_LBRACE -%token QUERY_AND QUERY_OR QUERY_NOT QUERY_AUTHOR QUERY_TAG QUERY_TAXON QUERY_META +%token QUERY_AND QUERY_OR QUERY_NOT QUERY_AUTHOR QUERY_TAG QUERY_TAXON %token QUERY_TREE %token EOF @@ -118,13 +118,12 @@ let ident_with_method_calls := let query0 := -| QUERY_AUTHOR; ~ = arg; <Query.Author> -| QUERY_TAG; ~ = arg; <Query.Tag> -| QUERY_TAXON; ~ = arg; <Query.Taxon> -| QUERY_AND; ~ = braces(queries); <Query.And> -| QUERY_OR; ~ = braces(queries); <Query.Or> -| QUERY_NOT; ~ = braces(query); <Query.Not> -| QUERY_META; k = txt_arg; v = arg; <Query.Meta> +| QUERY_AUTHOR; x = arg; { Query.Rel (`Incoming, `Authorship, x) } +| QUERY_TAG; x = arg; { Query.Rel (`Incoming, `Tags, x) } +| QUERY_TAXON; x = arg; { Query.Rel (`Incoming, `Taxa, x) } +| QUERY_AND; ~ = braces(queries); <Query.isect> +| QUERY_OR; ~ = braces(queries); <Query.Union> +| QUERY_NOT; ~ = braces(query); <Query.complement> let queries == ws_list(query0) diff --git a/lib/frontend/Import_graph.ml b/lib/frontend/Import_graph.ml new file mode 100644 index 0000000..c9d3dd1 --- /dev/null +++ b/lib/frontend/Import_graph.ml @@ -0,0 +1,37 @@ +open Forester_core + +module Gph = +struct + module G = Graph.Imperative.Digraph.Concrete (Addr) + include G + include Graph.Oper.I (G) + + let safe_succ g x = + if mem_vertex g x then succ g x else [] + + let safe_pred g x = + if mem_vertex g x then pred g x else [] +end + +module Topo = Graph.Topological.Make (Gph) + +let build_import_graph (trees : Code.tree list) = + let import_graph = Gph.create () in + + let rec analyse_tree roots (tree : Code.tree) = + let roots = Option.fold ~none:roots ~some:(fun x -> x :: roots) tree.addr in + begin + tree.addr |> Option.iter @@ fun addr -> + Gph.add_vertex import_graph @@ User_addr addr + end; + tree.code |> List.iter @@ fun node -> + match Asai.Range.(node.value) with + | Code.Import (_, dep) -> + roots |> List.iter @@ fun addr -> Gph.add_edge import_graph (User_addr dep) (User_addr addr) + | Code.Subtree (addr, code) -> + analyse_tree roots @@ Code.{tree with addr; code} + | _ -> () + in + + trees |> List.iter (analyse_tree []); + import_graph diff --git a/lib/frontend/Import_graph.mli b/lib/frontend/Import_graph.mli new file mode 100644 index 0000000..1b534e3 --- /dev/null +++ b/lib/frontend/Import_graph.mli @@ -0,0 +1,13 @@ +open Forester_core + +module Gph : sig + type t + val safe_succ : t -> addr -> addr list + val safe_pred : t -> addr -> addr list +end + +module Topo : sig + val fold : (addr -> 'a -> 'a) -> Gph.t -> 'a -> 'a +end + +val build_import_graph : Code.tree list -> Gph.t diff --git a/lib/frontend/Lexer.mll b/lib/frontend/Lexer.mll index 3963b02..9d0b62c 100644 --- a/lib/frontend/Lexer.mll +++ b/lib/frontend/Lexer.mll @@ -71,7 +71,6 @@ rule token = | "\\query/author" {Grammar.QUERY_AUTHOR } | "\\query/tag" {Grammar.QUERY_TAG } | "\\query/taxon" {Grammar.QUERY_TAXON } - | "\\query/meta" {Grammar.QUERY_META } | "\\query" { Grammar.QUERY_TREE } | "\\p" { Grammar.PRIM `P } | "\\em" { Grammar.PRIM `Em } diff --git a/lib/frontend/Build_latex.ml b/lib/render/Build_latex.ml similarity index 98% rename from lib/frontend/Build_latex.ml rename to lib/render/Build_latex.ml index 3dbf004..428a110 100644 --- a/lib/frontend/Build_latex.ml +++ b/lib/render/Build_latex.ml @@ -1,6 +1,5 @@ open Eio.Std open Forester_prelude -open Forester_render type 'a env = 'a constraint 'a = < cwd : Eio.Fs.dir_ty Eio.Path.t; @@ -9,7 +8,6 @@ type 'a env = 'a constraint 'a = < .. > as 'a - let tex_fp name = Format.sprintf "%s.tex" name diff --git a/lib/frontend/Build_latex.mli b/lib/render/Build_latex.mli similarity index 100% rename from lib/frontend/Build_latex.mli rename to lib/render/Build_latex.mli diff --git a/lib/render/Compile.ml b/lib/render/Compile.ml index 67a07c7..ddf9612 100644 --- a/lib/render/Compile.ml +++ b/lib/render/Compile.ml @@ -1,16 +1,24 @@ open Forester_prelude open Forester_core +module S = Addr_set + +type env = + {root : string option; + analysis : Eval.Analysis.t; + trees : Sem.tree Addr_map.t; + last_changed : addr -> Date.t option; + enqueue_latex : name:string -> preamble:string -> source:string -> unit} + module X = Xml_tree module F = Xml_forester -module E = Render_effect.Perform module String_map = Map.Make (String) -module Addr_map = Map.Make (Addr) module Ancestors = Algaeff.Reader.Make (struct type t = addr list end) module Current_addr = Algaeff.Reader.Make (struct type t = addr end) module Mainmatter_cache = Algaeff.State.Make (struct type t = X.content Addr_map.t end) +module Env = Algaeff.Reader.Make (struct type t = env end) module Xmlns_map = struct @@ -66,14 +74,64 @@ let rec normalise_prefix ?loc ~prefix ~xmlns kont = | _ -> kont ([], prefix) +let is_root addr = + let env = Env.read () in + Some addr = Option.map (fun x -> User_addr x) env.root + +let addr_peek_title scope = + let env = Env.read () in + Option.bind (Addr_map.find_opt scope env.trees) Sem.Util.peek_title + + +let get_tree addr = + let env = Env.read () in + Addr_map.find_opt addr env.trees + +let get_sorted_trees addrs : Sem.tree list = + let env = Env.read () in + let find addr = + match get_tree addr with + | None -> [] + | Some doc -> [doc] + in + Sem.Util.sort @@ List.concat_map find @@ S.elements addrs + +let get_trees_from_query query = + let env = Env.read () in + get_sorted_trees @@ Eval.Analysis.run_query env.analysis query + +let contributors scope = + let env = Env.read () in + let by_title = + Compare.under addr_peek_title @@ + Compare.option String.compare + in + List.sort by_title @@ S.elements @@ Eval.Analysis.run_query env.analysis @@ + let q_non_ref_under = + Query.isect [ + Query.tree_under scope; + Query.complement @@ Query.has_taxon "reference" + ] + in + let q_all_contributors = + Query.union_fam + q_non_ref_under + `Outgoing + `Contributorship + in + let q_authors = Query.rel `Outgoing `Authorship scope in + Query.isect [q_all_contributors; Query.complement q_authors] + let compile_date (date : Date.t) = - let date_addr = User_addr (Format.asprintf "%a" Date.pp date) in - let href = E.get_doc date_addr |> Option.map @@ fun _doc -> E.route date_addr in + let addr = + let addr = User_addr (Format.asprintf "%a" Date.pp date) in + get_tree addr |> Option.map @@ fun _doc -> addr + in let year = Date.year date in let month = Date.month date in let day = Date.day date in - X.Date {href; year; month; day} + X.Date {addr; year; month; day} let compile_dates = List.map compile_date @@ -100,7 +158,7 @@ let rec compile_located (located : Sem.node Range.located) = | Sem.Link (addr, title, modifier) -> begin - match E.get_doc addr with + match get_tree addr with | Some tree -> compile_internal_link ~title ~modifier ~addr ~dest:tree | None -> @@ -110,15 +168,13 @@ let rec compile_located (located : Sem.node Range.located) = | Sem.Ref addr -> begin - match E.get_doc addr with + match get_tree addr with | None -> Reporter.fatalf ?loc:located.loc Tree_not_found "could not find tree at address `%a` for reference" pp_addr addr | Some tree -> - let href = E.route addr in - let addr = Format.asprintf "%a" pp_addr addr in let taxon = tree.fm.taxon |> Option.map String_util.sentence_case in let number = tree.fm.number in - [X.Ref {addr; taxon; href; number}] + [X.Ref {addr; taxon; number}] end | Sem.Img path -> @@ -128,6 +184,7 @@ let rec compile_located (located : Sem.node Range.located) = X.splice @@ compile_nodes xs | Sem.Xml_tag (name, attrs, xs) -> + let env = Env.read () in let rec fold_attrs tag_prefix updates acc attrs = match attrs with | [] -> @@ -148,7 +205,7 @@ let rec compile_located (located : Sem.node Range.located) = normalise_prefix ?loc:located.loc ~prefix:k.prefix ~xmlns:k.xmlns @@ fun (updates', prefix) -> let xml_attr = X.{key = X.{prefix; uname = k.uname; xmlns = None}; - value = Render_text.Printer.contents @@ Render_text.render v} + value = Render_text.Printer.contents @@ Render_text.render ~trees:env.trees v} in fold_attrs tag_prefix (updates @ updates') (xml_attr :: acc) attrs in @@ -165,6 +222,7 @@ let rec compile_located (located : Sem.node Range.located) = "tried to compile object closure to XML" | Sem.Embed_tex {preamble; source} -> + let env = Env.read () in let as_tex x = Render_TeX_like.Printer.contents @@ Render_TeX_like.render ~cfg:{tex = true} x @@ -172,12 +230,12 @@ let rec compile_located (located : Sem.node Range.located) = let preamble = as_tex preamble in let source = as_tex source in let hash = Digest.to_hex @@ Digest.string @@ preamble ^ source in - E.enqueue_latex ~name:hash ~preamble ~source; + env.enqueue_latex ~name:hash ~preamble ~source; [X.Embedded_tex {hash; preamble; source}] | Sem.Transclude (opts, addr) -> begin - match E.get_doc addr with + match get_tree addr with | None -> Reporter.fatalf ?loc:located.loc Tree_not_found "could not find tree at address `%a` for transclusion" pp_addr addr | Some doc -> @@ -188,12 +246,11 @@ let rec compile_located (located : Sem.node Range.located) = compile_transclusion ~opts subtree | Sem.Query (opts, query) -> - let trees = E.run_query query in begin - match trees with + match get_trees_from_query query with | [] -> - [X.Prim (`P, X.Content [X.Info "Transclusion cycle"])] - | _ -> + [X.Prim (`P, X.Content [X.Info "Query returned no results"])] + | trees -> trees |> List.concat_map @@ fun tree -> let opts = Sem.{expanded = false; show_heading = true; title_override = None; taxon_override = None; toc = false; numbered = false; show_metadata = true} in compile_transclusion ~opts tree @@ -206,13 +263,15 @@ and compile_transclusion ~opts (tree : Sem.tree) = [X.Subtree (compile_tree ~opts tree)] and compile_title ~(opts : Sem.transclusion_opts) (fm : Sem.frontmatter) = + let env = Env.read () in + let trees = env.trees in let ancestors = Ancestors.read () in let title = match opts.title_override with | Some title -> Some title | None -> fm.title |> Option.map @@ - Render_util.expand_title_with_parents ~ancestors fm + Render_util.expand_title_with_parents ~trees ~ancestors fm in title |> Option.map @@ fun title -> compile_nodes @@ Sem.sentence_case title @@ -232,10 +291,9 @@ and compile_contributor author = and compile_attribution_inner author = let exception Untitled in try - match E.get_doc author with + match get_tree author with | None -> raise Untitled | Some biotree -> - let href = E.route biotree.fm.addr in let content = match biotree.fm.title with | None -> raise Untitled @@ -243,7 +301,7 @@ and compile_attribution_inner author = in let title = biotree.fm.title |> Option.map Sem.string_of_nodes in let addr = Option.some @@ Format.asprintf "%a" pp_addr author in - X.Content [X.Link {type_ = `Local; href; title; addr; content}] + X.Content [X.Local_link {title; addr = author; content}] with Untitled -> let name = Format.asprintf "%a" pp_addr author in X.Content [X.Text name] @@ -254,7 +312,8 @@ and compile_meta (key, body) = X.Meta {key; body} and compile_frontmatter ~opts (fm : Sem.frontmatter) = - let anchor = string_of_int @@ Oo.id (object end) in + let env = Env.read () in + let anchor = Option.some @@ string_of_int @@ Oo.id (object end) in let title = compile_title ~opts fm in let number = fm.number in let taxon = @@ -263,16 +322,16 @@ and compile_frontmatter ~opts (fm : Sem.frontmatter) = | Some taxon -> Some taxon | None -> fm.taxon in - let route = E.route fm.addr in let source_path = fm.source_path in - let addr = Format.asprintf "%a" pp_addr fm.addr in + let addr = Option.some fm.addr in let designated_parent = fm.designated_parent |> Option.map @@ fun addr -> Format.asprintf "%a" pp_addr addr in let dates = compile_dates fm.dates in - let attributions = compile_attributions ~contributors:(E.contributors fm.addr) ~authors:fm.authors in - let last_changed = E.last_changed fm.addr |> Option.map compile_date in + let contributors = contributors fm.addr in + let attributions = compile_attributions ~contributors ~authors:fm.authors in + let last_changed = env.last_changed fm.addr |> Option.map compile_date in let metas = fm.metas |> List.map compile_meta in X.{title; anchor; @@ -280,14 +339,13 @@ and compile_frontmatter ~opts (fm : Sem.frontmatter) = taxon; designated_parent; metas; - route; addr; source_path; dates; last_changed; attributions} -and compile_tree ?(backmatter = false) ~opts (tree : Sem.tree) = +and compile_tree ?(include_backmatter = false) ~opts (tree : Sem.tree) = Current_addr.run ~env:tree.fm.addr @@ fun () -> let ancestors = Ancestors.read () in let options = @@ -296,7 +354,7 @@ and compile_tree ?(backmatter = false) ~opts (tree : Sem.tree) = show_heading = opts.show_heading; show_metadata = opts.show_metadata; expanded = opts.expanded; - root = E.is_root tree.fm.addr} + root = is_root tree.fm.addr} in let frontmatter = compile_frontmatter ~opts tree.fm in let mainmatter = @@ -313,39 +371,53 @@ and compile_tree ?(backmatter = false) ~opts (tree : Sem.tree) = Mainmatter_cache.modify @@ Addr_map.add addr result; result end; - in let backmatter = - if backmatter then - Some (compile_backmatter tree.fm.addr) + if include_backmatter && not (is_root tree.fm.addr) then + compile_backmatter tree.fm.addr tree.bm else - None + [] in X.Tree {options; frontmatter; mainmatter; backmatter} -and compile_backmatter addr = +and compile_backmatter addr bm = let opts = {Sem.default_transclusion_opts with numbered = false} in let compile_trees = List.map @@ fun tree -> X.splice_tree @@ compile_tree ~opts tree in - let contributions = compile_trees @@ E.contributions addr in - let context = compile_trees @@ E.parents addr in - let related = compile_trees @@ E.related addr in - let backlinks = compile_trees @@ E.backlinks addr in - let references = compile_trees @@ E.bibliography addr in - [X.Contributions contributions; - X.Context context; - X.Related related; - X.Backlinks backlinks; - X.References references] + bm |> List.filter_map @@ function + | Sem.Backmatter_section {title; query} -> + let title = + Option.some @@ compile_nodes @@ + Sem.sentence_case title + in + match compile_trees @@ get_trees_from_query query with + | [] -> None + | trees -> + let options = + X.{toc = false; expanded = true; numbered = false; show_heading = true; show_metadata = false; root = false} + in + let frontmatter = + X.{title; anchor = None; number = None; taxon = None; designated_parent = None; metas = []; addr = None; source_path = None; dates = []; last_changed = None; attributions = []} + in + let mainmatter = + X.Content begin + trees |> List.map @@ fun tree -> + let options = X.{tree.options with expanded = false} in + let tree = X.{tree with options} in + X.Subtree (X.Tree tree) + end + in + Option.some @@ X.{options; frontmatter; mainmatter; backmatter = []} and compile_internal_link ~title ~modifier ~addr ~dest = - let href = E.route addr in + let env = Env.read () in + let trees = env.trees in let ancestors = Ancestors.read () in let dest_title = dest.fm.title |> Option.map @@ - Render_util.expand_title_with_parents ~ancestors dest.fm + Render_util.expand_title_with_parents ~trees ~ancestors dest.fm in let content = title @@ -361,12 +433,11 @@ and compile_internal_link ~title ~modifier ~addr ~dest = let title_string = String_util.sentence_case @@ Render_text.Printer.contents @@ - Render_text.render t + Render_text.render ~trees t in Some title_string in - let addr = Some (Format.asprintf "%a" pp_addr addr) in - [X.Link {type_ = `Local; href; title; content; addr}] + [X.Local_link {title; content; addr = addr}] and compile_external_link ~title ~modifier ~url = let href = url in @@ -376,7 +447,7 @@ and compile_external_link ~title ~modifier ~url = |> Option.value ~default:[Range.locate_opt None @@ Sem.Text url] |> compile_nodes in - [X.Link {type_ = `External; href; content; title = None; addr = None}]; + [X.External_link {href; content; title = None}]; and compile_nodes (xs : Sem.t) = X.Content (List.concat_map compile_located xs) @@ -388,8 +459,9 @@ let compile_tree_top tree = Ancestors.run ~env:[] @@ fun () -> let env = Xmlns_map.assoc ~prefix:F.reserved_prefix ~xmlns:F.forester_xmlns Xmlns_map.empty in Xmlns_prefixes.run ~env @@ fun () -> - compile_tree ~backmatter:true ~opts:Sem.default_transclusion_opts tree + compile_tree ~include_backmatter:true ~opts:Sem.default_transclusion_opts tree -let run kont = - Mainmatter_cache.run ~init:Addr_map.empty kont +let run ~env ~(tex_env : _ Build_latex.env) kont = + Env.run ~env @@ fun () -> + Mainmatter_cache.run ~init:Addr_map.empty @@ kont diff --git a/lib/render/Compile.mli b/lib/render/Compile.mli index ef8f7e5..e8cd645 100644 --- a/lib/render/Compile.mli +++ b/lib/render/Compile.mli @@ -1,6 +1,14 @@ +open Forester_prelude open Forester_core -val run : (unit -> 'a) -> 'a +type env = + {root : string option; + analysis : Eval.Analysis.t; + trees : Sem.tree Addr_map.t; + last_changed : addr -> Date.t option; + enqueue_latex : name:string -> preamble:string -> source:string -> unit} + +val run : env:env -> tex_env:_ Build_latex.env -> (unit -> 'a) -> 'a (** Initialises a cache for tree mainmatters in the given scope. *) val compile_tree_top : Sem.tree -> Xml_tree.tree_ diff --git a/lib/frontend/LaTeX_queue.ml b/lib/render/LaTeX_queue.ml similarity index 68% rename from lib/frontend/LaTeX_queue.ml rename to lib/render/LaTeX_queue.ml index 6a66e77..3525b96 100644 --- a/lib/frontend/LaTeX_queue.ml +++ b/lib/render/LaTeX_queue.ml @@ -1,7 +1,7 @@ module type S = sig val enqueue : name:string -> preamble:string -> source:string -> unit - val process : env:_ Build_latex.env -> max_fibers:int -> ignore_tex_cache : bool -> Eio.Fs.dir_ty Eio.Path.t list + val process : env:_ Build_latex.env -> ignore_tex_cache : bool -> Eio.Fs.dir_ty Eio.Path.t list end module Make () : S = @@ -12,12 +12,12 @@ struct if not @@ Hashtbl.mem svg_queue name then Hashtbl.add svg_queue name (preamble, source) - let process ~env ~max_fibers ~ignore_tex_cache : Eio.Fs.dir_ty Eio.Path.t list = + let process ~env ~ignore_tex_cache : Eio.Fs.dir_ty Eio.Path.t list = let build (name, (preamble, source)) = Build_latex.build_latex ~ignore_tex_cache ~env ~name ~source ~preamble in Hashtbl.to_seq svg_queue |> List.of_seq - |> Eio.Fiber.List.map ~max_fibers build + |> Eio.Fiber.List.map ~max_fibers:20 build |> List.concat end diff --git a/lib/frontend/LaTeX_queue.mli b/lib/render/LaTeX_queue.mli similarity index 50% rename from lib/frontend/LaTeX_queue.mli rename to lib/render/LaTeX_queue.mli index 2776274..3aaa864 100644 --- a/lib/frontend/LaTeX_queue.mli +++ b/lib/render/LaTeX_queue.mli @@ -1,7 +1,7 @@ module type S = sig val enqueue : name:string -> preamble:string -> source:string -> unit - val process : env:_ Build_latex.env -> max_fibers:int -> ignore_tex_cache : bool -> Eio.Fs.dir_ty Eio.Path.t list + val process : env:_ Build_latex.env -> ignore_tex_cache : bool -> Eio.Fs.dir_ty Eio.Path.t list end module Make () : S diff --git a/lib/frontend/LaTeX_template.ml b/lib/render/LaTeX_template.ml similarity index 100% rename from lib/frontend/LaTeX_template.ml rename to lib/render/LaTeX_template.ml diff --git a/lib/frontend/LaTeX_template.mli b/lib/render/LaTeX_template.mli similarity index 100% rename from lib/frontend/LaTeX_template.mli rename to lib/render/LaTeX_template.mli diff --git a/lib/render/Render_effect.ml b/lib/render/Render_effect.ml deleted file mode 100644 index 6573c59..0000000 --- a/lib/render/Render_effect.ml @@ -1,87 +0,0 @@ -open Forester_prelude -open Forester_core - -module type Handler = -sig - val route : addr -> string - val is_root : addr -> bool - val backlinks : addr -> Sem.tree list - val related : addr -> Sem.tree list - val bibliography : addr -> Sem.tree list - val parents : addr -> Sem.tree list - val contributors : addr -> addr list - val contributions : addr -> Sem.tree list - val enqueue_latex : name:string -> preamble:string -> source:string -> unit - val get_doc : addr -> Sem.tree option - val run_query : Sem.t Query.t -> Sem.tree list - val last_changed : addr -> Date.t option -end - -type _ Effect.t += - | Route : addr -> string Effect.t - | Is_root : addr -> bool Effect.t - | Backlinks : addr -> Sem.tree list Effect.t - | Related : addr -> Sem.tree list Effect.t - | Bibliography : addr -> Sem.tree list Effect.t - | Parents : addr -> Sem.tree list Effect.t - | Contributions : addr -> Sem.tree list Effect.t - | Contributors : addr -> addr list Effect.t - | Enqueue_latex : {name : string; preamble : string; source : string} -> unit Effect.t - | Get_doc : addr -> Sem.tree option Effect.t - | Run_query : Sem.t Query.t -> Sem.tree list Effect.t - | Last_changed : addr -> Date.t option Effect.t - -module Perform : Handler = -struct - let route addr = Effect.perform @@ Route addr - let is_root addr = Effect.perform @@ Is_root addr - let backlinks addr = Effect.perform @@ Backlinks addr - let related addr = Effect.perform @@ Related addr - let bibliography addr = Effect.perform @@ Bibliography addr - let contributions addr = Effect.perform @@ Contributions addr - let parents addr = Effect.perform @@ Parents addr - let contributors addr = Effect.perform @@ Contributors addr - let enqueue_latex ~name ~preamble ~source = Effect.perform @@ Enqueue_latex {name; preamble; source} - let get_doc addr = Effect.perform @@ Get_doc addr - let run_query query = Effect.perform @@ Run_query query - let last_changed addr = Effect.perform @@ Last_changed addr -end - -module Run (H : Handler) = -struct - let run f = - Effect.Deep.try_with f () @@ - {effc = - fun (type a) (eff : a Effect.t) -> - let resume x = - Option.some @@ fun (k : (a, _) Effect.Deep.continuation) -> - Algaeff.Fun.Deep.finally k @@ fun () -> x () - in - match eff with - | Route addr -> - resume @@ fun () -> H.route addr - | Is_root addr -> - resume @@ fun () -> H.is_root addr - | Backlinks addr -> - resume @@ fun () -> H.backlinks addr - | Related addr -> - resume @@ fun () -> H.related addr - | Bibliography addr -> - resume @@ fun () -> H.bibliography addr - | Parents addr -> - resume @@ fun () -> H.parents addr - | Contributors addr -> - resume @@ fun () -> H.contributors addr - | Contributions addr -> - resume @@ fun () -> H.contributions addr - | Enqueue_latex {name; preamble; source} -> - resume @@ fun () -> H.enqueue_latex ~name ~preamble ~source - | Get_doc addr -> - resume @@ fun () -> H.get_doc addr - | Run_query query -> - resume @@ fun () -> H.run_query query - | Last_changed addr -> - resume @@ fun () -> H.last_changed addr - | _ -> - None} -end diff --git a/lib/render/Render_effect.mli b/lib/render/Render_effect.mli deleted file mode 100644 index e4ddc5e..0000000 --- a/lib/render/Render_effect.mli @@ -1,25 +0,0 @@ -open Forester_prelude -open Forester_core - -module type Handler = -sig - val route : addr -> string - val is_root : addr -> bool - val backlinks : addr -> Sem.tree list - val related : addr -> Sem.tree list - val bibliography : addr -> Sem.tree list - val parents : addr -> Sem.tree list - val contributors : addr -> addr list - val contributions : addr -> Sem.tree list - val enqueue_latex : name:string -> preamble:string -> source:string -> unit - val get_doc : addr -> Sem.tree option - val run_query : Sem.t Query.t -> Sem.tree list - val last_changed : addr -> Date.t option -end - -module Perform : Handler - -module Run (_ : Handler) : -sig - val run : (unit -> 'a) -> 'a -end diff --git a/lib/render/Render_json.ml b/lib/render/Render_json.ml index a4663ab..0802491 100644 --- a/lib/render/Render_json.ml +++ b/lib/render/Render_json.ml @@ -2,20 +2,18 @@ open Forester_prelude open Forester_core open Sem -module E = Render_effect.Perform - -let render_tree ~dev (doc : Sem.tree) = +let render_tree ~root ~trees ~dev (doc : Sem.tree) = let addr = doc.fm.addr in let title = match doc.fm.title with | None -> `Null | Some title -> - let title = Render_util.expand_title_with_parents doc.fm title in + let title = Render_util.expand_title_with_parents ~trees doc.fm title in let title_string = String.trim @@ String_util.sentence_case @@ Render_text.Printer.contents @@ - Render_text.render title + Render_text.render ~trees title in `String title_string in @@ -26,13 +24,13 @@ let render_tree ~dev (doc : Sem.tree) = | Some taxon -> `String (String_util.sentence_case taxon) in let tags = `List (List.map (fun t -> `String t) doc.fm.tags) in - let route = `String (E.route addr) in + let route = `String (Serialise_xml_tree.route ~env:{root} addr) in let metas = let meta_string meta = String.trim @@ String_util.sentence_case @@ Render_text.Printer.contents @@ - Render_text.render meta + Render_text.render ~trees meta in `Assoc (List.map (fun (s, meta) -> (s, `String (meta_string meta))) @@ -60,6 +58,12 @@ let render_tree ~dev (doc : Sem.tree) = ])) | _ -> None -let render_trees ~(dev : bool) (docs : Sem.tree list) : Yojson.Basic.t = - `Assoc (List.filter_map (render_tree ~dev) docs) +let render_trees ~(dev : bool) ~root (trees : Sem.tree Addr_map.t) : Yojson.Basic.t = + `Assoc begin + Addr_map.to_seq trees + |> Seq.map snd + |> List.of_seq + |> Sem.Util.sort_for_index + |> List.filter_map (render_tree ~root ~trees ~dev) + end diff --git a/lib/render/Render_json.mli b/lib/render/Render_json.mli index 2472f2a..7b0ca80 100644 --- a/lib/render/Render_json.mli +++ b/lib/render/Render_json.mli @@ -1,4 +1,4 @@ open Forester_prelude open Forester_core -val render_trees : dev:bool -> Sem.tree list -> Yojson.Basic.t +val render_trees : dev:bool -> root:string option -> Sem.tree Addr_map.t -> Yojson.Basic.t diff --git a/lib/render/Render_text.ml b/lib/render/Render_text.ml index 8f8e988..a14b2e9 100644 --- a/lib/render/Render_text.ml +++ b/lib/render/Render_text.ml @@ -1,8 +1,6 @@ open Forester_prelude open Forester_core -module E = Render_effect.Perform - module Printer = struct module P0 = @@ -18,30 +16,30 @@ struct Format.asprintf "%a" (fun fmt _ -> printer fmt) () end -let rec render_node : Sem.node Range.located -> Printer.t = +let rec render_node ~trees : Sem.node Range.located -> Printer.t = fun node -> match node.value with | Sem.Text txt | Sem.Verbatim txt -> Printer.text txt | Sem.Math (_, xs) -> - render xs + render ~trees xs | Sem.Xml_tag (name, _, body) -> - render body + render ~trees body | Sem.Link (addr, None, modifier) -> - render @@ + render ~trees @@ Option.value ~default:[Range.locate_opt None @@ Sem.Text "Untitled"] @@ - Option.bind (E.get_doc addr) @@ fun doc -> - Option.map (Sem.apply_modifier modifier) doc.fm.title + Option.bind (Addr_map.find_opt addr trees) @@ fun (tree : Sem.tree) -> + Option.map (Sem.apply_modifier modifier) tree.fm.title | Sem.Link (addr, Some title, modifier) -> - render @@ Sem.apply_modifier modifier title + render ~trees @@ Sem.apply_modifier modifier title | Sem.If_tex (_, y) -> - render y + render ~trees y | Sem.Prim (_, x) -> - render x + render ~trees x | Sem.TeX_cs _ -> Printer.nil | _ -> Reporter.fatal ?loc:node.loc Unhandled_case "unhandled case in plain text renderer" -and render xs = - Printer.iter render_node xs +and render ~trees xs = + Printer.iter (render_node ~trees) xs diff --git a/lib/render/Render_text.mli b/lib/render/Render_text.mli index accf34e..8db99b6 100644 --- a/lib/render/Render_text.mli +++ b/lib/render/Render_text.mli @@ -8,4 +8,4 @@ sig val contents : t -> string end -val render : Sem.t -> Printer.t +val render : trees:Sem.tree Addr_map.t -> Sem.t -> Printer.t diff --git a/lib/render/Render_util.ml b/lib/render/Render_util.ml index 2dca3e5..712076c 100644 --- a/lib/render/Render_util.ml +++ b/lib/render/Render_util.ml @@ -1,16 +1,18 @@ open Forester_core -module E = Render_effect.Perform -let rec expand_title_with_parents ?(ancestors = []) (fm : Sem.frontmatter) title = +let rec expand_title_with_parents ~trees ?(ancestors = []) (fm : Sem.frontmatter) title = match fm.designated_parent with | Some parent_addr when not @@ List.mem parent_addr ancestors -> begin - match E.get_doc parent_addr with + match Addr_map.find_opt parent_addr trees with | None -> title - | Some parent -> + | Some (parent : Sem.tree) -> let chevron = [Range.locate_opt None @@ Sem.Text " › "] in - let parent_title = parent.fm.title |> Option.map @@ expand_title_with_parents parent.fm in + let parent_title = + parent.fm.title |> + Option.map @@ expand_title_with_parents ~trees parent.fm + in let parent_link = [Range.locate_opt None @@ Sem.Link (parent_addr, parent_title, Sentence_case)] diff --git a/lib/render/Serialise_xml_tree.ml b/lib/render/Serialise_xml_tree.ml index e61450a..5f2a517 100644 --- a/lib/render/Serialise_xml_tree.ml +++ b/lib/render/Serialise_xml_tree.ml @@ -5,9 +5,26 @@ module X = Xml_tree module F = Xml_forester module P = Pure_html -module String_map = Map.Make (String) - -module Mainmatter_cache = Algaeff.State.Make (struct type t = P.node String_map.t end) +module Mainmatter_cache = Algaeff.State.Make (struct type t = P.node Addr_map.t end) + +type env = {root : string option} +module Env = Algaeff.Reader.Make (struct type t = env end) + +let addr_to_string addr = + Format.asprintf "%a" pp_addr addr + +let route ?(env = Env.read ()) addr = + let is_root = Some addr = Option.map (fun x -> User_addr x) env.root in + let ext = "xml" in + let base = + match is_root with + | true -> "index" + | false -> + match addr with + | User_addr addr -> addr + | Machine_addr ix -> Format.sprintf "unstable-%i" ix + in + Format.asprintf "%s.%s" base ext let render_xml_qname = function @@ -19,7 +36,7 @@ let render_xml_attr X.{key; value} = let render_date (X.Date date) = F.date [ - date.href |> F.optional_ @@ F.href "%s" + date.addr |> F.optional_ @@ fun addr -> F.href "%s" @@ route addr ] [ F.year [] "%i" date.year; date.month |> F.optional @@ F.month [] "%i"; @@ -39,22 +56,32 @@ let rec render_tree (X.Tree tree) = render_frontmatter tree.frontmatter; begin let cache = Mainmatter_cache.get () in - let key = tree.frontmatter.route in - match String_map.find_opt key cache with - | Some cached -> cached - | None -> - let result = render_mainmatter tree.mainmatter in - Mainmatter_cache.modify (String_map.add key result); - result + match tree.frontmatter.addr with + | None -> render_mainmatter tree.mainmatter + | Some key -> + match Addr_map.find_opt key cache with + | Some cached -> cached + | None -> + let result = render_mainmatter tree.mainmatter in + Mainmatter_cache.modify (Addr_map.add key result); + result end; - tree.backmatter |> F.optional render_backmatter + render_backmatter @@ + List.map (fun x -> X.Tree x) tree.backmatter ] and render_frontmatter (fm : _ X.frontmatter) = F.frontmatter [] [ - F.anchor [] "%s" fm.anchor; - F.addr [] "%s" fm.addr; - F.route [] "%s" fm.route; + fm.anchor |> F.optional @@ F.anchor [] "%s"; + begin + match fm.addr with + | None -> F.null [] + | Some addr -> + F.null [ + F.addr [] "%s" (addr_to_string addr); + F.route [] "%s" (route addr) + ] + end; fm.title |> Option.map render_content |> F.optional @@ F.title []; fm.taxon |> F.optional @@ F.taxon [] "%s"; fm.source_path |> F.optional @@ F.source_path [] "%s"; @@ -68,25 +95,8 @@ and render_frontmatter (fm : _ X.frontmatter) = and render_mainmatter mm = F.mainmatter [] @@ render_content mm -and render_backmatter (bm : _ X.backmatter) = - F.backmatter [] @@ List.map render_backmatter_elt bm - -and render_backmatter_elt = - let render_trees trees = - trees |> List.map @@ fun tree -> - render_tree @@ X.Tree tree - in - function - | Contributions trees -> - F.contributions [] @@ render_trees trees - | Context trees -> - F.context [] @@ render_trees trees - | Related trees -> - F.related [] @@ render_trees trees - | Backlinks trees -> - F.backlinks [] @@ render_trees trees - | References trees -> - F.references [] @@ render_trees trees +and render_backmatter (bm : X.tree_ list) = + F.backmatter [] @@ List.map render_tree bm and render_meta (Meta meta) = F.meta [F.name "%s" meta.key] @@ @@ -120,21 +130,22 @@ and render_content_node = render_tree tree | X.Ref ref -> F.ref [ - F.addr_ "%s" ref.addr; - F.href "%s" ref.href; + F.addr_ "%s" (addr_to_string ref.addr); ref.taxon |> F.optional_ @@ F.taxon_ "%s"; ref.number |> F.optional_ @@ F.number_ "%s" ] - | X.Link link -> - let type_ = - match link.type_ with - | `Local -> "local" - | `External -> "external" - in + | X.Local_link link -> + F.link [ + F.type_ "local"; + F.href "%s" @@ route link.addr; + F.addr_ "%s" @@ addr_to_string link.addr; + link.title |> F.optional_ @@ F.title_ "%s" + ] @@ render_content link.content + + | X.External_link link -> F.link [ - F.type_ "%s" type_; + F.type_ "external"; F.href "%s" link.href; - link.addr |> F.optional_ @@ F.addr_ "%s"; link.title |> F.optional_ @@ F.title_ "%s" ] @@ render_content link.content | X.TeX tex -> @@ -165,5 +176,6 @@ let pp ?stylesheet fmt tree = Format.pp_print_newline fmt (); P.pp_xml fmt @@ render_tree tree -let run kont = - Mainmatter_cache.run ~init:String_map.empty kont +let run ~env kont = + Env.run ~env @@ fun () -> + Mainmatter_cache.run ~init:Addr_map.empty kont diff --git a/lib/render/Serialise_xml_tree.mli b/lib/render/Serialise_xml_tree.mli index 0487f56..4a3c273 100644 --- a/lib/render/Serialise_xml_tree.mli +++ b/lib/render/Serialise_xml_tree.mli @@ -1,7 +1,12 @@ open Forester_core -val run : (unit -> 'a) -> 'a +type env = {root : string option} + +val run : env:env -> (unit -> 'a) -> 'a (** Initialises a cache for tree mainmatters in the given scope. *) val pp : ?stylesheet:string -> Format.formatter -> Xml_tree.tree_ -> unit -(** Must be called within the scope of {!run}. *) \ No newline at end of file +(** Must be called within the scope of {!run}. *) + +val route : ?env:env -> addr -> string +(** If [env] is not provided, must be called within the scope of {!run}. *) diff --git a/lib/render/Xml_forester.ml b/lib/render/Xml_forester.ml index 2d79e95..be5e3c0 100644 --- a/lib/render/Xml_forester.ml +++ b/lib/render/Xml_forester.ml @@ -43,11 +43,9 @@ let root = bool_attr "root" let frontmatter = f_std_tag "frontmatter" let mainmatter = f_std_tag "mainmatter" let backmatter = f_std_tag "backmatter" -let contributions = f_std_tag "contributions" -let context = f_std_tag "context" -let related = f_std_tag "related" -let backlinks = f_std_tag "backlinks" -let references = f_std_tag "references" + +let query_tree = f_std_tag "query-tree" + let anchor attrs = f_text_tag "anchor" attrs let taxon attrs = f_text_tag "taxon" attrs let addr attrs = f_text_tag "addr" attrs diff --git a/lib/render/Xml_forester.mli b/lib/render/Xml_forester.mli index fdc63a9..831dd85 100644 --- a/lib/render/Xml_forester.mli +++ b/lib/render/Xml_forester.mli @@ -25,11 +25,6 @@ val info : std_tag val frontmatter : std_tag val mainmatter : std_tag val backmatter : std_tag -val contributions : std_tag -val context : std_tag -val related : std_tag -val backlinks : std_tag -val references : std_tag val anchor : _ text_tag val taxon : _ text_tag -- 2.43.4