This improved version of the previous patch simplifies the resource
management logic for compilation & rendering caches by using generative
module functors instead of effects. There is also a bit of performance
improvement, most likely due to switching these caches to imperative
hash tables.
Jon Sterling (1):
New query infrastructure; generalised backmatter computed from queries
bin/forester/main.ml | 11 +-
lib/core/Base.ml | 11 +-
lib/core/Eval.ml | 819 ++++++++++++--------
lib/core/Eval.mli | 7 +-
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 | 192 ++---
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 | 800 ++++++++++---------
lib/render/Compile.mli | 18 +-
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 | 329 ++++----
lib/render/Serialise_xml_tree.mli | 11 +-
lib/render/Xml_forester.ml | 8 +-
lib/render/Xml_forester.mli | 5 -
38 files changed, 1413 insertions(+), 1440 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
--
2.43.4
Copy & paste the following snippet into your terminal to import this patchset into git:
curl -s https://lists.sr.ht/~jonsterling/forester-devel/patches/53405/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>
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. Resource management (caches, etc.) is
simplified across the board using generative module functors.
+ 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.
Simplify resource management using generative functors
---
bin/forester/main.ml | 11 +-
lib/core/Base.ml | 11 +-
lib/core/Eval.ml | 819 ++++++++++++--------
lib/core/Eval.mli | 7 +-
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 | 192 ++---
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 | 800 ++++++++++---------
lib/render/Compile.mli | 18 +-
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 | 329 ++++----
lib/render/Serialise_xml_tree.mli | 11 +-
lib/render/Xml_forester.ml | 8 +-
lib/render/Xml_forester.mli | 5 -
38 files changed, 1413 insertions(+), 1440 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..cb81f53 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,10 @@ struct
| _ -> None
end
+module Addr_map = Map.Make (Addr)
+module Addr_set = Set.Make (Addr)
+module String_map = Map.Make (String)
+
type delim = Braces | Squares | Parens
[@@deriving show]
diff --git a/lib/core/Eval.ml b/lib/core/Eval.ml
index 7f197f7..efd9902 100644
--- a/lib/core/Eval.ml
+++ b/lib/core/Eval.ml
@@ -1,338 +1,511 @@
-open Base
-open Bwd
open Forester_prelude
+open Base
-module Lex_env = Algaeff.Reader.Make (struct type t = Sem.t Env.t end)
-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)
-
-let get_transclusion_opts () =
- let dynenv = Dyn_env.read () in
- let title_override = Env.find_opt Expand.Builtins.Transclude.title_sym dynenv in
- let taxon_override =
- match Env.find_opt Expand.Builtins.Transclude.taxon_sym dynenv with
- | Some [{value = Sem.Text text; _}] -> Some text
- | _ -> None
- in
- let get_bool key default =
- match Env.find_opt key dynenv with
- | Some [{value = Sem.Text "true"; _}] -> true
- | Some [{value = Sem.Text "false"; _}] -> false
- | _ -> default
- in
- let expanded = get_bool Expand.Builtins.Transclude.expanded_sym true in
- let show_heading = get_bool Expand.Builtins.Transclude.show_heading_sym true in
- let toc = get_bool Expand.Builtins.Transclude.toc_sym true in
- let numbered = get_bool Expand.Builtins.Transclude.numbered_sym true in
- let show_metadata = get_bool Expand.Builtins.Transclude.show_metadata_sym false in
- Sem.{title_override; taxon_override; toc; show_heading; expanded; numbered; show_metadata}
-
-let rec eval : Syn.t -> Sem.t =
- function
- | [] -> []
- | node :: rest ->
- eval_node node rest
-
-and eval_node : Syn.node Range.located -> Syn.t -> Sem.t =
- fun node rest ->
- match node.value with
- | Link {title; dest} ->
- let title = Option.map eval title in
- {node with value = Sem.Link (eval_addr dest, title, Identity)} :: eval rest
-
- | Ref dest ->
- let addr = eval_addr dest in
- {node with value = Sem.Ref addr} :: eval rest
-
- | Math (mmode, e) ->
- {node with value = Sem.Math (mmode, eval e)} :: eval rest
-
- | Prim (p, body) ->
- {node with value = Sem.Prim (p, eval_trim body)} :: eval rest
-
- | Xml_tag (name, attrs, body) ->
- let rec process attrs = match attrs with
- | [] -> []
- | (k,v) :: attrs ->
- let processed = process attrs in
- if List.mem_assoc k processed then begin
- Reporter.emitf ?loc:node.loc Duplicate_attribute
- "skipping duplicate XML attribute `%a`" pp_xml_resolved_qname k;
- processed
- end else
- (k, eval v) :: processed
- in
- {node with value = Sem.Xml_tag (name, process attrs, eval body)} :: eval rest
+module Q = Query
- | TeX_cs cs ->
- {node with value = Sem.TeX_cs cs} :: eval rest
+module G =
+struct
+ module G = Graph.Imperative.Digraph.Concrete (Addr)
+ include G
+ include Graph.Oper.I (G)
- | Transclude addr ->
- let opts = get_transclusion_opts () in
- let addr = eval_addr addr in
- {node with value = Sem.Transclude (opts, addr)} :: eval rest
+ let safe_succ g x =
+ if mem_vertex g x then succ g x else []
- | Subtree (addr, nodes) ->
- let addr =
- match addr with
- | Some addr -> User_addr addr
- | None -> Machine_addr (Oo.id (object end))
- in
- let opts = get_transclusion_opts () in
- let subtree = eval_tree_inner ~addr nodes in
- let fm = Fm.get () in
- let subtree = {subtree with fm = {subtree.fm with physical_parent = Some fm.addr; designated_parent = Some fm.addr}} in
- begin
- Emitted_trees.modify @@ fun trees ->
- subtree :: trees
- end;
- {node with value = Sem.Subtree (opts, subtree)} :: eval rest
-
- | If_tex (x , y) ->
- let x = eval x in
- let y = eval y in
- {node with value = Sem.If_tex (x, y)} :: eval rest
-
- | Query query ->
- let opts = get_transclusion_opts () in
- let opts =
- match opts.title_override with
- | None -> {opts with show_heading = false; toc = false}
- | Some _ -> opts
+ 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 Make () =
+struct
+
+ module Graphs =
+ struct
+ let all_addrs_ref : Addr_set.t ref =
+ ref Addr_set.empty
+
+ let rel_to_graph : (Query.rel_name, G.t) Hashtbl.t =
+ Hashtbl.create 20
+
+ let rel_to_rtgraph : (Query.rel_name, G.t) Hashtbl.t =
+ Hashtbl.create 20
+
+ let get_graph rel =
+ match Hashtbl.find_opt rel_to_graph rel with
+ | None ->
+ let gph = G.create () in
+ Hashtbl.add rel_to_graph rel gph;
+ gph
+ | Some gph -> gph
+
+ let get_rtgraph rel =
+ match Hashtbl.find_opt rel_to_rtgraph rel with
+ | None ->
+ let gph = G.transitive_closure ~reflexive:true @@ get_graph rel in
+ Hashtbl.add rel_to_rtgraph rel gph;
+ gph
+ | Some gph -> gph
+
+ let register_addr addr =
+ Hashtbl.clear rel_to_rtgraph;
+ all_addrs_ref := Addr_set.add addr !all_addrs_ref
+
+ let add_edge rel ~source ~target =
+ Hashtbl.remove rel_to_rtgraph rel;
+ let gph = get_graph rel in
+ G.add_edge gph source target
+ end
+
+ module Query_engine =
+ struct
+ let query_rel pol rel addr =
+ let fn =
+ match pol with
+ | `Incoming -> G.safe_pred
+ | `Outgoing -> G.safe_succ
+ in
+ let gph = Graphs.get_graph rel in
+ Addr_set.of_list @@ fn gph addr
+
+ let check_rel pol rel addr addr' =
+ let gph = Graphs.get_graph rel in
+ match pol with
+ | `Incoming -> G.mem_edge gph addr' addr
+ | `Outgoing -> G.mem_edge gph addr addr'
+
+ let rec check_query q addr =
+ match q with
+ | Q.Tree_under root ->
+ G.mem_edge (Graphs.get_rtgraph `Transclusion) root addr
+ | Q.Rel (pol, rel, addr') ->
+ check_rel pol rel addr' addr
+ | Q.Isect qs -> check_isect qs addr
+ | Q.Union qs -> check_union qs addr
+ | Q.Complement q ->
+ not @@ check_query q addr
+ | Q.Isect_fam (q, (pol, rel)) ->
+ let xs = Addr_set.to_list @@ run_query q in
+ xs |> List.for_all @@ fun x ->
+ check_rel pol rel x addr
+ | Q.Union_fam (q, (pol, rel)) ->
+ let xs = Addr_set.to_list @@ run_query q in
+ xs |> List.exists @@ fun x ->
+ check_rel pol rel x addr
+
+ and check_isect qs addr =
+ qs |> List.for_all @@ fun q ->
+ check_query q addr
+
+ and check_union qs addr =
+ qs |> List.exists @@ fun q ->
+ check_query q addr
+
+
+ and run_query =
+ function
+ | Q.Tree_under addr ->
+ G.safe_fold_succ
+ Addr_set.add
+ (Graphs.get_rtgraph `Transclusion)
+ addr
+ Addr_set.empty
+ | Q.Rel (pol, rel, addr) ->
+ query_rel pol rel addr
+ | Q.Isect qs -> run_isect qs
+ | Q.Union qs -> run_union qs
+ | Q.Complement q ->
+ Addr_set.diff !Graphs.all_addrs_ref @@ run_query q
+ | Q.Isect_fam (q, (pol, rel)) ->
+ let xs = Addr_set.to_list @@ run_query q in
+ run_isect @@ List.map (fun x -> Q.Rel (pol, rel, x)) xs
+ | Q.Union_fam (q, (pol, rel)) ->
+ let xs = Addr_set.to_list @@ run_query q in
+ run_union @@ List.map (fun x -> Q.Rel (pol, rel, x)) xs
+
+ and run_isect =
+ function
+ | [] -> !Graphs.all_addrs_ref
+ | q :: qs ->
+ run_query q |> Addr_set.filter @@ check_isect qs
+
+ and run_union qs =
+ let alg q = Addr_set.union (run_query q) in
+ List.fold_right alg qs Addr_set.empty
+
+ and fold_set_operation opr running =
+ function
+ | [] -> running
+ | q :: qs ->
+ let s = run_query q in
+ fold_set_operation opr (opr running s) qs
+ end
+
+ module Lex_env = Algaeff.Reader.Make (struct type t = Sem.t Env.t end)
+ 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)
+
+ let get_transclusion_opts () =
+ let dynenv = Dyn_env.read () in
+ let title_override = Env.find_opt Expand.Builtins.Transclude.title_sym dynenv in
+ let taxon_override =
+ match Env.find_opt Expand.Builtins.Transclude.taxon_sym dynenv with
+ | Some [{value = Sem.Text text; _}] -> Some text
+ | _ -> None
in
- let query = Query.map eval query in
- {node with value = Sem.Query (opts, query)} :: eval rest
-
- | Embed_tex {preamble; source} ->
- {node with value = Sem.Embed_tex {preamble = eval preamble; source = eval source}} :: eval rest
-
- | Lam (xs, body) ->
- let rec loop xs rest =
- match xs, rest with
- | [], rest -> eval body, rest
- | x :: xs, Range.{value = Syn.Group (Braces, u); loc = loc'} :: rest ->
- Lex_env.scope (Env.add x (eval u)) @@ fun () ->
- loop xs rest
- | x :: xs, Range.{value = Syn.Verbatim str; loc = loc'} :: rest ->
- let verb = [Range.{value = Sem.Verbatim str; loc = loc'}] in
- Lex_env.scope (Env.add x verb) @@ fun () ->
- loop xs rest
- | _ ->
- Reporter.fatalf Type_error ?loc:node.loc
- "expected function to be applied to `%i` additional arguments"
- (List.length xs)
+ let get_bool key default =
+ match Env.find_opt key dynenv with
+ | Some [{value = Sem.Text "true"; _}] -> true
+ | Some [{value = Sem.Text "false"; _}] -> false
+ | _ -> default
in
- let body, rest = loop xs rest in
- body @ eval rest
-
- | Object {self; methods} ->
- let table =
- let env = Lex_env.read () in
- let add (name, body) =
- let super = Symbol.fresh [] in
- Sem.MethodTable.add name Sem.{body; self; super; env}
+ let expanded = get_bool Expand.Builtins.Transclude.expanded_sym true in
+ let show_heading = get_bool Expand.Builtins.Transclude.show_heading_sym true in
+ let toc = get_bool Expand.Builtins.Transclude.toc_sym true in
+ let numbered = get_bool Expand.Builtins.Transclude.numbered_sym true in
+ let show_metadata = get_bool Expand.Builtins.Transclude.show_metadata_sym false in
+ Sem.{title_override; taxon_override; toc; show_heading; expanded; numbered; show_metadata}
+
+ let rec eval : Syn.t -> Sem.t =
+ function
+ | [] -> []
+ | node :: rest ->
+ eval_node node rest
+
+ 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
+ Graphs.add_edge `Links ~source:scope ~target:dest;
+ let title = Option.map eval title in
+ {node with value = Sem.Link (dest, title, Identity)} :: eval rest
+
+ | Ref dest ->
+ let scope = Scope.get () in
+ let dest = eval_addr dest in
+ Graphs.add_edge `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
+
+ | Prim (p, body) ->
+ {node with value = Sem.Prim (p, eval_trim body)} :: eval rest
+
+ | Xml_tag (name, attrs, body) ->
+ let rec process attrs = match attrs with
+ | [] -> []
+ | (k,v) :: attrs ->
+ let processed = process attrs in
+ if List.mem_assoc k processed then begin
+ Reporter.emitf ?loc:node.loc Duplicate_attribute
+ "skipping duplicate XML attribute `%a`" pp_xml_resolved_qname k;
+ processed
+ end else
+ (k, eval v) :: processed
in
- List.fold_right add methods Sem.MethodTable.empty
- in
- let sym = Symbol.fresh ["obj"] in
- Heap.modify @@ Env.add sym Sem.{prototype = None; methods = table};
- {node with value = Sem.Object sym} :: eval rest
-
- | Patch {obj; self; super; methods} ->
- begin
- match eval_strip obj with
- | [Range.{value = Sem.Object obj_ptr; _}] ->
- let table =
- let env = Lex_env.read () in
- let add (name, body) =
- Sem.MethodTable.add name
- Sem.{body; self; super; env}
- in
- List.fold_right add methods Sem.MethodTable.empty
+ {node with value = Sem.Xml_tag (name, process attrs, eval body)} :: eval rest
+
+ | TeX_cs cs ->
+ {node with value = Sem.TeX_cs cs} :: eval rest
+
+ | Transclude addr ->
+ let addr = eval_addr addr in
+ let scope = Scope.get () in
+ Graphs.add_edge `Transclusion ~source:scope ~target:addr;
+ let opts = get_transclusion_opts () in
+ {node with value = Sem.Transclude (opts, addr)} :: eval rest
+
+ | Subtree (addr, nodes) ->
+ let addr =
+ match addr with
+ | Some addr -> User_addr addr
+ | None -> Machine_addr (Oo.id (object end))
+ in
+ let scope = Scope.get () in
+ Graphs.add_edge `Transclusion ~source:scope ~target:addr;
+ let opts = get_transclusion_opts () in
+ let subtree = eval_tree_inner ~addr nodes in
+ let fm = Fm.get () in
+ let subtree = {subtree with fm = {subtree.fm with physical_parent = Some fm.addr; designated_parent = Some fm.addr}} in
+ begin
+ Emitted_trees.modify @@ fun trees ->
+ subtree :: trees
+ end;
+ {node with value = Sem.Subtree (opts, subtree)} :: eval rest
+
+ | If_tex (x , y) ->
+ let x = eval x in
+ let y = eval y in
+ {node with value = Sem.If_tex (x, y)} :: eval rest
+
+ | Query query ->
+ let opts = get_transclusion_opts () in
+ let opts =
+ match opts.title_override with
+ | None -> {opts with show_heading = false; toc = false}
+ | Some _ -> opts
+ in
+ let query = Query.map eval_addr query in
+ {node with value = Sem.Query (opts, query)} :: eval rest
+
+ | Embed_tex {preamble; source} ->
+ {node with value = Sem.Embed_tex {preamble = eval preamble; source = eval source}} :: eval rest
+
+ | Lam (xs, body) ->
+ let rec loop xs rest =
+ match xs, rest with
+ | [], rest -> eval body, rest
+ | x :: xs, Range.{value = Syn.Group (Braces, u); loc = loc'} :: rest ->
+ Lex_env.scope (Env.add x (eval u)) @@ fun () ->
+ loop xs rest
+ | x :: xs, Range.{value = Syn.Verbatim str; loc = loc'} :: rest ->
+ let verb = [Range.{value = Sem.Verbatim str; loc = loc'}] in
+ Lex_env.scope (Env.add x verb) @@ fun () ->
+ loop xs rest
+ | _ ->
+ Reporter.fatalf Type_error ?loc:node.loc
+ "expected function to be applied to `%i` additional arguments"
+ (List.length xs)
+ in
+ let body, rest = loop xs rest in
+ body @ eval rest
+
+ | Object {self; methods} ->
+ let table =
+ let env = Lex_env.read () in
+ let add (name, body) =
+ let super = Symbol.fresh [] in
+ Sem.MethodTable.add name Sem.{body; self; super; env}
in
- let sym = Symbol.fresh ["obj"] in
- Heap.modify @@ Env.add sym Sem.{prototype = Some obj_ptr; methods = table};
- {node with value = Sem.Object sym} :: eval rest
- | xs ->
- Reporter.fatalf ?loc:node.loc Type_error
- "tried to patch non-object"
- end
-
- | Call (obj, method_name) ->
- begin
- match eval_strip obj with
- | [Range.{value = Sem.Object sym; _}] as obj_val ->
- let rec call_method (obj : Sem.obj) =
- let proto_val =
- obj.prototype |> Option.map @@ fun ptr ->
- [Range.locate_opt None @@ Sem.Object ptr]
+ List.fold_right add methods Sem.MethodTable.empty
+ in
+ let sym = Symbol.fresh ["obj"] in
+ Heap.modify @@ Env.add sym Sem.{prototype = None; methods = table};
+ {node with value = Sem.Object sym} :: eval rest
+
+ | Patch {obj; self; super; methods} ->
+ begin
+ match eval_strip obj with
+ | [Range.{value = Sem.Object obj_ptr; _}] ->
+ let table =
+ let env = Lex_env.read () in
+ let add (name, body) =
+ Sem.MethodTable.add name
+ Sem.{body; self; super; env}
+ in
+ List.fold_right add methods Sem.MethodTable.empty
in
- match Sem.MethodTable.find_opt method_name obj.methods with
- | Some mthd ->
- let env =
- let env = Env.add mthd.self obj_val mthd.env in
- match proto_val with
- | None -> env
- | Some proto_val ->
- Env.add mthd.super proto_val env
+ let sym = Symbol.fresh ["obj"] in
+ Heap.modify @@ Env.add sym Sem.{prototype = Some obj_ptr; methods = table};
+ {node with value = Sem.Object sym} :: eval rest
+ | xs ->
+ Reporter.fatalf ?loc:node.loc Type_error
+ "tried to patch non-object"
+ end
+
+ | Call (obj, method_name) ->
+ begin
+ match eval_strip obj with
+ | [Range.{value = Sem.Object sym; _}] as obj_val ->
+ let rec call_method (obj : Sem.obj) =
+ let proto_val =
+ obj.prototype |> Option.map @@ fun ptr ->
+ [Range.locate_opt None @@ Sem.Object ptr]
in
- Lex_env.scope (fun _ -> env) @@ fun () ->
- eval mthd.body
- | None ->
- match obj.prototype with
- | Some proto ->
- call_method @@ Env.find proto @@ Heap.get ()
+ match Sem.MethodTable.find_opt method_name obj.methods with
+ | Some mthd ->
+ let env =
+ let env = Env.add mthd.self obj_val mthd.env in
+ match proto_val with
+ | None -> env
+ | Some proto_val ->
+ Env.add mthd.super proto_val env
+ in
+ Lex_env.scope (fun _ -> env) @@ fun () ->
+ eval mthd.body
| None ->
- Reporter.fatalf ?loc:node.loc Type_error
- "tried to call unbound method `%s`" method_name
- in
- let result = call_method @@ Env.find sym @@ Heap.get () in
- result @ eval rest
- | xs ->
- Reporter.fatalf ?loc:node.loc Type_error
- "tried to call method `%s` on non-object: %a" method_name Sem.pp xs
- end
-
- | Var x ->
- begin
- match Env.find_opt x @@ Lex_env.read () with
- | None ->
- Reporter.fatalf ?loc:node.loc Resolution_error
- "could not find variable named %a"
- Symbol.pp x
- | Some v -> v @ eval rest
- end
-
- | Put (k, v, body) ->
- let body =
- Dyn_env.scope (Env.add k @@ eval v) @@ fun () ->
- eval body
- in
- body @ eval rest
+ match obj.prototype with
+ | Some proto ->
+ call_method @@ Env.find proto @@ Heap.get ()
+ | None ->
+ Reporter.fatalf ?loc:node.loc Type_error
+ "tried to call unbound method `%s`" method_name
+ in
+ let result = call_method @@ Env.find sym @@ Heap.get () in
+ result @ eval rest
+ | xs ->
+ Reporter.fatalf ?loc:node.loc Type_error
+ "tried to call method `%s` on non-object: %a" method_name Sem.pp xs
+ end
+
+ | Var x ->
+ begin
+ match Env.find_opt x @@ Lex_env.read () with
+ | None ->
+ Reporter.fatalf ?loc:node.loc Resolution_error
+ "could not find variable named %a"
+ Symbol.pp x
+ | Some v -> v @ eval rest
+ end
+
+ | Put (k, v, body) ->
+ let body =
+ Dyn_env.scope (Env.add k @@ eval v) @@ fun () ->
+ eval body
+ in
+ body @ eval rest
- | Default (k, v, body) ->
- let body =
- let upd flenv = if Env.mem k flenv then flenv else Env.add k (eval v) flenv in
- Dyn_env.scope upd @@ fun () ->
- eval body
+ | Default (k, v, body) ->
+ let body =
+ let upd flenv = if Env.mem k flenv then flenv else Env.add k (eval v) flenv in
+ Dyn_env.scope upd @@ fun () ->
+ eval body
+ in
+ body @ eval rest
+
+ | Get key ->
+ begin
+ let env = Dyn_env.read () in
+ 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
+ "could not find fluid binding named %a"
+ Symbol.pp key
+ | Some v -> v @ eval rest
+ end
+
+ | Verbatim str ->
+ {node with value = Sem.Verbatim str} :: eval rest
+
+ | Group _ | Text _ ->
+ eval_textual @@ node :: rest
+
+ | Title title ->
+ let title = eval title in
+ Fm.modify (fun fm -> {fm with title = Some title});
+ eval rest
+
+ | Parent addr ->
+ Fm.modify (fun fm -> {fm with designated_parent = Some (User_addr addr)});
+ eval rest
+
+ | Meta (k, v) ->
+ let v = eval v in
+ Fm.modify (fun fm -> {fm with metas = fm.metas @ [k,v]});
+ eval rest
+
+ | Author author ->
+ let scope = Scope.get () in
+ let addr = User_addr author in
+ Graphs.add_edge `Authorship ~source:scope ~target:addr;
+ Fm.modify (fun fm -> {fm with authors = fm.authors @ [addr]});
+ eval rest
+
+ | Contributor author ->
+ let scope = Scope.get () in
+ let addr = User_addr author in
+ Graphs.add_edge `Contributorship ~source:scope ~target:addr;
+ Fm.modify (fun fm -> {fm with contributors = fm.contributors @ [addr]});
+ eval rest
+
+ | Tag tag ->
+ let scope = Scope.get () in
+ Graphs.add_edge `Tags ~source:scope ~target:(User_addr tag);
+ Fm.modify (fun fm -> {fm with tags = fm.tags @ [tag]});
+ eval rest
+
+ | Date date ->
+ begin
+ match Date.parse date with
+ | None ->
+ Reporter.fatalf Parse_error "Invalid date string `%s`" date
+ | Some date ->
+ Fm.modify (fun fm -> {fm with dates = fm.dates @ [date]});
+ eval rest
+ end
+
+ | Number num ->
+ Fm.modify (fun fm -> {fm with number = Some num});
+ eval rest
+
+ | Taxon taxon ->
+ let scope = Scope.get () in
+ Graphs.add_edge `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
+
+ and eval_trim xs = Sem.trim_whitespace @@ eval xs
+
+ and eval_textual ?(prefix = []) : Syn.t -> Sem.t =
+ function
+ | {value = Group (d, xs); _} :: rest ->
+ let l, r =
+ match d with
+ | Braces -> "{", "}"
+ | Squares -> "[", "]"
+ | Parens -> "(", ")"
+ in
+ eval_textual ~prefix:(l :: prefix) @@ xs @ Asai.Range.locate_opt None (Syn.Text r) :: rest
+ | {value = Text x; _} :: rest ->
+ eval_textual ~prefix:(x :: prefix) @@ rest
+ | rest ->
+ let txt = String.concat "" @@ List.rev prefix in
+ Range.locate_opt None (Sem.Text txt) :: eval rest
+
+ and eval_as_string xs =
+ Sem.string_of_nodes @@ eval_textual xs
+
+ and eval_addr xs =
+ User_addr (eval_as_string xs)
+
+ and eval_tree_inner ~addr (tree : Syn.tree) : Sem.tree =
+ Graphs.register_addr addr;
+ let scope =
+ match addr with
+ | User_addr _ -> addr
+ | _ -> Scope.get ()
in
- body @ eval rest
-
- | Get key ->
- begin
- let env = Dyn_env.read () in
- match Env.find_opt key @@ Dyn_env.read () with
- | None ->
- Eio.traceln "getting %a from %a" Symbol.pp key (Env.pp Sem.pp) env;
- Reporter.fatalf ?loc:node.loc Resolution_error
- "could not find fluid binding named %a"
- Symbol.pp key
- | Some v -> v @ eval rest
- end
-
- | Verbatim str ->
- {node with value = Sem.Verbatim str} :: eval rest
-
- | Group _ | Text _ ->
- eval_textual @@ node :: rest
-
- | Title title ->
- let title = eval title in
- Fm.modify (fun fm -> {fm with title = Some title});
- eval rest
-
- | Parent addr ->
- Fm.modify (fun fm -> {fm with designated_parent = Some (User_addr addr)});
- eval rest
-
- | Meta (k, v) ->
- let v = eval v in
- Fm.modify (fun fm -> {fm with metas = fm.metas @ [k,v]});
- eval rest
-
- | Author author ->
- Fm.modify (fun fm -> {fm with authors = fm.authors @ [User_addr author]});
- eval rest
-
- | Contributor author ->
- Fm.modify (fun fm -> {fm with contributors = fm.contributors @ [User_addr author]});
- eval rest
-
- | Tag tag ->
- Fm.modify (fun fm -> {fm with tags = fm.tags @ [tag]});
- eval rest
-
- | Date date ->
- begin
- match Date.parse date with
- | None ->
- Reporter.fatalf Parse_error "Invalid date string `%s`" date
- | Some date ->
- Fm.modify (fun fm -> {fm with dates = fm.dates @ [date]});
- eval rest
- end
-
- | Number num ->
- Fm.modify (fun fm -> {fm with number = Some num});
- eval rest
-
- | Taxon taxon ->
- begin
- Fm.modify @@ fun fm ->
- {fm with taxon = Some taxon}
- end;
- eval rest
-
-and eval_strip xs = Sem.strip_whitespace @@ eval xs
-
-and eval_trim xs = Sem.trim_whitespace @@ eval xs
-
-and eval_textual ?(prefix = []) : Syn.t -> Sem.t =
- function
- | {value = Group (d, xs); _} :: rest ->
- let l, r =
- match d with
- | Braces -> "{", "}"
- | Squares -> "[", "]"
- | Parens -> "(", ")"
+ Scope.run ~init:scope @@ fun () ->
+ let outer_fm = Fm.get () in
+ let fm =
+ {(Sem.empty_frontmatter ~addr) with
+ source_path = outer_fm.source_path;
+ authors = outer_fm.authors;
+ dates = outer_fm.dates}
in
- eval_textual ~prefix:(l :: prefix) @@ xs @ Asai.Range.locate_opt None (Syn.Text r) :: rest
- | {value = Text x; _} :: rest ->
- eval_textual ~prefix:(x :: prefix) @@ rest
- | rest ->
- let txt = String.concat "" @@ List.rev prefix in
- Range.locate_opt None (Sem.Text txt) :: eval rest
-
-and eval_as_string xs =
- Sem.string_of_nodes @@ eval_textual xs
-
-and eval_addr xs =
- User_addr (eval_as_string xs)
-
-and eval_tree_inner ~addr (tree : Syn.tree) : Sem.tree =
- let outer_fm = Fm.get () in
- let fm =
- {(Sem.empty_frontmatter ~addr) with
- source_path = outer_fm.source_path;
- authors = outer_fm.authors;
- dates = outer_fm.dates}
- in
- Fm.run ~init:fm @@ fun () ->
- let body = eval tree in
- let fm = Fm.get () in
- let open Sem in
- {fm; body}
-
-
-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 () ->
- Emitted_trees.run ~init:[] @@ fun () ->
- Heap.run ~init:Env.empty @@ fun () ->
- Lex_env.run ~env:Env.empty @@ fun () ->
- Dyn_env.run ~env:Env.empty @@ fun () ->
- let tree = eval_tree_inner ~addr tree in
- let emitted = Emitted_trees.get () in
- tree, emitted
+ 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; 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 () ->
+ Dyn_env.run ~env:Env.empty @@ fun () ->
+ let tree = eval_tree_inner ~addr tree in
+ let emitted = Emitted_trees.get () in
+ tree, emitted
+
+ let run_query = Query_engine.run_query
+end
diff --git a/lib/core/Eval.mli b/lib/core/Eval.mli
index 34a483f..5b455b8 100644
--- a/lib/core/Eval.mli
+++ b/lib/core/Eval.mli
@@ -1,3 +1,8 @@
+open Forester_prelude
open Base
-val eval_tree : addr:addr -> source_path:string option -> Syn.tree -> Sem.tree * Sem.tree list
+module Make () :
+sig
+ val eval_tree : addr:addr -> source_path:string option -> Syn.tree -> Sem.tree * Sem.tree list
+ val run_query : addr Query.t -> Addr_set.t
+end
\ No newline at end of file
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..5ea863c 100644
--- a/lib/frontend/Forest.ml
+++ b/lib/frontend/Forest.ml
@@ -3,130 +3,28 @@ 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;
+ run_query : addr Query.t -> Addr_set.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 module Ev = Eval.Make () in
let add_tree addr tree trees =
if M.mem addr trees then
begin
@@ -146,24 +44,24 @@ 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 (_, 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
| None -> units, trees
| Some tree ->
let units, syn = Expand.expand_tree units tree in
- let tree, emitted_trees = Eval.eval_tree ~addr ~source_path:tree.source_path syn in
- let add trees tree =
- add_tree Sem.(tree.fm.addr) tree trees
+ let tree, emitted_trees = Ev.eval_tree ~addr ~source_path:tree.source_path syn in
+ let add trees (tree : Sem.tree) =
+ add_tree tree.fm.addr tree trees
in
units, List.fold_left add trees @@ tree :: emitted_trees
in
- A.Topo.fold task import_graph (Expand.UnitMap.empty, M.empty)
+ Import_graph.Topo.fold task import_graph (Expand.UnitMap.empty, M.empty)
in
- {trees; analysis = A.analyze_trees trees}
+ {trees; run_query = Ev.run_query}
let rec random_not_in keys =
let attempt = Random.int (36*36*36*36 - 1) in
@@ -253,25 +151,10 @@ 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
- 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
- Serialise_xml_tree.pp ~stylesheet:cfg.stylesheet fmt @@
- 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 +191,46 @@ 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 module I =
+ struct
+ let root, trees, run_query, last_changed, enqueue_latex =
+ cfg.root, forest.trees, forest.run_query, last_changed env forest, LaTeX_queue.enqueue
+ end
+
+ in
+
+ let module C = Compile.Make (I) () in
+ let module Sxml = Serialise_xml_tree.Make (I) () in
+
+ let render_tree (tree : Sem.tree) =
+ let addr = tree.fm.addr in
+ let create = `Or_truncate 0o644 in
+ let path = Eio.Path.(cwd / "output" / Serialise_xml_tree.route ~root:cfg.root 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
+ Sxml.pp ~stylesheet:cfg.stylesheet fmt @@
+ C.compile_tree tree
+ in
+
let trees =
match render_only with
| None -> forest.trees |> M.to_seq |> Seq.map snd |> List.of_seq
@@ -328,13 +241,14 @@ let render_trees ~cfg ~forest ~render_only : unit =
| None ->
Reporter.fatalf Tree_not_found "Could not find tree with address `%a` when rendering forest" pp_addr addr
in
+
trees
|> Sem.Util.sort
- |> List.iter (render_tree ~cfg ~cwd);
- render_json ~cwd forest.trees;
+ |> List.iter render_tree;
+ 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..b450382 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;
+ run_query : addr Query.t -> Addr_set.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..066399e 100644
--- a/lib/render/Compile.ml
+++ b/lib/render/Compile.ml
@@ -1,395 +1,455 @@
open Forester_prelude
open Forester_core
+module type I =
+sig
+ val root : string option
+ val trees : Sem.tree Addr_map.t
+ val run_query : addr Query.t -> Addr_set.t
+ val last_changed : addr -> Date.t option
+ val enqueue_latex : name:string -> preamble:string -> source:string -> unit
+end
+
+module S = Addr_set
+
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 Xmlns_map =
+module Make (I : I) () =
struct
- type t =
- {prefix_to_xmlns : string String_map.t;
- xmlns_to_prefixes : string list String_map.t}
- let empty =
- {prefix_to_xmlns = String_map.empty;
- xmlns_to_prefixes = String_map.empty}
+ let mainmatter_cache : (addr, X.content) Hashtbl.t =
+ Hashtbl.create 1000
+
+ module Xmlns_map =
+ struct
+ type t =
+ {prefix_to_xmlns : string String_map.t;
+ xmlns_to_prefixes : string list String_map.t}
+
+ let empty =
+ {prefix_to_xmlns = String_map.empty;
+ xmlns_to_prefixes = String_map.empty}
+
+ let assoc ~prefix ~xmlns env =
+ {prefix_to_xmlns = String_map.add prefix xmlns env.prefix_to_xmlns;
+ xmlns_to_prefixes = String_map.add_to_list xmlns prefix env.xmlns_to_prefixes}
+ end
+
+ module Xmlns_prefixes = Algaeff.Reader.Make (Xmlns_map)
+
+ let get_xmlns_for_prefix prefix =
+ let env = Xmlns_prefixes.read () in
+ String_map.find_opt prefix env.prefix_to_xmlns
+
+ let rec normalise_prefix ?loc ~prefix ~xmlns kont =
+ match xmlns with
+ | Some xmlns ->
+ begin
+ let open Xmlns_map in
+ let env = Xmlns_prefixes.read () in
+ let exception Shadowing in
+ try
+ begin
+ match
+ String_map.find_opt prefix env.prefix_to_xmlns,
+ String_map.find_opt xmlns env.xmlns_to_prefixes
+ with
+ | None, (None | Some []) ->
+ let env = assoc ~prefix ~xmlns env in
+ Xmlns_prefixes.run ~env @@ fun () ->
+ kont @@ ([(prefix, xmlns)], prefix)
+ | Some xmlns', Some prefixes ->
+ if xmlns' = xmlns && List.mem prefix prefixes then
+ kont ([], prefix)
+ else
+ raise Shadowing
+ | _, Some (prefix' :: _) ->
+ kont ([], prefix')
+ | Some xmlns', None ->
+ raise Shadowing
+ end
+ with Shadowing ->
+ normalise_prefix ?loc ~prefix:(prefix ^ "_") ~xmlns:(Some xmlns) kont
+ end
+ | _ ->
+ kont ([], prefix)
- let assoc ~prefix ~xmlns env =
- {prefix_to_xmlns = String_map.add prefix xmlns env.prefix_to_xmlns;
- xmlns_to_prefixes = String_map.add_to_list xmlns prefix env.xmlns_to_prefixes}
-end
+ let is_root addr =
+ Some addr = Option.map (fun x -> User_addr x) I.root
-module Xmlns_prefixes = Algaeff.Reader.Make (Xmlns_map)
-
-let get_xmlns_for_prefix prefix =
- let env = Xmlns_prefixes.read () in
- String_map.find_opt prefix env.prefix_to_xmlns
-
-let rec normalise_prefix ?loc ~prefix ~xmlns kont =
- match xmlns with
- | Some xmlns ->
- begin
- let open Xmlns_map in
- let env = Xmlns_prefixes.read () in
- let exception Shadowing in
- try
- begin
- match
- String_map.find_opt prefix env.prefix_to_xmlns,
- String_map.find_opt xmlns env.xmlns_to_prefixes
- with
- | None, (None | Some []) ->
- let env = assoc ~prefix ~xmlns env in
- Xmlns_prefixes.run ~env @@ fun () ->
- kont @@ ([(prefix, xmlns)], prefix)
- | Some xmlns', Some prefixes ->
- if xmlns' = xmlns && List.mem prefix prefixes then
- kont ([], prefix)
- else
- raise Shadowing
- | _, Some (prefix' :: _) ->
- kont ([], prefix')
- | Some xmlns', None ->
- raise Shadowing
- end
- with Shadowing ->
- normalise_prefix ?loc ~prefix:(prefix ^ "_") ~xmlns:(Some xmlns) kont
- end
- | _ ->
- kont ([], prefix)
-
-
-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 year = Date.year date in
- let month = Date.month date in
- let day = Date.day date in
- X.Date {href; year; month; day}
-
-let compile_dates = List.map compile_date
-
-let rec compile_located (located : Sem.node Range.located) =
- match located.value with
- | Sem.Text txt ->
- [X.Text txt]
- | Sem.Verbatim txt ->
- [X.CDATA txt]
- | Sem.Prim (p, xs) ->
- compile_prim p xs
- | Sem.Math (mode, xs) ->
- let body =
- let module TP = Render_TeX_like.Printer in
- Str.global_replace (Str.regexp "\n") " " @@
- TP.contents @@ Render_TeX_like.render ~cfg:{tex = false} xs
+ let addr_peek_title scope =
+ Option.bind (Addr_map.find_opt scope I.trees) Sem.Util.peek_title
+
+
+ let get_tree addr =
+ Addr_map.find_opt addr I.trees
+
+ let get_sorted_trees addrs : Sem.tree list =
+ 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 =
+ get_sorted_trees @@ I.run_query query
+
+ let contributors scope =
+ let by_title =
+ Compare.under addr_peek_title @@
+ Compare.option String.compare
+ in
+ List.sort by_title @@ S.elements @@ I.run_query @@
+ let q_non_ref_under =
+ Query.isect [
+ Query.tree_under scope;
+ Query.complement @@ Query.has_taxon "reference"
+ ]
in
- let display =
- match mode with
- | Inline -> `Inline
- | Display -> `Block
+ let q_all_contributors =
+ Query.union_fam
+ q_non_ref_under
+ `Outgoing
+ `Contributorship
in
- [X.TeX {display; body}]
+ let q_authors = Query.rel `Outgoing `Authorship scope in
+ Query.isect [q_all_contributors; Query.complement q_authors]
- | Sem.Link (addr, title, modifier) ->
- begin
- match E.get_doc addr with
- | Some tree ->
- compile_internal_link ~title ~modifier ~addr ~dest:tree
- | None ->
- let url = Format.asprintf "%a" pp_addr addr in
- compile_external_link ~title ~modifier ~url
- end
- | Sem.Ref addr ->
- begin
- match E.get_doc 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}]
- end
-
- | Sem.Img path ->
- [X.Img {src = path}]
-
- | Sem.If_tex (_, xs) ->
- X.splice @@ compile_nodes xs
-
- | Sem.Xml_tag (name, attrs, xs) ->
- let rec fold_attrs tag_prefix updates acc attrs =
- match attrs with
- | [] ->
- let xmlns_attrs =
- updates |> List.map @@ fun (prefix, xmlns) ->
- X.{key =
- X.{prefix = "xmlns";
- uname = prefix;
- xmlns = None};
- value = xmlns}
- in
- let name = X.{prefix = tag_prefix; uname = name.uname; xmlns = get_xmlns_for_prefix tag_prefix} in
- let attrs = xmlns_attrs @ List.rev acc in
- let content = compile_nodes xs in
- X.Xml_tag {name; attrs; content}
-
- | (k, v) :: attrs ->
- 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}
- in
- fold_attrs tag_prefix (updates @ updates') (xml_attr :: acc) attrs
+ let compile_date (date : Date.t) =
+ 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 {addr; year; month; day}
+
+ let compile_dates = List.map compile_date
+
+ let rec compile_located (located : Sem.node Range.located) =
+ match located.value with
+ | Sem.Text txt ->
+ [X.Text txt]
+ | Sem.Verbatim txt ->
+ [X.CDATA txt]
+ | Sem.Prim (p, xs) ->
+ compile_prim p xs
+ | Sem.Math (mode, xs) ->
+ let body =
+ let module TP = Render_TeX_like.Printer in
+ Str.global_replace (Str.regexp "\n") " " @@
+ TP.contents @@ Render_TeX_like.render ~cfg:{tex = false} xs
+ in
+ let display =
+ match mode with
+ | Inline -> `Inline
+ | Display -> `Block
+ in
+ [X.TeX {display; body}]
- [normalise_prefix ~prefix:name.prefix ~xmlns:name.xmlns @@ fun (updates, tag_prefix) ->
- fold_attrs tag_prefix updates [] attrs]
+ | Sem.Link (addr, title, modifier) ->
+ begin
+ match get_tree addr with
+ | Some tree ->
+ compile_internal_link ~title ~modifier ~addr ~dest:tree
+ | None ->
+ let url = Format.asprintf "%a" pp_addr addr in
+ compile_external_link ~title ~modifier ~url
+ end
- | Sem.TeX_cs name ->
- Reporter.fatalf ?loc:located.loc Resolution_error
- "unresolved TeX control sequence `\\%a`" TeX_cs.pp name
+ | Sem.Ref addr ->
+ begin
+ 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 taxon = tree.fm.taxon |> Option.map String_util.sentence_case in
+ let number = tree.fm.number in
+ [X.Ref {addr; taxon; number}]
+ end
+
+ | Sem.Img path ->
+ [X.Img {src = path}]
+
+ | Sem.If_tex (_, xs) ->
+ X.splice @@ compile_nodes xs
+
+ | Sem.Xml_tag (name, attrs, xs) ->
+ let rec fold_attrs tag_prefix updates acc attrs =
+ match attrs with
+ | [] ->
+ let xmlns_attrs =
+ updates |> List.map @@ fun (prefix, xmlns) ->
+ X.{key =
+ X.{prefix = "xmlns";
+ uname = prefix;
+ xmlns = None};
+ value = xmlns}
+ in
+ let name = X.{prefix = tag_prefix; uname = name.uname; xmlns = get_xmlns_for_prefix tag_prefix} in
+ let attrs = xmlns_attrs @ List.rev acc in
+ let content = compile_nodes xs in
+ X.Xml_tag {name; attrs; content}
+
+ | (k, v) :: attrs ->
+ 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 ~trees:I.trees v}
+ in
+ fold_attrs tag_prefix (updates @ updates') (xml_attr :: acc) attrs
+ in
- | Sem.Object _ ->
- Reporter.fatal ?loc:located.loc Type_error
- "tried to compile object closure to XML"
+ [normalise_prefix ~prefix:name.prefix ~xmlns:name.xmlns @@ fun (updates, tag_prefix) ->
+ fold_attrs tag_prefix updates [] attrs]
- | Sem.Embed_tex {preamble; source} ->
- let as_tex x =
- Render_TeX_like.Printer.contents @@
- Render_TeX_like.render ~cfg:{tex = true} x
- in
- 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;
- [X.Embedded_tex {hash; preamble; source}]
-
- | Sem.Transclude (opts, addr) ->
- begin
- match E.get_doc 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 ->
- compile_transclusion ~opts doc
- end
-
- | Sem.Subtree (opts, subtree) ->
- compile_transclusion ~opts subtree
-
- | Sem.Query (opts, query) ->
- let trees = E.run_query query in
- begin
- match trees with
- | [] ->
- [X.Prim (`P, X.Content [X.Info "Transclusion cycle"])]
- | _ ->
- 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
- end
-
-and compile_transclusion ~opts (tree : Sem.tree) =
- let current = Current_addr.read () in
- let update old_ancestors = current :: old_ancestors in
- Ancestors.scope update @@ fun () ->
- [X.Subtree (compile_tree ~opts tree)]
-
-and compile_title ~(opts : Sem.transclusion_opts) (fm : Sem.frontmatter) =
- 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
- in
- title |> Option.map @@ fun title ->
- compile_nodes @@ Sem.sentence_case title
-
-and compile_attributions ~contributors ~authors =
- match authors, contributors with
- | [], [] -> []
- | _ ->
- List.map compile_author authors @ List.map compile_contributor contributors
-
-and compile_author author =
- X.Author (compile_attribution_inner author)
-
-and compile_contributor author =
- X.Contributor (compile_attribution_inner author)
-
-and compile_attribution_inner author =
- let exception Untitled in
- try
- match E.get_doc 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
- | Some title -> compile_nodes title
+ | Sem.TeX_cs name ->
+ Reporter.fatalf ?loc:located.loc Resolution_error
+ "unresolved TeX control sequence `\\%a`" TeX_cs.pp name
+
+ | Sem.Object _ ->
+ Reporter.fatal ?loc:located.loc Type_error
+ "tried to compile object closure to XML"
+
+ | Sem.Embed_tex {preamble; source} ->
+ let as_tex x =
+ Render_TeX_like.Printer.contents @@
+ Render_TeX_like.render ~cfg:{tex = true} x
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}]
- with Untitled ->
- let name = Format.asprintf "%a" pp_addr author in
- X.Content [X.Text name]
-
-
-and compile_meta (key, body) =
- let body = compile_nodes body in
- X.Meta {key; body}
-
-and compile_frontmatter ~opts (fm : Sem.frontmatter) =
- let anchor = string_of_int @@ Oo.id (object end) in
- let title = compile_title ~opts fm in
- let number = fm.number in
- let taxon =
- Option.map String_util.sentence_case @@
- match opts.taxon_override with
- | 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 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 metas = fm.metas |> List.map compile_meta in
- X.{title;
- anchor;
- number;
- taxon;
- designated_parent;
- metas;
- route;
- addr;
- source_path;
- dates;
- last_changed;
- attributions}
-
-and compile_tree ?(backmatter = false) ~opts (tree : Sem.tree) =
- Current_addr.run ~env:tree.fm.addr @@ fun () ->
- let ancestors = Ancestors.read () in
- let options =
- X.{toc = opts.toc;
- numbered = opts.numbered;
- show_heading = opts.show_heading;
- show_metadata = opts.show_metadata;
- expanded = opts.expanded;
- root = E.is_root tree.fm.addr}
- in
- let frontmatter = compile_frontmatter ~opts tree.fm in
- let mainmatter =
- begin
- match tree.fm.addr with
- | addr when List.mem addr ancestors ->
- X.Content [X.Prim (`P, X.Content [X.Info "Transclusion cycle"])]
- | addr ->
- let cache = Mainmatter_cache.get () in
- match Addr_map.find_opt addr cache with
- | Some cached -> cached
+ let preamble = as_tex preamble in
+ let source = as_tex source in
+ let hash = Digest.to_hex @@ Digest.string @@ preamble ^ source in
+ I.enqueue_latex ~name:hash ~preamble ~source;
+ [X.Embedded_tex {hash; preamble; source}]
+
+ | Sem.Transclude (opts, addr) ->
+ begin
+ match get_tree addr with
| None ->
- let result = compile_nodes tree.body in
- Mainmatter_cache.modify @@ Addr_map.add addr result;
- result
- end;
-
- in
- let backmatter =
- if backmatter then
- Some (compile_backmatter tree.fm.addr)
- else
- None
- in
- X.Tree {options; frontmatter; mainmatter; backmatter}
-
-and compile_backmatter addr =
- 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]
-
-and compile_internal_link ~title ~modifier ~addr ~dest =
- let href = E.route addr in
- let ancestors = Ancestors.read () in
- let dest_title =
- dest.fm.title |> Option.map @@
- Render_util.expand_title_with_parents ~ancestors dest.fm
- in
- let content =
- title
- |> Option.fold ~none:dest_title ~some:Option.some
- |> Option.map (Sem.apply_modifier modifier)
- |> Option.value ~default:[Range.locate_opt None @@ Sem.Text "Untitled"]
- |> compile_nodes
- in
- let title =
- match dest_title with
- | None -> None
- | Some t ->
- let title_string =
- String_util.sentence_case @@
- Render_text.Printer.contents @@
- Render_text.render t
+ Reporter.fatalf ?loc:located.loc Tree_not_found "could not find tree at address `%a` for transclusion" pp_addr addr
+ | Some doc ->
+ compile_transclusion ~opts doc
+ end
+
+ | Sem.Subtree (opts, subtree) ->
+ compile_transclusion ~opts subtree
+
+ | Sem.Query (opts, query) ->
+ begin
+ match get_trees_from_query query with
+ | [] ->
+ [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
+ end
+
+ and compile_transclusion ~opts (tree : Sem.tree) =
+ let current = Current_addr.read () in
+ let update old_ancestors = current :: old_ancestors in
+ Ancestors.scope update @@ fun () ->
+ [X.Subtree (compile_tree_inner ~opts tree)]
+
+ and compile_title ~(opts : Sem.transclusion_opts) (fm : Sem.frontmatter) =
+ let trees = I.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 ~trees ~ancestors fm
+ in
+ title |> Option.map @@ fun title ->
+ compile_nodes @@ Sem.sentence_case title
+
+ and compile_attributions ~contributors ~authors =
+ match authors, contributors with
+ | [], [] -> []
+ | _ ->
+ List.map compile_author authors @ List.map compile_contributor contributors
+
+ and compile_author author =
+ X.Author (compile_attribution_inner author)
+
+ and compile_contributor author =
+ X.Contributor (compile_attribution_inner author)
+
+ and compile_attribution_inner author =
+ let exception Untitled in
+ try
+ match get_tree author with
+ | None -> raise Untitled
+ | Some biotree ->
+ let content =
+ match biotree.fm.title with
+ | None -> raise Untitled
+ | Some title -> compile_nodes title
+ 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.Local_link {title; addr = author; content}]
+ with Untitled ->
+ let name = Format.asprintf "%a" pp_addr author in
+ X.Content [X.Text name]
+
+
+ and compile_meta (key, body) =
+ let body = compile_nodes body in
+ X.Meta {key; body}
+
+ and compile_frontmatter ~opts (fm : Sem.frontmatter) =
+ 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 =
+ Option.map String_util.sentence_case @@
+ match opts.taxon_override with
+ | Some taxon -> Some taxon
+ | None -> fm.taxon
+ in
+ let source_path = fm.source_path 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 contributors = contributors fm.addr in
+ let attributions = compile_attributions ~contributors ~authors:fm.authors in
+ let last_changed = I.last_changed fm.addr |> Option.map compile_date in
+ let metas = fm.metas |> List.map compile_meta in
+ X.{title;
+ anchor;
+ number;
+ taxon;
+ designated_parent;
+ metas;
+ addr;
+ source_path;
+ dates;
+ last_changed;
+ attributions}
+
+ and compile_tree_inner ?(include_backmatter = false) ~opts (tree : Sem.tree) =
+ Current_addr.run ~env:tree.fm.addr @@ fun () ->
+ let ancestors = Ancestors.read () in
+ let options =
+ X.{toc = opts.toc;
+ numbered = opts.numbered;
+ show_heading = opts.show_heading;
+ show_metadata = opts.show_metadata;
+ expanded = opts.expanded;
+ root = is_root tree.fm.addr}
+ in
+ let frontmatter = compile_frontmatter ~opts tree.fm in
+ let mainmatter =
+ begin
+ match tree.fm.addr with
+ | addr when List.mem addr ancestors ->
+ X.Content [X.Prim (`P, X.Content [X.Info "Transclusion cycle"])]
+ | addr ->
+ match Hashtbl.find_opt mainmatter_cache addr with
+ | Some cached -> cached
+ | None ->
+ let result = compile_nodes tree.body in
+ Hashtbl.add mainmatter_cache addr result;
+ result
+ end;
+ in
+ let backmatter =
+ if include_backmatter && not (is_root tree.fm.addr) then
+ compile_backmatter tree.fm.addr tree.bm
+ else
+ []
+ in
+ X.Tree {options; frontmatter; mainmatter; backmatter}
+
+ 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_inner ~opts tree
+ in
+ bm |> List.filter_map @@ function
+ | Sem.Backmatter_section {title; query} ->
+ let title =
+ Option.some @@ compile_nodes @@
+ Sem.sentence_case title
in
- Some title_string
- in
- let addr = Some (Format.asprintf "%a" pp_addr addr) in
- [X.Link {type_ = `Local; href; title; content; addr}]
-
-and compile_external_link ~title ~modifier ~url =
- let href = url in
- let content =
- title
- |> Option.map (Sem.apply_modifier modifier)
- |> Option.value ~default:[Range.locate_opt None @@ Sem.Text url]
- |> compile_nodes
- in
- [X.Link {type_ = `External; href; content; title = None; addr = None}];
-
-and compile_nodes (xs : Sem.t) = X.Content (List.concat_map compile_located xs)
-
-and compile_prim p xs =
- let content = compile_nodes xs in
- [X.Prim (p, content)]
-
-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
-
-
-let run kont =
- Mainmatter_cache.run ~init:Addr_map.empty kont
+ 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 trees = I.trees in
+ let ancestors = Ancestors.read () in
+ let dest_title =
+ dest.fm.title |> Option.map @@
+ Render_util.expand_title_with_parents ~trees ~ancestors dest.fm
+ in
+ let content =
+ title
+ |> Option.fold ~none:dest_title ~some:Option.some
+ |> Option.map (Sem.apply_modifier modifier)
+ |> Option.value ~default:[Range.locate_opt None @@ Sem.Text "Untitled"]
+ |> compile_nodes
+ in
+ let title =
+ match dest_title with
+ | None -> None
+ | Some t ->
+ let title_string =
+ String_util.sentence_case @@
+ Render_text.Printer.contents @@
+ Render_text.render ~trees t
+ in
+ Some title_string
+ in
+ [X.Local_link {title; content; addr = addr}]
+
+ and compile_external_link ~title ~modifier ~url =
+ let href = url in
+ let content =
+ title
+ |> Option.map (Sem.apply_modifier modifier)
+ |> Option.value ~default:[Range.locate_opt None @@ Sem.Text url]
+ |> compile_nodes
+ in
+ [X.External_link {href; content; title = None}];
+
+ and compile_nodes (xs : Sem.t) = X.Content (List.concat_map compile_located xs)
+
+ and compile_prim p xs =
+ let content = compile_nodes xs in
+ [X.Prim (p, content)]
+
+ let compile_tree 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_inner ~include_backmatter:true ~opts:Sem.default_transclusion_opts tree
+end
\ No newline at end of file
diff --git a/lib/render/Compile.mli b/lib/render/Compile.mli
index ef8f7e5..b389a19 100644
--- a/lib/render/Compile.mli
+++ b/lib/render/Compile.mli
@@ -1,7 +1,17 @@
+open Forester_prelude
open Forester_core
-val run : (unit -> 'a) -> 'a
-(** Initialises a cache for tree mainmatters in the given scope. *)
-val compile_tree_top : Sem.tree -> Xml_tree.tree_
-(** Must be called in the scope of {!run}. *)
+module type I =
+sig
+ val root : string option
+ val trees : Sem.tree Addr_map.t
+ val run_query : addr Query.t -> Addr_set.t
+ val last_changed : addr -> Date.t option
+ val enqueue_latex : name:string -> preamble:string -> source:string -> unit
+end
+
+module Make (_ : I) () :
+sig
+ val compile_tree : Sem.tree -> Xml_tree.tree_
+end
\ No newline at end of file
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..71d47ec 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 ~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..4cb22ef 100644
--- a/lib/render/Serialise_xml_tree.ml
+++ b/lib/render/Serialise_xml_tree.ml
@@ -5,165 +5,176 @@ 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)
-
-let render_xml_qname =
- function
- | X.{prefix = ""; uname; _} -> uname
- | X.{prefix; uname; _} -> Format.sprintf "%s:%s" prefix uname
-
-let render_xml_attr X.{key; value} =
- P.string_attr (render_xml_qname key) "%s" value
-
-let render_date (X.Date date) =
- F.date [
- date.href |> F.optional_ @@ F.href "%s"
- ] [
- F.year [] "%i" date.year;
- date.month |> F.optional @@ F.month [] "%i";
- date.day |> F.optional @@ F.day [] "%i"
- ]
-
-let rec render_tree (X.Tree tree) =
- F.tree [
- F.toc tree.options.toc;
- F.numbered tree.options.numbered;
- F.show_heading tree.options.show_heading;
- F.show_metadata tree.options.show_metadata;
- F.expanded tree.options.expanded;
- F.root tree.options.root;
- P.string_attr ("xmlns:" ^ F.reserved_prefix) "%s" F.forester_xmlns
- ] [
- 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
- end;
- tree.backmatter |> F.optional render_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.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";
- fm.dates |> List.map render_date |> F.null;
- F.authors [] @@ List.map render_attribution_elt fm.attributions;
- fm.number |> F.optional @@ F.number [] "%s";
- fm.designated_parent |> F.optional @@ F.parent [] "%s";
- fm.metas |> List.map render_meta |> F.null
- ]
-
-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
+module type I = sig val root : string option end
+
+let addr_to_string addr =
+ Format.asprintf "%a" pp_addr addr
+
+let route ~root addr =
+ let is_root = Some addr = Option.map (fun x -> User_addr x) 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
- 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_meta (Meta meta) =
- F.meta [F.name "%s" meta.key] @@
- render_content meta.body
-
-and render_attribution_elt =
- function
- | X.Author x ->
- F.author [] @@ render_content x
- | X.Contributor x ->
- F.contributor [] @@ render_content x
-
-and render_content (X.Content xs) =
- List.map render_content_node xs
-
-
-and render_content_node =
- function
- | X.Text x ->
- P.txt "%s" x
- | X.CDATA x ->
- P.txt ~raw:true "<![CDATA[%s]]>" x
- | X.Prim (p, x) ->
- F.prim p [] @@ render_content x
- | X.Xml_tag {name; attrs; content} ->
- P.std_tag
- (render_xml_qname name)
- (List.map render_xml_attr attrs)
- (render_content content)
- | X.Subtree tree ->
- render_tree tree
- | X.Ref ref ->
- F.ref [
- F.addr_ "%s" ref.addr;
- F.href "%s" ref.href;
- ref.taxon |> F.optional_ @@ F.taxon_ "%s";
- ref.number |> F.optional_ @@ F.number_ "%s"
+ Format.asprintf "%s.%s" base ext
+
+module Make (I : I) () =
+struct
+ let mainmatter_cache : (addr, P.node) Hashtbl.t =
+ Hashtbl.create 1000
+
+ let route = route ~root:I.root
+
+ let render_xml_qname =
+ function
+ | X.{prefix = ""; uname; _} -> uname
+ | X.{prefix; uname; _} -> Format.sprintf "%s:%s" prefix uname
+
+ let render_xml_attr X.{key; value} =
+ P.string_attr (render_xml_qname key) "%s" value
+
+ let render_date (X.Date date) =
+ F.date [
+ date.addr |> F.optional_ @@ fun addr -> F.href "%s" @@ route addr
+ ] [
+ F.year [] "%i" date.year;
+ date.month |> F.optional @@ F.month [] "%i";
+ date.day |> F.optional @@ F.day [] "%i"
+ ]
+
+ let rec render_tree (X.Tree tree) =
+ F.tree [
+ F.toc tree.options.toc;
+ F.numbered tree.options.numbered;
+ F.show_heading tree.options.show_heading;
+ F.show_metadata tree.options.show_metadata;
+ F.expanded tree.options.expanded;
+ F.root tree.options.root;
+ P.string_attr ("xmlns:" ^ F.reserved_prefix) "%s" F.forester_xmlns
+ ] [
+ render_frontmatter tree.frontmatter;
+ begin
+ match tree.frontmatter.addr with
+ | None -> render_mainmatter tree.mainmatter
+ | Some key ->
+ match Hashtbl.find_opt mainmatter_cache key with
+ | Some cached -> cached
+ | None ->
+ let result = render_mainmatter tree.mainmatter in
+ Hashtbl.add mainmatter_cache key result;
+ result
+ end;
+ render_backmatter @@
+ List.map (fun x -> X.Tree x) tree.backmatter
]
- | X.Link link ->
- let type_ =
- match link.type_ with
- | `Local -> "local"
- | `External -> "external"
- in
- F.link [
- F.type_ "%s" type_;
- 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 ->
- let display =
- match tex.display with
- | `Inline -> "inline"
- | `Block -> "block"
- in
- F.tex [F.display "%s" display] "<![CDATA[%s]]>" tex.body
- | X.Img img ->
- F.img [F.src "%s" img.src]
- | X.Embedded_tex emb ->
- F.embedded_tex [F.hash "%s" emb.hash] [
- F.embedded_tex_preamble [] "<![CDATA[%s]]>" emb.preamble;
- F.embedded_tex_body [] "<![CDATA[%s]]>" emb.source
+
+ and render_frontmatter (fm : _ X.frontmatter) =
+ F.frontmatter [] [
+ 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";
+ fm.dates |> List.map render_date |> F.null;
+ F.authors [] @@ List.map render_attribution_elt fm.attributions;
+ fm.number |> F.optional @@ F.number [] "%s";
+ fm.designated_parent |> F.optional @@ F.parent [] "%s";
+ fm.metas |> List.map render_meta |> F.null
]
- | X.Info x ->
- F.info [] [P.txt "%s" x]
-
-
-let pp ?stylesheet fmt tree =
- Format.fprintf fmt {|<?xml version="1.0" encoding="UTF-8"?>|};
- Format.pp_print_newline fmt ();
- begin
- stylesheet |> Option.iter @@ fun uri ->
- Format.fprintf fmt "<?xml-stylesheet type=\"text/xsl\" href=\"%s\"?>" uri
- end;
- Format.pp_print_newline fmt ();
- P.pp_xml fmt @@ render_tree tree
-
-let run kont =
- Mainmatter_cache.run ~init:String_map.empty kont
+
+ and render_mainmatter mm =
+ F.mainmatter [] @@ render_content mm
+
+ 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] @@
+ render_content meta.body
+
+ and render_attribution_elt =
+ function
+ | X.Author x ->
+ F.author [] @@ render_content x
+ | X.Contributor x ->
+ F.contributor [] @@ render_content x
+
+ and render_content (X.Content xs) =
+ List.map render_content_node xs
+
+
+ and render_content_node =
+ function
+ | X.Text x ->
+ P.txt "%s" x
+ | X.CDATA x ->
+ P.txt ~raw:true "<![CDATA[%s]]>" x
+ | X.Prim (p, x) ->
+ F.prim p [] @@ render_content x
+ | X.Xml_tag {name; attrs; content} ->
+ P.std_tag
+ (render_xml_qname name)
+ (List.map render_xml_attr attrs)
+ (render_content content)
+ | X.Subtree tree ->
+ render_tree tree
+ | X.Ref ref ->
+ F.ref [
+ F.addr_ "%s" (addr_to_string ref.addr);
+ ref.taxon |> F.optional_ @@ F.taxon_ "%s";
+ ref.number |> F.optional_ @@ F.number_ "%s"
+ ]
+ | 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_ "external";
+ F.href "%s" link.href;
+ link.title |> F.optional_ @@ F.title_ "%s"
+ ] @@ render_content link.content
+ | X.TeX tex ->
+ let display =
+ match tex.display with
+ | `Inline -> "inline"
+ | `Block -> "block"
+ in
+ F.tex [F.display "%s" display] "<![CDATA[%s]]>" tex.body
+ | X.Img img ->
+ F.img [F.src "%s" img.src]
+ | X.Embedded_tex emb ->
+ F.embedded_tex [F.hash "%s" emb.hash] [
+ F.embedded_tex_preamble [] "<![CDATA[%s]]>" emb.preamble;
+ F.embedded_tex_body [] "<![CDATA[%s]]>" emb.source
+ ]
+ | X.Info x ->
+ F.info [] [P.txt "%s" x]
+
+ let pp ?stylesheet fmt tree =
+ Format.fprintf fmt {|<?xml version="1.0" encoding="UTF-8"?>|};
+ Format.pp_print_newline fmt ();
+ begin
+ stylesheet |> Option.iter @@ fun uri ->
+ Format.fprintf fmt "<?xml-stylesheet type=\"text/xsl\" href=\"%s\"?>" uri
+ end;
+ Format.pp_print_newline fmt ();
+ P.pp_xml fmt @@ render_tree tree
+end
\ No newline at end of file
diff --git a/lib/render/Serialise_xml_tree.mli b/lib/render/Serialise_xml_tree.mli
index 0487f56..8727348 100644
--- a/lib/render/Serialise_xml_tree.mli
+++ b/lib/render/Serialise_xml_tree.mli
@@ -1,7 +1,10 @@
open Forester_core
-val run : (unit -> 'a) -> 'a
-(** Initialises a cache for tree mainmatters in the given scope. *)
+val route : root:string option -> addr -> string
-val pp : ?stylesheet:string -> Format.formatter -> Xml_tree.tree_ -> unit
-(** Must be called within the scope of {!run}. *)
\ No newline at end of file
+module type I = sig val root : string option end
+
+module Make (_ : I) () :
+sig
+ val pp : ?stylesheet:string -> Format.formatter -> Xml_tree.tree_ -> unit
+end
\ No newline at end of file
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