Changeset 18 in code for trunk/cli/html.ml


Ignore:
Timestamp:
Oct 22, 2022, 8:55:08 PM (2 years ago)
Author:
fox
Message:

Omit bullet in empty title conversions, tidy html.ml

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/cli/html.ml

    r15 r18  
    88let init kv =
    99        let open Logarion in
    10         let header = match  Store.KV.find "HTM-header" kv with
     10        let to_string key kv = match Store.KV.find key kv with
    1111                | fname -> Some (File_store.to_string fname)
    1212                | exception Not_found -> None in
    13         let footer = match  Store.KV.find "HTM-footer" kv with
    14                 | fname -> Some (File_store.to_string fname)
    15                 | exception Not_found -> None in
     13        let header = to_string "HTM-header" kv in
     14        let footer = to_string "HTM-footer" kv in
    1615        { templates = { header; footer} }
    1716
    … …  
    2827                "</a><nav><a href='feed.atom' id='feed'>feed</a></nav></header>"
    2928        in
    30         let footer = match htm.templates.footer with  None -> "" | Some x -> replace x in
    31   "<!DOCTYPE HTML><html><head><title>" ^ text_title ^ " • " ^ site_title ^ "</title>\n\
    32   <link rel='stylesheet' href='main.css'>\
    33   <link rel='alternate' href='feed.atom' type='application/atom+xml'>\
    34   <meta charset='utf-8'/><meta name='viewport' content='width=device-width, initial-scale=1.0'>\
    35   </head><body>\n" ^ header ^ body ^ footer ^ "</body></html>"
     29        let footer = match htm.templates.footer with None -> "" | Some x -> replace x in
     30        Printf.sprintf "<!DOCTYPE HTML><html><head><title>%s%s</title>\n\
     31        <link rel='stylesheet' href='main.css'>\
     32        <link rel='alternate' href='feed.atom' type='application/atom+xml'>\
     33        <meta charset='utf-8'/><meta name='viewport' content='width=device-width, initial-scale=1.0'>\
     34        </head><body>\n%s%s%s</body></html>"
     35        text_title (if site_title <> "" then (" • " ^ site_title) else "")
     36        header body footer
    3637
    3738let topic_link root topic =
    38   let replaced_space = String.map (function ' '->'+' | x->x) in
    39   "<a href='index." ^ root ^ ".htm#" ^ replaced_space topic ^ "'>"
    40   ^ String.capitalize_ascii topic ^ "</a>"
     39        let replaced_space = String.map (function ' '->'+' | x->x) in
     40        "<a href='index." ^ root ^ ".htm#" ^ replaced_space topic ^ "'>"
     41        ^ String.capitalize_ascii topic ^ "</a>"
    4142
    4243module HtmlConverter = struct
    … …  
    4748
    4849let page htm conversion text =
    49   let open Logarion in
    50   let open Text in
    51   let module T = Parsers.Plain_text.Make (HtmlConverter) in
    52   let sep_append ?(sep=", ") a x = match a,x with "",_ -> x | _, "" -> a | _ -> a ^ sep ^ x in
    53   let opt_kv key value = if String.length value > 0
    54         then "<dt>" ^ key ^ "<dd>" ^ value else "" in
    55 (*  let author acc auth = sep_append acc Person.(auth.name ^ " ") in*)
    56   let authors = (Person.Set.to_string text.authors ^ " ") in
    57   let keywords = str_set "keywords" text in
    58   let header =
    59     let time x = {|<time datetime="|} ^ x ^ {|">|} ^ x ^ "</time>" in
    60     let topic_links x =
    61       let to_linked t a =
    62         let ts = Topic_set.of_string t in
    63         sep_append a (List.fold_left (fun a t -> sep_append ~sep:" > " a (topic_link (List.hd ts) t)) "" ts) in
    64       String_set.fold to_linked x "" in
    65     "<article><header><dl>"
    66     ^ opt_kv "Title:" text.title
    67     ^ opt_kv "Authors:" authors
    68     ^ opt_kv "Date: " (time (Date.(pretty_date @@ listing text.date)))
    69     ^ opt_kv "Series: " (str_set "series" text)
    70     ^ opt_kv "Topics: " (topic_links (set "topics" text))
    71     ^ opt_kv "Keywords: " keywords
    72     ^ opt_kv "Id: " text.id
    73     ^ {|</dl></header><pre style="white-space:pre-wrap">|} in
    74   wrap conversion htm text.title ((T.of_string text.body header) ^ "</pre></article>")
     50        let open Logarion in
     51        let open Text in
     52        let module T = Parsers.Plain_text.Make (HtmlConverter) in
     53        let sep_append ?(sep=", ") a x = match a,x with "",_ -> x | _, "" -> a | _ -> a ^ sep ^ x in
     54        let opt_kv key value = if String.length value > 0
     55                then "<dt>" ^ key ^ "<dd>" ^ value else "" in
     56(*      let author acc auth = sep_append acc Person.(auth.name ^ " ") in*)
     57        let authors = (Person.Set.to_string text.authors ^ " ") in
     58        let keywords = str_set "keywords" text in
     59        let header =
     60                let time x = {|<time datetime="|} ^ x ^ {|">|} ^ x ^ "</time>" in
     61                let topic_links x =
     62                        let to_linked t a =
     63                                let ts = Topic_set.of_string t in
     64                                sep_append a (List.fold_left (fun a t -> sep_append ~sep:" > " a (topic_link (List.hd ts) t)) "" ts) in
     65                        String_set.fold to_linked x "" in
     66                "<article><header><dl>"
     67                ^ opt_kv "Title:" text.title
     68                ^ opt_kv "Authors:" authors
     69                ^ opt_kv "Date: " (time (Date.(pretty_date @@ listing text.date)))
     70                ^ opt_kv "Series: " (str_set "series" text)
     71                ^ opt_kv "Topics: " (topic_links (set "topics" text))
     72                ^ opt_kv "Keywords: " keywords
     73                ^ opt_kv "Id: " text.id
     74                ^ {|</dl></header><pre style="white-space:pre-wrap">|} in
     75        wrap conversion htm text.title ((T.of_string text.body header) ^ "</pre></article>")
    7576
    7677let to_dated_links ?(limit) meta_list =
    77   let meta_list = match limit with
    78     | None -> meta_list
    79     | Some limit->
    80        let rec reduced acc i = function
    81          | [] -> acc
    82          | h::t -> if i < limit then reduced (h::acc) (i+1) t else acc in
    83        List.rev @@ reduced [] 0 meta_list
    84   in
    85   List.fold_left
    86     (fun a m -> Printf.sprintf "%s<li> %s <a href=\"%s.htm\">%s</a>" a
    87       Logarion.(Date.(pretty_date (listing m.Text.date)))
    88       (Logarion.Text.short_id m) m.Logarion.Text.title)
    89     "" meta_list
     78        let meta_list = match limit with
     79                | None -> meta_list
     80                | Some limit->
     81                        let rec reduced acc i = function
     82                                | [] -> acc
     83                                | h::t -> if i < limit then reduced (h::acc) (i+1) t else acc in
     84                        List.rev @@ reduced [] 0 meta_list
     85        in
     86        List.fold_left
     87                (fun a m -> Printf.sprintf "%s<li> %s <a href=\"%s.htm\">%s</a>" a
     88                        Logarion.(Date.(pretty_date (listing m.Text.date)))
     89                        (Logarion.Text.short_id m) m.Logarion.Text.title)
     90                "" meta_list
    9091
    9192let date_index ?(limit) conv htm meta_list =
    92   match limit with
    93   | Some limit -> wrap conv htm "Index" (to_dated_links ~limit meta_list)
    94   | None -> wrap conv htm "Index" (to_dated_links meta_list)
     93        match limit with
     94        | Some limit -> wrap conv htm "Index" (to_dated_links ~limit meta_list)
     95        | None -> wrap conv htm "Index" (to_dated_links meta_list)
    9596
    9697let fold_topic_roots topic_roots =
    97   let list_item root t = "<li>" ^ topic_link root t in
    98   "<nav><h2>Main topics</h2>"
    99   ^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
    100   ^ "</ul></nav>"
     98        let list_item root t = "<li>" ^ topic_link root t in
     99        "<nav><h2>Main topics</h2>"
     100        ^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
     101        ^ "</ul></nav>"
    101102
    102103let fold_topics topic_map topic_roots metas =
    103   let open Logarion in
    104   let rec unordered_list root topic =
    105     List.fold_left (fun a x -> a ^ list_item root x) "<ul>" topic
    106     ^ "</ul>"
    107   and sub_items root topic = match Topic_set.Map.find_opt topic topic_map with
    108     | None -> ""
    109     | Some (_, subtopics) -> unordered_list root (String_set.elements subtopics)
    110   and list_item root t =
    111     let item =
    112       if List.exists (fun x -> String_set.mem t (String_set.map Topic_set.topic (Text.set "topics" x))) metas
    113       then topic_link root t else String.capitalize_ascii t
    114     in
    115     "<li>" ^ item ^ sub_items root t
    116   in
    117   "<nav><h2>Topics</h2>"
    118   ^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
    119   ^ "</ul></nav>"
     104        let open Logarion in
     105        let rec unordered_list root topic =
     106                List.fold_left (fun a x -> a ^ list_item root x) "<ul>" topic
     107                ^ "</ul>"
     108        and sub_items root topic = match Topic_set.Map.find_opt topic topic_map with
     109                | None -> ""
     110                | Some (_, subtopics) -> unordered_list root (String_set.elements subtopics)
     111        and list_item root t =
     112                let item =
     113                        if List.exists (fun x -> String_set.mem t (String_set.map Topic_set.topic (Text.set "topics" x))) metas
     114                        then topic_link root t else String.capitalize_ascii t
     115                in
     116                "<li>" ^ item ^ sub_items root t
     117        in
     118        "<nav><h2>Topics</h2>"
     119        ^ List.fold_left (fun a x -> a ^ list_item x x) "<ul>" (List.rev topic_roots)
     120        ^ "</ul></nav>"
    120121
    121122let text_item path meta =
    122   let open Logarion in
    123   "<time>" ^ Date.(pretty_date (listing meta.Text.date))
    124   ^ {|</time> <a href="|} ^ path ^ Text.short_id meta ^ {|.htm">|} ^ meta.Text.title
    125   ^ "</a><br>"
     123        let open Logarion in
     124        "<time>" ^ Date.(pretty_date (listing meta.Text.date))
     125        ^ {|</time> <a href="|} ^ path ^ Text.short_id meta ^ {|.htm">|} ^ meta.Text.title
     126        ^ "</a><br>"
    126127
    127128let listing_index topic_map topic_roots path metas =
    128   let rec item_group topics =
    129     List.fold_left (fun acc topic -> acc ^ sub_groups topic ^ items topic) "" topics
    130   and sub_groups topic = match Logarion.Topic_set.Map.find_opt topic topic_map with
    131     | None -> ""
    132     | Some (_, subtopics) -> item_group (Logarion.String_set.elements subtopics)
    133   and items topic =
    134     let items =
    135       let open Logarion in
    136       List.fold_left
    137         (fun a e ->
    138         if String_set.mem topic (String_set.map (Logarion.Topic_set.topic) (Text.set "Topics" e))
    139         then text_item path e ^ a else a) "" metas in
    140     match items with
    141     | "" -> ""
    142     | x -> {|<h2 id="|} ^ topic ^ {|">|} ^ String.capitalize_ascii topic ^ "</h2>" ^ x
    143   in
    144   "<nav><h1>Texts</h1>" ^ item_group topic_roots ^ "</nav>"
     129        let rec item_group topics =
     130                List.fold_left (fun acc topic -> acc ^ sub_groups topic ^ items topic) "" topics
     131        and sub_groups topic = match Logarion.Topic_set.Map.find_opt topic topic_map with
     132                | None -> ""
     133                | Some (_, subtopics) -> item_group (Logarion.String_set.elements subtopics)
     134        and items topic =
     135                let items =
     136                        let open Logarion in
     137                        List.fold_left
     138                                (fun a e ->
     139                                if String_set.mem topic (String_set.map (Logarion.Topic_set.topic) (Text.set "Topics" e))
     140                                then text_item path e ^ a else a) "" metas in
     141                match items with
     142                | "" -> ""
     143                | x -> {|<h2 id="|} ^ topic ^ {|">|} ^ String.capitalize_ascii topic ^ "</h2>" ^ x
     144        in
     145        "<nav><h1>Texts</h1>" ^ item_group topic_roots ^ "</nav>"
    145146
    146147let topic_main_index conv htm topic_roots metas =
    147   wrap conv htm "Topics"
    148     (fold_topic_roots topic_roots
    149      ^ "<nav><h1>Latest</h1><ul>" ^ to_dated_links ~limit:8 metas
    150      ^ {|</ul><a href="index.date.htm">More by date</a>|}
    151      ^ let peers = Logarion.Store.KV.find "Peers" conv.kv in
    152        (if peers = "" then "" else
    153         List.fold_left (fun a s -> Printf.sprintf {|%s<li><a href="%s">%s</a>|} a s s) "<h1>Peers</h1><ul>"
    154         (Str.split (Str.regexp ";\n") (Logarion.Store.KV.find "Peers" conv.kv))
    155         ^ "</ul>"))
     148        wrap conv htm "Topics"
     149                (fold_topic_roots topic_roots
     150                ^ "<nav><h1>Latest</h1><ul>" ^ to_dated_links ~limit:8 metas
     151                ^ {|</ul><a href="index.date.htm">More by date</a>|}
     152                ^ let peers = Logarion.Store.KV.find "Peers" conv.kv in
     153                        (if peers = "" then "" else
     154                                List.fold_left (fun a s -> Printf.sprintf {|%s<li><a href="%s">%s</a>|} a s s) "<h1>Peers</h1><ul>"
     155                                (Str.split (Str.regexp ";\n") (Logarion.Store.KV.find "Peers" conv.kv))
     156                                ^ "</ul>"))
    156157
    157158let topic_sub_index conv htm topic_map topic_root metas =
    158   wrap conv htm topic_root
    159     (fold_topics topic_map [topic_root] metas
    160 (*     ^ {|<a href=".atom" id="feed">|}^ String.capitalize_ascii topic_root ^{| feed </a>|}*)
    161      ^ listing_index topic_map [topic_root] "" metas)
     159        wrap conv htm topic_root
     160                (fold_topics topic_map [topic_root] metas
     161(*              ^ {|<a href=".atom" id="feed">|}^ String.capitalize_ascii topic_root ^{| feed </a>|}*)
     162                ^ listing_index topic_map [topic_root] "" metas)
    162163
    163164open Logarion
Note: See TracChangeset for help on using the changeset viewer.