◊(Local Yarn Code "Diff")

#lang racket/base

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

;; Tag functions used by pollen.rkt when HTML is the output format.
;; Pollen “tag functions” that return elements of a Yarn AST. This AST can be
;; rendered into HTML or other formats (using, e.g., the yarn/render/html module).

(require (for-syntax racket/base racket/syntax))
(require racket/list
         racket/function
         racket/draw
         racket/class
         pollen/decode
(require pollen/decode
         pollen/tag
         pollen/setup
         pollen/core
         net/uri-codec
         txexpr
         "dust.rkt")
         "index.rkt"
         "string.rkt"
         "tools.rkt")

(provide html-fn
(provide (all-defined-out))
         html-fndef)

;; Customized paragraph decoder replaces single newlines within paragraphs
;; with single spaces instead of <br> tags. Allows for “semantic line wrapping”.
(define (decode-hardwrapped-paragraphs xs)
  (define (no-linebreaks xs)
    (decode-linebreaks xs " "))
  (decode-paragraphs xs #:linebreak-proc no-linebreaks))

;; Yarn AST:
;; A shortcut macro: lets me define a whole lot of tag functions of the form:
;;  (define html-p (default-tag-function 'p)
;;  (document Block-Contents)
(define-syntax (provide/define-html-default-tags stx)
  (syntax-case stx ()
    [(_ TAG ...)
     (let ([tags (syntax->list #'(TAG ...))])
       (with-syntax ([((HTML-TAG-FUNC HTML-TAG) ...)
                      (for/list ([htag (in-list tags)])
                        (list (format-id stx "html-~a" (syntax-e htag)) (syntax-e htag)))])
         #'(begin
             (provide HTML-TAG-FUNC ...)
             (define HTML-TAG-FUNC (default-tag-function 'HTML-TAG)) ...)))]))

;;  Footnote definitions, index entry keys are stored in the metas
;; Here we go:
(provide/define-html-default-tags p
                                  b
                                  strong

;;  Block-Content := 
                                  i
                                  em
;;    (heading #:level Inline-Contents)
;;    | (paragraph Inline-Contents)
;;    | (thematic-break style)
                                  ol
                                  ul
                                  sup
                                  blockquote
;;    | (codeblock info Inline-Contents)
                                  code)

;;    | (blockquote items := (item Block-Contents))
(provide html-root
         html-title
;;    | (poetry title style Block-Contents)
         html-excerpt
         html-excerpt*
         html-item
;;    | (itemization style start Block-Contents)
         html-section
         html-subsection
         html-newthought
         html-sep
         html-caps
         html-mono
         html-center
;;    | (dialogue speeches := (speech interlocutor Block-Contents))
         html-strike
         html-block
         html-blockcode
         html-index
         html-figure
;;    | (figure source caption)
         html-figure-@2x
         html-image-link
         html-dialogue
         html-say
         html-saylines
         html-magick
         html-verse
         html-attrib
         html-link
         html-xref
;;    | (margin-note Block-Contents)
         html-url
         html-fn
         html-fndef
         html-note-with-srcline)

(define html-item (default-tag-function 'li))
(define html-section (default-tag-function 'h2))
(define html-subsection (default-tag-function 'h3))
(define html-newthought (default-tag-function 'span #:class "newthought"))
(define (html-sep) '(hr [[class "sep"]]))
(define html-caps (default-tag-function 'span #:class "caps"))
(define html-center (default-tag-function 'div #:style "text-align: center"))
(define html-strike (default-tag-function 'span #:style "text-decoration: line-through"))
(define html-dialogue (default-tag-function 'dl #:class "dialogue"))
(define html-mono (default-tag-function 'samp))

;;  Inline-Content :=
(define (html-block . elements)
  `(section [[class "content-block"]] (div [[class "content-block-main"]] ,@elements)))

;;    string?
(define (html-root . elements)
  (invalidate-series)
  (define first-pass
;;    | (italic Inline-Contents)
;;    | (bold Inline-Contents)
    (decode-elements (append elements (list (html-footnote-block)))
                     #:txexpr-elements-proc decode-hardwrapped-paragraphs
                     #:exclude-tags '(script style figure table pre)))
  (define second-pass
;;    | (link destination Inline-Contents)
;;    | (monospace Inline-Contents)
    (decode-elements first-pass
                     #:block-txexpr-proc detect-newthoughts
                     #:inline-txexpr-proc decode-link-urls
                     #:exclude-tags '(script style pre code)))
;;    | (strikethrough Inline-Contents)
;;    | (caps Inline-Contents)
;;    | (image description source)
  `(body ,@second-pass))

;;    | (xref type dest-key Inline-Contents)
(define (html-title . elements) `(title ,@elements))
(define (html-excerpt . elements) `(excerpt ,@elements))
(define (html-excerpt* . elements) `(excerpt* ,@elements))

(define (html-blockcode attrs elems)
;;    | (footnote-ref label)
;;    | line-break
  (define file (or (assoc 'filename attrs) ""))
  (define codeblock `(pre [[class "code"]] (code ,@elems)))
  (cond [(string>? file "") `(@ (div [[class "listing-filename"]] 128196 " " ,file) ,codeblock)]
        [else codeblock]))

(define (html-index attrs elems)
(define blocks-elements
  (define index-key (maybe-attr 'key attrs (tx-strs `(span ,@elems))))
  `(a [[id ,(here-id (list "_idx-" (uri-encode index-key)))]
       [href ,(string-append "/keyword-index.html#" (uri-encode (string-downcase index-key)))]
       [data-index-entry ,index-key]
       [class "index-link"]]
      ,@elems))

  '(heading
;; To be used within ◊dialogue
(define (html-say . elems)
  `(@ (dt ,(car elems) (span [[class "x"]] ": ")) (dd ,@(cdr elems))))

;; Same as ◊say, but preserve linebreaks
    paragraph
    thematic-break
(define (html-saylines . elems)
  (apply html-say (decode-linebreaks elems)))

    codeblock
(define (html-verse attrs elems)
  (let* ([title  (maybe-attr 'title attrs "")]
         [italic? (assoc 'italic? attrs)]
         [pre-attrs (cond [italic? '([class "verse"] [style "font-style: italic"])]
                          [else '([class "verse"])])]
         [pre-title (cond [(string>? title "") `(p [[class "verse-heading"]] ,title)]
                          [else ""])])
    `(div [[class "poem"]] ,pre-title (pre ,pre-attrs ,@elems))))

    blockquote
(define (html-magick . elems)
  (txexpr
    poetry
   'div '([class "antique"])
   (decode-elements
    elems
    #:string-proc
    itemization
    dialogue
    (λ (s) (regexp-replace* #px"(?<!f)s(?![fkb\\s”,;.’:\\!\\?]|$)" s "ſ")))))

(module+ test
    figure
    margin-note))
  (require rackunit)
  ; always round s at the end of a word
  (check-equal? (html-magick "mirrors? yes, it is") '(div [[class "antique"]] "mirrors? yes, it is"))
  ; always round s before/after f
  (check-equal? (html-magick "offset, satisfaction") '(div [[class "antique"]] "offset, ſatisfaction"))
  ; always LONG s before hyphen
  (check-equal? (html-magick "Shafts-bury") '(div [[class "antique"]] "Shaftſ-bury"))
  ; always round s before k or b (17th-century rules)
  (check-equal? (html-magick "ask, husband") '(div [[class "antique"]] "ask, husband"))
  ; always LONG s everywhere else
  (check-equal? (html-magick "song, substitutes") '(div [[class "antique"]] "ſong, ſubſtitutes")) 

  ;; Nested elements
  (check-equal?
(define inline-elements
  '(italic
   (html-magick '(root "This is " (a [[href "class"]] (b "song, substitutes"))))
   '(div [[class "antique"]] (root "This is " (a [[href "class"]] (b "ſong, ſubſtitutes"))))))

    bold
(define html-attrib (default-tag-function 'div #:class "attrib"))

;; (Private) Get the dimensions of an image file
(define (get-image-size filepath)
  (define bmp (make-object bitmap% filepath))
    link
    image
    xref
    footnote-ref
    line-break))
  (list (send bmp get-width) (send bmp get-height)))

;; (Private) Builds a path to an image in the [image-dir] subfolder of the current document's 
;; folder, relative to the current document’s folder
(define (image-source basename)
(define (title . t) (set-meta 'title t) (set-meta 'title-supplied? #t) "")
  (define here-path (string->path (maybe-meta 'here-path)))
  (define-values (_ here-rel-path-parts)
(define (section . s) `(heading [[level "2"]] ,@s))
    (drop-common-prefix (explode-path (current-project-root))
                        (explode-path here-path)))
  (let* ([folder-parts (drop-right here-rel-path-parts 1)]
         [img-path-parts (append folder-parts (list images-folder basename))]
         [img-path (apply build-path/convention-type 'unix img-path-parts)])
    (path->string img-path)))

(define (html-figure-@2x . elems)
  (define src (image-source (car elems)))
(define (subsection . s) `(heading [[level "3"]] ,@s))
(define (excerpt . e) (set-meta 'excerpt e))
(define (excerpt* . e) (apply excerpt e) `(@ ,@e))
  (define alt-text (tx-strs `(span ,@(cdr elems))))
  (define img-width (car (get-image-size (build-path (current-project-root) src))))
  (define style-str (format "width: ~apx" (/ img-width 2.0)))
  `(figure (img [[alt ,alt-text] [style ,style-str] [src ,(string-append web-root src)]])
           (figcaption ,@(cdr elems))))

(define (html-figure . elems)
(define (pause [type 'blank]) `(thematic-break ,type)) ; type = blank | mark
  (define src (string-append web-root (image-source (car elems))))
  (define alt-text (tx-strs `(span ,@(cdr elems))))
  `(figure [[class "fullwidth"]]
           (img [[alt ,alt-text] [src ,src]])
           (figcaption ,@(cdr elems))))

;; Simple link to an image
(define (html-image-link . elems)
  (define src (image-source (car elems)))
  (define title (tx-strs `(span ,@(cdr elems))))
(define codeblock (default-tag-function 'codeblock #:info ""))
(define blockquote (default-tag-function 'blockquote)) ; #:caption
(define figure (default-tag-function 'figure))
  `(a [[href ,(string-append web-root src)] [title ,title]] ,@(cdr elems)))

;; There is no way in vanilla CSS to create a selector for “p tags that contain
;; a span of class ‘newthought’”. So we can handle it at the Pollen processing level.
(define (detect-newthoughts block-xpr)
  (define (is-newthought? tx) ; Helper function
(define (i . inline) `(italic ,@inline))
(define em i)
(define (b . inline) `(bold ,@inline))
    (and (txexpr? tx)
         (eq? 'span (get-tag tx))
         (attrs-have-key? tx 'class)
         (string=? "newthought" (attr-ref tx 'class))))
  (if (and (eq? (get-tag block-xpr) 'p)
           (is-newthought? (first (get-elements block-xpr))))
      (attr-set block-xpr 'class "pause-before")
      block-xpr))

(define (mono . inline) `(monospace ,@inline))
;; Links
;;
;; Private use:
(define all-link-urls (make-hash))

(define (caps . inline) `(caps ,@inline))
(define (strike . inline) `(strikethrough ,@inline))
;; Provided tag functions:
(define (html-link . args)
(define br 'line-break)
  `(link& [[ref ,(format "~a" (first args))]] ,@(rest args)))

(define (html-url ref url)
  (define page-path (hash-ref (current-metas) 'here-path))
(define (link ref . elems) `(link ,ref ,@elems))
(define (url ref URL) (update-metas-subhash 'urls ref URL) "")
  (define page-link-urls (hash-ref! all-link-urls page-path make-hash))
  (hash-set! page-link-urls (format "~a" ref) url) "")

;; Private use (by html-root):
(define (decode-link-urls tx)
(define (xref type elems k)
  (define page-path (hash-ref (current-metas) 'here-path))
  (define page-link-urls (hash-ref! all-link-urls page-path make-hash))
  (cond [(eq? (get-tag tx) 'link&)
         (let* ([url-ref (attr-ref tx 'ref)]
                [url (or (hash-ref page-link-urls url-ref #f)
                         (format "Missing reference: ~a" url-ref))])
           `(a [[href ,url]] ,@(get-elements tx)))]
        [else tx]))

  (define key (or k (normalize-key (->text elems))))
;; Fast link to another article
(define html-xref
  (case-lambda
    [(title) `(a [[href ,(format "~aarticles/~a.html" web-root (normalize title))]
                  [class "xref"]]
  (cons-to-metas-list 'xref-keys key)
                 (i ,title))]
    [elems `(a [[href ,(format "~aarticles/~a.html" web-root (first elems))]
                [class "xref"]]
               ,@(rest elems))]))
  `(xref ,type ,key ,@elems))

;; Footnotes
;;
;; Private use:
(define all-fn-names (make-hash))
(define (pin #:key [key #f] . elems) (xref 'idx elems key))
(define all-fn-definitions (make-hash))
(define (fn-id x) (here-id (string-append x "_fn")))
(define (fndef-id x) (here-id (string-append x "_fndef")))

(define (def #:key [key #f] . elems) (xref 'def elems key))
;; Provided footnote tag functions:
(define (html-fn . args)
(define (ref #:key [key #f] . elems) (xref 'ref elems key))
  (define name (format "~a" (first args)))
  (define page-path (hash-ref (current-metas) 'here-path))
  (define page-fn-names (cons name (hash-ref! all-fn-names page-path '())))
  (hash-set! all-fn-names page-path page-fn-names)
  

  (let* ([def-anchorlink (string-append "#" (fndef-id name))]
         [nth-ref        (number->string (count (curry string=? name) page-fn-names))]
         [ref-id         (string-append (fn-id name) nth-ref)]
         [fn-number      (+ 1 (index-of (remove-duplicates (reverse page-fn-names)) name))]
         [ref-text       (format "(~a)" fn-number)])
    (cond [(empty? (rest args)) `(sup (a [[href ,def-anchorlink] [id ,ref-id]] ,ref-text))]
          [else `(span [[class "links-footnote"] [id ,ref-id]]
(define (fn ref) `(footnote-ref ,ref))
                       ,@(rest args)
                       (sup (a [[href ,def-anchorlink]] ,ref-text)))])))
(define (fndef ref . elems) (update-metas-subhash 'footnote-defs ref elems) "")

(define (html-fndef . elems)
  (define page-path (hash-ref (current-metas) 'here-path))
  (define page-fn-defs (hash-ref! all-fn-definitions page-path make-hash))
(define (ol . elems) `(itemization [[start "1"]] ,@elems))     ; #:style
(define (ul . elems) `(itemization ,@elems))       ; #:style
(define (item . blocks) `(item ,@blocks))
  (hash-set! page-fn-defs (format "~a" (first elems)) (rest elems)))

;; Private use (by html-root)
(define (html-footnote-block)
  (define page-path (hash-ref (current-metas) 'here-path))
(define (dialogue . speeches) `(dialogue ,@speeches))
(define (say interlocutor elems) `(speech ,interlocutor ,@elems))
  (define page-fn-names (hash-ref! all-fn-names page-path '()))
  (define page-fn-defs (hash-ref! all-fn-definitions page-path (make-hash)))
  (define note-items
(define (saylines interlocutor elems)
    (for/list ([fn-name (in-list (remove-duplicates (reverse page-fn-names)))])
      (let* ([definition-text (or (hash-ref page-fn-defs fn-name #f)
                                  '((i "Missing footnote definition!")))]
             [backref-count (count (curry string=? fn-name) page-fn-names)]
             [backrefs (for/list ([fnref-num (in-range backref-count)])
                         `(a [[href ,(string-append "#"
                                                    (fn-id fn-name)
                                                    (format "~a" (+ 1 fnref-num)))]] "↩"))])
        `(li [[id ,(fndef-id fn-name)]] ,@definition-text ,@backrefs))))
  (cond [(null? note-items) ""]
        [else `(section ((class "footnotes")) (hr) (ol ,@note-items))]))
  `(speech ,interlocutor ,@(decode-linebreaks elems 'line-break)))

(define (html-note-with-srcline attrs elems)
  (txexpr 'note attrs (decode-hardwrapped-paragraphs elems)))
(define verse (default-tag-function 'poetry)) ; #:title, #:style