mbutterick
/
pollen
3
3
Fork 0
Code Issues 1 Pull Requests Projects Releases Wiki Activity

1.5 update

Browse Source
dev-stylish-5
Matthew Butterick 6 years ago
parent e70f476c93
commit 559da05c8d
43 changed files with 936 additions and 897 deletions
Show Stats Download Patch File Download Diff File

28
pollen/cache.rkt
Unescape Escape View File

@ -1,9 +1,10 @@
#lang racket/base
(require racket/file
racket/list
racket/fasl
sugar/define
"private/cache-utils.rkt"
"private/debug.rkt"
"private/log.rkt"
"setup.rkt")
;; The cache is a hash with paths as keys.
@ -21,37 +22,42 @@
(message (format "removing cache directory: ~a" path))
(delete-directory/files path)))
(define ((path-error-handler caller-name path-or-path-string) e)
(raise-argument-error caller-name "valid path or path-string" path-or-path-string))
(define-namespace-anchor cache-module-ns)
(define use-fasl? #false)
(define cached-require-base
(let ([ram-cache (make-hash)])
(λ (path-or-path-string subkey caller-name)
(define path (with-handlers ([exn:fail? (λ (e) (raise-argument-error caller-name "valid path or path-string" path-or-path-string))])
(define path
(with-handlers ([exn:fail? (path-error-handler caller-name path-or-path-string)])
(path->complete-path (if (path? path-or-path-string)
path-or-path-string
(string->path path-or-path-string)))))
(unless (file-exists? path)
(raise-argument-error caller-name "path to existing file" path-or-path-string))
(cond
[(setup:compile-cache-active path)
(define key (paths->key path))
(define (convert-path-to-cache-record) (path->hash path))
(define (get-cache-record) (cache-ref! key convert-path-to-cache-record))
(define (convert-path-to-cache-record) ((if use-fasl? s-exp->fasl values) (path->hash path)))
(define (get-cache-record) ((if use-fasl? fasl->s-exp values) (cache-ref! key convert-path-to-cache-record)))
(define ram-cache-record (hash-ref! ram-cache key get-cache-record))
(hash-ref ram-cache-record subkey)]
[else (parameterize ([current-namespace (make-base-namespace)])
(namespace-attach-module (namespace-anchor->namespace cache-module-ns) 'pollen/setup) ; brings in params
[else
(parameterize ([current-namespace (make-base-namespace)])
;; brings in currently instantiated params (unlike namespace-require)
(define outer-ns (namespace-anchor->namespace cache-module-ns))
(namespace-attach-module outer-ns 'pollen/setup)
(dynamic-require path subkey))]))))
(define+provide (cached-require path-string subkey)
(cached-require-base path-string subkey 'cached-require))
(define+provide (cached-doc path-string)
(cached-require-base path-string (setup:main-export) 'cached-doc))
(define+provide (cached-metas path-string)
(cached-require-base path-string (setup:meta-export) 'cached-metas))

65
pollen/core.rkt
Unescape Escape View File

@ -1,12 +1,18 @@
#lang racket/base
(require (for-syntax racket/base "setup.rkt" "private/splice.rkt"))
(require txexpr/base xml/path sugar/define sugar/coerce sugar/test racket/string)
(require "private/file-utils.rkt"
(require (for-syntax
racket/base
"setup.rkt")
racket/match
txexpr/base
xml/path
sugar/define
sugar/coerce
sugar/test
"private/file-utils.rkt"
"setup.rkt"
"cache.rkt"
"pagetree.rkt"
"tag.rkt"
"private/splice.rkt")
"tag.rkt")
(define is-meta-value? hash?)
(define is-doc-value? txexpr?)
@ -22,15 +28,15 @@
((coerce/symbol? (or/c is-meta-value? is-doc-value? pagenode? pathish?)) (symbol?) . ->* . (or/c #f txexpr-elements?))
(define metas-result (and (not (is-doc-value? value-source)) (select-from-metas key value-source caller)))
(define doc-result (and (not (is-meta-value? value-source)) (select-from-doc key value-source caller)))
(define result (filter values (apply append (map ->list (list metas-result doc-result)))))
(and (pair? result) result))
(match (filter values (apply append (map ->list (list metas-result doc-result))))
[(? pair? res) res]
[_ #false]))
(define+provide/contract (select key value-source)
(coerce/symbol? (or/c is-meta-value? is-doc-value? pagenode? pathish?) . -> . (or/c #f txexpr-element?))
(define result (select* key value-source 'select))
(and (pair? result) (car result)))
(match (select* key value-source 'select)
[(cons res _) res]
[_ #false]))
(module-test-external
(check-equal? (select* 'key '#hash((key . "value"))) '("value"))
@ -52,31 +58,28 @@
(check-false (select* 'absent-key doc))
(check-false (select 'absent-key doc))))
(define+provide/contract (select-from-metas key metas-source [caller 'select-from-metas])
;; output contract is a single txexpr-element
;; because metas is a hash, and a hash has only one value for a key.
((coerce/symbol? (or/c is-meta-value? pagenode? pathish?)) (symbol?) . ->* . (or/c #f txexpr-element?))
(define metas (if (is-meta-value? metas-source)
metas-source
(get-metas metas-source caller)))
(and (hash-has-key? metas key) (hash-ref metas key)))
(hash-ref (match metas-source
[(? is-meta-value? ms) ms]
[_ (get-metas metas-source caller)]) key #false))
(module-test-external
(let ([metas '#hash((key . "value"))])
(check-equal? (select-from-metas 'key metas) "value")
(check-false (select-from-metas 'absent-key metas))))
(define+provide/contract (select-from-doc key doc-source [caller 'select-from-doc])
;; output contract is a list of elements
;; because doc is a txexpr, and a txexpr can have multiple values for a key
((coerce/symbol? (or/c is-doc-value? pagenode? pathish?)) (symbol?) . ->* . (or/c #f txexpr-elements?))
(define doc (if (is-doc-value? doc-source)
doc-source
(get-doc doc-source caller)))
(define result (se-path*/list (list key) doc))
(and (pair? result) result))
(match (se-path*/list (list key) (match doc-source
[(? is-doc-value?) doc-source]
[_ (get-doc doc-source caller)]))
[(? pair? result) result]
[_ #false]))
(module-test-external
(check-equal? (select-from-doc 'key '(root (key "value"))) '("value"))
@ -85,27 +88,23 @@
(check-equal? (select-from-doc 'key doc) '("value"))
(check-false (select-from-doc 'absent-key doc))))
(define (convert+validate-path pagenode-or-path caller)
(let* ([path (if (pagenode? pagenode-or-path)
(define path (if (pagenode? pagenode-or-path)
(build-path (current-project-root) (symbol->string pagenode-or-path))
pagenode-or-path)]
[path (or (get-source path) path)])
(unless (file-exists? path)
(raise-argument-error caller "existing Pollen source, or name of its output path" path))
path))
pagenode-or-path))
(define src-path (or (get-source path) path))
(unless (file-exists? src-path)
(raise-argument-error caller "existing Pollen source, or name of its output path" src-path))
src-path)
(define+provide/contract (get-metas pagenode-or-path [caller 'get-metas])
(((or/c pagenode? pathish?)) (symbol?) . ->* . is-meta-value?)
(cached-metas (convert+validate-path pagenode-or-path caller)))
(define+provide/contract (get-doc pagenode-or-path [caller 'get-doc])
(((or/c pagenode? pathish?)) (symbol?) . ->* . (or/c is-doc-value? string?))
(cached-doc (convert+validate-path pagenode-or-path caller)))
;; This `@` definition is here to provide a hook for the docs.
;; But this is just default tag behavior, and thus would work without the definition.
;; Which is why the splicing tag can be renamed:
@ -125,7 +124,6 @@
(SPLICING-TAG . BODY)
(SPLICING-TAG)))]))
(provide for/splice for*/splice)
(define-syntax (for/splice/base stx)
@ -141,6 +139,5 @@
(syntax-case stx ()
[(_ . BODY) (syntax-property #'(for/splice/base . BODY) 'form #'for*/list)]))
(provide when/block) ; bw compat
(define-syntax when/block (make-rename-transformer #'when/splice))

90
pollen/decode.rkt
Unescape Escape View File

@ -2,6 +2,7 @@
(require xml
txexpr/base
racket/list
racket/match
sugar/list
sugar/define
sugar/test
@ -48,27 +49,29 @@
#:exclude-tags txexpr-tags?
#:exclude-attrs txexpr-attrs?) . ->* . decode-proc-output-contract)
(let loop ([x tx-in])
(cond
[(txexpr? x) (define-values (tag attrs elements) (txexpr->values x))
(match x
[(? txexpr?)
(define-values (tag attrs elements) (txexpr->values x))
(cond
[(or (memq tag excluded-tags)
(for/or ([attr (in-list attrs)])
(member attr excluded-attrs)))
x] ; because it's excluded
(member attr excluded-attrs))) x] ; because it's excluded
[else
;; we apply processing here rather than do recursive descent on the pieces
;; because if we send them back through loop, certain element types are ambiguous
;; e.g., ((p "foo")) tests out as both txexpr-attrs and txexpr-elements
(define decoded-txexpr (make-txexpr (txexpr-tag-proc tag)
(define decoded-txexpr
(make-txexpr (txexpr-tag-proc tag)
(txexpr-attrs-proc attrs)
(txexpr-elements-proc (append-map (λ (x) (->list/tx (loop x))) elements))))
(txexpr-proc ((if (block-txexpr? decoded-txexpr)
block-txexpr-proc
inline-txexpr-proc) decoded-txexpr))])]
[(string? x) (string-proc x)]
[(or (symbol? x) (valid-char? x)) (entity-proc x)]
[(cdata? x) (cdata-proc x)]
[else (error "decode: can't decode" x)])))
[(? string?) (string-proc x)]
[(? symbol?) (entity-proc x)]
[(? valid-char?) (entity-proc x)]
[(? cdata?) (cdata-proc x)]
[else (raise-argument-error 'decode "decodable thing" x)])))
(module-test-external
(require racket/list txexpr racket/function)
@ -115,10 +118,8 @@
(make-keyword-procedure
(λ (kws kwargs . args)
(define temp-tag (gensym "temp-tag"))
(define elements (car args))
(define decode-result (keyword-apply decode kws kwargs (list (cons temp-tag elements))))
(get-elements decode-result))))
(define elements (first args))
(get-elements (keyword-apply decode kws kwargs (list (cons temp-tag elements)))))))
(define+provide/contract (block-txexpr? x)
(any/c . -> . boolean?)
@ -129,17 +130,20 @@
(define+provide/contract (decode-linebreaks elems [maybe-linebreak-proc '(br)]
#:separator [newline (setup:linebreak-separator)])
((txexpr-elements?) ((or/c #f txexpr-element? (txexpr-element? txexpr-element? . -> . (or/c #f txexpr-element?))) #:separator string?) . ->* . txexpr-elements?)
((txexpr-elements?)
((or/c #f txexpr-element?
(txexpr-element? txexpr-element? . -> . (or/c #f txexpr-element?))) #:separator string?)
. ->* . txexpr-elements?)
(unless (string? newline)
(raise-argument-error 'decode-linebreaks "string" newline))
(define linebreak-proc (if (procedure? maybe-linebreak-proc)
maybe-linebreak-proc
(λ (e1 e2) maybe-linebreak-proc)))
(define linebreak-proc (match maybe-linebreak-proc
[(? procedure? proc) proc]
[val (λ (e1 e2) val)]))
(define elems-vec (list->vector elems))
(filter values
(for/list ([(elem idx) (in-indexed elems-vec)])
(cond
[(= idx 0) elem] ; pass first item
[(zero? idx) elem] ; pass first item
[(= idx (sub1 (vector-length elems-vec))) elem] ; pass through last item
[(equal? elem newline)
(define prev (vector-ref elems-vec (sub1 idx)))
@ -147,7 +151,7 @@
;; only convert if neither adjacent tag is a block
;; (because blocks automatically force a newline before & after)
(if (or (block-txexpr? prev) (block-txexpr? next))
#f ; flag for filtering
#false ; flag for filtering
(linebreak-proc prev next))]
[else elem]))))
@ -169,17 +173,21 @@
(define+provide/contract (merge-newlines x)
(txexpr-elements? . -> . txexpr-elements?)
(define newline-pat (regexp (format "^~a+$" (setup:newline))))
(define (newline? x) (and (string? x) (regexp-match newline-pat x)))
(define (newline? x) (match x
[(regexp newline-pat) #true]
[_ #false]))
(define (merge-newline-slice xs)
(if (newline? (car xs)) ; if first member of slice is newline, they all are
(list (apply string-append xs))
xs))
(define empty-string? (λ (x) (equal? x "")))
(match xs
;; if first member of slice is newline, they all are
[(cons (? newline?) _) (list (apply string-append xs))]
[_ xs]))
(define (empty-string? x) (equal? x ""))
(let loop ([x x])
(if (and (pair? x) (not (attrs? x)))
(let ([xs (map loop (filter-not empty-string? x))])
(append-map merge-newline-slice (slicef xs newline?)))
x)))
(match x
[(? pair? x) #:when (not (attrs? x))
(define xs (map loop (filter-not empty-string? x)))
(append-map merge-newline-slice (slicef xs newline?))]
[_ x])))
(module-test-external
(require racket/list)
@ -189,7 +197,6 @@
(check-equal? (merge-newlines '(p "\n" "\n" "foo" "\n" "\n\n" "bar" (em "\n" "\n" "\n")))
'(p "\n\n" "foo" "\n\n\n" "bar" (em "\n\n\n"))))
(define+provide/contract (decode-paragraphs elements-in [maybe-wrap-proc 'p]
#:linebreak-proc [linebreak-proc decode-linebreaks]
#:force? [force-paragraph #f])
@ -206,26 +213,30 @@
(define (paragraph-break? x)
(define paragraph-pattern (pregexp (format "^~a+$" paragraph-separator)))
(and (string? x) (regexp-match paragraph-pattern x)))
(match x
[(pregexp paragraph-pattern) #true]
[_ #false]))
(define (explicit-or-implicit-paragraph-break? x)
(or (paragraph-break? x) (block-txexpr? x)))
(define wrap-proc (if (procedure? maybe-wrap-proc)
maybe-wrap-proc
(λ (elems) (list* maybe-wrap-proc elems))))
(define wrap-proc (match maybe-wrap-proc
[(? procedure? proc) proc]
[_ (λ (elems) (list* maybe-wrap-proc elems))]))
(define (wrap-paragraph elems)
(if (andmap block-txexpr? elems)
elems ; leave a series of block xexprs alone
(list (wrap-proc elems)))) ; otherwise wrap in p tag
(match elems
[(list (? block-txexpr?) ...) elems] ; leave a series of block xexprs alone
[_ (list (wrap-proc elems))])) ; otherwise wrap in p tag
(define elements (prep-paragraph-flow elements-in))
(if (ormap explicit-or-implicit-paragraph-break? elements) ; need this condition to prevent infinite recursion
;; use append-map on wrap-paragraph rather than map to permit return of multiple elements
(append-map wrap-paragraph (append-map (λ (es) (filter-split es paragraph-break?)) (slicef elements block-txexpr?))) ; split into ¶¶, using both implied and explicit paragraph breaks
;; use `append-map` on `wrap-paragraph` rather than `map` to permit return of multiple elements
(append-map wrap-paragraph
(append-map (λ (es) (filter-split es paragraph-break?)) (slicef elements block-txexpr?))) ; split into ¶¶, using both implied and explicit paragraph breaks
(if force-paragraph
(append-map wrap-paragraph (slicef elements block-txexpr?)) ; upconverts non-block elements to paragraphs
;; upconverts non-block elements to paragraphs
(append-map wrap-paragraph (slicef elements block-txexpr?))
elements)))
(module-test-external
@ -246,7 +257,6 @@
'((p "foo") (div "bar") (div "zam")))
(check-equal? (decode-paragraphs '("foo" "\n\n" (div "bar") "\n\n" (div "zam")))
'((p "foo") (div "bar") (div "zam")))
(check-equal? (decode-paragraphs '("foo")) '("foo"))
(check-equal? (decode-paragraphs '("foo") #:force? #t) '((p "foo")))
(check-equal? (decode-paragraphs '((div "foo"))) '((div "foo")))

2
pollen/mode.rkt
Unescape Escape View File

@ -96,7 +96,7 @@ Intractable problem; unavoidable limitation.
(lexer-maker #:command-char #\◊)
(fallback))]
[(drracket:indentation)
(dynamic-require 'pollen/private/mode-indentation 'determine-spaces)]
(dynamic-require 'pollen/private/external/mode-indentation 'determine-spaces)]
[else (fallback)]))))))
(module at-reader racket/base

57
pollen/pagetree.rkt
Unescape Escape View File

@ -30,8 +30,7 @@
;; for contracts: faster than (listof pagenode?)
(define (pagenodes? x)
(and (list? x) (andmap pagenode? x)))
(define (pagenodes? x) (and (list? x) (andmap pagenode? x)))
(define+provide (pagenodeish? x)
@ -60,10 +59,11 @@
(define+provide (validate-pagetree x)
(and (txexpr? x)
(let ([pagenodes (pagetree-strict->list x)])
(for/and ([p (in-list pagenodes)]
(let ()
(define pagenodes (pagetree-strict->list x))
(for ([p (in-list pagenodes)]
#:unless (pagenode? p))
(error 'validate-pagetree "~v is not a valid pagenode" p))
(raise-argument-error 'validate-pagetree "valid pagenodes" p))
(with-handlers ([exn:fail? (λ (e) (error 'validate-pagetree "~a" (exn-message e)))])
(members-unique?/error pagenodes))
x)))
@ -89,7 +89,7 @@
(define (unique-sorted-output-paths xs)
(define output-paths (map ->output-path xs))
(define all-paths (filter path-visible? (remove-duplicates output-paths)))
(define path-is-directory? (λ (f) (directory-exists? (build-path dir f))))
(define (path-is-directory? f) (directory-exists? (build-path dir f)))
(define-values (subdirectories files) (partition path-is-directory? all-paths))
(define-values (pagetree-sources other-files) (partition pagetree-source? files))
(define (sort-names xs) (sort xs #:key ->string string<?))
@ -104,7 +104,7 @@
(define (cache-dir? path) (member (->string path) default-cache-names))
(unless (directory-exists? dir)
(error 'directory->pagetree "directory ~v doesn't exist" dir))
(raise-argument-error 'directory->pagetree "existing directory" dir))
(decode-pagetree (map ->pagenode (unique-sorted-output-paths (filter-not cache-dir? (directory-list dir))))))
@ -125,7 +125,7 @@
(load-pagetree pagetree-source)))
(define (topmost-node x) (car (->list x)))
(define (topmost-node x) (first (->list x)))
(define+provide/contract (parent pnish [pt-or-path (current-pagetree)] #:allow-root [allow-root? #f])
@ -139,7 +139,7 @@
current-parent
(for/or ([st (in-list (filter list? current-children))])
(loop pagenode st))))))
(if (eq? result (car pt))
(if (eq? result (first pt))
(and allow-root? result)
result))
@ -156,12 +156,11 @@
(define+provide/contract (children p [pt-or-path (current-pagetree)])
(((or/c #f pagenodeish?)) ((or/c pagetree? pathish?)) . ->* . (or/c #f pagenodes?))
(and pt-or-path p
(let loop ([pagenode (->pagenode p)]
[pt (get-pagetree pt-or-path)])
(if (eq? pagenode (car pt))
(map topmost-node (cdr pt))
(for/or ([subtree (in-list (filter pair? pt))])
(loop pagenode subtree))))))
(let loop ([pagenode (->pagenode p)][pt (get-pagetree pt-or-path)])
(match pagenode
[(== (first pt) eq?) (map topmost-node (rest pt))]
[_ (for/or ([subtree (in-list (filter pair? pt))])
(loop pagenode subtree))]))))
(module-test-external
@ -194,7 +193,7 @@
#:unless (eq? sib (->pagenode pnish)))
sib)
[(? pair? sibs) sibs]
[else #f]))
[_ #false]))
(module-test-external
@ -210,13 +209,13 @@
;; private helper function.
;; only takes pt as input.
;; used by `pagetree?` predicate, so can't use `pagetree?` contract.
(define (pagetree-strict->list pt) (flatten (cdr pt)))
(define (pagetree-strict->list pt) (flatten (rest pt)))
;; flatten tree to sequence
(define+provide/contract (pagetree->list pt-or-path)
((or/c pagetree? pathish?) . -> . pagenodes?)
; use cdr to get rid of root tag at front
; use rest to get rid of root tag at front
(pagetree-strict->list (get-pagetree pt-or-path)))
@ -230,14 +229,13 @@
(let loop ([side side]
[pagenode (->pagenode pnish)]
[pagetree-nodes (pagetree->list (get-pagetree pt-or-path))])
(if (eq? side 'right)
(match (memq pagenode pagetree-nodes)
(case side
[(right) (match (memq pagenode pagetree-nodes)
[(list _ rest ...) rest]
[else #f])
(match (loop 'right pagenode (reverse pagetree-nodes))
[_ #false])]
[else (match (loop 'right pagenode (reverse pagetree-nodes))
[(? pair? result) (reverse result)]
[else #f])))))
[_ #false])]))))
(module-test-internal
(require rackunit)
@ -266,7 +264,7 @@
(((or/c #f pagenodeish?)) ((or/c pagetree? pathish?)) . ->* . (or/c #f pagenode?))
(match (previous* pnish pt-or-path)
[(list _ ... result) result]
[else #f]))
[_ #false]))
(module-test-external
@ -280,7 +278,7 @@
(((or/c #f pagenodeish?)) ((or/c pagetree? pathish?)) . ->* . (or/c #f pagenode?))
(match (next* pnish pt-or-path)
[(list result _ ...) result]
[else #f]))
[_ #false]))
(module-test-external
@ -292,10 +290,9 @@
(define/contract+provide (path->pagenode path [starting-path (current-project-root)])
((coerce/path?) (coerce/path?) . ->* . coerce/symbol?)
(define starting-dir
(if (directory-exists? starting-path)
starting-path
(dirname starting-path)))
(define starting-dir (match starting-path
[(? directory-exists?) starting-path]
[_ (dirname starting-path)]))
(->output-path (find-relative-path (->complete-path starting-dir) (->complete-path path))))

65
pollen/private/cache-utils.rkt
Unescape Escape View File

@ -10,17 +10,17 @@
compiler/cm)
(provide (all-defined-out))
(define (paths->key source-path [template-path #f] [output-path #f])
;; can't use relative paths for cache keys because source files include `here-path` which is absolute.
;; problem is that cache could appear valid on another filesystem (based on relative pathnames & mod dates)
;; but would actually be invalid (because the `here-path` names are wrong).
;; key is list of file + mod-time pairs, use #f for missing
;; we don't include output-path in path-strings-to-track
;; because we don't want to attach a mod date
;; because cache validity is not sensitive to mod date of output path
;; (in fact we would expect it to be earlier, since we want to rely on an earlier version)
(define path-strings-to-track (list* source-path
;; can't use relative paths for cache keys because source files include `here-path` which is absolute.
;; problem is that cache could appear valid on another filesystem (based on relative pathnames & mod dates)
;; but would actually be invalid (because the `here-path` names are wrong).
;; key is list of file + mod-time pairs, use #f for missing
;; we don't include output-path in path-strings-to-track
;; because we don't want to attach a mod date
;; because cache validity is not sensitive to mod date of output path
;; (in fact we would expect it to be earlier, since we want to rely on an earlier version)
(define (paths->key source-path [template-path #false] [output-path #false])
(define path-strings-to-track
(list* source-path
;; if template has a source file, track that instead
(and template-path (or (get-source template-path) template-path))
;; is either list of files or (list #f)
@ -33,40 +33,37 @@
(for/list ([ps (in-list path-strings-to-track)])
(cond
[ps (define cp (->complete-path ps))
(cons (path->string cp) (file-or-directory-modify-seconds cp #f (λ () 0)))]
[else #f])))
(cons (path->string cp) (file-or-directory-modify-seconds cp #false (λ () 0)))]
[else #false])))
(list* pollen-env poly-flag (and output-path (path->string output-path)) path+mod-time-pairs))
(define (key->source-path key) (car (fourth key)))
(define (key->output-path key) (third key))
(module-test-internal
(define ps "/users/nobody/project/source.html.pm")
(check-equal? (key->source-path (paths->key ps)) ps))
(define-namespace-anchor cache-utils-module-ns)
(define (path->hash path)
(for-each managed-compile-zo (or (get-directory-require-files path) null))
(define path-dir (dirname path))
(apply hasheq
(let ([doc-key (setup:main-export)]
[meta-key (setup:meta-export)])
(let ([doc-key (setup:main-export)] [meta-key (setup:meta-export)])
(unless (and (symbol? doc-key) (symbol? meta-key))
(raise-argument-error 'path->hash "symbols for doc and meta key" (cons doc-key meta-key)))
;; new namespace forces `dynamic-require` to re-instantiate 'path'
;; otherwise it gets cached in current namespace.
(parameterize ([current-namespace (make-base-namespace)]
[current-directory path-dir])
;; I monkeyed around with using the metas submodule to pull out the metas (for speed)
;; but in practice most files get their doc requested too.
;; so it's just simpler to get both at once and be done with it.
;; the savings of avoiding two cache fetches at the outset outweighs
;; the benefit of not reloading doc when you just need metas.
(namespace-attach-module (namespace-anchor->namespace cache-utils-module-ns) 'pollen/setup) ; brings in params
;; new namespace forces `dynamic-require` to re-instantiate `path`
;; otherwise it gets cached in current namespace.
(parameterize ([current-namespace (make-base-namespace)]
[current-directory (dirname path)])
;; brings in currently instantiated params (unlike namespace-require)
(define outer-ns (namespace-anchor->namespace cache-utils-module-ns))
(namespace-attach-module outer-ns 'pollen/setup)
(define doc-missing-thunk (λ () ""))
(define metas-missing-thunk (λ () (hasheq)))
(list doc-key (dynamic-require path doc-key doc-missing-thunk)
@ -96,16 +93,16 @@
(define-values (cache-dir private-cache-dir) (make-cache-dirs dest-path))
(define-values (dest-path-dir dest-path-filename _) (split-path dest-path))
(define dest-file (build-path cache-dir (format "~a.rktd" dest-path-filename)))
(define (fetch-dest-file) (write-to-file (path-hash-thunk) dest-file #:exists 'replace))
#|
`cache-file` looks for a file in private-cache-dir previously cached with key
(which in this case carries modification dates and POLLEN env).
If a cached file is found, copies it to dest-file (which must not exist already, unless exists-ok? is true)
Otherwise, fetch-dest-file is called; if dest-file exists after calling fetch-dest-file,
it is copied to private-cache-dir and recorded with key.
|#
(define (fetch-dest-file)
(write-to-file (path-hash-thunk) dest-file #:exists 'replace))
;; `cache-file` looks for a file in private-cache-dir previously cached with key
;; (which in this case carries modification dates and POLLEN env).
;; If a cached file is found, copies it to dest-file (which must not exist already, unless exists-ok? is true)
;; Otherwise, fetch-dest-file is called; if dest-file exists after calling fetch-dest-file,
;; it is copied to private-cache-dir and recorded with key.
(cache-file dest-file
#:exists-ok? #t
#:exists-ok? #true
key
private-cache-dir
fetch-dest-file

89
pollen/private/command.rkt
Unescape Escape View File

@ -5,8 +5,10 @@
racket/list
racket/vector
racket/cmdline
racket/match
sugar/coerce
"file-utils.rkt"
"log.rkt"
"../setup.rkt"
"../render.rkt"
"../pagetree.rkt")
@ -18,19 +20,20 @@
;; todo: investigate this
(module+ raco
(define command-name (with-handlers ([exn:fail? (λ _ #f)])
(define command-name (with-handlers ([exn:fail? (λ () #f)])
(vector-ref (current-command-line-arguments) 0)))
(dispatch command-name))
(define (get-first-arg-or-current-dir [args (cdr (vector->list (current-command-line-arguments)))]) ; cdr to strip command name from front
(normalize-path
(with-handlers ([exn:fail? (λ (exn) (current-directory))])
;; incoming path argument is handled as described in docs for current-directory
(very-nice-path (car args)))))
(define (dispatch command-name)
(with-logging-to-port
(current-error-port)
(λ ()
(case command-name
[("test" "xyzzy") (handle-test)]
[(#f "help") (handle-help)]
@ -42,6 +45,9 @@
[("setup") (handle-setup (get-first-arg-or-current-dir))]
[("clone" "publish") (handle-publish)]
[else (handle-unknown command-name)]))
#:logger pollen-logger
'info
'pollen))
(define (very-nice-path x)
(path->complete-path (simplify-path (cleanse-path (->path x)))))
@ -67,21 +73,19 @@ version print the version" (current-server-port) (make-publish-di
(define (handle-version)
(displayln (dynamic-require 'pollen/private/version 'pollen:version)))
(define (handle-reset directory-maybe)
(displayln "resetting cache ...")
((dynamic-require 'pollen/cache 'reset-cache) directory-maybe))
(define (handle-setup directory-maybe)
(displayln "preheating cache ...")
((dynamic-require 'pollen/private/preheat-cache 'preheat-cache) directory-maybe))
(define (handle-render)
(define render-target-wanted (make-parameter (current-poly-target)))
(define render-with-subdirs? (make-parameter #f))
(define parsed-args (command-line #:program "raco pollen render"
(define parsed-args
(command-line #:program "raco pollen render"
#:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'render' from the front
#:once-each
[("-t" "--target") target-arg "Render target for poly sources"
@ -91,19 +95,18 @@ version print the version" (current-server-port) (make-publish-di
[("-s" "--subdir") "Render subdirectories nonrecursively" (render-with-subdirs? 'include)]
#:args other-args
other-args))
(define path-args (if (empty? parsed-args)
(list (current-directory))
parsed-args))
(parameterize ([current-poly-target (render-target-wanted)]) ;; applies to both cases
(cond
;; directory mode: one directory as argument
[(and (= 1 (length path-args)) (directory-exists? (car path-args)))
(define top-dir (very-nice-path (car path-args)))
(let loop ([args parsed-args])
(match args
[(== empty) (loop (list (current-directory)))]
[(list dir) ;; directory mode: one directory as argument
#:when (directory-exists? dir)
(define top-dir (very-nice-path dir))
(let render-one-dir ([dir top-dir])
(parameterize ([current-directory dir]
[current-project-root (if (eq? (render-with-subdirs?) 'recursive)
dir
top-dir)])
[current-project-root (case (render-with-subdirs?)
[(recursive) dir]
[else top-dir])])
(define dirlist (directory-list dir))
(define preprocs (filter preproc-source? dirlist))
(define static-pagetrees (filter pagetree-source? dirlist))
@ -124,15 +127,15 @@ version print the version" (current-server-port) (make-publish-di
#:when (and (directory-exists? path)
(not (omitted-path? path))))
(render-one-dir (->complete-path path))))))]
[else ;; path mode
[path-args ;; path mode
(displayln (format "rendering ~a" (string-join (map ->string path-args) " ")))
(apply render-batch (map very-nice-path path-args))])))
(apply render-batch (map very-nice-path path-args))]))))
(define (handle-start)
(define launch-wanted #f)
(define localhost-wanted #f)
(define clargs (command-line #:program "raco pollen start"
(define clargs
(command-line #:program "raco pollen start"
#:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'start' from the front
#:once-each
[("--launch" "-l") "Launch browser after start" (set! launch-wanted #t)]
@ -142,33 +145,30 @@ version print the version" (current-server-port) (make-publish-di
(define dir (path->directory-path (get-first-arg-or-current-dir clargs)))
(unless (directory-exists? dir)
(error (format "~a is not a directory" dir)))
(define port (with-handlers ([exn:fail? (λ (e) #f)])
(define http-port (with-handlers ([exn:fail? (λ (e) #f)])
(string->number (cadr clargs))))
(when (and port (not (exact-positive-integer? port)))
(error (format "~a is not a valid port number" port)))
(when (and http-port (not (exact-positive-integer? http-port)))
(error (format "~a is not a valid port number" http-port)))
(parameterize ([current-project-root dir]
[current-server-port (or port (setup:project-server-port))]
[current-server-port (or http-port (setup:project-server-port))]
[current-server-listen-ip (and localhost-wanted "127.0.0.1")])
(displayln "Starting project server ...")
(message "starting project server ...")
((dynamic-require 'pollen/private/project-server 'start-server) (format "/~a" (setup:main-pagetree dir)) launch-wanted)))
(define (make-publish-dir-name [project-root (current-directory)] [arg-command-name #f])
(define user-publish-path
(expand-user-path (->path (setup:publish-directory project-root))))
(if (complete-path? user-publish-path)
user-publish-path
(build-path (find-system-path 'desk-dir)
(->path (if (equal? arg-command-name "clone") ; bw compat
"clone"
user-publish-path)))))
(->path (case arg-command-name
[("clone") "clone"] ; bw compat
[else user-publish-path])))))
(define (delete-it path)
(cond
[(directory-exists? path) (delete-directory/files path)]
[(file-exists? path) (delete-file path)]))
(match path
[(? directory-exists?) (delete-directory/files path)]
[(? file-exists?) (delete-file path)]))
(define (contains-directory? possible-superdir possible-subdir)
(define (has-prefix? xs prefix)
@ -176,11 +176,10 @@ version print the version" (current-server-port) (make-publish-di
(andmap equal? prefix (take xs (length prefix)))))
((explode-path possible-subdir) . has-prefix? . (explode-path possible-superdir)))
(define (handle-publish)
(define command-name ; either "publish" or "clone"
(vector-ref (current-command-line-arguments) 0))
(define force-target-overwrite? (make-parameter #t))
(define force-target-overwrite? (make-parameter #true))
(define other-args (command-line
;; drop command name
#:argv (vector-drop (current-command-line-arguments) 1)
@ -217,8 +216,8 @@ version print the version" (current-server-port) (make-publish-di
(begin
(display (format "destination directory ~a exists. Overwrite? [yes/no] " dest-dir))
(case (read)
[(y yes) #t]
[else #f]))))
[(y yes) #true]
[else #false]))))
(cond
[do-publish-operation?
(when (directory-exists? dest-dir)
@ -236,11 +235,11 @@ version print the version" (current-server-port) (make-publish-di
[else (displayln "publish aborted")]))
(define (handle-unknown command)
(if (regexp-match #rx"(shit|fuck)" command)
(displayln (let ([responses '("Cursing at free software? Really?" "How uncouth." "Same to you, buddy.")])
(list-ref responses (random (length responses)))))
(begin
(displayln (format "`~a` is an unknown command." command))
(match command
[(regexp #rx"(shit|fuck)")
(define responses '("Cursing at free software? Really?" "How uncouth." "Same to you, buddy."))
(displayln (list-ref responses (random (length responses))))]
[_ (displayln (format "`~a` is an unknown command." command))
(display "These are the available ") ; ... "Pollen commands:"
(handle-help)
(exit 1))))
(exit 1)]))

78
pollen/private/debug.rkt
Unescape Escape View File

@ -1,78 +0,0 @@
#lang racket/base
(require (for-syntax racket/base racket/syntax))
(require racket/date racket/string)
(require sugar/debug sugar/define)
(provide (all-from-out sugar/debug))
; todo: contracts, tests, docs
; debug utilities
(define months (list "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
(define last-message-time #f)
(define (seconds-since-last-message)
(define now (current-seconds))
(define then last-message-time)
(set! last-message-time now)
(if then
(- now then)
"0"))
(define (zero-fill str count)
(set! str (format "~a" str))
(if (> (string-length str) count)
str
(string-append (make-string (- count (string-length str)) #\0) str)))
(define+provide (make-datestamp)
(define date (current-date))
(define date-fields (map (λ (x) (zero-fill x 2))
(list
(date-day date)
(list-ref months (sub1 (date-month date)))
(date-year date)
)))
(string-join date-fields "-"))
(define+provide (make-timestamp)
(define date (current-date))
(define time-fields (map (λ (x) (zero-fill x 2))
(list
; (date-day date)
; (list-ref months (sub1 (date-month date)))
(if (<= (date-hour date) 12)
(date-hour date) ; am hours + noon hour
(modulo (date-hour date) 12)) ; pm hours after noon hour
(date-minute date)
(date-second date))))
(string-append (string-join time-fields ":") (if (< (date-hour date) 12) "am" "pm")))
(define (make-debug-timestamp)
(format "[~a ∆~as]" (make-timestamp) (seconds-since-last-message)))
;; creates pollen-logger and associated functions:
;; log-pollen-fatal, log-pollen-error, log-pollen-warning,
;; log-pollen-info, and log-pollen-debug
(define-logger pollen)
(define-syntax (make-message-logger-functions stx)
(syntax-case stx ()
[(_ stem)
(with-syntax ([message-stem (format-id stx "message-~a" #'stem)]
[log-pollen-stem (format-id stx "log-pollen-~a" #'stem)])
#'(begin
;; does file have particular extension
(define+provide (message-stem . items)
(log-pollen-stem (string-join `(,(make-debug-timestamp) ,@(map (λ (x)(if (string? x) x (format "~v" x))) items)))))))]))
(make-message-logger-functions fatal)
(make-message-logger-functions error)
(make-message-logger-functions warning)
(make-message-logger-functions info)
(make-message-logger-functions debug)
(define+provide (message . items)
(displayln (string-join `(,@(map (λ (x)(if (string? x) x (format "~v" x))) items)))))

0
pollen/private/doclang-raw.rkt → pollen/private/external/doclang-raw.rkt vendored
Unescape Escape View File

34
pollen/private/external/include-template.rkt vendored
Unescape Escape View File

@ -0,0 +1,34 @@
#lang racket/base
(require (for-syntax racket/base
racket/list
syntax/parse)
(only-in scribble/text/syntax-utils include/text)
(only-in "output.rkt" output)
racket/match
racket/port)
(provide include-template)
;; Adaptation of function in web-server/templates library
;; to check for binary result and pass it through.
;; Actually patches underlying bug in `output`.
(define (finish result)
(match result
[(? bytes? bs) bs]
;; list of expressions with byte string in last place.
;; infer that user is trying to return a binary as the last value in a template,
;; and treat it as a single binary value.
[(list _ ... (? bytes? bs)) bs]
[_ (with-output-to-string (λ () (output result)))]))
(define-syntax (include-template stx)
(syntax-parse stx
[(_ (~optional (~seq #:command-char command-char:expr)) src:expr)
(quasisyntax/loc stx
(finish (include/text #,@(if (attribute command-char)
(list #'#:command-char #'command-char)
empty)
src)))]))

69
pollen/private/external/logging.rkt vendored
Unescape Escape View File

@ -0,0 +1,69 @@
#lang racket/base
;; 181030: Needed for compatibility with Racket 6.0.
;; This module introduced until 6.3.
(require racket/contract/base)
(provide log-level/c)
(define log-level/c (or/c 'none 'fatal 'error 'warning 'info 'debug))
(define log-spec? (listof (or/c symbol? #f)))
(define log-event? (vector-immutable/c log-level/c string? any/c (or/c symbol? #f)))
(provide/contract [with-intercepted-logging
(->* ((-> log-event? any)
(-> any)
log-level/c)
(#:logger logger?)
#:rest log-spec?
any)]
[with-logging-to-port
(->* (output-port? (-> any) log-level/c)
(#:logger logger?)
#:rest log-spec?
any)])
(define (receiver-thread receiver stop-chan intercept)
(thread
(lambda ()
(define (clear-events)
(let ([l (sync/timeout 0 receiver)])
(when l ; still something to read
(intercept l) ; interceptor gets the whole vector
(clear-events))))
(let loop ()
(let ([l (sync receiver stop-chan)])
(cond [(eq? l 'stop)
;; we received all the events we were supposed
;; to get, read them all (w/o waiting), then
;; stop
(clear-events)]
[else ; keep going
(intercept l)
(loop)]))))))
(define (with-intercepted-logging interceptor proc #:logger [logger #f]
. log-spec)
(let* ([orig-logger (current-logger)]
;; Unless we're provided with an explicit logger to monitor we
;; use a local logger to avoid getting messages that didn't
;; originate from proc. Since it's a child of the original logger,
;; the rest of the program still sees the log entries.
[logger (or logger (make-logger #f orig-logger))]
[receiver (apply make-log-receiver logger log-spec)]
[stop-chan (make-channel)]
[t (receiver-thread receiver stop-chan interceptor)])
(begin0
(parameterize ([current-logger logger])
(proc))
(channel-put stop-chan 'stop) ; stop the receiver thread
(thread-wait t))))
(define (with-logging-to-port port proc #:logger [logger #f] . log-spec)
(apply with-intercepted-logging
#:logger logger
(lambda (l) (displayln (vector-ref l 1) ; actual message
port))
proc
log-spec))

2
pollen/private/manual-history.rkt → pollen/private/external/manual-history.rkt vendored
Unescape Escape View File

@ -10,7 +10,7 @@
#|
Need this to make pollen docs buildable on v6.0.
`history` not added to scribble/manul till v6.1.
`history` not added to scribble/manual till v6.1.
|#
(provide pollen-history)

0
pollen/private/mode-indentation.rkt → pollen/private/external/mode-indentation.rkt vendored
Unescape Escape View File

0
pollen/private/output.rkt → pollen/private/external/output.rkt vendored
Unescape Escape View File

0
pollen/private/pipe.py → pollen/private/external/pipe.py vendored
Unescape Escape View File

33
pollen/private/include-template.rkt
Unescape Escape View File

@ -1,33 +0,0 @@
#lang racket/base
(require (only-in scribble/text/syntax-utils include/text)
(only-in "output.rkt" output)
racket/list
(for-syntax racket/base
racket/list
syntax/parse)
racket/port)
;; Adaptation of function in web-server/templates library
;; to check for binary result and pass it through.
;; Actually patches underlying bug in `output`.
(define-syntax (include-template stx)
(syntax-parse stx
[(_ (~optional (~seq #:command-char command-char:expr)) p:expr)
(quasisyntax/loc stx
(let ([result (include/text #,@(if (attribute command-char)
(list #'#:command-char #'command-char)
empty)
p)])
(let ([result (cond
[(bytes? result) result]
;; list of expressions with byte string in last place.
;; infer that user is trying to return a binary as the last value in a template,
;; and treat it as a single binary value.
[(and (list? result) (bytes? (last result))) (last result)]
[else result])])
(if (bytes? result)
(with-output-to-bytes (λ () (write-bytes result)))
(with-output-to-string (λ () (output result)))))))]))
(provide include-template)

14
pollen/private/log.rkt
Unescape Escape View File

@ -0,0 +1,14 @@
#lang racket/base
(require racket/format
racket/string
"external/logging.rkt")
(provide (all-defined-out) (all-from-out "external/logging.rkt"))
;; creates `pollen-logger` and associated functions:
;; log-pollen-fatal, log-pollen-error, log-pollen-warning,
;; log-pollen-info, and log-pollen-debug
(define-logger pollen)
(define (message . items)
(log-pollen-info (string-join (map ~a items) " ")))

33
pollen/private/main-base.rkt
Unescape Escape View File

@ -1,29 +1,34 @@
#lang racket/base
(require (for-syntax racket/base syntax/strip-context "../setup.rkt" "split-metas.rkt")
"to-string.rkt" "../pagetree.rkt" "splice.rkt" "../setup.rkt" "../core.rkt"
(prefix-in doclang: "doclang-raw.rkt"))
(require (for-syntax racket/base
syntax/strip-context
"../setup.rkt"
"split-metas.rkt")
racket/match
racket/list
"to-string.rkt"
"../pagetree.rkt"
"splice.rkt"
"../setup.rkt"
"../core.rkt"
(prefix-in doclang: "external/doclang-raw.rkt"))
(provide (except-out (all-from-out racket/base) #%module-begin)
(rename-out [pollen-module-begin #%module-begin]))
(define ((make-parse-proc parser-mode root-proc) xs)
(define (stringify xs) (apply string-append (map to-string xs)))
(cond
[(eq? parser-mode default-mode-pagetree) (decode-pagetree xs)]
[(eq? parser-mode default-mode-markup) (apply root-proc (remove-voids xs))]
[(eq? parser-mode default-mode-markdown)
(match parser-mode
[(== default-mode-pagetree) (decode-pagetree xs)]
[(== default-mode-markup) (apply root-proc (remove-voids xs))]
[(== default-mode-markdown)
(let* ([xs (stringify xs)]
[xs ((dynamic-require 'markdown 'parse-markdown) xs)]
[xs (map strip-empty-attrs xs)])
(apply root-proc xs))]
[else (stringify xs)])) ; preprocessor mode
[_ (stringify xs)])) ; preprocessor mode
(define (strip-leading-newlines doc)
;; drop leading newlines, as they're often the result of `defines` and `requires`
(or (memf (λ (ln) (and (not (equal? ln (setup:newline)))
(not (equal? ln "")))) doc) null))
(dropf doc (λ (ln) (member ln (list (setup:newline) "")))))
(define-syntax (pollen-module-begin stx)
(syntax-case stx ()
@ -38,7 +43,7 @@
DOC-ID ; positional arg for doclang-raw: name of export
(λ (xs)
(define proc (make-parse-proc PARSER-MODE ROOT-ID))
(define trimmed-xs (if (setup:trim-whitespace?) (strip-leading-newlines xs) xs))
(define trimmed-xs ((if (setup:trim-whitespace?) strip-leading-newlines values) xs))
(define doc-elements (splice trimmed-xs (setup:splicing-tag)))
(proc doc-elements)) ; positional arg for doclang-raw: post-processor
(module META-MOD-ID racket/base

71
pollen/private/preheat-cache.rkt
Unescape Escape View File

@ -1,14 +1,44 @@
#lang racket/base
(require "file-utils.rkt" racket/file "cache-utils.rkt" "debug.rkt" racket/path racket/place sugar/list)
(require racket/file
racket/path
racket/place
racket/list
sugar/list
"file-utils.rkt"
"cache-utils.rkt"
"log.rkt")
(provide preheat-cache)
(define (path-cached? path)
;; #true = already cached; #false = not cached
;; seems like it would be slow to load cache.rktd but it's not.
(define-values (_ private-cache-dir) (make-cache-dirs path))
(define cache-db-file (build-path private-cache-dir "cache.rktd"))
(and (file-exists? cache-db-file)
(hash-has-key? (file->value cache-db-file) (paths->key path))))
;; compile a path inside a place (= parallel processing)
(define (path-into-place starting-dir path)
(message (format "caching: ~a" (find-relative-path starting-dir path)))
(define p
(place ch
(define path (place-channel-get ch))
(define-values (_ path-name __) (split-path path))
(message (format "compiling: ~a" path))
;; use #false to signal compile error. Otherwise allow errors to pass.
(define result
(with-handlers ([exn:fail? (λ (e) (message (format "compile failed: ~a" path-name)) #false)])
(path->hash path)))
(place-channel-put ch result)))
(place-channel-put p path)
p)
(define (preheat-cache starting-dir)
(unless (and (path-string? starting-dir) (directory-exists? starting-dir))
(error 'preheat-cache (format "~a is not a directory" starting-dir)))
(raise-argument-error 'preheat-cache "directory" starting-dir))
(define max-places (processor-count)) ; number of parallel processes to spawn at a time
(define paths-that-should-be-cached (for/list ([path (in-directory starting-dir)]
(define paths-that-should-be-cached
(for/list ([path (in-directory starting-dir)]
#:when (for/or ([proc (in-list (list preproc-source?
markup-source?
markdown-source?
@ -18,38 +48,15 @@
;; if a file is already in the cache, no need to hit it again.
;; this allows partially completed preheat jobs to resume.
(define uncached-paths (filter
(λ (path)
;; #t = not cached; #f = already cached
;; seems like it would be slow to load cache.rktd but it's not.
(define-values (_ private-cache-dir) (make-cache-dirs path))
(define cache-db-file (build-path private-cache-dir "cache.rktd"))
(cond
[(not (file-exists? cache-db-file)) #t]
[else (define cache-db (file->value cache-db-file))
(not (hash-has-key? cache-db (paths->key path)))])) paths-that-should-be-cached))
;; compile a path inside a place (= parallel processing)
(define (path-into-place path)
(message (format "caching: ~a" (find-relative-path starting-dir path)))
(define p (place ch
(define path (place-channel-get ch))
(define-values (path-dir path-name _) (split-path path))
(message (format "compiling: ~a" path))
;; use #f to signal compile error. Otherwise allow errors to pass.
(define result (with-handlers ([exn:fail? (λ _ (message (format "compile failed: ~a" path-name)) #f)])
(path->hash path)))
(place-channel-put ch result)))
(place-channel-put p path)
p)
(define uncached-paths (filter-not path-cached? paths-that-should-be-cached))
;; compile the paths in groups, so they can be incrementally saved.
;; that way, if there's a failure, the progress is preserved.
;; but the slowest file in a group will prevent further progress.
(for ([path-group (in-list (slice-at uncached-paths max-places))])
(define path-places (map path-into-place path-group))
(define path-places (map (λ (pg) (path-into-place starting-dir pg)) path-group))
(for ([path (in-list path-group)]
[ppl (in-list path-places)])
(define result (place-channel-get ppl))
(when result ; #f is used to signal compile error
(cache-ref! (paths->key path) (λ _ result))))))
(when result ; #false is used to signal compile error
(cache-ref! (paths->key path) (λ () result))))))

53
pollen/private/project-server-routes.rkt
Unescape Escape View File

@ -1,14 +1,32 @@
#lang racket/base
(require racket/list racket/contract racket/file racket/format xml racket/match racket/set racket/string racket/promise racket/path)
(require web-server/http/xexpr web-server/dispatchers/dispatch)
(require net/url)
(require web-server/http/request-structs)
(require web-server/http/response-structs)
(require web-server/http/redirect)
(require 2htdp/image)
(require "../setup.rkt" "../render.rkt" sugar sugar/unstable/string sugar/unstable/misc sugar/unstable/container txexpr/base "file-utils.rkt" "debug.rkt" "../pagetree.rkt" "../cache.rkt")
(module+ test (require rackunit))
(require racket/list
racket/contract
racket/file
racket/format
racket/match
racket/string
racket/promise
racket/path
web-server/http/xexpr
web-server/dispatchers/dispatch
net/url
web-server/http/request-structs
web-server/http/response-structs
web-server/http/redirect
2htdp/image
"../setup.rkt"
"../render.rkt"
sugar
sugar/unstable/string
sugar/unstable/misc
sugar/unstable/container
txexpr/base
"file-utils.rkt"
"log.rkt"
"../pagetree.rkt"
"../cache.rkt")
(module+ test (require))
;;; Routes for the server module
;;; separated out for ease of testing
@ -40,14 +58,15 @@
;; print message to console about a request
(define/contract (logger req)
(request? . -> . void?)
(define client (request-client-ip req))
(define localhost-client "::1")
(define url-string (url->string (request-uri req)))
(when (not (ends-with? url-string "favicon.ico"))
(message "request:" (if (regexp-match #rx"/$" url-string)
(string-append url-string " directory default page")
(string-replace url-string (setup:main-pagetree) " dashboard"))
(if (not (equal? client localhost-client)) (format "from ~a" client) ""))))
(unless (ends-with? url-string "favicon.ico")
(message (match url-string
[(regexp #rx"/$") (string-append url-string " directory default page")]
[_ (string-replace url-string (setup:main-pagetree) " dashboard")])
(match (request-client-ip req)
[(== localhost-client) ""]
[client (format "from ~a" client)]))))
;; pass string args to route, then
;; package route into right format for web server
@ -289,7 +308,7 @@
(define/contract (route-404 req)
(request? . -> . response?)
(define missing-path-string (path->string (simplify-path (req->path req))))
(message (format "route-404: Can't find ~a" missing-path-string))
(message (format "can't find ~a" missing-path-string))
(response/xexpr+doctype
`(html
(head (title "404 error") (link ((href "/error.css") (rel "stylesheet"))))

19
pollen/private/project-server.rkt
Unescape Escape View File

@ -1,10 +1,9 @@
#lang web-server/base
(require racket/list
web-server/servlet-env
web-server/dispatch)
(require "project-server-routes.rkt"
"debug.rkt"
web-server/dispatch
"project-server-routes.rkt"
"log.rkt"
"../setup.rkt"
"../file.rkt"
"../cache.rkt"
@ -15,19 +14,19 @@
(define (start-server servlet-path [open-browser-window? #f])
(define-values (pollen-servlet _)
(dispatch-rules
[((string-arg) ... (? (λ (x) (equal? "" x)))) route-index] ; last element of a "/"-terminated url is ""
[((string-arg) ... (? (λ (x) (string=? "" x)))) route-index] ; last element of a "/"-terminated url is ""
[((string-arg) ... (? pagetree-source?)) route-dashboard]
[((string-arg) ... "in" (string-arg) ...) route-in]
[((string-arg) ... "out" (string-arg) ...) route-out]
[else route-default]))
(message (format "Welcome to Pollen ~a" pollen:version) (format "(Racket ~a)" (version)))
(message (format "Project root is ~a" (current-project-root)))
(message (format "welcome to Pollen ~a (Racket ~a)" pollen:version (version)))
(message (format "project root is ~a" (current-project-root)))
(define server-name (format "http://localhost:~a" (current-server-port)))
(message (format "Project server is ~a" server-name) "(Ctrl+C to exit)")
(message (format "Project dashboard is ~a/~a" server-name (setup:main-pagetree)))
(message "Ready to rock")
(message (format "project server is ~a (Ctrl+C to exit)" server-name))
(message (format "project dashboard is ~a/~a" server-name (setup:main-pagetree)))
(message "ready to rock")
(parameterize ([error-print-width 1000])
(serve/servlet pollen-servlet

17
pollen/private/project.rkt
Unescape Escape View File

@ -1,19 +1,20 @@
#lang racket/base
(require racket/syntax
racket/match
sugar/define
sugar/coerce
"../setup.rkt"
"file-utils.rkt")
(define+provide/contract (get-directory-require-files source-arg)
(pathish? . -> . (or/c #f (λ (xs) (and (list? xs) (andmap complete-path? xs)))))
(define source-path (->path source-arg))
(define require-filenames (list default-directory-require))
(define possible-requires (for*/list ([rf (in-list require-filenames)]
[p (in-value (find-upward-from source-path rf))]
#:when p)
p))
(and (pair? possible-requires) possible-requires))
(pathish? . -> . (or/c #false (λ (xs) (and (list? xs) (andmap complete-path? xs)))))
;; only one file, but we'll leave it in plural form
(match (for*/list ([rf (in-list (list default-directory-require))]
[path (in-value (find-upward-from (->path source-arg) rf))]
#:when path)
path)
[(? pair? possible-requires) possible-requires]
[_ #false]))
(define+provide/contract (require+provide-directory-require-files here-arg #:provide [provide? #t])

69
pollen/private/reader-base.rkt
Unescape Escape View File

@ -4,7 +4,9 @@
racket/class
racket/string
racket/runtime-path
racket/match
setup/getinfo
sugar/file
(for-syntax racket/base)
(only-in scribble/reader make-at-reader)
"../setup.rkt"
@ -13,27 +15,20 @@
(define (source-name->pollen-require-path source-name)
;; the `path-string` passed in from `read-syntax` can actually be `any/c`
(if (syntax? source-name)
(syntax-source source-name)
;; captures paths, strings, "unsaved editor", path-strings, symbols
source-name))
((if (syntax? source-name) syntax-source values) source-name))
(define (infer-parser-mode reader-mode reader-here-path)
(if (eq? reader-mode default-mode-auto)
(let* ([file-ext-pattern (pregexp "\\w+$")]
[here-ext (string->symbol (car (regexp-match file-ext-pattern reader-here-path)))]
[auto-computed-mode (cond
[(eq? here-ext (setup:pagetree-source-ext)) default-mode-pagetree]
[(eq? here-ext (setup:markup-source-ext)) default-mode-markup]
[(eq? here-ext (setup:markdown-source-ext)) default-mode-markdown]
[else default-mode-preproc])])
auto-computed-mode)
reader-mode))
(define (custom-read p)
(syntax->datum (custom-read-syntax (object-name p) p)))
(match reader-mode
[(== default-mode-auto)
(match (cond [(get-ext reader-here-path) => string->symbol])
[(== (setup:pagetree-source-ext)) default-mode-pagetree]
[(== (setup:markup-source-ext)) default-mode-markup]
[(== (setup:markdown-source-ext)) default-mode-markdown]
[_ default-mode-preproc])]
[_ reader-mode]))
(define (custom-read p) (syntax->datum (custom-read-syntax (object-name p) p)))
(define (custom-read-syntax #:reader-mode [reader-mode #f] source-name input-port)
(define source-stx (let ([read-inner (make-at-reader
@ -78,27 +73,27 @@
(define ((custom-get-info mode) in mod line col pos)
;; DrRacket caches source file information per session,
;; so we can do the same to avoid multiple searches for the command char.
(let ([command-char-cache (make-hash)])
(define command-char-cache (make-hash))
(λ (key default)
(case key
[(color-lexer drracket:toolbar-buttons) ; only do source-path searching if we have one of these keys
(define maybe-source-path (with-handlers ([exn:fail? (λ (exn) #f)])
;; only do source-path searching if we have one of these two keys
[(color-lexer drracket:toolbar-buttons)
(define maybe-source-path
(with-handlers ([exn:fail? (λ (exn) #false)])
;; Robert Findler does not endorse `get-filename` here,
;; because it's sneaky and may not always work.
;; OTOH Scribble relies on it, so IMO it's highly unlikely to change.
(let ([maybe-definitions-frame (object-name in)])
(send maybe-definitions-frame get-filename)))) ; will be #f if unsaved file
(define my-command-char (hash-ref! command-char-cache maybe-source-path (λ _ (setup:command-char maybe-source-path))))
(send (object-name in) get-filename)))
(define my-command-char
(hash-ref! command-char-cache maybe-source-path (λ () (setup:command-char maybe-source-path))))
(case key
[(color-lexer)
(define my-make-scribble-inside-lexer
(dynamic-require 'syntax-color/scribble-lexer 'make-scribble-inside-lexer (λ () #f)))
(if my-make-scribble-inside-lexer
(my-make-scribble-inside-lexer #:command-char my-command-char)
default)]
(match (dynamic-require 'syntax-color/scribble-lexer 'make-scribble-inside-lexer (λ () #false))
[(? procedure? make-lexer) (make-lexer #:command-char my-command-char)]
[_ default])]
[(drracket:toolbar-buttons)
(define my-make-drracket-buttons (dynamic-require 'pollen/private/drracket-buttons 'make-drracket-buttons))
(my-make-drracket-buttons my-command-char)])]
(match (dynamic-require 'pollen/private/drracket-buttons 'make-drracket-buttons (λ () #false))
[(? procedure? make-buttons) (make-buttons my-command-char)])])]
[(drracket:indentation)
(dynamic-require 'scribble/private/indentation 'determine-spaces)]
[(drracket:default-filters)
@ -109,13 +104,13 @@
(list (list "Pollen sources" (string-join filter-strings ";")))]
[(drracket:default-extension)
(symbol->string
(cond
[(eq? mode default-mode-auto) (setup:preproc-source-ext)]
[(eq? mode default-mode-preproc) (setup:preproc-source-ext)]
[(eq? mode default-mode-markdown) (setup:markdown-source-ext)]
[(eq? mode default-mode-markup) (setup:markup-source-ext)]
[(eq? mode default-mode-pagetree) (setup:pagetree-source-ext)]))]
[else default]))))
(match mode
[(== default-mode-auto) (setup:preproc-source-ext)]
[(== default-mode-preproc) (setup:preproc-source-ext)]
[(== default-mode-markdown) (setup:markdown-source-ext)]
[(== default-mode-markup) (setup:markup-source-ext)]
[(== default-mode-pagetree) (setup:pagetree-source-ext)]))]
[else default])))
(define-syntax-rule (reader-module-begin mode . _)
(#%module-begin

44
pollen/private/runtime-config.rkt
Unescape Escape View File

@ -1,35 +1,43 @@
#lang racket/base
(require pollen/setup scribble/reader racket/pretty version/utils racket/port racket/string)
(provide (all-defined-out))
(require pollen/setup
scribble/reader
racket/pretty
version/utils
racket/port
racket/string
txexpr/base)
(provide show configure current-top-path)
(define current-top-path (make-parameter #f))
(define (my-pretty-print x)
;; #:newline option for `pretty-print` was introduced in 6.6.0.3
(if (version<? (version) "6.7")
;; so trim trailing newline manually in earlier versions
(display (string-trim #:left? #f (with-output-to-string (λ () (pretty-print x))) "\n"))
(pretty-print #:newline? #f x)))
(define (my-error-handler exn)
(error '|pollen markup error| (string-join (cdr (string-split (exn-message exn) ": ")) ": ")))
(define (show doc parser-mode here-path)
;; we only want the top doc to print in the runtime environment
;; otherwise if a Pollen source imports others, they will all print their docs in sequence.
;; so only print if the current here-path is the top path, which is stored in the `current-top-path` parameter.
(let ([ctp (current-top-path)])
(when (and ctp (equal? here-path ctp))
(when (equal? here-path (current-top-path))
(if (memq parser-mode (list default-mode-preproc default-mode-template))
(display doc)
;; #:newline option for `pretty-print` was introduced in 6.6.0.3,
;; so trim trailing newline manually
(let ([pretty-print-proc (if (version<? (version) "6.7")
(λ (x) (display (string-trim #:left? #f (with-output-to-string (λ () (pretty-print x))) "\n")))
(λ (x) (pretty-print #:newline? #f x)))])
;; OK to use dynamic-require because runtime-config itself is dynamic-required
(pretty-print-proc (with-handlers ([exn:fail? (λ (exn) ((error '|pollen markup error|
((dynamic-require 'racket/string 'string-join) (cdr ((dynamic-require 'racket/string 'string-split) (exn-message exn) ": ")) ": "))))])
((dynamic-require 'txexpr/base 'validate-txexpr) doc))))))))
(with-handlers ([exn:fail? my-error-handler])
(my-pretty-print (validate-txexpr doc))))))
(define (configure top-here-path)
(current-top-path top-here-path) ;; puts `show` into the right mode
;; wrap REPL interactions with pollen expression support
(current-top-path top-here-path) ; puts `show` into the right mode
(define old-read (current-read-interaction))
(define (pollen-repl-read src in)
;; wrap repl interactions with pollen expression support
(define pollen-readtable (make-at-readtable #:command-char (setup:command-char)))
(define (new-read src in)
(parameterize ([current-readtable pollen-readtable])
(old-read src in)))
(current-read-interaction new-read))
(current-read-interaction pollen-repl-read))

46
pollen/private/splice.rkt
Unescape Escape View File

@ -1,31 +1,33 @@
#lang racket/base
(require racket/match
racket/list)
(provide (all-defined-out))
;; (string->symbol (format "~a" #\u200B))
(define splice-signal-tag '@)
(define (attrs? x)
(and (list? x)
(andmap (λ (xi)
(and (list? xi)
(= (length xi) 2)
(symbol? (car xi))
(string? (cadr xi)))) x)))
(match x
[(list (list (? symbol?) (? string?)) ...) #true]
[_ #false]))
(define (null-string? x) (equal? x ""))
(define ((spliceable? splicing-tag) x)
(match x
[(cons (== splicing-tag eq?) _) #true]
[_ #false]))
(define (splice x [splicing-tag splice-signal-tag])
; (listof txexpr-elements?) . -> . (listof txexpr-elements?))
(define spliceable? (λ (x) (and (pair? x) (eq? (car x) splicing-tag))))
(define not-null-string? (λ (x) (not (and (string? x) (zero? (string-length x))))))
(let loop ([x x])
(if (list? x) ; don't exclude `attrs?` here, because it will exclude valid splice input like '((@ "foo"))
(apply append (map (λ (x) (let ([proc (if (spliceable? x) ; drop the splice-signal from front with `cdr`
cdr
list)]
[x (if (not (attrs? x)) ; don't recur on attributes, so null strings are not spliced within
(loop x)
x)])
(proc x))) (filter not-null-string? x)))
(append-map (λ (x)
; drop the splice-signal from front with `rest`
; don't recur on attributes, so null strings are not spliced within
(define proc (if ((spliceable? splicing-tag) x) rest list))
(proc (if (attrs? x) x (loop x))))
(filter-not null-string? x))
x)))
(module+ test
@ -40,29 +42,25 @@
(check-equal? (splice `((,splice-signal-tag "str"))) '("str")))
;; this will strip all empty lists.
;; in practice, they would only appear in attrs position
(define (strip-empty-attrs x)
(let loop ([x x])
(if (list? x)
;; this will strip all empty lists.
;; in practice, they would only appear in attrs position
(map loop (filter (λ (x) (not (null? x))) x))
(if (pair? x)
(map loop (filter-not null? x))
x)))
(module+ test
(check-equal? (strip-empty-attrs '(p ())) '(p))
(check-equal? (strip-empty-attrs '(p () "foo")) '(p "foo"))
(check-equal? (strip-empty-attrs '(p () (em () "foo") "bar")) '(p (em "foo") "bar")))
;; used with pollen/markup to suppress void arguments,
;; consistent with how pollen/pre and pollen/markdown handle them
(define (remove-voids x)
(let loop ([x x])
(if (pair? x)
(for/list ([xi (in-list x)]
#:unless (void? xi))
(loop xi))
(map loop (filter-not void? x))
x)))
(module+ test

22
pollen/private/split-metas.rkt
Unescape Escape View File

@ -1,18 +1,20 @@
#lang racket/base
(require racket/match
racket/list)
(provide (all-defined-out))
(define (split-metas x meta-key)
(apply hasheq
(let loop ([x (if (syntax? x) (syntax->datum x) x)])
(cond
[(list? x) (cond
[(and (= (length x) 3) (eq? (car x) meta-key))
(unless (symbol? (cadr x))
(raise-argument-error 'define-meta "valid meta key" (cadr x)))
(cdr x)] ; list with meta key and meta value
[else (apply append (map loop x))])]
[else null]))))
(let loop ([x ((if (syntax? x) syntax->datum values) x)])
(match x
[(? list? xs)
(match xs
[(list (== meta-key eq?) key val)
(unless (symbol? key)
(raise-argument-error 'define-meta "valid meta key" key))
(list key val)]
[_ (append-map loop xs)])]
[_ null]))))
(module+ test
(require rackunit)

2
pollen/private/ts.rktd
Unescape Escape View File

@ -1 +1 @@
1540875704
1540958640

10
pollen/private/update-info.rkt
Unescape Escape View File

@ -1,10 +0,0 @@
#lang racket/base
(require racket/runtime-path racket/file pollen/private/version)
(define-runtime-path info-file "../../info.rkt")
(module+ main
(define str (file->string info-file))
(define newstr
(regexp-replace #rx"\\(define version .*?\\)" str (format "(define version ~v)" pollen:version-strict)))
(display-to-file newstr info-file #:exists 'replace))

31
pollen/private/whitespace.rkt
Unescape Escape View File

@ -1,28 +1,23 @@
#lang racket/base
(require racket/match)
(provide (all-defined-out))
(define (whitespace-base x #:nbsp-is-white? nbsp-white?)
(define pat (pregexp (format "^[\\s~a]+$" (if nbsp-white? #\u00A0 ""))))
(and (let loop ([x x])
(cond
[(string? x) (or (zero? (string-length x)) (regexp-match pat x))] ; empty string is deemed whitespace
[(symbol? x) (loop (symbol->string x))]
[(pair? x) (andmap loop x)]
[(vector? x) (loop (vector->list x))]
[else #f]))
#t))
(define white-pat (pregexp (format "^[\\s~a]+$" (if nbsp-white? #\u00A0 ""))))
(let loop ([x x])
(match x
["" #true] ; empty string is deemed whitespace
[(pregexp white-pat) #true]
[(? symbol?) (loop (symbol->string x))]
[(? pair?) (andmap loop x)]
[(? vector?) (loop (vector->list x))]
[_ #false])))
(define (whitespace? x) (whitespace-base x #:nbsp-is-white? #f))
(define (whitespace? x)
(whitespace-base x #:nbsp-is-white? #f))
(define not-whitespace? (λ (x) (not (whitespace? x))))
(define (whitespace/nbsp? x)
(whitespace-base x #:nbsp-is-white? #t))
(define (not-whitespace? x) (not (whitespace? x)))
(define (whitespace/nbsp? x) (whitespace-base x #:nbsp-is-white? #t))
(module+ test
(require rackunit racket/format)

128
pollen/render.rkt
Unescape Escape View File

@ -1,18 +1,17 @@
#lang racket/base
(require racket/file
racket/path
compiler/cm
racket/match
sugar/test
sugar/define
sugar/file
sugar/coerce
"private/file-utils.rkt"
"cache.rkt"
"private/debug.rkt"
"private/log.rkt"
"private/project.rkt"
"private/cache-utils.rkt"
"pagetree.rkt"
"template.rkt"
"core.rkt"
"setup.rkt")
@ -23,7 +22,6 @@
;; render functions will always go when no mod-date is found.
(define (reset-mod-date-hash!) (set! mod-date-hash (make-hash)))
(module-test-internal
(require racket/runtime-path)
(define-runtime-path sample-dir "test/data/samples")
@ -31,8 +29,6 @@
(map path->complete-path (filter (λ (name) (regexp-match "sample-" name)) (directory-list ".")))))
(define-values (sample-01 sample-02 sample-03) (apply values samples)))
;; each key for mod-date-hash is a list of file / mod-date pairs (using pollen/cache keymaking function)
;; when a file is rendered, a new key is stored in the hash (with trivial value #t)
;; after that, the hash-key-comparision routine intrinsic to hash lookup
@ -40,15 +36,13 @@
;; create a new key with current files. If the key is in the hash, the render has happened.
;; if not, a new render is needed.
(define (update-mod-date-hash! source-path template-path)
(hash-set! mod-date-hash (paths->key source-path template-path) #t))
(hash-set! mod-date-hash (paths->key source-path template-path) #true))
(define (mod-date-missing-or-changed? source-path template-path)
(not (hash-has-key? mod-date-hash (paths->key source-path template-path))))
(define (list-of-pathish? x) (and (list? x) (andmap pathish? x)))
(define+provide/contract (render-batch . xs)
(() #:rest list-of-pathish? . ->* . void?)
;; Why not just (for-each render ...)?
@ -58,7 +52,6 @@
(reset-mod-date-hash!)
(for-each render-from-source-or-output-path xs))
(define+provide/contract (render-pagenodes pagetree-or-path)
((or/c pagetree? pathish?) . -> . void?)
(define pagetree (if (pagetree? pagetree-or-path)
@ -67,7 +60,6 @@
(parameterize ([current-directory (current-project-root)])
(apply render-batch (map ->complete-path (pagetree->list pagetree)))))
(define+provide/contract (render-from-source-or-output-path so-pathish)
(pathish? . -> . void?)
(define so-path (->complete-path so-pathish)) ; so-path = source or output path (could be either)
@ -101,7 +93,7 @@
[(not (file-exists? output-path)) 'file-missing]
[(mod-date-missing-or-changed? source-path template-path) 'mod-key-missing-or-changed]
[(not (setup:render-cache-active source-path)) 'render-cache-deactivated]
[else #f]))
[else #false]))
(when render-needed?
(define render-result
(let ([key (paths->key source-path template-path output-path)])
@ -115,23 +107,20 @@
#:dest-path 'output
#:notify-cache-use
(λ (str)
(message (format "rendering: /~a (from cache)"
(message (format "from cache /~a"
(find-relative-path (current-project-root) output-path))))))))) ; will either be string or bytes
(display-to-file render-result output-path
#:exists 'replace
#:mode (if (string? render-result) 'text 'binary))))
(define+provide/contract (render-to-file-if-needed source-path [maybe-template-path #f] [maybe-output-path #f])
((complete-path?) ((or/c #f complete-path?) (or/c #f complete-path?)) . ->* . void?)
(render-to-file-base 'render-to-file-if-needed #f source-path maybe-output-path maybe-template-path))
(define+provide/contract (render-to-file source-path [maybe-template-path #f] [maybe-output-path #f])
((complete-path?) ((or/c #f complete-path?) (or/c #f complete-path?)) . ->* . void?)
(render-to-file-base 'render-to-file #t source-path maybe-output-path maybe-template-path))
(define+provide/contract (render source-path [maybe-template-path #f] [maybe-output-path #f])
((complete-path?) ((or/c #f complete-path?) (or/c #f complete-path?)) . ->* . (or/c string? bytes?))
(define output-path (or maybe-output-path (->output-path source-path)))
@ -156,58 +145,59 @@
(raise-argument-error 'render (format "valid rendering function for ~a" source-path) render-proc))
(define template-path (or maybe-template-path (get-template-for source-path output-path)))
(message (format "rendering: /~a as /~a"
(find-relative-path (current-project-root) source-path)
(find-relative-path (current-project-root) output-path)))
;; output-path and template-path may not have an extension, so check them in order with fallback
(define render-result (parameterize ([current-poly-target (->symbol (or (get-ext output-path)
(message (format "rendering /~a"
(find-relative-path (current-project-root) source-path)))
(match-define-values ((cons render-result _) _ real _)
(parameterize ([current-poly-target (->symbol (or (get-ext output-path)
(and template-path (get-ext template-path))
(current-poly-target)))])
(apply render-proc (list source-path template-path output-path))))
(time-apply render-proc (list source-path template-path output-path))))
;; wait till last possible moment to store mod dates, because render-proc may also trigger its own subrenders
;; e.g., of a template.
(message (format "rendered /~a ~a"
(find-relative-path (current-project-root) output-path)
(if (< real 1000)
(format "(~a ms)" real)
(format "(~a s)" (/ real 1000.0)))))
(update-mod-date-hash! source-path template-path)
render-result)
(define (render-null-source source-path . ignored-paths)
;((complete-path?) #:rest any/c . ->* . bytes?)
;; All this does is copy the source. Hence, "null".
;; todo: add test to avoid copying if unnecessary (good idea in case the file is large)
(file->bytes source-path))
(define (render-scribble-source source-path . _)
;((complete-path?) #:rest any/c . ->* . string?)
(local-require scribble/core scribble/manual (prefix-in scribble- scribble/render))
(define source-dir (dirname source-path))
;; make fresh namespace for scribble rendering (avoids dep/zo caching)
(time (parameterize ([current-namespace (make-base-namespace)]
(parameterize ([current-namespace (make-base-namespace)]
[current-directory (->complete-path source-dir)])
(namespace-attach-module (namespace-anchor->namespace render-module-ns) 'scribble/core)
(namespace-attach-module (namespace-anchor->namespace render-module-ns) 'scribble/manual)
(define outer-ns (namespace-anchor->namespace render-module-ns))
(namespace-attach-module outer-ns 'scribble/core)
(namespace-attach-module outer-ns 'scribble/manual)
;; scribble/lp files have their doc export in a 'doc submodule, so check both locations
(define doc
[cond
[(dynamic-require source-path 'doc (λ () #f))]
[(dynamic-require `(submod ,source-path doc) 'doc (λ () #f))]
[else #f]])
(match (cond
[(dynamic-require source-path 'doc (λ () #false))]
[(dynamic-require `(submod ,source-path doc) 'doc (λ () #false))]
[else #false])
;; BTW this next action has side effects: scribble will copy in its core files if they don't exist.
(when doc
(scribble-render (list doc) (list source-path)))))
(define result (file->string (->output-path source-path)))
(delete-file (->output-path source-path)) ; because render promises the data, not the side effect
result)
[(? part? doc) (scribble-render (list doc) (list source-path))]
[_ (void)]))
(begin0 ; because render promises the data, not the side effect
(file->string (->output-path source-path))
(delete-file (->output-path source-path))))
(define (render-preproc-source source-path . _)
(time (parameterize ([current-directory (->complete-path (dirname source-path))])
(render-through-eval (syntax->datum
(parameterize ([current-directory (->complete-path (dirname source-path))])
(render-datum-through-eval (syntax->datum
(with-syntax ([SOURCE-PATH source-path])
#'(begin (require pollen/cache)
(cached-doc SOURCE-PATH))))))))
(cached-doc SOURCE-PATH)))))))
(define (render-markup-or-markdown-source source-path [maybe-template-path #f] [maybe-output-path #f])
(define output-path (or maybe-output-path (->output-path source-path)))
@ -217,7 +207,7 @@
(unless template-path
(raise-argument-error 'render-markup-or-markdown-source "valid template path" template-path))
(render-from-source-or-output-path template-path) ; because template might have its own preprocessor source
(define expr-to-eval
(define datum-to-eval
(syntax->datum
(with-syntax ([DIRECTORY-REQUIRE-FILES (require-directory-require-files source-path)]
[DOC-ID (setup:main-export source-path)]
@ -229,9 +219,9 @@
[TEMPLATE-PATH (->string template-path)])
#'(begin
(require (for-syntax racket/base)
pollen/private/include-template
pollen/private/external/include-template
pollen/cache
pollen/private/debug
pollen/private/log
pollen/pagetree
pollen/core)
DIRECTORY-REQUIRE-FILES
@ -245,27 +235,18 @@
DOC-ID
(include-template #:command-char COMMAND-CHAR (file TEMPLATE-PATH))))))))
;; set current-directory because include-template wants to work relative to source location
(time (parameterize ([current-directory (->complete-path (dirname source-path))])
(render-through-eval expr-to-eval))))
(parameterize ([current-directory (->complete-path (dirname source-path))])
(render-datum-through-eval datum-to-eval)))
(define (templated-source? path)
(or (markup-source? path) (markdown-source? path)))
(define (file-exists-or-has-source? path) ; path could be #f
(and path (for/first ([proc (in-list (list values ->preproc-source-path ->null-source-path))]
#:when (file-exists? (proc path)))
path)))
(define+provide/contract (get-template-for source-path [maybe-output-path #f])
((complete-path?)((or/c #f complete-path?)) . ->* . (or/c #f complete-path?))
(define (file-exists-or-has-source? p) ; p could be #f
(and p (for/first ([proc (in-list (list values ->preproc-source-path ->null-source-path))]
#:when (file-exists? (proc p)))
p)))
(define (get-template)
(define output-path (or maybe-output-path (->output-path source-path)))
(define output-path-ext (or (get-ext output-path) (current-poly-target))) ; output-path may not have an extension
(define (get-template-from-metas)
(define (get-template-from-metas source-path output-path-ext)
(with-handlers ([exn:fail:contract? (λ (e) #f)]) ; in case source-path doesn't work with cached-require
(parameterize ([current-directory (current-project-root)])
(define source-metas (cached-metas source-path))
@ -276,22 +257,25 @@
template-name-or-names))
(and template-name (build-path (dirname source-path) template-name)))))
(define (get-default-template)
(define (get-default-template source-path output-path-ext)
(and output-path-ext
(let ([default-template-filename (add-ext (setup:template-prefix source-path) output-path-ext)])
(find-upward-from source-path default-template-filename file-exists-or-has-source?))))
(define (get-fallback-template)
(define (get-fallback-template source-path output-path-ext)
(and output-path-ext
(build-path (current-server-extras-path)
(add-ext (setup:fallback-template-prefix source-path) output-path-ext))))
(or (file-exists-or-has-source? (get-template-from-metas))
(file-exists-or-has-source? (get-default-template))
(file-exists-or-has-source? (get-fallback-template))))
(and (templated-source? source-path) (get-template)))
(define+provide/contract (get-template-for source-path [maybe-output-path #f])
((complete-path?)((or/c #f complete-path?)) . ->* . (or/c #f complete-path?))
(and (templated-source? source-path)
(let ()
(define output-path (or maybe-output-path (->output-path source-path)))
;; output-path may not have an extension
(define output-path-ext (or (get-ext output-path) (current-poly-target)))
(for/or ([proc (list get-template-from-metas get-default-template get-fallback-template)])
(file-exists-or-has-source? (proc source-path output-path-ext))))))
(module-test-external
(require pollen/setup sugar/file sugar/coerce)
@ -312,10 +296,10 @@
(check-false (get-template-for (->complete-path "foo.poly.pm")))
(check-equal? (get-template-for (->complete-path "foo.html.pm")) fallback.html)))
(define-namespace-anchor render-module-ns)
(define (render-through-eval expr-to-eval)
(define (render-datum-through-eval datum-to-eval)
;; render a datum, not a syntax object, so that it can have fresh bindings.
(parameterize ([current-namespace (make-base-namespace)]
[current-output-port (current-error-port)])
(namespace-attach-module (namespace-anchor->namespace render-module-ns) 'pollen/setup) ; brings in params
(eval expr-to-eval)))
(eval datum-to-eval)))

4
pollen/scribblings/mb-tools.rkt
Unescape Escape View File

@ -1,7 +1,7 @@
#lang at-exp racket/base
(require (for-syntax racket/base racket/syntax pollen/setup) scribble/core scribble/manual scribble/private/manual-sprop scribble/decode scribble/html-properties racket/runtime-path racket/format "../private/manual-history.rkt" pollen/setup)
(require (for-syntax racket/base racket/syntax pollen/setup) scribble/core scribble/manual scribble/private/manual-sprop scribble/decode scribble/html-properties racket/runtime-path racket/format "../private/external/manual-history.rkt" pollen/setup)
(provide (all-defined-out) (all-from-out racket/runtime-path "../private/manual-history.rkt"))
(provide (all-defined-out) (all-from-out racket/runtime-path "../private/external/manual-history.rkt"))
(define-runtime-path mb-css "mb.css")

10
pollen/scribblings/quick.scrbl
Unescape Escape View File

@ -116,11 +116,11 @@ Now here's a third: the Pollen project server. To start the project server, retu
After a moment, you'll see the startup message:
@terminal{
Welcome to Pollen @|pollen:version| (Racket @(version))
Project root is /path/to/your/directory
Project server is http://localhost:8080 (Ctrl+C to exit)
Project dashboard is http://localhost:8080/index.ptree
Ready to rock}
pollen: welcome to Pollen @|pollen:version| (Racket @(version))
pollen: project root is /path/to/your/directory
pollen: project server is http://localhost:8080 (Ctrl+C to exit)
pollen: project dashboard is http://localhost:8080/index.ptree
pollen: ready to rock}
Open a web browser and point it at the project dashboard, which by default is @link-tt{http://localhost:8080/index.ptree}. The top line of the window will say @tt{Project root} and show the name of the starting directory. Below that will be a listing of the files in the directory.

78
pollen/scribblings/setup.scrbl
Unescape Escape View File

@ -16,15 +16,15 @@ The values below can be changed by overriding them in your @racket["pollen.rkt"]
@itemlist[#:style 'ordered
@item{Within this file, @seclink["submodules" #:doc '(lib "scribblings/guide/guide.scrbl")]{create a submodule} called @racket[setup].}
@item{Within this file, @seclink["submodules" #:doc '(lib "scribblings/guide/guide.scrbl")]{create a submodule} called @racket[setup].}
@item{Within this submodule, use @racket[define] to make a variable with the same name as the one in @racket[pollen/setup], but without the @racket[setup:] prefix.}
@item{Within this submodule, use @racket[define] to make a variable with the same name as the one in @racket[pollen/setup], but without the @racket[setup:] prefix.}
@item{Assign it whatever value you like.}
@item{Assign it whatever value you like.}
@item{Repeat as needed.}
@item{Repeat as needed.}
@item{(Don't forget to @racket[provide] the variables from within your @racket[setup] submodule.)}
@item{(Don't forget to @racket[provide] the variables from within your @racket[setup] submodule.)}
]
@ -33,17 +33,17 @@ When Pollen runs, these definitions will supersede those in @racketmodname[polle
For instance, suppose you wanted the main export of every Pollen source file to be called @racket[van-halen] rather than @racket[doc], the extension of Pollen markup files to be @racket[.rock] rather than @racket[.pm], and the command character to be @litchar{🎸} instead of @litchar{◊}. Your @racket["pollen.rkt"] would look like this:
@fileblock["pollen.rkt"
@codeblock{
#lang racket/base
@codeblock{
#lang racket/base
;; ... the usual definitions and tag functions ...
;; ... the usual definitions and tag functions ...
(module setup racket/base
(module setup racket/base
(provide (all-defined-out))
(define main-export 'van-halen)
(define markup-source-ext 'rock)
(define command-char #\🎸))
}]
}]
Of course, you can restore the defaults simply by removing these defined values from @racket["pollen.rkt"].
@ -52,7 +52,7 @@ Every @racket[setup:]@racket[_name] function will resolve the current value of t
@section{Values}
@defoverridable[project-server-port integer?]{
Determines the default HTTP port for the project server.}
Determines the default HTTP port for the project server.}
@defoverridable[main-export symbol?]{The main X-expression exported from a compiled Pollen source file.}
@ -63,14 +63,14 @@ Every @racket[setup:]@racket[_name] function will resolve the current value of t
@deftogether[(
@defoverridable[preproc-source-ext symbol?]
@defoverridable[markup-source-ext symbol?]
@defoverridable[markdown-source-ext symbol?]
@defoverridable[null-source-ext symbol?]
@defoverridable[pagetree-source-ext symbol?]
@defoverridable[template-source-ext symbol?]
@defoverridable[scribble-source-ext symbol?]
)]{File extensions for Pollen source files.}
@defoverridable[preproc-source-ext symbol?]
@defoverridable[markup-source-ext symbol?]
@defoverridable[markdown-source-ext symbol?]
@defoverridable[null-source-ext symbol?]
@defoverridable[pagetree-source-ext symbol?]
@defoverridable[template-source-ext symbol?]
@defoverridable[scribble-source-ext symbol?]
)]{File extensions for Pollen source files.}
@defoverridable[main-pagetree string?]{Pagetree that Pollen dashboard loads by default in each directory.}
@ -81,9 +81,9 @@ Every @racket[setup:]@racket[_name] function will resolve the current value of t
@defoverridable[block-tags (listof symbol?)]{Tags that are treated as blocks by @racket[block-txexpr?]. Initialized to the @link["https://developer.mozilla.org/en-US/docs/Web/HTML/Block-level_elements"]{block-level elements in HTML5}, namely:
@racketidfont{@(string-join (map symbol->string (cdr default-block-tags)) " ")}
@racketidfont{@(string-join (map symbol->string (cdr default-block-tags)) " ")}
... plus @racket[setup:main-root-node].}
... plus @racket[setup:main-root-node].}
@ -93,10 +93,10 @@ Every @racket[setup:]@racket[_name] function will resolve the current value of t
@deftogether[(
@(defoverridable newline string?)
@(defoverridable linebreak-separator string?)
@(defoverridable paragraph-separator string?)
)]
@(defoverridable newline string?)
@(defoverridable linebreak-separator string?)
@(defoverridable paragraph-separator string?)
)]
Default separators used in decoding.
@ -108,17 +108,17 @@ Default separators used in decoding.
@defoverridable[cache-watchlist (listof (or/c path? path-string?))]{List of extra files that the cache (= render cache + compile cache, collectively) watches during a project-server session. If one of the files on the watchlist changes, the cache is invalidated (just as it would be if @racket["pollen.rkt"] changed).
If the cache can't find a certain file on the watchlist, it will be ignored. Therefore, to avoid unexpected behavior, the best policy is to pass in complete paths (or path strings). An easy way to convert a module name into a complete path is with @racket[resolve-module-path]:
If the cache can't find a certain file on the watchlist, it will be ignored. Therefore, to avoid unexpected behavior, the best policy is to pass in complete paths (or path strings). An easy way to convert a module name into a complete path is with @racket[resolve-module-path]:
@fileblock["pollen.rkt"
@codeblock{
(module+ setup
@fileblock["pollen.rkt"
@codeblock{
(module+ setup
(require syntax/modresolve)
(provide (all-defined-out))
(define cache-watchlist (map resolve-module-path '("my-module.rkt"))))
}]
}]
@pollen-history[#:added "1.4"]
@pollen-history[#:added "1.4"]
}
@ -129,13 +129,13 @@ Default separators used in decoding.
@defoverridable[omitted-path? (path? . -> . boolean?)]{Predicate that determines whether a path is omitted from @secref{raco_pollen_render} and @secref{raco_pollen_publish} operations. If the predicate evaluated to @racket[#t], then the path is omitted.
@pollen-history[#:added "1.1"]}
@pollen-history[#:added "1.1"]}
@defoverridable[extra-published-path? (path? . -> . boolean?)]{@pollen-history[#:changed "1.1" @elem{Deprecated. Please use @racket[setup:extra-path?].}]}
@defoverridable[extra-path? (path? . -> . boolean?)]{Predicate that determines if path is rendered & published, overriding @racket[(setup:omitted-path?)] above, and Pollen's default publish settings. For instance, Pollen automatically omits files with a @racket[.rkt] extension. If you wanted to force a @racket[.rkt] file to be published, you could include it here.
@pollen-history[#:added "1.1"]}
@pollen-history[#:added "1.1"]}
@defoverridable[splicing-tag symbol?]{Key used to signal that an X-expression should be spliced into its containing X-expression.}
@ -149,9 +149,9 @@ Default separators used in decoding.
@defoverridable[index-pages (listof string?)]{List of strings that the project server will use as directory default pages, in order of priority. Has no effect on command-line rendering operations. Also has no effect on your live web server (usually that's a setting you need to make in an @tt{.htaccess} configuration file).} But with this setting, you can simulate the behavior of your live server, so that internal index-page URLs work correctly.
@defoverridable[trim-whitespace? boolean?]{Predicate that controls whether the Pollen source reader trims whitespace from the beginning of a @racket[doc] export. You might set this to @racket[#false] if you're using Pollen as a preprocessor for another programming language and you want to preserve leading whitespace accurately.
@defoverridable[trim-whitespace? boolean?]{Predicate that controls whether the Pollen source reader trims whitespace from the beginning of a @racket[doc] export. You might set this to @racket[#false] if you're using Pollen as a preprocessor for another programming language and you want to preserve leading whitespace accurately.
@pollen-history[#:added "1.5"]}
@pollen-history[#:added "1.5"]}
@section{Parameters}
@ -159,16 +159,16 @@ Default separators used in decoding.
I mean @italic{parameters} in the Racket sense, i.e. values that can be fed to @racket[parameterize].
@defparam[current-server-port port integer? #:value default-project-server-port]{
A parameter that sets the HTTP port for the project server.}
A parameter that sets the HTTP port for the project server.}
@defparam[current-project-root port path?]{
A parameter that holds the root directory of the current project (e.g., the directory where you launched @code{raco pollen start}).}
A parameter that holds the root directory of the current project (e.g., the directory where you launched @code{raco pollen start}).}
@defparam[current-server-extras-path dir path? #:value #f]{
A parameter that reports the path to the directory of support files for the project server.}
A parameter that reports the path to the directory of support files for the project server.}
@defparam[current-poly-target target symbol? #:value 'html]{
A parameter that reports the current rendering target for @racket[poly] source files.}
A parameter that reports the current rendering target for @racket[poly] source files.}

5
pollen/scribblings/version-history.scrbl
Unescape Escape View File

@ -24,6 +24,11 @@ Beyond keeping the commit history available, I make no promise to maintain the p
@section{Changelog}
@subsection{Version 1.5}
Added @racket[setup:trim-whitespace?].
@subsection{Version 1.4}
Added @racket[setup:cache-watchlist], @racket[for/splice], @racket[for*/splice], @racket[current-metas].

45
pollen/tag.rkt
Unescape Escape View File

@ -1,32 +1,37 @@
#lang pollen/mode racket/base
(require (for-syntax racket/base syntax/parse))
(require txexpr/base racket/string racket/match)
(require (for-syntax
racket/base
syntax/parse)
txexpr/base
racket/string
racket/match)
(provide default-tag-function make-default-tag-function define-tag-function)
(define (parse-leading-attrs xs)
(match xs
[(cons (? txexpr-attrs? leading-attrs) tail) (values leading-attrs tail)]
[else (values null xs)]))
(define (colon-attr-name? x)
(match x
[(? symbol?)
(=> resume)
(match (symbol->string x)
[(regexp #rx".*?(?=:$)" (cons res _)) (string->symbol res)]
[_ (resume)])]
[_ #false]))
(define (parse-colon-attrs xs)
(define (colon-attr-name? x)
(and (symbol? x)
(let ([result (regexp-match #rx".*?(?=:$)" (symbol->string x))])
(and (pair? result) (string->symbol (car result))))))
(let parse-next ([xs xs][colon-attrs empty])
(match xs
[(list* (? colon-attr-name? name) (? string? val) xs)
(parse-next xs (cons (list (colon-attr-name? name) val) colon-attrs))]
[else (values colon-attrs xs)])))
[_ (values colon-attrs xs)])))
(define (parse-kw-attrs kw-symbols-in kw-args)
(define kw-symbols (map (λ (kw) (string->symbol (string-trim (keyword->string kw) "#:"))) kw-symbols-in))
(map list kw-symbols kw-args))
(define (make-one-tag-function outer-kws outer-kw-args id)
(make-keyword-procedure
(λ (inner-kws inner-kw-args . xs)
@ -40,25 +45,23 @@
;; construct the xexpr result "manually" (i.e., not with `make-txexpr` because it may not be a legit txexpr for now
;; (but it may become one through further processing, so no need to be finicky)
;; however, don't show empty attrs.
(define attrs (append kw-attrs colon-attrs leading-attrs))
(cons id (if (null? attrs)
xs
(cons attrs xs)))))))
(cons id (match (append kw-attrs colon-attrs leading-attrs)
[(== empty) xs]
[attrs (cons attrs xs)]))))))
(define default-tag-function
(make-keyword-procedure
(λ (outer-kws outer-kw-args . ids)
(let ([tag-proc (apply compose1 (for/list ([id (in-list ids)])
(make-one-tag-function outer-kws outer-kw-args id)))]
[tag-proc-name (string->symbol (format "pollen-tag:~a" (string-join (map symbol->string ids) "+")))])
(procedure-rename tag-proc tag-proc-name)))))
(define tag-proc (apply compose1 (for/list ([id (in-list ids)])
(make-one-tag-function outer-kws outer-kw-args id))))
(define tag-proc-name (string->symbol (format "pollen-tag:~a" (string-join (map symbol->string ids) "+"))))
(procedure-rename tag-proc tag-proc-name))))
(define make-default-tag-function default-tag-function) ; bw compat
(module+ test
(require rackunit txexpr/check)
(require txexpr/check)
(define outerdiv (default-tag-function 'div #:class "outer" #:style "outer"))
(check-txexprs-equal? (outerdiv "foo") '(div ((class "outer") (style "outer")) "foo"))
(check-txexprs-equal? (outerdiv) '(div ((class "outer") (style "outer"))))
@ -91,7 +94,7 @@
(module+ test
(require rackunit)
(require)
(define foo2 (default-tag-function 'foo))
(define-tag-function (foo attrs elems)

BIN
pollen/test/data/pixel/pixel.png
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 95 B

1
pollen/test/data/pixel/template.png.p
Unescape Escape View File

@ -0,0 +1 @@
◊doc

3
pollen/test/data/pixel/test-pixel.png.pm
Unescape Escape View File

@ -0,0 +1,3 @@
#lang pollen
◊(require racket/file)
◊(file->bytes "pixel.png")

18
pollen/test/test-bytes.rkt
Unescape Escape View File

@ -0,0 +1,18 @@
#lang at-exp racket/base
(require rackunit racket/runtime-path pollen/render racket/file pollen/setup)
(define-runtime-path pixel-dir "data/pixel")
(define-runtime-path test-pixel-src "data/pixel/test-pixel.png.pm")
(define-runtime-path test-pixel "data/pixel/test-pixel.png")
(define-runtime-path pixel "data/pixel/pixel.png")
(define-runtime-path template "data/pixel/template.png")
;; test makes sure that quick tour files work
(parameterize ([current-output-port (open-output-string)]
[current-directory pixel-dir]
[current-project-root pixel-dir])
(check-not-exn (λ _ (render-to-file-if-needed test-pixel-src)))
(check-true (file-exists? test-pixel))
(check-equal? (file->bytes test-pixel) (file->bytes pixel)))
(for-each (λ (f) (when (file-exists? f) (delete-file f))) (list test-pixel template))

2
pollen/test/test-output.rkt
Unescape Escape View File

@ -1,5 +1,5 @@
#lang racket/base
(require rackunit pollen/private/output racket/port)
(require rackunit pollen/private/external/output racket/port)
(define-syntax-rule (check-output outputter string)
(check-equal? (with-output-to-string (λ () outputter)) string))

5
pollen/test/test-poly.rkt
Unescape Escape View File

@ -1,5 +1,8 @@
#lang at-exp racket/base
(require rackunit pollen/setup racket/runtime-path pollen/render)
(require rackunit
pollen/setup
racket/runtime-path
pollen/render)
;; define-runtime-path only allowed at top level
(define-runtime-path poly-dir "data/poly")

13
pollen/top.rkt
Unescape Escape View File

@ -2,19 +2,10 @@
(require (for-syntax racket/base) pollen/tag)
(provide def/c (rename-out (top~ #%top)))
;; Changes the default behavior of #%top.
;; Unbound identifiers are allowed, and treated as the
;; tag in a txexpr (with the rest of the expression treated as the body)
;; To suppress this behavior, use def/c to wrap any name.
;; If that name isn't already defined, you'll get the usual syntax error.
(define-syntax-rule (top~ . ID)
;; #%app shouldn't be necessary, but temp fix for Racket7
(#%app make-default-tag-function 'ID))
(define-syntax (def/c stx)
(syntax-case stx ()
[(_ X)
(if (identifier-binding #'X )
#'X
#'(#%top . X))]))
[(_ X) (identifier-binding #'X) #'X]
[(_ X) #'(#%top . X)]))

4
pollen/unstable/pygments.rkt
Unescape Escape View File

@ -10,7 +10,7 @@
rackjure/str
xml
(only-in html read-html-as-xml)
"../private/debug.rkt"
"../private/log.rkt"
"../private/splice.rkt")
(provide highlight make-highlight-css)
@ -86,7 +86,7 @@ if zero is False:
(define-values (pyg-in pyg-out pyg-pid pyg-err pyg-proc)
(values #f #f #f #f #f))
(define-runtime-path pipe.py "../private/pipe.py")
(define-runtime-path pipe.py "../private/external/pipe.py")
(define start
(let ([start-attempted? #f])

Write Preview
Loading…
Cancel
Save