1.5 update

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

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

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

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

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

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

@ -10,63 +10,60 @@
compiler/cm) compiler/cm)
(provide (all-defined-out)) (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.
;; 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)
;; 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).
;; but would actually be invalid (because the `here-path` names are wrong). ;; key is list of file + mod-time pairs, use #f for missing
;; 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
;; we don't include output-path in path-strings-to-track ;; because cache validity is not sensitive to mod date of output path
;; because we don't want to attach a mod date ;; (in fact we would expect it to be earlier, since we want to rely on an earlier version)
;; because cache validity is not sensitive to mod date of output path (define (paths->key source-path [template-path #false] [output-path #false])
;; (in fact we would expect it to be earlier, since we want to rely on an earlier version) (define path-strings-to-track
(define path-strings-to-track (list* source-path (list* source-path
;; if template has a source file, track that instead ;; if template has a source file, track that instead
(and template-path (or (get-source template-path) template-path)) (and template-path (or (get-source template-path) template-path))
;; is either list of files or (list #f) ;; is either list of files or (list #f)
(append (->list (get-directory-require-files source-path)) (append (->list (get-directory-require-files source-path))
;; user-designated files to track ;; user-designated files to track
(map ->string (setup:cache-watchlist source-path))))) (map ->string (setup:cache-watchlist source-path)))))
(define pollen-env (getenv default-env-name)) (define pollen-env (getenv default-env-name))
(define poly-flag (and (has-inner-poly-ext? source-path) (current-poly-target))) (define poly-flag (and (has-inner-poly-ext? source-path) (current-poly-target)))
(define path+mod-time-pairs (define path+mod-time-pairs
(for/list ([ps (in-list path-strings-to-track)]) (for/list ([ps (in-list path-strings-to-track)])
(cond (cond
[ps (define cp (->complete-path ps)) [ps (define cp (->complete-path ps))
(cons (path->string cp) (file-or-directory-modify-seconds cp #f (λ () 0)))] (cons (path->string cp) (file-or-directory-modify-seconds cp #false (λ () 0)))]
[else #f]))) [else #false])))
(list* pollen-env poly-flag (and output-path (path->string output-path)) path+mod-time-pairs)) (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->source-path key) (car (fourth key)))
(define (key->output-path key) (third key)) (define (key->output-path key) (third key))
(module-test-internal (module-test-internal
(define ps "/users/nobody/project/source.html.pm") (define ps "/users/nobody/project/source.html.pm")
(check-equal? (key->source-path (paths->key ps)) ps)) (check-equal? (key->source-path (paths->key ps)) ps))
(define-namespace-anchor cache-utils-module-ns) (define-namespace-anchor cache-utils-module-ns)
(define (path->hash path) (define (path->hash path)
(for-each managed-compile-zo (or (get-directory-require-files path) null)) (for-each managed-compile-zo (or (get-directory-require-files path) null))
(define path-dir (dirname path))
(apply hasheq (apply hasheq
(let ([doc-key (setup:main-export)] (let ([doc-key (setup:main-export)] [meta-key (setup:meta-export)])
[meta-key (setup:meta-export)])
(unless (and (symbol? doc-key) (symbol? meta-key)) (unless (and (symbol? doc-key) (symbol? meta-key))
(raise-argument-error 'path->hash "symbols for doc and meta key" (cons doc-key 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. ;; otherwise it gets cached in current namespace.
(parameterize ([current-namespace (make-base-namespace)] (parameterize ([current-namespace (make-base-namespace)]
[current-directory path-dir]) [current-directory (dirname path)])
;; I monkeyed around with using the metas submodule to pull out the metas (for speed) ;; brings in currently instantiated params (unlike namespace-require)
;; but in practice most files get their doc requested too. (define outer-ns (namespace-anchor->namespace cache-utils-module-ns))
;; so it's just simpler to get both at once and be done with it. (namespace-attach-module outer-ns 'pollen/setup)
;; 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
(define doc-missing-thunk (λ () "")) (define doc-missing-thunk (λ () ""))
(define metas-missing-thunk (λ () (hasheq))) (define metas-missing-thunk (λ () (hasheq)))
(list doc-key (dynamic-require path doc-key doc-missing-thunk) (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 (cache-dir private-cache-dir) (make-cache-dirs dest-path))
(define-values (dest-path-dir dest-path-filename _) (split-path 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 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)) (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). ;; `cache-file` looks for a file in private-cache-dir previously cached with key
If a cached file is found, copies it to dest-file (which must not exist already, unless exists-ok? is true) ;; (which in this case carries modification dates and POLLEN env).
Otherwise, fetch-dest-file is called; if dest-file exists after calling fetch-dest-file, ;; If a cached file is found, copies it to dest-file (which must not exist already, unless exists-ok? is true)
it is copied to private-cache-dir and recorded with key. ;; 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 (cache-file dest-file
#:exists-ok? #t #:exists-ok? #true
key key
private-cache-dir private-cache-dir
fetch-dest-file fetch-dest-file

@ -5,8 +5,10 @@
racket/list racket/list
racket/vector racket/vector
racket/cmdline racket/cmdline
racket/match
sugar/coerce sugar/coerce
"file-utils.rkt" "file-utils.rkt"
"log.rkt"
"../setup.rkt" "../setup.rkt"
"../render.rkt" "../render.rkt"
"../pagetree.rkt") "../pagetree.rkt")
@ -18,30 +20,34 @@
;; todo: investigate this ;; todo: investigate this
(module+ raco (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))) (vector-ref (current-command-line-arguments) 0)))
(dispatch command-name)) (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 (define (get-first-arg-or-current-dir [args (cdr (vector->list (current-command-line-arguments)))]) ; cdr to strip command name from front
(normalize-path (normalize-path
(with-handlers ([exn:fail? (λ (exn) (current-directory))]) (with-handlers ([exn:fail? (λ (exn) (current-directory))])
;; incoming path argument is handled as described in docs for current-directory ;; incoming path argument is handled as described in docs for current-directory
(very-nice-path (car args))))) (very-nice-path (car args)))))
(define (dispatch command-name) (define (dispatch command-name)
(case command-name (with-logging-to-port
[("test" "xyzzy") (handle-test)] (current-error-port)
[(#f "help") (handle-help)] (λ ()
[("start") (handle-start)] ; parses its own args (case command-name
;; "second" arg is actually third in command line args, so use cddr not cdr [("test" "xyzzy") (handle-test)]
[("render") (handle-render)] ; render parses its own args from current-command-line-arguments [(#f "help") (handle-help)]
[("version") (handle-version)] [("start") (handle-start)] ; parses its own args
[("reset") (handle-reset (get-first-arg-or-current-dir))] ;; "second" arg is actually third in command line args, so use cddr not cdr
[("setup") (handle-setup (get-first-arg-or-current-dir))] [("render") (handle-render)] ; render parses its own args from current-command-line-arguments
[("clone" "publish") (handle-publish)] [("version") (handle-version)]
[else (handle-unknown command-name)])) [("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) (define (very-nice-path x)
(path->complete-path (simplify-path (cleanse-path (->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) (define (handle-version)
(displayln (dynamic-require 'pollen/private/version 'pollen:version))) (displayln (dynamic-require 'pollen/private/version 'pollen:version)))
(define (handle-reset directory-maybe) (define (handle-reset directory-maybe)
(displayln "resetting cache ...") (displayln "resetting cache ...")
((dynamic-require 'pollen/cache 'reset-cache) directory-maybe)) ((dynamic-require 'pollen/cache 'reset-cache) directory-maybe))
(define (handle-setup directory-maybe) (define (handle-setup directory-maybe)
(displayln "preheating cache ...") (displayln "preheating cache ...")
((dynamic-require 'pollen/private/preheat-cache 'preheat-cache) directory-maybe)) ((dynamic-require 'pollen/private/preheat-cache 'preheat-cache) directory-maybe))
(define (handle-render) (define (handle-render)
(define render-target-wanted (make-parameter (current-poly-target))) (define render-target-wanted (make-parameter (current-poly-target)))
(define render-with-subdirs? (make-parameter #f)) (define render-with-subdirs? (make-parameter #f))
(define parsed-args (command-line #:program "raco pollen render" (define parsed-args
#:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'render' from the front (command-line #:program "raco pollen render"
#:once-each #:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'render' from the front
[("-t" "--target") target-arg "Render target for poly sources" #:once-each
(render-target-wanted (->symbol target-arg))] [("-t" "--target") target-arg "Render target for poly sources"
[("-r" "--recursive") "Render subdirectories recursively" (render-target-wanted (->symbol target-arg))]
(render-with-subdirs? 'recursive)] [("-r" "--recursive") "Render subdirectories recursively"
[("-s" "--subdir") "Render subdirectories nonrecursively" (render-with-subdirs? 'include)] (render-with-subdirs? 'recursive)]
#:args other-args [("-s" "--subdir") "Render subdirectories nonrecursively" (render-with-subdirs? 'include)]
other-args)) #:args other-args
(define path-args (if (empty? parsed-args) other-args))
(list (current-directory))
parsed-args))
(parameterize ([current-poly-target (render-target-wanted)]) ;; applies to both cases (parameterize ([current-poly-target (render-target-wanted)]) ;; applies to both cases
(cond (let loop ([args parsed-args])
;; directory mode: one directory as argument (match args
[(and (= 1 (length path-args)) (directory-exists? (car path-args))) [(== empty) (loop (list (current-directory)))]
(define top-dir (very-nice-path (car path-args))) [(list dir) ;; directory mode: one directory as argument
(let render-one-dir ([dir top-dir]) #:when (directory-exists? dir)
(parameterize ([current-directory dir] (define top-dir (very-nice-path dir))
[current-project-root (if (eq? (render-with-subdirs?) 'recursive) (let render-one-dir ([dir top-dir])
dir (parameterize ([current-directory dir]
top-dir)]) [current-project-root (case (render-with-subdirs?)
(define dirlist (directory-list dir)) [(recursive) dir]
(define preprocs (filter preproc-source? dirlist)) [else top-dir])])
(define static-pagetrees (filter pagetree-source? dirlist)) (define dirlist (directory-list dir))
;; if there are no static pagetrees, use make-project-pagetree (define preprocs (filter preproc-source? dirlist))
;; (which will synthesize a pagetree if needed, which includes all sources) (define static-pagetrees (filter pagetree-source? dirlist))
(define batch-to-render ;; if there are no static pagetrees, use make-project-pagetree
(map very-nice-path ;; (which will synthesize a pagetree if needed, which includes all sources)
(cond (define batch-to-render
[(null? static-pagetrees) (map very-nice-path
(displayln (format "rendering generated pagetree for directory ~a" dir)) (cond
(cdr (make-project-pagetree dir))] [(null? static-pagetrees)
[else (displayln (format "rendering generated pagetree for directory ~a" dir))
(displayln (format "rendering preproc & pagetree files in directory ~a" dir)) (cdr (make-project-pagetree dir))]
(append preprocs static-pagetrees)]))) [else
(apply render-batch batch-to-render) (displayln (format "rendering preproc & pagetree files in directory ~a" dir))
(when (render-with-subdirs?) (append preprocs static-pagetrees)])))
(for ([path (in-list dirlist)] (apply render-batch batch-to-render)
#:when (and (directory-exists? path) (when (render-with-subdirs?)
(not (omitted-path? path)))) (for ([path (in-list dirlist)]
(render-one-dir (->complete-path path))))))] #:when (and (directory-exists? path)
[else ;; path mode (not (omitted-path? path))))
(displayln (format "rendering ~a" (string-join (map ->string path-args) " "))) (render-one-dir (->complete-path path))))))]
(apply render-batch (map very-nice-path path-args))]))) [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 (handle-start)
(define launch-wanted #f) (define launch-wanted #f)
(define localhost-wanted #f) (define localhost-wanted #f)
(define clargs (command-line #:program "raco pollen start" (define clargs
#:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'start' from the front (command-line #:program "raco pollen start"
#:once-each #:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'start' from the front
[("--launch" "-l") "Launch browser after start" (set! launch-wanted #t)] #:once-each
[("--local") "Restrict access to localhost" (set! localhost-wanted #t)] [("--launch" "-l") "Launch browser after start" (set! launch-wanted #t)]
#:args other-args [("--local") "Restrict access to localhost" (set! localhost-wanted #t)]
other-args)) #:args other-args
other-args))
(define dir (path->directory-path (get-first-arg-or-current-dir clargs))) (define dir (path->directory-path (get-first-arg-or-current-dir clargs)))
(unless (directory-exists? dir) (unless (directory-exists? dir)
(error (format "~a is not a directory" 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)))) (string->number (cadr clargs))))
(when (and port (not (exact-positive-integer? port))) (when (and http-port (not (exact-positive-integer? http-port)))
(error (format "~a is not a valid port number" port))) (error (format "~a is not a valid port number" http-port)))
(parameterize ([current-project-root dir] (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")]) [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))) ((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 (make-publish-dir-name [project-root (current-directory)] [arg-command-name #f])
(define user-publish-path (define user-publish-path
(expand-user-path (->path (setup:publish-directory project-root)))) (expand-user-path (->path (setup:publish-directory project-root))))
(if (complete-path? user-publish-path) (if (complete-path? user-publish-path)
user-publish-path user-publish-path
(build-path (find-system-path 'desk-dir) (build-path (find-system-path 'desk-dir)
(->path (if (equal? arg-command-name "clone") ; bw compat (->path (case arg-command-name
"clone" [("clone") "clone"] ; bw compat
user-publish-path))))) [else user-publish-path])))))
(define (delete-it path) (define (delete-it path)
(cond (match path
[(directory-exists? path) (delete-directory/files path)] [(? directory-exists?) (delete-directory/files path)]
[(file-exists? path) (delete-file path)])) [(? file-exists?) (delete-file path)]))
(define (contains-directory? possible-superdir possible-subdir) (define (contains-directory? possible-superdir possible-subdir)
(define (has-prefix? xs prefix) (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))))) (andmap equal? prefix (take xs (length prefix)))))
((explode-path possible-subdir) . has-prefix? . (explode-path possible-superdir))) ((explode-path possible-subdir) . has-prefix? . (explode-path possible-superdir)))
(define (handle-publish) (define (handle-publish)
(define command-name ; either "publish" or "clone" (define command-name ; either "publish" or "clone"
(vector-ref (current-command-line-arguments) 0)) (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 (define other-args (command-line
;; drop command name ;; drop command name
#:argv (vector-drop (current-command-line-arguments) 1) #:argv (vector-drop (current-command-line-arguments) 1)
@ -217,8 +216,8 @@ version print the version" (current-server-port) (make-publish-di
(begin (begin
(display (format "destination directory ~a exists. Overwrite? [yes/no] " dest-dir)) (display (format "destination directory ~a exists. Overwrite? [yes/no] " dest-dir))
(case (read) (case (read)
[(y yes) #t] [(y yes) #true]
[else #f])))) [else #false]))))
(cond (cond
[do-publish-operation? [do-publish-operation?
(when (directory-exists? dest-dir) (when (directory-exists? dest-dir)
@ -236,11 +235,11 @@ version print the version" (current-server-port) (make-publish-di
[else (displayln "publish aborted")])) [else (displayln "publish aborted")]))
(define (handle-unknown command) (define (handle-unknown command)
(if (regexp-match #rx"(shit|fuck)" command) (match command
(displayln (let ([responses '("Cursing at free software? Really?" "How uncouth." "Same to you, buddy.")]) [(regexp #rx"(shit|fuck)")
(list-ref responses (random (length responses))))) (define responses '("Cursing at free software? Really?" "How uncouth." "Same to you, buddy."))
(begin (displayln (list-ref responses (random (length responses))))]
(displayln (format "`~a` is an unknown command." command)) [_ (displayln (format "`~a` is an unknown command." command))
(display "These are the available ") ; ... "Pollen commands:" (display "These are the available ") ; ... "Pollen commands:"
(handle-help) (handle-help)
(exit 1)))) (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. 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) (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 #lang racket/base
(require (for-syntax racket/base syntax/strip-context "../setup.rkt" "split-metas.rkt") (require (for-syntax racket/base
"to-string.rkt" "../pagetree.rkt" "splice.rkt" "../setup.rkt" "../core.rkt" syntax/strip-context
(prefix-in doclang: "doclang-raw.rkt")) "../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) (provide (except-out (all-from-out racket/base) #%module-begin)
(rename-out [pollen-module-begin #%module-begin])) (rename-out [pollen-module-begin #%module-begin]))
(define ((make-parse-proc parser-mode root-proc) xs) (define ((make-parse-proc parser-mode root-proc) xs)
(define (stringify xs) (apply string-append (map to-string xs))) (define (stringify xs) (apply string-append (map to-string xs)))
(cond (match parser-mode
[(eq? parser-mode default-mode-pagetree) (decode-pagetree xs)] [(== default-mode-pagetree) (decode-pagetree xs)]
[(eq? parser-mode default-mode-markup) (apply root-proc (remove-voids xs))] [(== default-mode-markup) (apply root-proc (remove-voids xs))]
[(eq? parser-mode default-mode-markdown) [(== default-mode-markdown)
(let* ([xs (stringify xs)] (let* ([xs (stringify xs)]
[xs ((dynamic-require 'markdown 'parse-markdown) xs)] [xs ((dynamic-require 'markdown 'parse-markdown) xs)]
[xs (map strip-empty-attrs xs)]) [xs (map strip-empty-attrs xs)])
(apply root-proc xs))] (apply root-proc xs))]
[else (stringify xs)])) ; preprocessor mode [_ (stringify xs)])) ; preprocessor mode
(define (strip-leading-newlines doc) (define (strip-leading-newlines doc)
;; drop leading newlines, as they're often the result of `defines` and `requires` ;; drop leading newlines, as they're often the result of `defines` and `requires`
(or (memf (λ (ln) (and (not (equal? ln (setup:newline))) (dropf doc (λ (ln) (member ln (list (setup:newline) "")))))
(not (equal? ln "")))) doc) null))
(define-syntax (pollen-module-begin stx) (define-syntax (pollen-module-begin stx)
(syntax-case stx () (syntax-case stx ()
@ -38,7 +43,7 @@
DOC-ID ; positional arg for doclang-raw: name of export DOC-ID ; positional arg for doclang-raw: name of export
(λ (xs) (λ (xs)
(define proc (make-parse-proc PARSER-MODE ROOT-ID)) (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))) (define doc-elements (splice trimmed-xs (setup:splicing-tag)))
(proc doc-elements)) ; positional arg for doclang-raw: post-processor (proc doc-elements)) ; positional arg for doclang-raw: post-processor
(module META-MOD-ID racket/base (module META-MOD-ID racket/base

@ -1,55 +1,62 @@
#lang racket/base #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) (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) (define (preheat-cache starting-dir)
(unless (and (path-string? starting-dir) (directory-exists? 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 max-places (processor-count)) ; number of parallel processes to spawn at a time
(define paths-that-should-be-cached
(define paths-that-should-be-cached (for/list ([path (in-directory starting-dir)] (for/list ([path (in-directory starting-dir)]
#:when (for/or ([proc (in-list (list preproc-source? #:when (for/or ([proc (in-list (list preproc-source?
markup-source? markup-source?
markdown-source? markdown-source?
pagetree-source?))]) pagetree-source?))])
(proc path))) (proc path)))
path)) path))
;; if a file is already in the cache, no need to hit it again. ;; if a file is already in the cache, no need to hit it again.
;; this allows partially completed preheat jobs to resume. ;; this allows partially completed preheat jobs to resume.
(define uncached-paths (filter (define uncached-paths (filter-not path-cached? paths-that-should-be-cached))
(λ (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)
;; compile the paths in groups, so they can be incrementally saved. ;; compile the paths in groups, so they can be incrementally saved.
;; that way, if there's a failure, the progress is preserved. ;; that way, if there's a failure, the progress is preserved.
;; but the slowest file in a group will prevent further progress. ;; but the slowest file in a group will prevent further progress.
(for ([path-group (in-list (slice-at uncached-paths max-places))]) (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)] (for ([path (in-list path-group)]
[ppl (in-list path-places)]) [ppl (in-list path-places)])
(define result (place-channel-get ppl)) (define result (place-channel-get ppl))
(when result ; #f is used to signal compile error (when result ; #false is used to signal compile error
(cache-ref! (paths->key path) (λ _ result)))))) (cache-ref! (paths->key path) (λ () result))))))

@ -1,14 +1,32 @@
#lang racket/base #lang racket/base
(require racket/list racket/contract racket/file racket/format xml racket/match racket/set racket/string racket/promise racket/path) (require racket/list
(require web-server/http/xexpr web-server/dispatchers/dispatch) racket/contract
(require net/url) racket/file
(require web-server/http/request-structs) racket/format
(require web-server/http/response-structs) racket/match
(require web-server/http/redirect) racket/string
(require 2htdp/image) racket/promise
(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") racket/path
web-server/http/xexpr
(module+ test (require rackunit)) 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 ;;; Routes for the server module
;;; separated out for ease of testing ;;; separated out for ease of testing
@ -40,14 +58,15 @@
;; print message to console about a request ;; print message to console about a request
(define/contract (logger req) (define/contract (logger req)
(request? . -> . void?) (request? . -> . void?)
(define client (request-client-ip req))
(define localhost-client "::1") (define localhost-client "::1")
(define url-string (url->string (request-uri req))) (define url-string (url->string (request-uri req)))
(when (not (ends-with? url-string "favicon.ico")) (unless (ends-with? url-string "favicon.ico")
(message "request:" (if (regexp-match #rx"/$" url-string) (message (match url-string
(string-append url-string " directory default page") [(regexp #rx"/$") (string-append url-string " directory default page")]
(string-replace url-string (setup:main-pagetree) " dashboard")) [_ (string-replace url-string (setup:main-pagetree) " dashboard")])
(if (not (equal? client localhost-client)) (format "from ~a" client) "")))) (match (request-client-ip req)
[(== localhost-client) ""]
[client (format "from ~a" client)]))))
;; pass string args to route, then ;; pass string args to route, then
;; package route into right format for web server ;; package route into right format for web server
@ -146,9 +165,9 @@
(define (make-link-cell href+text) (define (make-link-cell href+text)
(match-define (cons href text) href+text) (match-define (cons href text) href+text)
(filter-not void? `(cell ,(when text (filter-not void? `(cell ,(when text
(if href (if href
`(a ((href ,href)) ,text) `(a ((href ,href)) ,text)
text))))) text)))))
(define (make-parent-row) (define (make-parent-row)
(define title (string-append "Project root" (if (equal? (current-project-root) dashboard-dir) (format " = ~a" dashboard-dir) ""))) (define title (string-append "Project root" (if (equal? (current-project-root) dashboard-dir) (format " = ~a" dashboard-dir) "")))
@ -162,51 +181,51 @@
(define (make-path-row filename source indent-level) (define (make-path-row filename source indent-level)
`(row ,@(map make-link-cell `(row ,@(map make-link-cell
(append (list (append (list
(let ([main-cell (cond ; main cell (let ([main-cell (cond ; main cell
[(directory-exists? (build-path dashboard-dir filename)) ; links subdir to its dashboard [(directory-exists? (build-path dashboard-dir filename)) ; links subdir to its dashboard
(cons (format "~a/~a" filename (setup:main-pagetree)) (format "~a/" filename))] (cons (format "~a/~a" filename (setup:main-pagetree)) (format "~a/" filename))]
[(and source (equal? (get-ext source) "scrbl")) ; scribble source [(and source (equal? (get-ext source) "scrbl")) ; scribble source
(cons #f `(a ((href ,filename)) ,filename (span ((class "file-ext")) " (from " ,(->string (find-relative-path dashboard-dir source)) ")")))] (cons #f `(a ((href ,filename)) ,filename (span ((class "file-ext")) " (from " ,(->string (find-relative-path dashboard-dir source)) ")")))]
[source ; ordinary source. use remove-ext because source may have escaped extension in it [source ; ordinary source. use remove-ext because source may have escaped extension in it
(define source-first-ext (get-ext source)) (define source-first-ext (get-ext source))
(define source-minus-ext (unescape-ext (remove-ext source))) (define source-minus-ext (unescape-ext (remove-ext source)))
(define source-second-ext (get-ext source-minus-ext)) (define source-second-ext (get-ext source-minus-ext))
(cond ; multi source. expand to multiple output files. (cond ; multi source. expand to multiple output files.
[(and source-second-ext (equal? source-second-ext (->string (setup:poly-source-ext (->complete-path source))))) [(and source-second-ext (equal? source-second-ext (->string (setup:poly-source-ext (->complete-path source)))))
(define source-base (remove-ext source-minus-ext)) (define source-base (remove-ext source-minus-ext))
(define output-names (map (λ (ext) (->string (add-ext source-base ext))) (setup:poly-targets (->complete-path source)))) (define output-names (map (λ (ext) (->string (add-ext source-base ext))) (setup:poly-targets (->complete-path source))))
(cons #f `(div ,@(map (λ (on) `(a ((href ,on)) ,on (span ((class "file-ext")) "." ,source-first-ext ,(format " (from ~a)" (->string (find-relative-path dashboard-dir source)))))) output-names)))] (cons #f `(div ,@(map (λ (on) `(a ((href ,on)) ,on (span ((class "file-ext")) "." ,source-first-ext ,(format " (from ~a)" (->string (find-relative-path dashboard-dir source)))))) output-names)))]
[else [else
(define extra-row-string (define extra-row-string
(if (equal? source-minus-ext (remove-ext source)) ; escaped and unescaped versions are equal (if (equal? source-minus-ext (remove-ext source)) ; escaped and unescaped versions are equal
"" ; no extra string needed "" ; no extra string needed
(format " (from ~a)" (->string (find-relative-path dashboard-dir source))))) (format " (from ~a)" (->string (find-relative-path dashboard-dir source)))))
(cons #f `(a ((href ,filename)) ,(->string source-minus-ext) (span ((class "file-ext")) "." ,source-first-ext ,extra-row-string)))])] (cons #f `(a ((href ,filename)) ,(->string source-minus-ext) (span ((class "file-ext")) "." ,source-first-ext ,extra-row-string)))])]
[else ; other non-source file [else ; other non-source file
(cons filename filename)])]) (cons filename filename)])])
(cons (car main-cell) (cons (car main-cell)
(let* ([cell-content (cdr main-cell)] (let* ([cell-content (cdr main-cell)]
[indent-padding (+ 1 indent-level)] [indent-padding (+ 1 indent-level)]
[padding-attr `(class ,(format "indent_~a" indent-padding))]) [padding-attr `(class ,(format "indent_~a" indent-padding))])
(cond (cond
[(string? cell-content) `(span (,padding-attr) ,cell-content)] [(string? cell-content) `(span (,padding-attr) ,cell-content)]
[(txexpr? cell-content) [(txexpr? cell-content)
;; indent link text by depth in pagetree ;; indent link text by depth in pagetree
`(,(get-tag cell-content) ,(cons padding-attr (get-attrs cell-content)) ,@(get-elements cell-content))] `(,(get-tag cell-content) ,(cons padding-attr (get-attrs cell-content)) ,@(get-elements cell-content))]
[else (error 'make-path-row (format "mysterious cell data: ~v" cell-content))])))) [else (error 'make-path-row (format "mysterious cell data: ~v" cell-content))]))))
(cond ; 'in' cell (cond ; 'in' cell
[source (cons (format "in/~a" source) "in")] [source (cons (format "in/~a" source) "in")]
[(or (pagetree-source? filename) (sourceish? filename)) (cons (format "in/~a" filename) "in")] [(or (pagetree-source? filename) (sourceish? filename)) (cons (format "in/~a" filename) "in")]
[else empty-cell]) [else empty-cell])
(cond ; 'out' cell (cond ; 'out' cell
[(directory-exists? (build-path dashboard-dir filename)) (cons #f #f)] [(directory-exists? (build-path dashboard-dir filename)) (cons #f #f)]
[(pagetree-source? filename) empty-cell] [(pagetree-source? filename) empty-cell]
[else (cons (format "out/~a" filename) "out")])))))) [else (cons (format "out/~a" filename) "out")]))))))
(define (ineligible-path? x) (member x (setup:paths-excluded-from-dashboard))) (define (ineligible-path? x) (member x (setup:paths-excluded-from-dashboard)))
@ -223,32 +242,32 @@
depth))) depth)))
(apply body-wrapper #:title (format "~a" dashboard-dir) (apply body-wrapper #:title (format "~a" dashboard-dir)
(cons (make-parent-row) (cons (make-parent-row)
(cond (cond
[(not (null? project-paths)) [(not (null? project-paths))
(define path-source-pairs (define path-source-pairs
(map (map
(λ (p) (define source (λ (p) (define source
(let ([possible-source (get-source (build-path dashboard-dir p))]) (let ([possible-source (get-source (build-path dashboard-dir p))])
(and possible-source (->string (find-relative-path dashboard-dir possible-source))))) (and possible-source (->string (find-relative-path dashboard-dir possible-source)))))
(cons p source)) (cons p source))
project-paths)) project-paths))
(define-values (reversed-unique-path-source-pairs seen-paths) ; delete pairs with duplicate sources (define-values (reversed-unique-path-source-pairs seen-paths) ; delete pairs with duplicate sources
(for/fold ([psps empty][seen-source-paths empty]) (for/fold ([psps empty][seen-source-paths empty])
([psp (in-list path-source-pairs)]) ([psp (in-list path-source-pairs)])
(define source-path (cdr psp)) (define source-path (cdr psp))
(if (and source-path (member source-path seen-source-paths)) (if (and source-path (member source-path seen-source-paths))
(values psps seen-source-paths) ; skip the pair (values psps seen-source-paths) ; skip the pair
(values (cons psp psps) (cons source-path seen-source-paths))))) (values (cons psp psps) (cons source-path seen-source-paths)))))
(define unique-path-source-pairs (reverse reversed-unique-path-source-pairs)) (define unique-path-source-pairs (reverse reversed-unique-path-source-pairs))
(define filenames (map (compose1 ->string car) unique-path-source-pairs)) (define filenames (map (compose1 ->string car) unique-path-source-pairs))
(define sources (map cdr unique-path-source-pairs)) (define sources (map cdr unique-path-source-pairs))
(define indent-levels (map directory-pagetree-depth filenames)) (define indent-levels (map directory-pagetree-depth filenames))
(parameterize ([current-directory dashboard-dir]) (parameterize ([current-directory dashboard-dir])
(map make-path-row filenames sources indent-levels))] (map make-path-row filenames sources indent-levels))]
[else (list '(row (cell ((class "no-files")) "No files yet in this directory") (td) (td)))])))) [else (list '(row (cell ((class "no-files")) "No files yet in this directory") (td) (td)))]))))
(define route-dashboard (route-wrapper dashboard)) (define route-dashboard (route-wrapper dashboard))
@ -289,7 +308,7 @@
(define/contract (route-404 req) (define/contract (route-404 req)
(request? . -> . response?) (request? . -> . response?)
(define missing-path-string (path->string (simplify-path (req->path req)))) (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 (response/xexpr+doctype
`(html `(html
(head (title "404 error") (link ((href "/error.css") (rel "stylesheet")))) (head (title "404 error") (link ((href "/error.css") (rel "stylesheet"))))

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

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

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

@ -1,35 +1,43 @@
#lang racket/base #lang racket/base
(require pollen/setup scribble/reader racket/pretty version/utils racket/port racket/string) (require pollen/setup
(provide (all-defined-out)) 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 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) (define (show doc parser-mode here-path)
;; we only want the top doc to print in the runtime environment ;; 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. ;; 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. ;; 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 (equal? here-path (current-top-path))
(when (and ctp (equal? here-path ctp)) (if (memq parser-mode (list default-mode-preproc default-mode-template))
(if (memq parser-mode (list default-mode-preproc default-mode-template)) (display doc)
(display doc) (with-handlers ([exn:fail? my-error-handler])
;; #:newline option for `pretty-print` was introduced in 6.6.0.3, (my-pretty-print (validate-txexpr doc))))))
;; 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))))))))
(define (configure top-here-path) (define (configure top-here-path)
(current-top-path top-here-path) ;; puts `show` into the right mode (current-top-path top-here-path) ; puts `show` into the right mode
;; wrap REPL interactions with pollen expression support
(define old-read (current-read-interaction)) (define old-read (current-read-interaction))
(define pollen-readtable (make-at-readtable #:command-char (setup:command-char))) (define (pollen-repl-read src in)
(define (new-read src in) ;; wrap repl interactions with pollen expression support
(define pollen-readtable (make-at-readtable #:command-char (setup:command-char)))
(parameterize ([current-readtable pollen-readtable]) (parameterize ([current-readtable pollen-readtable])
(old-read src in))) (old-read src in)))
(current-read-interaction new-read)) (current-read-interaction pollen-repl-read))

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

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

@ -1 +1 @@
1540875704 1540958640

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

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

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

@ -1,7 +1,7 @@
#lang at-exp racket/base #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") (define-runtime-path mb-css "mb.css")

@ -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: After a moment, you'll see the startup message:
@terminal{ @terminal{
Welcome to Pollen @|pollen:version| (Racket @(version)) pollen: welcome to Pollen @|pollen:version| (Racket @(version))
Project root is /path/to/your/directory pollen: project root is /path/to/your/directory
Project server is http://localhost:8080 (Ctrl+C to exit) pollen: project server is http://localhost:8080 (Ctrl+C to exit)
Project dashboard is http://localhost:8080/index.ptree pollen: project dashboard is http://localhost:8080/index.ptree
Ready to rock} 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. 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.

@ -16,34 +16,34 @@ The values below can be changed by overriding them in your @racket["pollen.rkt"]
@itemlist[#:style 'ordered @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.)}
] ]
When Pollen runs, these definitions will supersede those in @racketmodname[pollen/setup]. When Pollen runs, these definitions will supersede those in @racketmodname[pollen/setup].
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: 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" @fileblock["pollen.rkt"
@codeblock{ @codeblock{
#lang racket/base #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)) (provide (all-defined-out))
(define main-export 'van-halen) (define main-export 'van-halen)
(define markup-source-ext 'rock) (define markup-source-ext 'rock)
(define command-char #\🎸)) (define command-char #\🎸))
}] }]
Of course, you can restore the defaults simply by removing these defined values from @racket["pollen.rkt"]. 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} @section{Values}
@defoverridable[project-server-port integer?]{ @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.} @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[( @deftogether[(
@defoverridable[preproc-source-ext symbol?] @defoverridable[preproc-source-ext symbol?]
@defoverridable[markup-source-ext symbol?] @defoverridable[markup-source-ext symbol?]
@defoverridable[markdown-source-ext symbol?] @defoverridable[markdown-source-ext symbol?]
@defoverridable[null-source-ext symbol?] @defoverridable[null-source-ext symbol?]
@defoverridable[pagetree-source-ext symbol?] @defoverridable[pagetree-source-ext symbol?]
@defoverridable[template-source-ext symbol?] @defoverridable[template-source-ext symbol?]
@defoverridable[scribble-source-ext symbol?] @defoverridable[scribble-source-ext symbol?]
)]{File extensions for Pollen source files.} )]{File extensions for Pollen source files.}
@defoverridable[main-pagetree string?]{Pagetree that Pollen dashboard loads by default in each directory.} @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: @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[( @deftogether[(
@(defoverridable newline string?) @(defoverridable newline string?)
@(defoverridable linebreak-separator string?) @(defoverridable linebreak-separator string?)
@(defoverridable paragraph-separator string?) @(defoverridable paragraph-separator string?)
)] )]
Default separators used in decoding. 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). @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" @fileblock["pollen.rkt"
@codeblock{ @codeblock{
(module+ setup (module+ setup
(require syntax/modresolve) (require syntax/modresolve)
(provide (all-defined-out)) (provide (all-defined-out))
(define cache-watchlist (map resolve-module-path '("my-module.rkt")))) (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. @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-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. @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.} @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[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} @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]. 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]{ @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?]{ @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]{ @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]{ @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.}

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

@ -1,32 +1,37 @@
#lang pollen/mode racket/base #lang pollen/mode racket/base
(require (for-syntax racket/base syntax/parse)) (require (for-syntax
(require txexpr/base racket/string racket/match) racket/base
syntax/parse)
txexpr/base
racket/string
racket/match)
(provide default-tag-function make-default-tag-function define-tag-function) (provide default-tag-function make-default-tag-function define-tag-function)
(define (parse-leading-attrs xs) (define (parse-leading-attrs xs)
(match xs (match xs
[(cons (? txexpr-attrs? leading-attrs) tail) (values leading-attrs tail)] [(cons (? txexpr-attrs? leading-attrs) tail) (values leading-attrs tail)]
[else (values null xs)])) [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 (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]) (let parse-next ([xs xs][colon-attrs empty])
(match xs (match xs
[(list* (? colon-attr-name? name) (? string? val) xs) [(list* (? colon-attr-name? name) (? string? val) xs)
(parse-next xs (cons (list (colon-attr-name? name) val) colon-attrs))] (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 (parse-kw-attrs kw-symbols-in kw-args)
(define kw-symbols (map (λ (kw) (string->symbol (string-trim (keyword->string kw) "#:"))) kw-symbols-in)) (define kw-symbols (map (λ (kw) (string->symbol (string-trim (keyword->string kw) "#:"))) kw-symbols-in))
(map list kw-symbols kw-args)) (map list kw-symbols kw-args))
(define (make-one-tag-function outer-kws outer-kw-args id) (define (make-one-tag-function outer-kws outer-kw-args id)
(make-keyword-procedure (make-keyword-procedure
(λ (inner-kws inner-kw-args . xs) (λ (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 ;; 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) ;; (but it may become one through further processing, so no need to be finicky)
;; however, don't show empty attrs. ;; however, don't show empty attrs.
(define attrs (append kw-attrs colon-attrs leading-attrs)) (cons id (match (append kw-attrs colon-attrs leading-attrs)
(cons id (if (null? attrs) [(== empty) xs]
xs [attrs (cons attrs xs)]))))))
(cons attrs xs)))))))
(define default-tag-function (define default-tag-function
(make-keyword-procedure (make-keyword-procedure
(λ (outer-kws outer-kw-args . ids) (λ (outer-kws outer-kw-args . ids)
(let ([tag-proc (apply compose1 (for/list ([id (in-list ids)]) (define tag-proc (apply compose1 (for/list ([id (in-list ids)])
(make-one-tag-function outer-kws outer-kw-args id)))] (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) "+")))]) (define tag-proc-name (string->symbol (format "pollen-tag:~a" (string-join (map symbol->string ids) "+"))))
(procedure-rename tag-proc tag-proc-name))))) (procedure-rename tag-proc tag-proc-name))))
(define make-default-tag-function default-tag-function) ; bw compat (define make-default-tag-function default-tag-function) ; bw compat
(module+ test (module+ test
(require rackunit txexpr/check) (require txexpr/check)
(define outerdiv (default-tag-function 'div #:class "outer" #:style "outer")) (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 "foo") '(div ((class "outer") (style "outer")) "foo"))
(check-txexprs-equal? (outerdiv) '(div ((class "outer") (style "outer")))) (check-txexprs-equal? (outerdiv) '(div ((class "outer") (style "outer"))))
@ -91,7 +94,7 @@
(module+ test (module+ test
(require rackunit) (require)
(define foo2 (default-tag-function 'foo)) (define foo2 (default-tag-function 'foo))
(define-tag-function (foo attrs elems) (define-tag-function (foo attrs elems)

Binary file not shown.

After

Width:  |  Height:  |  Size: 95 B

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

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

@ -1,5 +1,5 @@
#lang racket/base #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) (define-syntax-rule (check-output outputter string)
(check-equal? (with-output-to-string (λ () outputter)) string)) (check-equal? (with-output-to-string (λ () outputter)) string))

@ -1,5 +1,8 @@
#lang at-exp racket/base #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 only allowed at top level
(define-runtime-path poly-dir "data/poly") (define-runtime-path poly-dir "data/poly")

@ -2,19 +2,10 @@
(require (for-syntax racket/base) pollen/tag) (require (for-syntax racket/base) pollen/tag)
(provide def/c (rename-out (top~ #%top))) (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) (define-syntax-rule (top~ . ID)
;; #%app shouldn't be necessary, but temp fix for Racket7
(#%app make-default-tag-function 'ID)) (#%app make-default-tag-function 'ID))
(define-syntax (def/c stx) (define-syntax (def/c stx)
(syntax-case stx () (syntax-case stx ()
[(_ X) [(_ X) (identifier-binding #'X) #'X]
(if (identifier-binding #'X ) [(_ X) #'(#%top . X)]))
#'X
#'(#%top . X))]))

@ -10,7 +10,7 @@
rackjure/str rackjure/str
xml xml
(only-in html read-html-as-xml) (only-in html read-html-as-xml)
"../private/debug.rkt" "../private/log.rkt"
"../private/splice.rkt") "../private/splice.rkt")
(provide highlight make-highlight-css) (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) (define-values (pyg-in pyg-out pyg-pid pyg-err pyg-proc)
(values #f #f #f #f #f)) (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 (define start
(let ([start-attempted? #f]) (let ([start-attempted? #f])

Loading…
Cancel
Save