◊(Local Yarn Code "tags-html.rkt at [5b4bc26c]")

File tags-html.rkt artifact f673367b part of check-in 5b4bc26c


#lang racket/base

;; Copyright (c) 2018 Joel Dueck.
;;
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; A copy of the License is included with this source code, in the
;; file "LICENSE.txt".
;; You may also obtain a copy of the License at
;;
;;       http://www.apache.org/licenses/LICENSE-2.0
;;
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.
;;
;; Author contact information:
;;   joel@jdueck.net
;;   https://joeldueck.com
;; -------------------------------------------------------------------------

;; Tag functions used by pollen.rkt when HTML is the output format.

(require (for-syntax racket/base racket/syntax))
(require racket/list
         racket/function
         pollen/decode
         pollen/tag
         txexpr
         "dust.rkt")

(provide html-fn
         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))

;; A shortcut macro: lets me define a whole lot of tag functions of the form:
;;  (define html-p (default-tag-function 'p)
(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)) ...)))]))

;; Here we go:
(provide/define-html-default-tags p
                                  b
                                  strong
                                  i
                                  em
                                  strike
                                  ol
                                  ul
                                  sup
                                  blockquote
                                  code)

(provide html-root
         html-item
         html-section
         html-subsection
         html-newthought
         html-smallcaps
         html-center
         html-blockcode
         html-verse
         html-link
         html-url
         html-fn
         html-fndef)

(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-smallcaps (default-tag-function 'span #:class "smallcaps"))
(define html-center (default-tag-function 'div #:style "text-align: center"))

(define-tag-function (html-root attrs elements)
  (define first-pass
    (decode-elements elements
                     #:txexpr-elements-proc decode-hardwrapped-paragraphs
                     #:exclude-tags '(script style figure table pre)))
  (define second-pass
    (decode-elements first-pass
                     #:block-txexpr-proc detect-newthoughts
                     #:inline-txexpr-proc decode-link-urls
                     #:string-proc (compose1 smart-quotes smart-dashes)
                     #:exclude-tags '(script style pre code)))
  `(body ,@second-pass ,(html-footnote-block)))

(define-tag-function (html-blockcode attrs elems)
  (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-tag-function (html-verse attrs elems)
  (let* ([title  (or (assoc '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 ,pre-attrs ,pre-title ,@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
    (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))

;; Links
;;
;; Private use:
(define link-urls (make-hash))

;; Provided tag functions:
(define (html-link . args)
  `(link& [[ref ,(format "~a" (first args))]] ,@(rest args)))

(define (html-url ref url)
  (hash-set! link-urls (format "~a" ref) url))

;; Private use (by html-root):
(define (decode-link-urls tx)
  (cond [(eq? (get-tag tx) 'link&)
         (let* ([url-ref (attr-ref tx 'ref)]
                [url (or (hash-ref link-urls url-ref #f)
                         (format "Missing reference: ~a" url-ref))])
           `(a [[href ,url]] ,@(get-elements tx)))]
        [else tx]))

;; Footnotes
;;
;; Private use:
(define fn-names null)
(define fn-definitions (make-hash))
(define (fn-id x) (string-append x "_fn"))
(define (fndef-id x) (string-append x "_fndef"))

;; Provided footnote tag functions:
(define (html-fn . args)
  (define name (format "~a" (first args)))
  (set! fn-names (cons name fn-names))
  (let* ([def-anchorlink (string-append "#" (fndef-id name))]
         [nth-ref        (number->string (count (curry string=? name) fn-names))]
         [ref-id         (string-append (fn-id name) nth-ref)]
         [fn-number      (+ 1 (index-of (remove-duplicates (reverse 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]]
                       ,@(rest args)
                       (sup (a [[href ,def-anchorlink]] ,ref-text)))])))

(define (html-fndef . elems)
  (hash-set! fn-definitions (format "~a" (first elems)) (rest elems)))

;; Private use (by html-root)
(define (html-footnote-block)
  (define note-items
    (for/list ([fn-name (in-list (remove-duplicates (reverse fn-names)))])
              (let* ([definition-text (or (hash-ref fn-definitions fn-name #f)
                                          '((i "Missing footnote definition!")))]
                     [backref-count (count (curry string=? fn-name) 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))]))