◊(Local Yarn Code "snippets-html.rkt at [e52e53c8]")

File snippets-html.rkt artifact f524862a part of check-in e52e53c8


#lang pollen/mode racket/base

; SPDX-License-Identifier: BlueOak-1.0.0
; This file is licensed under the Blue Oak Model License 1.0.0.

;; Provides functions for displaying content in HTML templates.
(require pollen/core
         pollen/template
         pollen/decode
         pollen/private/version
         racket/string
         racket/function
         racket/list
         txexpr
         openssl/sha1
         "cache.rkt"
         "dust.rkt")

(provide html$-page-head
         html$-page-body-open
         html$-series-list
         html$-article-open
         html$-article-close
         html$-article-listing-short
         html$-page-footer
         html$-page-body-close
         html$-note-contents
         html$-note-listing-full
         html$-note-in-article
         html$-notes-section
         html$-paginate-navlinks)

(define (html$-page-head [title #f] [close-head? #t])
  ◊string-append{<head>
 <title>◊if[title title ""] </title>
 <meta charset="utf-8" />
 <meta name="viewport" content="width=device-width, initial-scale=1">
 <meta name="generator" content="Racket ◊(version) + Pollen ◊|pollen:version|">
 <link rel="stylesheet" type="text/css" href="/web-extra/martin.css">
 ◊if[close-head? "</head>" ""]})

(define (html$-page-body-open [class ""])
  (define body-class (if (non-empty-string? class) (format " class=\"~a\"" class) ""))
  ◊string-append{<body◊|body-class|><main>
 <a href="/index.html"><header>
 <img src="/web-extra/mark.svg" alt="The Local Yarn" height="103" class="logo">
 <h1>The Local Yarn</h1>
 </header></a>})

(define (html$-article-open pagenode title? title-tx published)
  (cond
    [title?
     ◊string-append{<article class="with-title hentry">
      ◊(->html `(h1 [[class "entry-title"]] ,@(get-elements title-tx)))
      <p class="time"><a href="/◊(symbol->string pagenode)" class="rel-bookmark">
      <time datetime="◊published" class="published">◊ymd->english[published]</time>
      </a></p>
      <section class="entry-content">}]
    [else
     ◊string-append{<article class="no-title hentry">
      <h1><a href="/◊(symbol->string pagenode)" class="rel-bookmark">
      <time datetime="◊published" class="entry-title">◊ymd->english[published]</time>
      </a></h1>
      <section class="entry-content">}]))

(define (html$-article-close footertext)
  (cond [(non-empty-string? footertext)
         ◊string-append{</section>
          <footer class="article-info"><span class="x">(</span>◊|footertext|<span class="x">)</span></footer>
          </article>}]
        [else "</section></article>"]))

(define (html$-article-listing-short pagenode pubdate title)
  ◊string-append{
 <li><a href="/◊(symbol->string pagenode)">
 <div class="article-list-date caps">◊(ymd->english pubdate)</div>
 <div class="article-list-title">◊|title|</div>
 </a></li>})

(define (html$-page-footer)
  ◊string-append{
<footer id="main">
 <p class="title">The Local Yarn</p>
 <nav><a href="/">Home</a> •
    <a href="/blog-pg1.html">Blog</a> •
    <a href="/keyword-index.html">Keyword Index</a> •
    <a href="/code"><i><code>◊"◊"(Source&nbsp;Code)</code></i></a>
 </nav>
 ◊(html$-series-list)
 </footer>})

(define (html$-page-body-close)
  ◊string-append{
 </main>
 ◊(html$-page-footer)
 </body>})

;; Notes
;;
(define (html$-note-contents disposition-mark disposition-verb elems)
  (define disposition
    (cond [(non-empty-string? disposition-mark)
           `(abbr [[class "disposition-mark-in-note"]
                   [title ,(string-append "The original article is herewith considered "
                                          disposition-verb)]]
                  ,disposition-mark)]
          [else ""]))
  (define body-elems
    (cond
      [(and (block-txexpr? (car elems)) (non-empty-string? disposition-mark))
       (define-values (first-tag first-attrs first-elems) (txexpr->values (car elems)))
       (cons (txexpr first-tag first-attrs (cons disposition first-elems)) (cdr elems))]
      [else
       (cons disposition elems)]))
  (string-append* (map ->html body-elems)))

(define (html$-note-listing-full pagenode note-id title-html-flow date contents [author default-authorname] [author-url ""])
  (define author-part
    (cond [(non-empty-string? author-url)
           ◊string-append{
            <div class="note-meta">
            &mdash;<a class="u-author h-card" href="◊|author-url|"><i>◊|author|</i></a>
            </div>}]
          [else ◊string-append{
            <div class="note-meta">
            &mdash;<span class="h-card"><i>◊|author|</i></span>
            </div>}]))
  (define maybe-author-class
    (cond [(string=? author default-authorname) "by-proprietor"]
          [else ""]))
  
  ◊string-append{
 <article class="with-title ◊maybe-author-class hentry">
 <h1 class="entry-title note-full">◊|title-html-flow|</h1>
 <p class="time"><a href="/◊(symbol->string pagenode)#◊note-id" class="rel-bookmark note-permlink">
 <time datetime="◊date">◊ymd->english[date]</time>
 </a></p>
 <section class="entry-content">
 <div class="p-content p-name">◊|contents|</div>
 ◊author-part
 </section>
 </article>})

(define (html$-note-in-article id date contents author author-url)
  (define maybe-author-class?
    (cond [(or (string=? author default-authorname) (string=? author "")) "by-proprietor"]
          [else ""]))
  (define author-part
    (cond [(non-empty-string? author-url)
           ◊string-append{<a class="u-author h-card" href="◊author-url"><i>◊|author|</i></a>}]
          [else
           ◊string-append{<span class="h-card"><i>◊|author|</i></span>}]))

  ◊string-append{<div class="note ◊maybe-author-class? u-comment" id="◊|id|">
 <h3><a class="rel-bookmark note-permlink" href="#◊|id|"><time class="dt-published" datetime="◊date">◊ymd->english[date]</time>
 </a></h3>
 <div class="p-content p-name">
 ◊contents
 </div>
 <div class="note-meta">
 &mdash;◊author-part
 </div>
 </div>})

(define (html$-notes-section note-htmls)
  ◊string-append{<div class="further-notes" id="furthernotes">
 <h2>Further Notes</h2>
 ◊(apply string-append note-htmls)
 </div>})

;; (private) Returns HTML for a list-item link to a particular page in a set of numbered pages
(define (html$-paginate-link basename pagenum [linktext (number->string pagenum)] [class ""])
  (define cstr (if (non-empty-string? class) (format " class=\"~a\"" class) ""))
  (format "<li~a><a href=\"/~a-pg~a.html\">~a</a></li>" cstr basename pagenum linktext))

;; Returns HTML for a series of list items with links to numbered pages
(define (html$-paginate-navlinks pagenum pagecount basename)
  (define slots 9)
  (define on-first-group? (<= pagenum (- slots 4)))
  (define on-last-group? (>= pagenum (- pagecount slots -4)))
  (define only-one-group? (<= pagecount slots))
  (define group-start (- pagenum (quotient (- slots 4) 2))) ; not always used!
  (define page-func (curry html$-paginate-link basename))

  (define page-group-syms
    (cond [only-one-group?
           `(,@(range 1 (+ 1 pagecount)))]
          [on-first-group?
           `(,@(range 1 (min (+ 1 pagecount) (- slots 1))) "..." ,pagecount)]
          [on-last-group?
           `(1 "..." ,@(range (- pagecount slots -3) (+ pagecount 1)))]
          [else
           `(1
             "..."
             ,@(range group-start (min (+ 1 pagecount) (+ group-start (- slots 4))))
             "..."
             ,pagecount)]))
 
  (define page-group
    (for/list ([psym (in-list page-group-syms)])
      (cond
        [(and (number? psym) (equal? psym pagenum))
         (format "<li class=\"current-page\">~a</li>" psym)]
        [(number? psym) (page-func psym)]
        [else "<li>&#8230;</li>"])))
  
  (define prev-link
    (if (eq? 1 pagenum)
        "<li class=\"nav-text inactive-link\">&larr;Newer</li>"
        (page-func (- pagenum 1) "&larr;&thinsp;Newer" "nav-text")))

  (define next-link
    (if (eq? pagecount pagenum)
        "<li class=\"nav-text inactive-link\">Older&rarr;</li>"
        (page-func (+ pagenum 1) "Older&thinsp;&rarr;" "nav-text")))

  (string-join `(,prev-link ,@page-group ,next-link)))

(define (series->txpr s)
  `(li (a [[href ,(symbol->string (cache:series-page s))]]
          (i ,(cache:series-title s)))))

(define (html$-series-list)
  (define series-list-items
    (for/list ([group (in-list (series-grouped-list))])
      `(div (h2 ,(cache:series-noun-plural (first group))) (ul ,@(map series->txpr group)))))
  (->html `(section [[class "column-list"] [style "margin-top: 1.3rem"]] ,@series-list-items)))