dev-stylish-5
Matthew Butterick 4 years ago
parent e70f476c93
commit 559da05c8d

@ -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.
@ -18,40 +19,45 @@
(raise-argument-error 'reset-cache "path-string to existing directory" starting-dir))
(for ([path (in-directory starting-dir)]
#:when (cache-directory? path))
(message (format "removing cache directory: ~a" path))
(delete-directory/files path)))
(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))])
(path->complete-path (if (path? path-or-path-string)
path-or-path-string
(string->path 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
(dynamic-require path subkey))]))))
[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))

@ -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))

@ -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))
(cond
[(or (memq tag excluded-tags)
(for/or ([attr (in-list attrs)])
(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)
(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)])))
(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
[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)
(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?) (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,27 +130,30 @@
(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
[(= idx (sub1 (vector-length elems-vec))) elem] ; pass through last item
[(equal? elem newline)
(define prev (vector-ref elems-vec (sub1 idx)))
(define next (vector-ref elems-vec (add1 idx)))
;; 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
(linebreak-proc prev next))]
[else elem]))))
(cond
[(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)))
(define next (vector-ref elems-vec (add1 idx)))
;; 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))
#false ; flag for filtering
(linebreak-proc prev next))]
[else elem]))))
(module-test-external
(check-equal? (decode-linebreaks '("foo" "\n" "bar")) '("foo" (br) "bar"))
@ -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")))

@ -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

@ -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)
@ -49,9 +48,9 @@
(define pt-root-tag (setup:pagetree-root-node))
(define (splice-nested-pagetree xs)
(apply append (for/list ([x (in-list xs)])
(if (and (txexpr? x) (eq? (get-tag x) pt-root-tag))
(get-elements x)
(list x)))))
(if (and (txexpr? x) (eq? (get-tag x) pt-root-tag))
(get-elements x)
(list x)))))
(validate-pagetree
(decode (cons pt-root-tag xs)
#:txexpr-elements-proc (compose1 splice-nested-pagetree (λ (xs) (filter-not whitespace? xs)))
@ -60,10 +59,11 @@
(define+provide (validate-pagetree x)
(and (txexpr? x)
(let ([pagenodes (pagetree-strict->list x)])
(for/and ([p (in-list pagenodes)]
#:unless (pagenode? p))
(error 'validate-pagetree "~v is not a valid pagenode" p))
(let ()
(define pagenodes (pagetree-strict->list x))
(for ([p (in-list pagenodes)]
#:unless (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])
@ -138,8 +138,8 @@
(if (memq pagenode (map topmost-node current-children))
current-parent
(for/or ([st (in-list (filter list? current-children))])
(loop pagenode st))))))
(if (eq? result (car pt))
(loop pagenode st))))))
(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
@ -192,9 +191,9 @@
(((or/c #f pagenodeish?)) ((or/c pagetree? pathish?)) . ->* . (or/c #f pagenodes?))
(match (for/list ([sib (in-list (or (siblings pnish pt-or-path) empty))]
#:unless (eq? sib (->pagenode pnish)))
sib)
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)
[(list _ rest ...) rest]
[else #f])
(match (loop 'right pagenode (reverse pagetree-nodes))
[(? pair? result) (reverse result)]
[else #f])))))
(case side
[(right) (match (memq pagenode pagetree-nodes)
[(list _ rest ...) rest]
[_ #false])]
[else (match (loop 'right pagenode (reverse pagetree-nodes))
[(? pair? result) (reverse result)]
[_ #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))))

@ -10,63 +10,60 @@
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
;; 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)
(append (->list (get-directory-require-files source-path))
;; user-designated files to track
(map ->string (setup:cache-watchlist 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)
(append (->list (get-directory-require-files source-path))
;; user-designated files to track
(map ->string (setup:cache-watchlist source-path)))))
(define pollen-env (getenv default-env-name))
(define poly-flag (and (has-inner-poly-ext? source-path) (current-poly-target)))
(define path+mod-time-pairs
(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])))
(cond
[ps (define cp (->complete-path ps))
(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'
;; 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.
;; 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
[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

@ -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,30 +20,34 @@
;; 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)
(case command-name
[("test" "xyzzy") (handle-test)]
[(#f "help") (handle-help)]
[("start") (handle-start)] ; parses its own args
;; "second" arg is actually third in command line args, so use cddr not cdr
[("render") (handle-render)] ; render parses its own args from current-command-line-arguments
[("version") (handle-version)]
[("reset") (handle-reset (get-first-arg-or-current-dir))]
[("setup") (handle-setup (get-first-arg-or-current-dir))]
[("clone" "publish") (handle-publish)]
[else (handle-unknown command-name)]))
(with-logging-to-port
(current-error-port)
(λ ()
(case command-name
[("test" "xyzzy") (handle-test)]
[(#f "help") (handle-help)]
[("start") (handle-start)] ; parses its own args
;; "second" arg is actually third in command line args, so use cddr not cdr
[("render") (handle-render)] ; render parses its own args from current-command-line-arguments
[("version") (handle-version)]
[("reset") (handle-reset (get-first-arg-or-current-dir))]
[("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,108 +73,102 @@ 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"
#: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"
(render-target-wanted (->symbol target-arg))]
[("-r" "--recursive") "Render subdirectories recursively"
(render-with-subdirs? 'recursive)]
[("-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))
(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"
(render-target-wanted (->symbol target-arg))]
[("-r" "--recursive") "Render subdirectories recursively"
(render-with-subdirs? 'recursive)]
[("-s" "--subdir") "Render subdirectories nonrecursively" (render-with-subdirs? 'include)]
#:args other-args
other-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 render-one-dir ([dir top-dir])
(parameterize ([current-directory dir]
[current-project-root (if (eq? (render-with-subdirs?) 'recursive)
dir
top-dir)])
(define dirlist (directory-list dir))
(define preprocs (filter preproc-source? dirlist))
(define static-pagetrees (filter pagetree-source? dirlist))
;; if there are no static pagetrees, use make-project-pagetree
;; (which will synthesize a pagetree if needed, which includes all sources)
(define batch-to-render
(map very-nice-path
(cond
[(null? static-pagetrees)
(displayln (format "rendering generated pagetree for directory ~a" dir))
(cdr (make-project-pagetree dir))]
[else
(displayln (format "rendering preproc & pagetree files in directory ~a" dir))
(append preprocs static-pagetrees)])))
(apply render-batch batch-to-render)
(when (render-with-subdirs?)
(for ([path (in-list dirlist)]
#:when (and (directory-exists? path)
(not (omitted-path? path))))
(render-one-dir (->complete-path path))))))]
[else ;; path mode
(displayln (format "rendering ~a" (string-join (map ->string path-args) " ")))
(apply render-batch (map very-nice-path 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 (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))
;; if there are no static pagetrees, use make-project-pagetree
;; (which will synthesize a pagetree if needed, which includes all sources)
(define batch-to-render
(map very-nice-path
(cond
[(null? static-pagetrees)
(displayln (format "rendering generated pagetree for directory ~a" dir))
(cdr (make-project-pagetree dir))]
[else
(displayln (format "rendering preproc & pagetree files in directory ~a" dir))
(append preprocs static-pagetrees)])))
(apply render-batch batch-to-render)
(when (render-with-subdirs?)
(for ([path (in-list dirlist)]
#:when (and (directory-exists? path)
(not (omitted-path? path))))
(render-one-dir (->complete-path path))))))]
[path-args ;; path mode
(displayln (format "rendering ~a" (string-join (map ->string 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"
#: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)]
[("--local") "Restrict access to localhost" (set! localhost-wanted #t)]
#:args other-args
other-args))
(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)]
[("--local") "Restrict access to localhost" (set! localhost-wanted #t)]
#:args other-args
other-args))
(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)])
(string->number (cadr clargs))))
(when (and port (not (exact-positive-integer? port)))
(error (format "~a is not a valid port number" port)))
(define http-port (with-handlers ([exn:fail? (λ (e) #f)])
(string->number (cadr clargs))))
(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))
(display "These are the available ") ; ... "Pollen commands:"
(handle-help)
(exit 1))))
(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)]))

@ -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,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)))]))

@ -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))

@ -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)

@ -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)

@ -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) " ")))

@ -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)]