| 1 | let wrap (title:string) (subtitle:string) body =
|
|---|
| 2 | {|<!DOCTYPE HTML>|}
|
|---|
| 3 | ^ {|<html><head><title>|}
|
|---|
| 4 | ^ subtitle ^ " | " ^ title
|
|---|
| 5 | ^ {|</title><link rel="stylesheet" href="main.css">|}
|
|---|
| 6 | ^ {|<link rel="alternate" href="feed.atom" type="application/atom+xml">|}
|
|---|
| 7 | ^ {|<meta charset="utf-8"/>|}
|
|---|
| 8 | ^ {|<meta name="viewport" content="width=device-width, initial-scale=1.0">|}
|
|---|
| 9 | ^ {|</head><body><header><a href=".">|} ^ title
|
|---|
| 10 | ^ {|</a> <nav><a href="feed.atom" id="feed">feed</a></nav></header>|} ^ body
|
|---|
| 11 | ^ "</body></html>"
|
|---|
| 12 |
|
|---|
| 13 | let topic_link root topic =
|
|---|
| 14 | let replaced_space = String.map (function ' '->'+' | x->x) in
|
|---|
| 15 | {|<a href="index.|} ^ root ^ {|.htm#|} ^ replaced_space topic ^ {|">|}
|
|---|
| 16 | ^ String.capitalize_ascii topic ^ "</a>"
|
|---|
| 17 |
|
|---|
| 18 | let page archive_title text =
|
|---|
| 19 | let open Logarion in
|
|---|
| 20 | let open Text in
|
|---|
| 21 | let module T = Parsers.Plain_text.Make (Converter.Html) in
|
|---|
| 22 | let sep_append ?(sep=", ") a x = match a,x with "",_ -> x | _, "" -> a | _ -> a ^ sep ^ x in
|
|---|
| 23 | let opt_kv key value = if String.length value > 0 then "<dt>" ^ key ^ "<dd>" ^ value else "" in
|
|---|
| 24 | (* let author acc auth = sep_append acc Person.(auth.name ^ " ") in*)
|
|---|
| 25 | let authors = (Person.Set.to_string text.authors ^ " ") in
|
|---|
| 26 | let keywords = str_set "keywords" text in
|
|---|
| 27 | let header =
|
|---|
| 28 | let time x = {|<time datetime="|} ^ x ^ {|">|} ^ x ^ "</time>" in
|
|---|
| 29 | let topic_links x =
|
|---|
| 30 | let to_linked t a =
|
|---|
| 31 | let ts = Topic_set.of_string t in
|
|---|
| 32 | sep_append a (List.fold_left (fun a t -> sep_append ~sep:" > " a (topic_link (List.hd ts) t)) "" ts) in
|
|---|
| 33 | String_set.fold to_linked x "" in
|
|---|
| 34 | "<article><header><dl>"
|
|---|
| 35 | ^ opt_kv "Title:" text.title
|
|---|
| 36 | ^ opt_kv "Authors:" authors
|
|---|
| 37 | ^ opt_kv "Date: " (time (Date.(pretty_date @@ listing text.date)))
|
|---|
| 38 | ^ opt_kv "Series: " (str_set "series" text)
|
|---|
| 39 | ^ opt_kv "Topics: " (topic_links (set "topics" text))
|
|---|
| 40 | ^ opt_kv "Keywords: " keywords
|
|---|
| 41 | ^ opt_kv "Id: " (Id.to_string text.uuid)
|
|---|
| 42 | ^ {|</dl></header><pre style="white-space:pre-wrap">|} in
|
|---|
| 43 | wrap archive_title text.title ((T.of_string text.body header) ^ "</pre></article>")
|
|---|
| 44 |
|
|---|
| 45 | let to_dated_links ?(limit) meta_list =
|
|---|
| 46 | let meta_list = match limit with
|
|---|
| 47 | | None -> meta_list
|
|---|
| 48 | | Some limit->
|
|---|
| 49 | let rec reduced acc i = function
|
|---|
| 50 | | [] -> acc
|
|---|
| 51 | | h::t -> if i < limit then reduced (h::acc) (i+1) t else acc in
|
|---|
| 52 | List.rev @@ reduced [] 0 meta_list
|
|---|
| 53 | in
|
|---|
| 54 | List.fold_left
|
|---|
| 55 | (fun a m ->
|
|---|
| 56 | a ^ Logarion.(Date.(pretty_date (listing m.Text.date)) ^ " ")
|
|---|
| 57 | ^ {|<a href="|} ^ Logarion.Text.short_id m ^ {|.htm">|} ^ m.Logarion.Text.title ^ "</a><br>")
|
|---|
| 58 | "" meta_list
|
|---|
| 59 |
|
|---|
| 60 | let date_index ?(limit) title meta_list =
|
|---|
| 61 | match limit with
|
|---|
| 62 | | Some limit -> wrap title "Index" (to_dated_links ~limit meta_list)
|
|---|
| 63 | | None -> wrap title "Index" (to_dated_links meta_list)
|
|---|
| 64 |
|
|---|
| 65 | let fold_topic_roots topic_roots =
|
|---|
| 66 | let list_item root t = "<li>" ^ topic_link root t in
|
|---|
| 67 | "<nav><h2>Main topics</h2>"
|
|---|
| 68 | ^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
|
|---|
| 69 | ^ "</ul></nav>"
|
|---|
| 70 |
|
|---|
| 71 | let fold_topics topic_map topic_roots metas =
|
|---|
| 72 | let open Logarion in
|
|---|
| 73 | let rec unordered_list root topic =
|
|---|
| 74 | List.fold_left (fun a x -> a ^ list_item root x) "<ul>" topic
|
|---|
| 75 | ^ "</ul>"
|
|---|
| 76 | and sub_items root topic = match Topic_set.Map.find_opt topic topic_map with
|
|---|
| 77 | | None -> ""
|
|---|
| 78 | | Some (_, subtopics) -> unordered_list root (String_set.elements subtopics)
|
|---|
| 79 | and list_item root t =
|
|---|
| 80 | let item =
|
|---|
| 81 | if List.exists (fun x -> String_set.mem t (String_set.map Topic_set.topic (Text.set "topics" x))) metas
|
|---|
| 82 | then topic_link root t else String.capitalize_ascii t
|
|---|
| 83 | in
|
|---|
| 84 | "<li>" ^ item ^ sub_items root t
|
|---|
| 85 | in
|
|---|
| 86 | "<nav><h2>Topics</h2>"
|
|---|
| 87 | ^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
|
|---|
| 88 | ^ "</ul></nav>"
|
|---|
| 89 |
|
|---|
| 90 | let text_item path meta =
|
|---|
| 91 | let open Logarion in
|
|---|
| 92 | "<time>" ^ Date.(pretty_date (listing meta.Text.date))
|
|---|
| 93 | ^ {|</time> <a href="|} ^ path ^ Text.short_id meta ^ {|.htm">|} ^ meta.Text.title
|
|---|
| 94 | ^ "</a><br>"
|
|---|
| 95 |
|
|---|
| 96 | let listing_index topic_map topic_roots path metas =
|
|---|
| 97 | let rec item_group topics =
|
|---|
| 98 | List.fold_left (fun acc topic -> acc ^ sub_groups topic ^ items topic) "" topics
|
|---|
| 99 | and sub_groups topic = match Logarion.Topic_set.Map.find_opt topic topic_map with
|
|---|
| 100 | | None -> ""
|
|---|
| 101 | | Some (_, subtopics) -> item_group (Logarion.String_set.elements subtopics)
|
|---|
| 102 | and items topic =
|
|---|
| 103 | let items =
|
|---|
| 104 | let open Logarion in
|
|---|
| 105 | List.fold_left
|
|---|
| 106 | (fun a e ->
|
|---|
| 107 | if String_set.mem topic (String_set.map (Logarion.Topic_set.topic) (Text.set "Topics" e))
|
|---|
| 108 | then text_item path e ^ a else a) "" metas in
|
|---|
| 109 | match items with
|
|---|
| 110 | | "" -> ""
|
|---|
| 111 | | x -> {|<h2 id="|} ^ topic ^ {|">|} ^ String.capitalize_ascii topic ^ "</h2>" ^ x
|
|---|
| 112 | in
|
|---|
| 113 | "<nav><h1>Texts</h1>" ^ item_group topic_roots ^ "</nav>"
|
|---|
| 114 |
|
|---|
| 115 | let topic_main_index title topic_roots metas =
|
|---|
| 116 | wrap title "Topics"
|
|---|
| 117 | (fold_topic_roots topic_roots
|
|---|
| 118 | ^ "<nav><h1>Latest</h1>" ^ to_dated_links ~limit:10 metas
|
|---|
| 119 | ^ {|<a href="index.date.htm">More by date</a></nav>|} )
|
|---|
| 120 |
|
|---|
| 121 | let topic_sub_index title topic_map topic_root metas =
|
|---|
| 122 | wrap title topic_root
|
|---|
| 123 | (fold_topics topic_map [topic_root] metas
|
|---|
| 124 | (* ^ {|<a href=".atom" id="feed">|}^ String.capitalize_ascii topic_root ^{| feed </a>|}*)
|
|---|
| 125 | ^ listing_index topic_map [topic_root] "" metas)
|
|---|
