ADDED dates.rkt
Index: dates.rkt
==================================================================
--- dates.rkt
+++ dates.rkt
@@ -0,0 +1,33 @@
+#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
+;; -------------------------------------------------------------------------
+
+;; Convenience functions for date strings
+
+(require gregor
+ racket/string)
+
+(provide (all-defined-out))
+
+;; Ignores everything after the first space
+(define (ymd->english ymd-string)
+ (~t (iso8601->date (car (string-split ymd-string))) "MMMM d, yyyy"))
ADDED pollen.rkt
Index: pollen.rkt
==================================================================
--- pollen.rkt
+++ pollen.rkt
@@ -0,0 +1,123 @@
+#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
+;; -------------------------------------------------------------------------
+
+;; Functions for tags and template content used in all Pollen source files and templates.
+
+(require (for-syntax racket/base
+ racket/syntax
+ syntax/parse
+ pollen/setup))
+
+(require pollen/tag
+ pollen/setup
+ racket/function
+ "tags-html.rkt"
+ "template-html.rkt")
+
+(provide (all-defined-out)
+ (all-from-out "template-html.rkt"))
+
+(module setup racket/base
+ (require syntax/modresolve)
+ (provide (all-defined-out))
+ (define poly-targets '(html))
+ (define cache-watchlist
+ (map resolve-module-path '("tags-html.rkt"
+ "template-html.rkt"
+ "dates.rkt"))))
+
+;; Macro for defining tag functions that automatically branch based on the
+;; current output format and the list of poly-targets in the setup module.
+;;
+(define-syntax (poly-branch-tag stx)
+ (syntax-parse stx
+ [(_ TAG:id)
+ (with-syntax ([((POLY-TARGET POLY-FUNC) ...)
+ (for/list ([target (in-list (setup:poly-targets))])
+ (list target (format-id stx "~a-~a" target #'TAG)))]
+ [DEFAULT-FUNC (format-id stx "html-~a" #'TAG)])
+ #'(define-tag-function (TAG attributes elems)
+ (define args (cons attributes elems))
+ (case (current-poly-target)
+ [(POLY-TARGET) (apply POLY-FUNC args)] ...
+ [else (apply DEFAULT-FUNC args)])))]))
+
+;; Like above, but uses define instead of define-tag-function, so arguments
+;; are given ‘straight’ rather than being parsed out as attributes.
+;;
+(define-syntax (poly-branch-func stx)
+ (syntax-parse stx
+ [(_ TAG:id)
+ (with-syntax ([((POLY-TARGET POLY-FUNC) ...)
+ (for/list ([target (in-list (setup:poly-targets))])
+ (list target (format-id stx "~a-~a" target #'TAG)))]
+ [DEFAULT-FUNC (format-id stx "html-~a" #'TAG)])
+ #'(define (TAG . args)
+ (case (current-poly-target)
+ [(POLY-TARGET) (apply POLY-FUNC args)] ...
+ [else (apply DEFAULT-FUNC args)])))]))
+
+;; Define all the tag functions
+(poly-branch-tag root)
+
+(poly-branch-tag p)
+(poly-branch-tag i)
+(poly-branch-tag em)
+(poly-branch-tag b)
+(poly-branch-tag strong)
+(poly-branch-tag strike)
+;(poly-branch-tag color)
+(poly-branch-tag ol)
+(poly-branch-tag ul)
+(poly-branch-tag item)
+(poly-branch-tag sup)
+(poly-branch-tag blockquote)
+(poly-branch-tag newthought)
+(poly-branch-tag smallcaps)
+(poly-branch-tag center)
+(poly-branch-tag section)
+(poly-branch-tag subsection)
+(poly-branch-tag code)
+(poly-branch-tag blockcode)
+(poly-branch-tag verse) ; [#:title ""] [#:italic "no"]
+
+(poly-branch-func link)
+(poly-branch-func url)
+(poly-branch-func fn)
+(poly-branch-func fndef)
+
+;; Not yet implemented
+; (poly-branch-tag table) ; #:columns ""
+; (poly-branch-tag inline-math)
+; (poly-branch-tag margin-note)
+; (poly-branch-tag noun)
+; (poly-branch-func index-entry entry)
+; (poly-branch-tag figure) ; #:src "img--sans-path.png" [#:has-print-version? "yes"]
+; (poly-branch-tag spot-illustration) ; #:src "img--sans-path.png" [#:has-print-version? "yes"]
+
+;; My pet shortcut for for/splice. Greatly cuts down on parentheses for the
+;; most common use case (looping through a single list).
+(define-syntax (for/s stx)
+ (syntax-case stx ()
+ [(_ thing listofthings result-expr ...)
+ #'(for/splice ([thing (in-list listofthings)]) result-expr ...)]))
ADDED tags-html.rkt
Index: tags-html.rkt
==================================================================
--- tags-html.rkt
+++ tags-html.rkt
@@ -0,0 +1,190 @@
+#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)
+
+(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))]))
ADDED template-html.rkt
Index: template-html.rkt
==================================================================
--- template-html.rkt
+++ template-html.rkt
@@ -0,0 +1,70 @@
+#lang pollen/mode 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
+;; -------------------------------------------------------------------------
+
+;; Provides functions for displaying content in HTML templates.
+(require pollen/core
+ "dates.rkt")
+
+(provide (all-defined-out))
+
+(define (ht-head [title #f])
+ ◊@{<head>
+ <title>The Local Yarn◊when/splice[title]{: ◊title}</title>
+ <meta charset="utf-8" />
+ <meta name="viewport" content="width=device-width, initial-scale=1">
+ <link rel="stylesheet" type="text/css" href="/web-extra/martin.css">
+ </head>})
+
+(define (ht-page-top)
+ ◊@{<body><main>
+ <a href="/"><header>
+ <img src="/web-extra/logo.png" height="103" width="129" class="logo">
+ <h1>The Local Yarn</h1>
+ </header></a>})
+
+(define (ht-article-header)
+ (define title (select-from-metas 'title (current-metas)))
+ (define published (select-from-metas 'published (current-metas)))
+ (cond
+ [title
+ ◊@{<article class="with-title hentry">
+ <h1 class="entry-title">◊|title|</h1>
+ <p class="time"><a href="#" class="rel-bookmark">
+ <time datetime="◊published" class="published">◊ymd->english[published]</time>
+ </a></p>
+ <section class="entry-content">}]
+ [else
+ ◊@{<article class="no-title hentry">
+ <h1><a href="#" class="rel-bookmark">
+ <time datetime="◊published" class="entry-title">◊ymd->english[published]</time>
+ </a></h1>
+ <section class="entry-content">}]))
+
+(define (ht-article-footer)
+ ◊@{</section>
+ <footer class="article-info"><span class="x">(</span>Part of ‘Talking About Poetry’. Once I threw a mudball at a birdhouse. I’m not exactly proud of it, though.<span class="x">)</span></footer>
+ </article>})
+
+(define (ht-page-bottom)
+ ◊@{<footer>By Joel Dueck</footer>
+ </main></body>})
ADDED template.html.p
Index: template.html.p
==================================================================
--- template.html.p
+++ template.html.p
@@ -0,0 +1,14 @@
+<!DOCTYPE html>
+<html>
+◊ht-head[(select-from-metas 'title here)]
+
+◊ht-page-top[]
+
+◊ht-article-header[]
+◊(->html (cdr doc))
+◊ht-article-footer[]
+
+◊ht-page-bottom[]
+
+</html>
+