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.
@ -21,37 +22,42 @@
(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
(with-handlers ([exn:fail? (path-error-handler caller-name path-or-path-string)])
(path->complete-path (if (path? path-or-path-string) (path->complete-path (if (path? path-or-path-string)
path-or-path-string path-or-path-string
(string->path 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)])
;; 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))])))) (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?)
(define-values (tag attrs elements) (txexpr->values x))
(cond (cond
[(or (memq tag excluded-tags) [(or (memq tag excluded-tags)
(for/or ([attr (in-list attrs)]) (for/or ([attr (in-list attrs)])
(member attr excluded-attrs))) (member attr excluded-attrs))) x] ; because it's excluded
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
(make-txexpr (txexpr-tag-proc tag)
(txexpr-attrs-proc attrs) (txexpr-attrs-proc attrs)
(txexpr-elements-proc (append-map (λ (x) (->list/tx (loop x))) elements)))) (txexpr-elements-proc (append-map (λ (x) (->list/tx (loop x))) elements))))
(txexpr-proc ((if (block-txexpr? decoded-txexpr) (txexpr-proc ((if (block-txexpr? decoded-txexpr)
block-txexpr-proc block-txexpr-proc
inline-txexpr-proc) decoded-txexpr))])] inline-txexpr-proc) decoded-txexpr))])]
[(string? x) (string-proc x)] [(? string?) (string-proc x)]
[(or (symbol? x) (valid-char? x)) (entity-proc x)] [(? symbol?) (entity-proc x)]
[(cdata? x) (cdata-proc x)] [(? valid-char?) (entity-proc x)]
[else (error "decode: can't decode" 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,17 +130,20 @@
(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)))
@ -147,7 +151,7 @@
;; 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]))))
@ -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)
@ -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))
(for ([p (in-list pagenodes)]
#:unless (pagenode? p)) #:unless (pagenode? p))
(error 'validate-pagetree "~v is not a valid pagenode" p)) (raise-argument-error 'validate-pagetree "valid pagenodes" p))
(with-handlers ([exn:fail? (λ (e) (error 'validate-pagetree "~a" (exn-message e)))]) (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])
@ -139,7 +139,7 @@
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
@ -194,7 +193,7 @@
#: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,17 +10,17 @@
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 ;; we don't include output-path in path-strings-to-track
;; because we don't want to attach a mod date ;; because we don't want to attach a mod date
;; because cache validity is not sensitive to mod date of output path ;; because cache validity is not sensitive to mod date of output path
;; (in fact we would expect it to be earlier, since we want to rely on an earlier version) ;; (in fact we would expect it to be earlier, since we want to rely on an earlier version)
(define path-strings-to-track (list* source-path (define (paths->key source-path [template-path #false] [output-path #false])
(define path-strings-to-track
(list* source-path
;; if template has a source file, track that instead ;; 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)
@ -33,40 +33,37 @@
(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'
;; otherwise it gets cached in current namespace.
(parameterize ([current-namespace (make-base-namespace)]
[current-directory path-dir])
;; I monkeyed around with using the metas submodule to pull out the metas (for speed) ;; 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. ;; 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. ;; 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 savings of avoiding two cache fetches at the outset outweighs
;; the benefit of not reloading doc when you just need metas. ;; the benefit of not reloading doc when you just need metas.
(namespace-attach-module (namespace-anchor->namespace cache-utils-module-ns) 'pollen/setup) ; brings in params ;; new namespace forces `dynamic-require` to re-instantiate `path`
;; otherwise it gets cached in current namespace.
(parameterize ([current-namespace (make-base-namespace)]
[current-directory (dirname path)])
;; brings in currently instantiated params (unlike namespace-require)
(define outer-ns (namespace-anchor->namespace cache-utils-module-ns))
(namespace-attach-module outer-ns 'pollen/setup)
(define doc-missing-thunk (λ () "")) (define 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,19 +20,20 @@
;; 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)
(with-logging-to-port
(current-error-port)
(λ ()
(case command-name (case command-name
[("test" "xyzzy") (handle-test)] [("test" "xyzzy") (handle-test)]
[(#f "help") (handle-help)] [(#f "help") (handle-help)]
@ -42,6 +45,9 @@
[("setup") (handle-setup (get-first-arg-or-current-dir))] [("setup") (handle-setup (get-first-arg-or-current-dir))]
[("clone" "publish") (handle-publish)] [("clone" "publish") (handle-publish)]
[else (handle-unknown command-name)])) [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,21 +73,19 @@ 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
(command-line #:program "raco pollen render"
#:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'render' from the front #:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'render' from the front
#:once-each #:once-each
[("-t" "--target") target-arg "Render target for poly sources" [("-t" "--target") target-arg "Render target for poly sources"
@ -91,19 +95,18 @@ version print the version" (current-server-port) (make-publish-di
[("-s" "--subdir") "Render subdirectories nonrecursively" (render-with-subdirs? 'include)] [("-s" "--subdir") "Render subdirectories nonrecursively" (render-with-subdirs? 'include)]
#:args other-args #:args other-args
other-args)) other-args))
(define path-args (if (empty? parsed-args)
(list (current-directory))
parsed-args))
(parameterize ([current-poly-target (render-target-wanted)]) ;; applies to both cases (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
#:when (directory-exists? dir)
(define top-dir (very-nice-path dir))
(let render-one-dir ([dir top-dir]) (let render-one-dir ([dir top-dir])
(parameterize ([current-directory dir] (parameterize ([current-directory dir]
[current-project-root (if (eq? (render-with-subdirs?) 'recursive) [current-project-root (case (render-with-subdirs?)
dir [(recursive) dir]
top-dir)]) [else top-dir])])
(define dirlist (directory-list dir)) (define dirlist (directory-list dir))
(define preprocs (filter preproc-source? dirlist)) (define preprocs (filter preproc-source? dirlist))
(define static-pagetrees (filter pagetree-source? dirlist)) (define static-pagetrees (filter pagetree-source? dirlist))
@ -124,15 +127,15 @@ version print the version" (current-server-port) (make-publish-di
#:when (and (directory-exists? path) #:when (and (directory-exists? path)
(not (omitted-path? path)))) (not (omitted-path? path))))
(render-one-dir (->complete-path path))))))] (render-one-dir (->complete-path path))))))]
[else ;; path mode [path-args ;; path mode
(displayln (format "rendering ~a" (string-join (map ->string path-args) " "))) (displayln (format "rendering ~a" (string-join (map ->string path-args) " ")))
(apply render-batch (map very-nice-path path-args))]))) (apply render-batch (map very-nice-path path-args))]))))
(define (handle-start) (define (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
(command-line #:program "raco pollen start"
#:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'start' from the front #:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'start' from the front
#:once-each #:once-each
[("--launch" "-l") "Launch browser after start" (set! launch-wanted #t)] [("--launch" "-l") "Launch browser after start" (set! launch-wanted #t)]
@ -142,33 +145,30 @@ version print the version" (current-server-port) (make-publish-di
(define dir (path->directory-path (get-first-arg-or-current-dir clargs))) (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 (preheat-cache starting-dir) (define (path-cached? path)
(unless (and (path-string? starting-dir) (directory-exists? starting-dir)) ;; #true = already cached; #false = not cached
(error 'preheat-cache (format "~a is not a directory" starting-dir)))
(define max-places (processor-count)) ; number of parallel processes to spawn at a time
(define paths-that-should-be-cached (for/list ([path (in-directory starting-dir)]
#:when (for/or ([proc (in-list (list preproc-source?
markup-source?
markdown-source?
pagetree-source?))])
(proc path)))
path))
;; if a file is already in the cache, no need to hit it again.
;; this allows partially completed preheat jobs to resume.
(define uncached-paths (filter
(λ (path)
;; #t = not cached; #f = already cached
;; seems like it would be slow to load cache.rktd but it's not. ;; seems like it would be slow to load cache.rktd but it's not.
(define-values (_ private-cache-dir) (make-cache-dirs path)) (define-values (_ private-cache-dir) (make-cache-dirs path))
(define cache-db-file (build-path private-cache-dir "cache.rktd")) (define cache-db-file (build-path private-cache-dir "cache.rktd"))
(cond (and (file-exists? cache-db-file)
[(not (file-exists? cache-db-file)) #t] (hash-has-key? (file->value cache-db-file) (paths->key path))))
[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) ;; compile a path inside a place (= parallel processing)
(define (path-into-place path) (define (path-into-place starting-dir path)
(message (format "caching: ~a" (find-relative-path starting-dir path))) (message (format "caching: ~a" (find-relative-path starting-dir path)))
(define p (place ch (define p
(place ch
(define path (place-channel-get ch)) (define path (place-channel-get ch))
(define-values (path-dir path-name _) (split-path path)) (define-values (_ path-name __) (split-path path))
(message (format "compiling: ~a" path)) (message (format "compiling: ~a" path))
;; use #f to signal compile error. Otherwise allow errors to pass. ;; use #false to signal compile error. Otherwise allow errors to pass.
(define result (with-handlers ([exn:fail? (λ _ (message (format "compile failed: ~a" path-name)) #f)]) (define result
(with-handlers ([exn:fail? (λ (e) (message (format "compile failed: ~a" path-name)) #false)])
(path->hash path))) (path->hash path)))
(place-channel-put ch result))) (place-channel-put ch result)))
(place-channel-put p path) (place-channel-put p path)
p) p)
(define (preheat-cache starting-dir)
(unless (and (path-string? starting-dir) (directory-exists? starting-dir))
(raise-argument-error 'preheat-cache "directory" starting-dir))
(define max-places (processor-count)) ; number of parallel processes to spawn at a time
(define paths-that-should-be-cached
(for/list ([path (in-directory starting-dir)]
#:when (for/or ([proc (in-list (list preproc-source?
markup-source?
markdown-source?
pagetree-source?))])
(proc path)))
path))
;; if a file is already in the cache, no need to hit it again.
;; this allows partially completed preheat jobs to resume.
(define uncached-paths (filter-not path-cached? paths-that-should-be-cached))
;; 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
@ -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)
(syntax-source source-name)
;; captures paths, strings, "unsaved editor", path-strings, symbols ;; captures paths, strings, "unsaved editor", path-strings, symbols
source-name)) ((if (syntax? source-name) syntax-source values) source-name))
(define (infer-parser-mode reader-mode reader-here-path) (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,27 +73,27 @@
(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)
(define maybe-source-path
(with-handlers ([exn:fail? (λ (exn) #false)])
;; Robert Findler does not endorse `get-filename` here, ;; Robert Findler does not endorse `get-filename` here,
;; because it's sneaky and may not always work. ;; because it's sneaky and may not always work.
;; OTOH Scribble relies on it, so IMO it's highly unlikely to change. ;; OTOH Scribble relies on it, so IMO it's highly unlikely to change.
(let ([maybe-definitions-frame (object-name in)]) (send (object-name in) get-filename)))
(send maybe-definitions-frame get-filename)))) ; will be #f if unsaved file (define my-command-char
(define my-command-char (hash-ref! command-char-cache maybe-source-path (λ _ (setup:command-char maybe-source-path)))) (hash-ref! command-char-cache maybe-source-path (λ () (setup:command-char maybe-source-path))))
(case key (case key
[(color-lexer) [(color-lexer)
(define my-make-scribble-inside-lexer (match (dynamic-require 'syntax-color/scribble-lexer 'make-scribble-inside-lexer (λ () #false))
(dynamic-require 'syntax-color/scribble-lexer 'make-scribble-inside-lexer (λ () #f))) [(? procedure? make-lexer) (make-lexer #:command-char my-command-char)]
(if my-make-scribble-inside-lexer [_ default])]
(my-make-scribble-inside-lexer #:command-char my-command-char)
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)
@ -109,13 +104,13 @@
(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)
;; #:newline option for `pretty-print` was introduced in 6.6.0.3, (with-handlers ([exn:fail? my-error-handler])
;; so trim trailing newline manually (my-pretty-print (validate-txexpr doc))))))
(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-repl-read src in)
;; wrap repl interactions with pollen expression support
(define pollen-readtable (make-at-readtable #:command-char (setup:command-char))) (define pollen-readtable (make-at-readtable #:command-char (setup:command-char)))
(define (new-read src in)
(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")))
(define (strip-empty-attrs x)
(let loop ([x x])
(if (list? x)
;; this will strip all empty lists. ;; this will strip all empty lists.
;; in practice, they would only appear in attrs position ;; in practice, they would only appear in attrs position
(map loop (filter (λ (x) (not (null? x))) x)) (define (strip-empty-attrs x)
(let loop ([x x])
(if (pair? x)
(map loop (filter-not null? 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,28 +1,23 @@
#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)

@ -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)
@ -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)))
@ -156,58 +145,59 @@
(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"
(find-relative-path (current-project-root) source-path)))
(match-define-values ((cons render-result _) _ real _)
(parameterize ([current-poly-target (->symbol (or (get-ext output-path)
(and template-path (get-ext template-path)) (and template-path (get-ext template-path))
(current-poly-target)))]) (current-poly-target)))])
(apply render-proc (list source-path template-path output-path)))) (time-apply render-proc (list source-path template-path output-path))))
;; wait till last possible moment to store mod dates, because render-proc may also trigger its own subrenders ;; 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.
(when doc [(? part? doc) (scribble-render (list doc) (list source-path))]
(scribble-render (list doc) (list source-path))))) [_ (void)]))
(define result (file->string (->output-path source-path))) (begin0 ; because render promises the data, not the side effect
(delete-file (->output-path source-path)) ; because render promises the data, not the side effect (file->string (->output-path source-path))
result) (delete-file (->output-path source-path))))
(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,27 +235,18 @@
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+provide/contract (get-template-for source-path [maybe-output-path #f]) (define (get-template-from-metas source-path output-path-ext)
((complete-path?)((or/c #f complete-path?)) . ->* . (or/c #f complete-path?))
(define (file-exists-or-has-source? p) ; p could be #f
(and p (for/first ([proc (in-list (list values ->preproc-source-path ->null-source-path))]
#:when (file-exists? (proc p)))
p)))
(define (get-template)
(define output-path (or maybe-output-path (->output-path source-path)))
(define output-path-ext (or (get-ext output-path) (current-poly-target))) ; output-path may not have an extension
(define (get-template-from-metas)
(with-handlers ([exn:fail:contract? (λ (e) #f)]) ; in case source-path doesn't work with cached-require (with-handlers ([exn:fail:contract? (λ (e) #f)]) ; in case source-path doesn't work with cached-require
(parameterize ([current-directory (current-project-root)]) (parameterize ([current-directory (current-project-root)])
(define source-metas (cached-metas source-path)) (define source-metas (cached-metas source-path))
@ -276,22 +257,25 @@
template-name-or-names)) template-name-or-names))
(and template-name (build-path (dirname source-path) template-name))))) (and template-name (build-path (dirname source-path) template-name)))))
(define (get-default-template) (define (get-default-template source-path output-path-ext)
(and output-path-ext (and output-path-ext
(let ([default-template-filename (add-ext (setup:template-prefix source-path) 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?)))) (find-upward-from source-path default-template-filename file-exists-or-has-source?))))
(define (get-fallback-template) (define (get-fallback-template source-path output-path-ext)
(and output-path-ext (and output-path-ext
(build-path (current-server-extras-path) (build-path (current-server-extras-path)
(add-ext (setup:fallback-template-prefix source-path) output-path-ext)))) (add-ext (setup:fallback-template-prefix source-path) output-path-ext))))
(or (file-exists-or-has-source? (get-template-from-metas)) (define+provide/contract (get-template-for source-path [maybe-output-path #f])
(file-exists-or-has-source? (get-default-template)) ((complete-path?)((or/c #f complete-path?)) . ->* . (or/c #f complete-path?))
(file-exists-or-has-source? (get-fallback-template)))) (and (templated-source? source-path)
(let ()
(and (templated-source? source-path) (get-template))) (define output-path (or maybe-output-path (->output-path source-path)))
;; output-path may not have an extension
(define output-path-ext (or (get-ext output-path) (current-poly-target)))
(for/or ([proc (list get-template-from-metas get-default-template get-fallback-template)])
(file-exists-or-has-source? (proc source-path output-path-ext))))))
(module-test-external (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.

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