Source file Compile.ml

open Forester_prelude
open Forester_core

module type I =
sig
  val root : string option
  val trees : Sem.tree Addr_map.t
  val run_query : Query.dbix Query.expr -> Addr_set.t
  val last_changed : addr -> Date.t option
  val get_resource : hash:string -> string
end

module S = Addr_set

module X = Xml_tree
module F = Xml_forester

module Ancestors = Algaeff.Reader.Make (struct type t = addr list end)
module Current_addr = Algaeff.Reader.Make (struct type t = addr end)

module Make (I : I) () =
struct

  let mainmatter_cache : (addr, X.content) Hashtbl.t =
    Hashtbl.create 1000

  module Xmlns_effect = struct
    include (Xmlns_effect.Make ())

    let run f =
      run ~reserved:[{prefix = F.reserved_prefix; xmlns = F.forester_xmlns}] f
  end

  let is_root addr =
    Some addr = Option.map (fun x -> User_addr x) I.root

  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 @@
    Query.distill_expr @@ Query.hereditary_contributors (Addr scope)

  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 xs
      in
      let display =
        match mode with
        | Inline -> `Inline
        | Display -> `Block
      in
      [X.TeX {display; body}]

    | 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.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 {src} ->
      [X.Img (Remote src)]

    | Sem.Xml_tag (name, attrs, xs) ->
      let compile_attr (k, v) =
        let key = Xmlns_effect.normalise_qname k in
        let value = Render_text.Printer.contents @@ Render_text.render ~trees:I.trees v in
        X.{key; value}
      in
      let prefixes_to_add, (name, attrs, content) =
        Xmlns_effect.within_scope @@ fun () ->
        let name = Xmlns_effect.normalise_qname name in
        let attrs = List.map compile_attr attrs in
        let content = compile_nodes xs in
        name, attrs, content
      in
      let attrs =
        let xmlns_attrs =
          prefixes_to_add |> List.map @@ fun Xmlns_effect.{xmlns; prefix} ->
          let key = X.{prefix = "xmlns"; uname = prefix; xmlns = None} in
          let value = xmlns in
          X.{key; value}
        in
        xmlns_attrs @ attrs
      in
      [Xml_tag {name; attrs; content}]

    | Sem.Resource {format; hash; sources} ->
      let resource = I.get_resource ~hash in
      let base64 = Base64.encode_string resource in
      let content = X.Content [X.Img (X.Inline {format; base64})] in
      let sources = List.map compile_resource_source sources in
      let resource = X.{hash; content; sources} in
      [X.Resource resource]

    | Sem.Transclude (opts, addr) ->
      begin
        match get_tree addr with
        | None ->
          Reporter.fatalf ?loc:located.loc Tree_not_found "could not find tree at address `%a` for transclusion" pp_addr addr
        | Some doc ->
          compile_transclusion ~opts doc
      end

    | Sem.Subtree (opts, subtree) ->
      compile_transclusion ~opts subtree

    | Sem.Query_tree (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

    | Sem.TeX_cs name ->
      Reporter.fatalf ?loc:located.loc Resolution_error
        "unresolved control sequence `\\%a`" TeX_cs.pp name

  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_resource_source Sem.{type_; part; source} =
    X.{type_; part; source}

  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
    begin
      title |> Option.map @@ fun title ->
      compile_nodes @@ Sem.sentence_case title
    end,
    begin
      title |> Option.map @@ fun title ->
      String_util.sentence_case @@
      Render_text.Printer.contents @@
      Render_text.render ~trees title
    end

  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
        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, title_text = 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; title_text; 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  () ->
    Xmlns_effect.run @@ 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 = Sem.sentence_case title in
      let title_content = Option.some @@ compile_nodes title in
      let title_text = Option.some @@ Render_text.Printer.contents @@ Render_text.render ~trees:I.trees title in
      match compile_trees @@ get_trees_from_query query with
      | [] -> None
      | trees ->
        let options =
          X.{toc = false; expanded = true; numbered = false; show_heading = true; show_metadata = false; root = false}
        in
        let frontmatter =
          X.{title = title_content; title_text; 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 () ->
    compile_tree_inner ~include_backmatter:true ~opts:Sem.default_transclusion_opts tree
end