Index: pollen.rkt
==================================================================
--- pollen.rkt
+++ pollen.rkt
@@ -1,36 +1,11 @@
#lang racket/base
-(require pollen/decode
- txexpr
- yarn/markup
- yarn/string
- yarn/tools)
+(require yarn/markup)
(provide
(all-defined-out)
(all-from-out yarn/markup))
(module+ setup
(provide block-tags)
(define block-tags blocks-elements))
-
-;; 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 'paragraph #:linebreak-proc no-linebreaks))
-
-(define (root . elems)
- (validate-txexpr `(test ,@elems))
- (check-title elems)
- `(document ,@(decode-hardwrapped-paragraphs elems)))
-
-(define (check-title elems)
- (cond
- [(and (not (meta-set? 'title))
- ((tx-is? 'poetry #:has-attrs 'title) (car elems)))
- (set-meta 'title (format "‘~a’" (attr-ref (car elems) 'title)))
- (set-meta 'title-supplied? #t)]
- [(not (meta-set? 'title))
- (set-meta 'title (first-words elems 5))]))
ADDED yarn-lib/info.rkt
Index: yarn-lib/info.rkt
==================================================================
--- yarn-lib/info.rkt
+++ yarn-lib/info.rkt
@@ -0,0 +1,11 @@
+#lang info
+
+(define collection "yarn")
+(define version "0.9")
+
+(define pkg-desc "implementation part of \"yarn\"")
+(define license 'BlueOak-1.0.0)
+(define deps '("base"
+ "pollen"
+ "threading-lib"
+ "txexpr"))
Index: yarn-lib/markup.rkt
==================================================================
--- yarn-lib/markup.rkt
+++ yarn-lib/markup.rkt
@@ -6,16 +6,43 @@
;; 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 pollen/decode
pollen/tag
+ racket/string
+ txexpr
"index.rkt"
"string.rkt"
- "tools.rkt")
+ "tools.rkt"
+ yarn/path)
(provide (all-defined-out))
+(define (root . elems)
+ (print (validate-txexpr `(test ,@elems)))
+ (check-title elems)
+ (serialize-article-placeholder)
+ `(document ,@(decode-hardwrapped-paragraphs elems)))
+
+;; Customized paragraph decoder replaces single newlines within paragraphs
+;; with single spaces instead of
tags (allow hard-wrapped paragraphs)
+(define (decode-hardwrapped-paragraphs xs)
+ (define (no-linebreaks xs)
+ (decode-linebreaks xs " "))
+ (decode-paragraphs xs 'paragraph #:linebreak-proc no-linebreaks))
+
+;; Set a title if not already set
+(define (check-title elems)
+ (cond
+ [(and (not (meta-set? 'title))
+ (pair? elems)
+ ((tx-is? 'poetry #:has-attrs 'title) (car elems)))
+ (set-meta 'title (format "‘~a’" (attr-ref (car elems) 'title)))
+ (set-meta 'title-supplied? #t)]
+ [(not (meta-set? 'title))
+ (set-meta 'title (if (pair? elems) (first-words elems 5) ""))]))
+
;; Yarn AST:
;; (document Block-Contents)
;; Footnote definitions, index entry keys are stored in the metas
;; Block-Content :=
@@ -108,5 +135,18 @@
(define (saylines interlocutor elems)
`(speech ,interlocutor ,@(decode-linebreaks elems 'line-break)))
(define verse (default-tag-function 'poetry)) ; #:title, #:style
+(define-tag-function (note attrs elems)
+ (let* ([note-count (update-meta 'note-count add1 0)]
+ [note-id (string-append (attr-ref attrs 'date) (format "_~a" note-count))]
+ [maybe-disp (string-split (attr-ref attrs 'disposition ""))]
+ [the-note (attr-set* `(note ,attrs ,@elems) 'id note-id 'parent (here-output-path))])
+ (cond
+ [(> (length maybe-disp) 1)
+ (set-meta 'disposition `(,(car maybe-disp)
+ ,(string-join (cdr maybe-disp))
+ ,note-id))])
+ (cons-to-metas-list 'notes the-note)
+ (serialize-note the-note note-count)
+ ""))
ADDED yarn-lib/path.rkt
Index: yarn-lib/path.rkt
==================================================================
--- yarn-lib/path.rkt
+++ yarn-lib/path.rkt
@@ -0,0 +1,28 @@
+#lang racket/base
+
+; SPDX-License-Identifier: BlueOak-1.0.0
+; This file is licensed under the Blue Oak Model License 1.0.0.
+
+(require pollen/core
+ pollen/file
+ pollen/setup
+ racket/path)
+
+(provide here-source-path
+ here-output-path)
+
+(define (identity v) v)
+
+;; Return the path to the current Pollen source, relative to project root
+(define (here-source-path #:string? [string? #t])
+ (define proc (if string? path->string identity))
+ (cond
+ [(current-metas)
+ (proc (find-relative-path (current-project-root) (hash-ref (current-metas) 'here-path)))]
+ [else "."]))
+
+;; Return the path to the output filename for the current Pollen source,
+;; relative to project root
+(define (here-output-path #:string? [string? #t])
+ (define proc (if string? path->string identity))
+ (proc (->output-path (here-source-path #:string? #f))))
Index: yarn-lib/render/html.rkt
==================================================================
--- yarn-lib/render/html.rkt
+++ yarn-lib/render/html.rkt
@@ -5,10 +5,11 @@
;; Renders a Yarn AST and metadata into HTML
(require "../tools.rkt"
"../string.rkt"
+ "../path.rkt"
koyo/haml
pollen/core
pollen/decode
racket/function
racket/list
@@ -149,14 +150,14 @@
[data-index-entry ,key]
[class ,(symbol->string type)]]
,@elems))
(define (render-footnote-ref ref)
- (cons-to-metas-list 'fn-names ref)
+ (cons-to-metas-list 'fn-names ref)
(let* ([here (here-key)]
[fn-names (hash-ref (current-metas) 'fn-names)]
[def-anchor (format "#~a_fndef_~a" here ref)]
[nth-ref (number->string (count (curry equal? ref) fn-names))]
[ref-id (format "#~a_fn_~a_~a" here ref nth-ref)]
[fn-number (+ 1 (index-of (remove-duplicates (reverse fn-names)) ref))]
[ref-text (format "(~a)" fn-number)])
`(sup (a [[href ,def-anchor] [id ,ref-id]] ,ref-text))))
Index: yarn-lib/string.rkt
==================================================================
--- yarn-lib/string.rkt
+++ yarn-lib/string.rkt
@@ -21,16 +21,17 @@
;; 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 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 (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 (first-words txprs words-needed)
(define in (open-input-string (->text (car txprs))))
(define out (open-output-string))
(define words-found
(let loop ([words-found 0] [last-c #\null] [last-c-in-word? #f])
Index: yarn-lib/tools.rkt
==================================================================
--- yarn-lib/tools.rkt
+++ yarn-lib/tools.rkt
@@ -1,14 +1,11 @@
#lang racket/base
(require file/sha1
pollen/core
- pollen/file
- pollen/setup
- (only-in racket/function identity)
- racket/match
- racket/path
+ racket/file
+ racket/list
racket/string
threading
txexpr)
(provide (all-defined-out))
@@ -33,27 +30,23 @@
sha1-bytes
bytes->hex-string
(substring 0 8))))
(string-append (hash-ref metas 'here-key set-here-key!) suffix))
-(define (here-source-path #:string? [string? #t])
- (define proc (if string? path->string identity))
- (cond
- [(current-metas)
- (proc (find-relative-path (current-project-root) (hash-ref (current-metas) 'here-path)))]
- [else "."]))
-
-(define (here-output-path #:string? [string? #t])
- (define proc (if string? path->string identity))
- (proc (->output-path (here-source-path #:string? #f))))
+;;
+;; Meta tools ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(define (meta-set? key)
(and (hash-ref (current-metas) key #f) #t))
(define (set-meta key val)
(current-metas (hash-set (current-metas) key val))
val)
+
+(define (update-meta key proc default)
+ (let ([updated (proc (hash-ref (current-metas) key default))])
+ (set-meta key updated)))
(define (cons-to-metas-list key val)
(define consed (cons val (hash-ref (current-metas) key '())))
(current-metas (hash-set (current-metas) key consed))
consed)
@@ -67,12 +60,50 @@
(hash-ref (hash-ref (current-metas) key #hasheq()) subkey #f))
;; Returns a function will test if a txexpr's tag matches the given symbol and
;; (optionally) contains all given attributes.
(define (tx-is? t #:has-attrs [a '()])
- (define tags (if (list? t) tags (list t)))
+ (define tags (if (list? t) t (list t)))
(define attrs (if (list? a) a (list a)))
(lambda (v)
(and (txexpr? v)
(member (get-tag v) tags)
(andmap (λ (attr) (attrs-have-key? a attr)) attrs)
#t)))
+
+;; “Notes”, in addition to being attached to/contained in articles, are also
+;; shown alongside articles in the chronological feed. To make building this
+;; mixed chronological feed faster, articles and notes create files in a
+;; “serialize” subfolder at compile time:
+;; * The filenames are prefixed with the thing’s YMD date.
+;; * Note-files contain a datum of the entire note.
+;; * Article-files contain only the path to the article’s source.
+;;
+;; This way building the chrono feed is simple and doesn’t require loading
+;; and sorting the docs/metas of the entire article set.
+
+(define serialize-folder "compiled/.serialized")
+
+(define (current-serialize-folder-path)
+ (and~> (hash-ref (current-metas) 'here-path #f)
+ explode-path
+ (drop-right 1)
+ (append (list serialize-folder))
+ (apply build-path _)))
+
+;;
+;; TODO: Possible speed gains by spawning a thread to do this
+(define (serialize-article-placeholder)
+ (let* ([ser-folder (current-serialize-folder-path)]
+ [filename (format "~a.article" (hash-ref (current-metas) 'published))]
+ [placeholder (build-path ser-folder filename)])
+ (unless (directory-exists? ser-folder) (make-directory ser-folder))
+ (unless (file-exists? placeholder)
+ (write-to-file (hash-ref (current-metas) 'here-path)
+ (build-path ser-folder filename)
+ #:exists 'truncate))))
+
+(define (serialize-note note num)
+ (let ([ser-folder (current-serialize-folder-path)]
+ [filename (format "~a_~a.note" (attr-ref note 'date) num)])
+ (unless (directory-exists? ser-folder) (make-directory ser-folder))
+ (write-to-file note (build-path ser-folder filename) #:exists 'truncate)))