let wrap (title:string) (subtitle:string) body = {||} ^ {||} ^ subtitle ^ " | " ^ title ^ {||} ^ {||} ^ {||} ^ {||} ^ {|
|} ^ title ^ {|
|} ^ body ^ "" let topic_link root topic = let replaced_space = String.map (function ' '->'+' | x->x) in {||} ^ String.capitalize_ascii topic ^ "" let page archive_title text = let open Logarion in let open Text in let module T = Parsers.Plain_text.Make (Converter.Html) in let sep_append ?(sep=", ") a x = match a,x with "",_ -> x | _, "" -> a | _ -> a ^ sep ^ x in let opt_kv key value = if String.length value > 0 then "
" ^ key ^ "
" ^ value else "" in (* let author acc auth = sep_append acc Person.(auth.name ^ " ") in*) let authors = (Person.Set.to_string text.authors ^ " ") in let keywords = str_set "keywords" text in let header = let time x = {|" in let topic_links x = let to_linked t a = let ts = Topic_set.of_string t in sep_append a (List.fold_left (fun a t -> sep_append ~sep:" > " a (topic_link (List.hd ts) t)) "" ts) in String_set.fold to_linked x "" in "
" ^ opt_kv "Title:" text.title ^ opt_kv "Authors:" authors ^ opt_kv "Date: " (time (Date.(pretty_date @@ listing text.date))) ^ opt_kv "Series: " (str_set "series" text) ^ opt_kv "Topics: " (topic_links (set "topics" text)) ^ opt_kv "Keywords: " keywords ^ opt_kv "Id: " (Id.to_string text.uuid) ^ {|
|} in
  wrap archive_title text.title ((T.of_string text.body header) ^ "
") let to_dated_links ?(limit) meta_list = let meta_list = match limit with | None -> meta_list | Some limit-> let rec reduced acc i = function | [] -> acc | h::t -> if i < limit then reduced (h::acc) (i+1) t else acc in List.rev @@ reduced [] 0 meta_list in List.fold_left (fun a m -> a ^ Logarion.(Date.(pretty_date (listing m.Text.date)) ^ " ") ^ {||} ^ m.Logarion.Text.title ^ "
") "" meta_list let date_index ?(limit) title meta_list = match limit with | Some limit -> wrap title "Index" (to_dated_links ~limit meta_list) | None -> wrap title "Index" (to_dated_links meta_list) let fold_topic_roots topic_roots = let list_item root t = "
  • " ^ topic_link root t in "" let fold_topics topic_map topic_roots metas = let open Logarion in let rec unordered_list root topic = List.fold_left (fun a x -> a ^ list_item root x) "" and sub_items root topic = match Topic_set.Map.find_opt topic topic_map with | None -> "" | Some (_, subtopics) -> unordered_list root (String_set.elements subtopics) and list_item root t = let item = if List.exists (fun x -> String_set.mem t (String_set.map Topic_set.topic (Text.set "topics" x))) metas then topic_link root t else String.capitalize_ascii t in "
  • " ^ item ^ sub_items root t in "" let text_item path meta = let open Logarion in " |} ^ meta.Text.title ^ "
    " let listing_index topic_map topic_roots path metas = let rec item_group topics = List.fold_left (fun acc topic -> acc ^ sub_groups topic ^ items topic) "" topics and sub_groups topic = match Logarion.Topic_set.Map.find_opt topic topic_map with | None -> "" | Some (_, subtopics) -> item_group (Logarion.String_set.elements subtopics) and items topic = let items = let open Logarion in List.fold_left (fun a e -> if String_set.mem topic (String_set.map (Logarion.Topic_set.topic) (Text.set "Topics" e)) then text_item path e ^ a else a) "" metas in match items with | "" -> "" | x -> {|

    |} ^ String.capitalize_ascii topic ^ "

    " ^ x in "" let topic_main_index title topic_roots metas = wrap title "Topics" (fold_topic_roots topic_roots ^ "|} ) let topic_sub_index title topic_map topic_root metas = wrap title topic_root (fold_topics topic_map [topic_root] metas (* ^ {||}^ String.capitalize_ascii topic_root ^{| feed |}*) ^ listing_index topic_map [topic_root] "" metas)