Omit bullet in empty title conversions, tidy html.ml
This commit is contained in:
orbifx
parent
93be78f7c9
commit
4c32abf03b
221
cli/html.ml
221
cli/html.ml
|
|
@ -7,12 +7,11 @@ let default_opts = { templates = empty_templates }
|
|||
|
||||
let init kv =
|
||||
let open Logarion in
|
||||
let header = match Store.KV.find "HTM-header" kv with
|
||||
| fname -> Some (File_store.to_string fname)
|
||||
| exception Not_found -> None in
|
||||
let footer = match Store.KV.find "HTM-footer" kv with
|
||||
let to_string key kv = match Store.KV.find key kv with
|
||||
| fname -> Some (File_store.to_string fname)
|
||||
| exception Not_found -> None in
|
||||
let header = to_string "HTM-header" kv in
|
||||
let footer = to_string "HTM-footer" kv in
|
||||
{ templates = { header; footer} }
|
||||
|
||||
let wrap c htm text_title body =
|
||||
|
|
@ -27,17 +26,19 @@ let wrap c htm text_title body =
|
|||
| None -> "<header><a href='.'>" ^ site_title ^
|
||||
"</a><nav><a href='feed.atom' id='feed'>feed</a></nav></header>"
|
||||
in
|
||||
let footer = match htm.templates.footer with None -> "" | Some x -> replace x in
|
||||
"<!DOCTYPE HTML><html><head><title>" ^ text_title ^ " • " ^ site_title ^ "</title>\n\
|
||||
<link rel='stylesheet' href='main.css'>\
|
||||
<link rel='alternate' href='feed.atom' type='application/atom+xml'>\
|
||||
<meta charset='utf-8'/><meta name='viewport' content='width=device-width, initial-scale=1.0'>\
|
||||
</head><body>\n" ^ header ^ body ^ footer ^ "</body></html>"
|
||||
let footer = match htm.templates.footer with None -> "" | Some x -> replace x in
|
||||
Printf.sprintf "<!DOCTYPE HTML><html><head><title>%s%s</title>\n\
|
||||
<link rel='stylesheet' href='main.css'>\
|
||||
<link rel='alternate' href='feed.atom' type='application/atom+xml'>\
|
||||
<meta charset='utf-8'/><meta name='viewport' content='width=device-width, initial-scale=1.0'>\
|
||||
</head><body>\n%s%s%s</body></html>"
|
||||
text_title (if site_title <> "" then (" • " ^ site_title) else "")
|
||||
header body footer
|
||||
|
||||
let topic_link root topic =
|
||||
let replaced_space = String.map (function ' '->'+' | x->x) in
|
||||
"<a href='index." ^ root ^ ".htm#" ^ replaced_space topic ^ "'>"
|
||||
^ String.capitalize_ascii topic ^ "</a>"
|
||||
let replaced_space = String.map (function ' '->'+' | x->x) in
|
||||
"<a href='index." ^ root ^ ".htm#" ^ replaced_space topic ^ "'>"
|
||||
^ String.capitalize_ascii topic ^ "</a>"
|
||||
|
||||
module HtmlConverter = struct
|
||||
include Converter.Html
|
||||
|
|
@ -46,119 +47,119 @@ module HtmlConverter = struct
|
|||
end
|
||||
|
||||
let page htm conversion text =
|
||||
let open Logarion in
|
||||
let open Text in
|
||||
let module T = Parsers.Plain_text.Make (HtmlConverter) 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 "<dt>" ^ key ^ "<dd>" ^ 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 = {|<time datetime="|} ^ x ^ {|">|} ^ x ^ "</time>" 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
|
||||
"<article><header><dl>"
|
||||
^ 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: " text.id
|
||||
^ {|</dl></header><pre style="white-space:pre-wrap">|} in
|
||||
wrap conversion htm text.title ((T.of_string text.body header) ^ "</pre></article>")
|
||||
let open Logarion in
|
||||
let open Text in
|
||||
let module T = Parsers.Plain_text.Make (HtmlConverter) 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 "<dt>" ^ key ^ "<dd>" ^ 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 = {|<time datetime="|} ^ x ^ {|">|} ^ x ^ "</time>" 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
|
||||
"<article><header><dl>"
|
||||
^ 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: " text.id
|
||||
^ {|</dl></header><pre style="white-space:pre-wrap">|} in
|
||||
wrap conversion htm text.title ((T.of_string text.body header) ^ "</pre></article>")
|
||||
|
||||
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 -> Printf.sprintf "%s<li> %s <a href=\"%s.htm\">%s</a>" a
|
||||
Logarion.(Date.(pretty_date (listing m.Text.date)))
|
||||
(Logarion.Text.short_id m) m.Logarion.Text.title)
|
||||
"" 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 -> Printf.sprintf "%s<li> %s <a href=\"%s.htm\">%s</a>" a
|
||||
Logarion.(Date.(pretty_date (listing m.Text.date)))
|
||||
(Logarion.Text.short_id m) m.Logarion.Text.title)
|
||||
"" meta_list
|
||||
|
||||
let date_index ?(limit) conv htm meta_list =
|
||||
match limit with
|
||||
| Some limit -> wrap conv htm "Index" (to_dated_links ~limit meta_list)
|
||||
| None -> wrap conv htm "Index" (to_dated_links meta_list)
|
||||
match limit with
|
||||
| Some limit -> wrap conv htm "Index" (to_dated_links ~limit meta_list)
|
||||
| None -> wrap conv htm "Index" (to_dated_links meta_list)
|
||||
|
||||
let fold_topic_roots topic_roots =
|
||||
let list_item root t = "<li>" ^ topic_link root t in
|
||||
"<nav><h2>Main topics</h2>"
|
||||
^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
|
||||
^ "</ul></nav>"
|
||||
let list_item root t = "<li>" ^ topic_link root t in
|
||||
"<nav><h2>Main topics</h2>"
|
||||
^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
|
||||
^ "</ul></nav>"
|
||||
|
||||
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) "<ul>" topic
|
||||
^ "</ul>"
|
||||
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
|
||||
"<li>" ^ item ^ sub_items root t
|
||||
in
|
||||
"<nav><h2>Topics</h2>"
|
||||
^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
|
||||
^ "</ul></nav>"
|
||||
let open Logarion in
|
||||
let rec unordered_list root topic =
|
||||
List.fold_left (fun a x -> a ^ list_item root x) "<ul>" topic
|
||||
^ "</ul>"
|
||||
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
|
||||
"<li>" ^ item ^ sub_items root t
|
||||
in
|
||||
"<nav><h2>Topics</h2>"
|
||||
^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
|
||||
^ "</ul></nav>"
|
||||
|
||||
let text_item path meta =
|
||||
let open Logarion in
|
||||
"<time>" ^ Date.(pretty_date (listing meta.Text.date))
|
||||
^ {|</time> <a href="|} ^ path ^ Text.short_id meta ^ {|.htm">|} ^ meta.Text.title
|
||||
^ "</a><br>"
|
||||
let open Logarion in
|
||||
"<time>" ^ Date.(pretty_date (listing meta.Text.date))
|
||||
^ {|</time> <a href="|} ^ path ^ Text.short_id meta ^ {|.htm">|} ^ meta.Text.title
|
||||
^ "</a><br>"
|
||||
|
||||
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 -> {|<h2 id="|} ^ topic ^ {|">|} ^ String.capitalize_ascii topic ^ "</h2>" ^ x
|
||||
in
|
||||
"<nav><h1>Texts</h1>" ^ item_group topic_roots ^ "</nav>"
|
||||
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 -> {|<h2 id="|} ^ topic ^ {|">|} ^ String.capitalize_ascii topic ^ "</h2>" ^ x
|
||||
in
|
||||
"<nav><h1>Texts</h1>" ^ item_group topic_roots ^ "</nav>"
|
||||
|
||||
let topic_main_index conv htm topic_roots metas =
|
||||
wrap conv htm "Topics"
|
||||
(fold_topic_roots topic_roots
|
||||
^ "<nav><h1>Latest</h1><ul>" ^ to_dated_links ~limit:8 metas
|
||||
^ {|</ul><a href="index.date.htm">More by date</a>|}
|
||||
^ let peers = Logarion.Store.KV.find "Peers" conv.kv in
|
||||
(if peers = "" then "" else
|
||||
List.fold_left (fun a s -> Printf.sprintf {|%s<li><a href="%s">%s</a>|} a s s) "<h1>Peers</h1><ul>"
|
||||
(Str.split (Str.regexp ";\n") (Logarion.Store.KV.find "Peers" conv.kv))
|
||||
^ "</ul>"))
|
||||
wrap conv htm "Topics"
|
||||
(fold_topic_roots topic_roots
|
||||
^ "<nav><h1>Latest</h1><ul>" ^ to_dated_links ~limit:8 metas
|
||||
^ {|</ul><a href="index.date.htm">More by date</a>|}
|
||||
^ let peers = Logarion.Store.KV.find "Peers" conv.kv in
|
||||
(if peers = "" then "" else
|
||||
List.fold_left (fun a s -> Printf.sprintf {|%s<li><a href="%s">%s</a>|} a s s) "<h1>Peers</h1><ul>"
|
||||
(Str.split (Str.regexp ";\n") (Logarion.Store.KV.find "Peers" conv.kv))
|
||||
^ "</ul>"))
|
||||
|
||||
let topic_sub_index conv htm topic_map topic_root metas =
|
||||
wrap conv htm topic_root
|
||||
(fold_topics topic_map [topic_root] metas
|
||||
(* ^ {|<a href=".atom" id="feed">|}^ String.capitalize_ascii topic_root ^{| feed </a>|}*)
|
||||
^ listing_index topic_map [topic_root] "" metas)
|
||||
wrap conv htm topic_root
|
||||
(fold_topics topic_map [topic_root] metas
|
||||
(* ^ {|<a href=".atom" id="feed">|}^ String.capitalize_ascii topic_root ^{| feed </a>|}*)
|
||||
^ listing_index topic_map [topic_root] "" metas)
|
||||
|
||||
open Logarion
|
||||
let indices htm c =
|
||||
|
|
|
|||
Loading…
Reference in New Issue