Index: code-docs/dust.scrbl
==================================================================
--- code-docs/dust.scrbl
+++ code-docs/dust.scrbl
@@ -11,19 +11,20 @@
scribble/example)
@(require (for-label "../pollen.rkt"
"../dust.rkt"
racket/base
+ racket/contract
txexpr
sugar/coerce
pollen/tag
pollen/setup
pollen/pagetree
pollen/core))
@(define dust-eval (make-base-eval))
-@(dust-eval '(require "dust.rkt"))
+@(dust-eval '(require "dust.rkt" txexpr))
@title{@filepath{dust.rkt}}
@defmodule["dust.rkt" #:packages ()]
@@ -73,34 +74,75 @@
Look up a value in @code{(current-metas)} that may or may not be present, returning the value of
@racket[_missing-expr] if it’s not there.
@defproc[(tx-strs [tx txexpr?]) string?]
-Finds all the strings from the @emph{elements} of @racket[_tx] (ignoring attributes) and concatenates them together.
+Finds all the strings from the @emph{elements} of @racket[_tx] (ignoring attributes) and
+concatenates them together.
@examples[#:eval dust-eval
(tx-strs '(p [[class "intro"]]
(em "I’m not opening the safe") ", Wilson remembers thinking."))]
-@defproc[(first-words [str string?] [n exact-nonnegative-integer?]) string?]
+@defproc[(make-tag-predicate [sym symbol?]) (-> any/c boolean?)]
+
+Returns a function (or @italic{predicate}) that returns @racket[#t] if its argument is
+a @racket[_txexpr] whose tag is @racket[_sym]. This predicate is useful for passing as the
+@racket[_pred] expression in functions @racket[splitf-txexpr] and @racket[findf-txexpr].
+
+@examples[#:eval dust-eval
+(define is-aside? (make-tag-predicate 'aside))
+
+(is-aside? '(q "I am not mad, Sir Topas. I say to you this house is dark."))
+(is-aside? '(aside "How smart a lash that speech doth give my Conscience?"))]
+
+@defproc[(first-words [txprs (listof txexpr?)] [n exact-nonnegative-integer?]) string?]
+
+Given a list of tagged X-expressions, returns a string containing the first @racket[_n] words found
+in the string elements of @racket[_txprs], or all of the words if there are less than @racket[_n]
+words available. Used by @racket[default_title].
-Returns a string containing the first @racket[_n] words of @racket[_str], removing any trailing
-punctuation. It will trip on opening punctuation or punctuation surrounded by spaces.
+This function aims to be smart about punctuation, and equally fast no matter how large the list of
+elements that you send it.
@examples[#:eval dust-eval
-(first-words "Another time, perhaps." 2)
-(first-words "‘One problem’ – it don’t always do punctuation right." 3)]
+(define txs-decimals
+ '((p "Four score and 7.8 years ago — our fathers etc etc")))
+(define txs-punc-and-split-elems
+ '((p "“Stop!” she called.") (p "(She was never one to be silent.)")))
+(define txs-dashes
+ '((p [[class "newthought"]] (span [[class "smallcaps"]] "One - and") " only one.")
+ (p "That was all she would allow.")))
+(define txs-parens-commas
+ '((p "She counted (" (em "one, two") "— silently, eyes unblinking")))
+(define txs-short
+ '((span "Not much here!")))
+
+(first-words txs-decimals 5)
+(first-words txs-punc-and-split-elems 5)
+(first-words txs-dashes 5)
+(first-words txs-parens-commas 5)
+(first-words txs-short 5)
+]
@section{Article parsers and helpers}
-@defproc[(default-title [date string?]) string?]
+@defproc[(default-title [body-txprs (listof txexpr?)]) string?]
+
+Given a list of tagged X-expressions (the elements of an article’s doc, e.g.), returns a string
+containing a suitable title for the document. (Uses @racket[first-words].)
Titles are not required for articles, but there are contexts where you need something that
serves as a title if one is not present, and that’s what this function supplies.
@examples[#:eval dust-eval
-(default-title "2018-02-19")]
+(define doc
+ '(root (p "If I had been astonished at first catching a glimpse of so outlandish an "
+ "individual as Queequeg circulating among the polite society of a civilized "
+ "town, that astonishment soon departed upon taking my first daylight "
+ "stroll through the streets of New Bedford…")))
+(default-title (get-elements doc))]
@defproc[(series-pagenode) pagenode?]
If @code{(current-metas)} has the key @racket['series], converts its value to the pagenode pointing to
that series, otherwise returns @racket['||].
Index: code-docs/pollen.scrbl
==================================================================
--- code-docs/pollen.scrbl
+++ code-docs/pollen.scrbl
@@ -56,10 +56,14 @@
see, e.g., @filepath{tags-html.rkt}.
Functions defined with this macro @emph{do not} accept keyword arguments. If you need keyword
arguments, see @racket[poly-branch-kwargs-tag].
+@margin-note{The thought behind having two macros so similar is that, by cutting out handling for keyword
+arguments, @racket[poly-branch-tag] could produce simpler and faster code. I have not verified if
+this intuition is meaningful or correct.}
+
@defproc[#:kind "syntax"
(poly-branch-kwargs-tag (id symbol?))
(-> txexpr?)]
Works just like @racket[poly-branch-tag], but uses Pollen’s @racket[define-tag-function] so that
@@ -66,18 +70,26 @@
keyword arguments will automatically be parsed as X-expression attributes.
Additionally, the branch functions called from the new function must accept exactly two arguments:
a list of attributes and a list of elements.
-@margin-note{The thought behind having two macros so similar is that, by cutting out handling for keyword
-arguments, @racket[poly-branch-tag] could produce simpler and faster code. I have not verified if
-this intuition is meaningful or correct.}
-
@section{Markup reference}
These are the tags that can be used in any of @italic{The Local Yarn}’s Pollen documents (articles,
etc).
+
+@defproc[(title [element xexpr?] ...) txexpr?]
+
+@margin-note{The @code{title} function is not actually defined in @filepath{pollen.rkt} or anywhere
+else. In Pollen, any undefined function @tt{title} defaults to @racket[(default-tag-function
+title)], which is what I want. It is documented here because its presence or absence has
+side-effects on the display of the article.}
+
+Supplies a title for the document. You can use any otherwise-valid markup within the title tag.
+
+Titles are optional; if you don’t specify a title, the article will appear without one. This is
+a feature!
@defproc[(p [element xexpr?] ...) txexpr?]
Wrap text in a paragraph. You almost never need to use this tag explicitly;
just separate paragraphs by an empty line.
Index: crystalize.rkt
==================================================================
--- crystalize.rkt
+++ crystalize.rkt
@@ -97,15 +97,10 @@
(define table_articles (make-table-schema "articles" table_articles-fields))
(define table_notes (make-table-schema "notes" table_notes-fields #:primary-key-cols '(pagenode note_id)))
(define table_series (make-table-schema "series" table_series-fields))
-;; Split all ◊note tags out of the Pollen doc
-(define (doc->body/notes doc)
- (define (is-note? tx) (and (txexpr? tx) (equal? 'note (get-tag tx))))
- (splitf-txexpr doc is-note?))
-
;; ~~~ Provided functions: Initializing; Saving posts and notes
;; Initialize the database connection, creating the database if it doesn’t
;; exist, and executing the table schema queries
;;
@@ -114,74 +109,71 @@
;; Save an article and its notes (if any) to the database, and return the
;; rendered HTML of the complete article.
;;
(define (crystalize-article! pagenode doc)
- (define pubdate (select-from-metas 'published (current-metas)))
- (define-values (body-txpr note-txprs) (doc->body/notes doc))
- (define doc-html (->html (cdr body-txpr)))
-
+ (define-values
+ (doc2 maybe-title) (splitf-txexpr doc (make-tag-predicate 'title)))
+ (define-values
+ (body-txpr note-txprs) (splitf-txexpr doc2 (make-tag-predicate 'note)))
(define-values (disposition disp-note-id)
(notes->last-disposition-values note-txprs))
- (define title-specified? (non-empty-string? (maybe-meta 'title)))
- (define-values (title-plain title-html-flow)
- (title-plain+html-values body-txpr disposition))
- (define series-node (maybe-meta 'series))
- (define header (html$-article-open title-specified? title-html-flow pubdate))
-
- (define footertext (make-article-footertext pagenode series-node disposition disp-note-id (length note-txprs)))
- (define footer (html$-article-close footertext))
-
- (define notes-section-html (crystalize-notes! pagenode title-plain note-txprs))
-
- ;; Values must come in the order defined in table_article_fields
- (define article-record
- (list (symbol->string pagenode)
- title-plain
- title-html-flow
- (bool->int title-specified?)
- pubdate
- (maybe-meta 'updated)
- (maybe-meta 'author default-authorname)
- (maybe-meta 'conceal)
- series-node
- (maybe-meta 'noun (series-noun))
- (length note-txprs)
- doc-html
- disposition
- disp-note-id
- (string-append header doc-html footer)
- "" ; listing_excerpt_html: Not yet used
- "")) ; listing_short_html: Not yet used
-
- (apply query! (make-insert/replace-query 'articles table_articles-fields) article-record)
-
- (string-append header doc-html notes-section-html footer))
+
+ (let* ([pubdate (select-from-metas 'published (current-metas))]
+ [doc-html (->html (cdr body-txpr))]
+ [title-specified? (not (equal? '() maybe-title))]
+ [title-val (if (not (null? maybe-title)) (car maybe-title) maybe-title)]
+ [title-tx (make-article-title title-val body-txpr disposition disp-note-id)]
+ [title-html (->html title-tx)]
+ [title-plain (tx-strs title-tx)]
+ [series-node (series-pagenode)]
+ [header (html$-article-open title-specified? title-tx pubdate)]
+ [footertext (make-article-footertext pagenode series-node disposition disp-note-id (length note-txprs))]
+ [footer (html$-article-close footertext)]
+ [notes-section-html (crystalize-notes! pagenode title-plain note-txprs)])
+
+ ;; Values must come in the order defined in table_article_fields
+ (define article-record
+ (list (symbol->string pagenode)
+ title-plain
+ title-html
+ (bool->int title-specified?)
+ pubdate
+ (maybe-meta 'updated)
+ (maybe-meta 'author default-authorname)
+ (maybe-meta 'conceal)
+ (symbol->string series-node)
+ (maybe-meta 'noun (series-noun))
+ (length note-txprs)
+ doc-html
+ disposition
+ disp-note-id
+ (string-append header doc-html footer)
+ "" ; listing_excerpt_html: Not yet used
+ "")) ; listing_short_html: Not yet used
+
+ (apply query! (make-insert/replace-query 'articles table_articles-fields) article-record)
+
+ (string-append header doc-html notes-section-html footer)))
;; ~~~ Article-related helper functions ~~~
;;
-;; Return both a plain-text and HTML version of a title for the current article,
-;; supplying a default if no title was specified in the metas.
-(define (title-plain+html-values body-tx disposition)
- (define title (maybe-meta 'title ""))
- (define title-val
- (cond [(and (string? title) (string=? title ""))
- (format "“~a…”" (first-words (tx-strs body-tx) 5))]
- [else title]))
+;; Return a title txexpr for the current article, constructing a default if no title text was specified.
+(define (make-article-title supplied-title body-tx disposition disp-note-id)
+ (define title-elems
+ (cond [(null? supplied-title) (list (default-title (get-elements body-tx)))]
+ [else (get-elements supplied-title)]))
(define disposition-part
(cond [(non-empty-string? disposition)
(define-values (mark _) (disposition-values disposition))
- (format "~a" mark)]
+ `(span [[class "disposition-mark"]] (a [[href ,(string-append "#" disp-note-id)]] ,mark))]
[else ""]))
+ ;; Returns a txexpr, the tag will be discarded by the template/snippets
+ `(title ,@title-elems ,disposition-part))
- (cond [(txexpr? title-val)
- (values (apply string-append (tx-strs title-val))
- (string-append (->html title-val) disposition-part))]
- [else (values title-val (string-append title-val disposition-part))]))
-
;; Convert a bunch of information about an article into some nice English and links.
(define (make-article-footertext pagenode series disposition disp-note-id note-count)
(define s-title (series-title))
(define s-noun (series-noun))
(define series-part
Index: dust.rkt
==================================================================
--- dust.rkt
+++ dust.rkt
@@ -34,11 +34,13 @@
(provide maybe-meta ; Select from (current-metas) or default value ("") if not available
maybe-attr ; Return an attribute’s value or a default ("") if not available
series-noun ; Retrieve noun-singular from current 'series meta, or ""
series-title ; Retrieve title of series in current 'series meta, or ""
+ series-pagenode
attr-present? ; Test if an attribute is present
+ make-tag-predicate
tx-strs
ymd->english
ymd->dateformat
default-authorname
default-title
@@ -54,12 +56,12 @@
(define default-authorname "Joel Dueck")
(define series-path "series")
(define articles-path "articles")
-(define (default-title date)
- (format "Entry of ~a" (ymd->dateformat date "d MMM YYYY")))
+(define (default-title body-txprs)
+ (format "“~a…”" (first-words body-txprs 5)))
(define (maybe-meta m [missing ""])
(or (select-from-metas m (current-metas)) missing))
;; Checks current-metas for a 'series meta and returns the pagenode of that series,
@@ -110,23 +112,20 @@
(define result (assoc name attrs))
(cond
[(pair? result) (cadr result)]
[else missing]))
+;; Returns a function will test if a txexpr's tag matches the given symbol.
+(define (make-tag-predicate tagsym)
+ (lambda (tx) (and (txexpr? tx) (equal? tagsym (get-tag tx)))))
+
(define (tx-strs xpr)
(cond
[(txexpr? xpr) (apply string-append (map tx-strs (get-elements xpr)))]
[(string? xpr) xpr]
[else ""]))
-(define (first-words str n)
- (define trunc
- (apply string-append
- (add-between (take (string-split str) n) " ")))
- ;; Remove trailing punctuation (commas, etc.)
- (regexp-replace #px"\\W+$" trunc ""))
-
(module+ test
(require rackunit)
(define test-metas (hash 'name "Fiver" 'size "Small"))
(define test-attrs '([name "Hazel"] [rank "Chief"]))
@@ -138,10 +137,80 @@
(check-equal? (attr-present? 'name test-attrs) #t)
(check-equal? (attr-present? 'dingus test-attrs) #f)
(check-equal? (maybe-attr 'rank test-attrs) "Chief")
(check-equal? (maybe-attr 'dingus test-attrs) "")
(check-equal? (maybe-attr 'dingus test-attrs "zippy") "zippy"))
+
+;; Return the first N words out of a list of txexprs. This function will unpack the strings out of
+;; the elements of one txexpr at a time until it finds the requested number of words. It aims to be
+;; both reliable and fast for any size of list you pass it, and smart about the punctuation it
+;; allows through.
+(define (first-words txprs words-needed)
+ (define punc-allowed-in-word '(#\- #\' #\% #\$ #\‘ #\’ #\# #\& #\/ #\. #\!))
+
+ (define (word-boundary? c) (or (char-whitespace? c) (equal? c #\null) (eof-object? c)))
+ (define (word-char? c) (or (char-alphabetic? c) (char-numeric? c)))
+
+ (define in (open-input-string (tx-strs (first txprs))))
+ (define out (open-output-string))
+
+ (define words-found
+ (let loop ([words-found 0] [last-c #\null] [last-c-in-word? #f])
+ (define c (read-char in))
+
+ (cond [(equal? words-found words-needed) words-found]
+ [(eof-object? c)
+ (cond [(positive? words-found) (if last-c-in-word? (+ 1 words-found) words-found)]
+ [else 0])]
+ [else
+ (define-values (write-this-char? new-word-count c-in-word?)
+ (cond
+ ;; Spaces increment the word count if the previous character was part of,
+ ;; or adjacent to, a word
+ [(and (char-whitespace? c) last-c-in-word?)
+ (values (if (equal? words-needed (+ 1 words-found)) #f #t) (+ 1 words-found) #f)]
+ ;; Some punctuation survives if the previous or next char is part of a word
+ [(member c punc-allowed-in-word)
+ (cond [(or (word-char? last-c) (word-char? (peek-char in)))
+ (values #t words-found #t)]
+ [else (values #f words-found #f)])]
+ [(word-char? c)
+ (values #t words-found #t)]
+ ;; If c is a non-whitespace non-allowed character that immediately follows a word,
+ ;; do not write it out but count it as being part of the word.
+ [(and (not (word-char? c)) (not (char-whitespace? c)) last-c-in-word?)
+ (values #f words-found #t)]
+ [else (values #f words-found #f)]))
+
+ (cond [write-this-char? (write-char c out)])
+ (loop new-word-count c c-in-word?)])))
+
+ (define words (get-output-string out))
+ (cond [(equal? words-found words-needed) words]
+ [(equal? '() (rest txprs)) words]
+ [else (string-append words " " (first-words (rest txprs) (- words-needed words-found)))]))
+
+(module+ test
+ (require rackunit)
+ (define txs-decimals
+ '((p "Four score and 7.8 years ago — our fathers brought forth on this continent etc etc")))
+ (define txs-punc+split-elems
+ '((p "“Stop!” she called.") (p "(She was never one to be silent.)")))
+ (define txs-dashes
+ '((p [[class "newthought"]] (span [[class "smallcaps"]] "One - and") " only one.")
+ (p "That was all she would allow.")))
+ (define txs-parens-commas
+ '((p "She counted (" (em "one, two") "— silently, eyes unblinking")))
+ (define txs-short
+ '((span "Not much here!")))
+
+ (check-equal? (first-words txs-decimals 5) "Four score and 7.8 years")
+ (check-equal? (first-words txs-punc+split-elems 5) "Stop! she called. She was")
+ (check-equal? (first-words txs-dashes 5) "One and only one. That")
+ (check-equal? (first-words txs-dashes 4) "One and only one.")
+ (check-equal? (first-words txs-parens-commas 5) "She counted one two silently")
+ (check-equal? (first-words txs-short 5) "Not much here!"))
;; Convert, e.g., "* thoroughly recanted" into (values "*" "thoroughly recanted")
(define (disposition-values str)
(cond [(string=? "" str) (values "" "")]
[else (let ([splut (string-split str)])
Index: pollen.rkt
==================================================================
--- pollen.rkt
+++ pollen.rkt
@@ -37,13 +37,14 @@
(provide (all-defined-out)
(all-from-out "crystalize.rkt" "snippets-html.rkt"))
(module setup racket/base
- (require syntax/modresolve)
+ (require syntax/modresolve pollen/setup)
(provide (all-defined-out))
(define poly-targets '(html))
+ (define block-tags (cons 'title default-block-tags))
(define cache-watchlist
(map resolve-module-path '("tags-html.rkt"
"snippets-html.rkt"
"dust.rkt"
"crystalize.rkt"))))
Index: snippets-html.rkt
==================================================================
--- snippets-html.rkt
+++ snippets-html.rkt
@@ -54,15 +54,15 @@
