#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
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 html-note) (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 (html-root . 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 (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 (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))])) (define (html-note attrs elems) (txexpr 'note attrs (decode-paragraphs elems #:force? #t)))