diff --git a/pollen/cache.rkt b/pollen/cache.rkt index a7a88ec..1bacd69 100644 --- a/pollen/cache.rkt +++ b/pollen/cache.rkt @@ -1,9 +1,10 @@ #lang racket/base (require racket/file racket/list + racket/fasl sugar/define "private/cache-utils.rkt" - "private/debug.rkt" + "private/log.rkt" "setup.rkt") ;; The cache is a hash with paths as keys. @@ -18,40 +19,45 @@ (raise-argument-error 'reset-cache "path-string to existing directory" starting-dir)) (for ([path (in-directory starting-dir)] #:when (cache-directory? path)) - (message (format "removing cache directory: ~a" path)) - (delete-directory/files path))) + (message (format "removing cache directory: ~a" path)) + (delete-directory/files path))) + +(define ((path-error-handler caller-name path-or-path-string) e) + (raise-argument-error caller-name "valid path or path-string" path-or-path-string)) (define-namespace-anchor cache-module-ns) + +(define use-fasl? #false) + (define cached-require-base (let ([ram-cache (make-hash)]) (λ (path-or-path-string subkey caller-name) - (define path (with-handlers ([exn:fail? (λ (e) (raise-argument-error caller-name "valid path or path-string" path-or-path-string))]) - (path->complete-path (if (path? path-or-path-string) - path-or-path-string - (string->path path-or-path-string))))) - + (define path + (with-handlers ([exn:fail? (path-error-handler caller-name path-or-path-string)]) + (path->complete-path (if (path? path-or-path-string) + path-or-path-string + (string->path path-or-path-string))))) (unless (file-exists? path) (raise-argument-error caller-name "path to existing file" path-or-path-string)) - (cond [(setup:compile-cache-active path) (define key (paths->key path)) - (define (convert-path-to-cache-record) (path->hash path)) - (define (get-cache-record) (cache-ref! key convert-path-to-cache-record)) + (define (convert-path-to-cache-record) ((if use-fasl? s-exp->fasl values) (path->hash path))) + (define (get-cache-record) ((if use-fasl? fasl->s-exp values) (cache-ref! key convert-path-to-cache-record))) (define ram-cache-record (hash-ref! ram-cache key get-cache-record)) (hash-ref ram-cache-record subkey)] - [else (parameterize ([current-namespace (make-base-namespace)]) - (namespace-attach-module (namespace-anchor->namespace cache-module-ns) 'pollen/setup) ; brings in params - (dynamic-require path subkey))])))) - + [else + (parameterize ([current-namespace (make-base-namespace)]) + ;; brings in currently instantiated params (unlike namespace-require) + (define outer-ns (namespace-anchor->namespace cache-module-ns)) + (namespace-attach-module outer-ns 'pollen/setup) + (dynamic-require path subkey))])))) (define+provide (cached-require path-string subkey) (cached-require-base path-string subkey 'cached-require)) - (define+provide (cached-doc path-string) (cached-require-base path-string (setup:main-export) 'cached-doc)) - (define+provide (cached-metas path-string) (cached-require-base path-string (setup:meta-export) 'cached-metas)) \ No newline at end of file diff --git a/pollen/core.rkt b/pollen/core.rkt index 94e5776..beed70f 100644 --- a/pollen/core.rkt +++ b/pollen/core.rkt @@ -1,12 +1,18 @@ #lang racket/base -(require (for-syntax racket/base "setup.rkt" "private/splice.rkt")) -(require txexpr/base xml/path sugar/define sugar/coerce sugar/test racket/string) -(require "private/file-utils.rkt" +(require (for-syntax + racket/base + "setup.rkt") + racket/match + txexpr/base + xml/path + sugar/define + sugar/coerce + sugar/test + "private/file-utils.rkt" "setup.rkt" "cache.rkt" "pagetree.rkt" - "tag.rkt" - "private/splice.rkt") + "tag.rkt") (define is-meta-value? hash?) (define is-doc-value? txexpr?) @@ -22,15 +28,15 @@ ((coerce/symbol? (or/c is-meta-value? is-doc-value? pagenode? pathish?)) (symbol?) . ->* . (or/c #f txexpr-elements?)) (define metas-result (and (not (is-doc-value? value-source)) (select-from-metas key value-source caller))) (define doc-result (and (not (is-meta-value? value-source)) (select-from-doc key value-source caller))) - (define result (filter values (apply append (map ->list (list metas-result doc-result))))) - (and (pair? result) result)) - + (match (filter values (apply append (map ->list (list metas-result doc-result)))) + [(? pair? res) res] + [_ #false])) (define+provide/contract (select key value-source) (coerce/symbol? (or/c is-meta-value? is-doc-value? pagenode? pathish?) . -> . (or/c #f txexpr-element?)) - (define result (select* key value-source 'select)) - (and (pair? result) (car result))) - + (match (select* key value-source 'select) + [(cons res _) res] + [_ #false])) (module-test-external (check-equal? (select* 'key '#hash((key . "value"))) '("value")) @@ -52,31 +58,28 @@ (check-false (select* 'absent-key doc)) (check-false (select 'absent-key doc)))) - (define+provide/contract (select-from-metas key metas-source [caller 'select-from-metas]) ;; output contract is a single txexpr-element ;; because metas is a hash, and a hash has only one value for a key. ((coerce/symbol? (or/c is-meta-value? pagenode? pathish?)) (symbol?) . ->* . (or/c #f txexpr-element?)) - (define metas (if (is-meta-value? metas-source) - metas-source - (get-metas metas-source caller))) - (and (hash-has-key? metas key) (hash-ref metas key))) + (hash-ref (match metas-source + [(? is-meta-value? ms) ms] + [_ (get-metas metas-source caller)]) key #false)) (module-test-external (let ([metas '#hash((key . "value"))]) (check-equal? (select-from-metas 'key metas) "value") (check-false (select-from-metas 'absent-key metas)))) - (define+provide/contract (select-from-doc key doc-source [caller 'select-from-doc]) ;; output contract is a list of elements ;; because doc is a txexpr, and a txexpr can have multiple values for a key ((coerce/symbol? (or/c is-doc-value? pagenode? pathish?)) (symbol?) . ->* . (or/c #f txexpr-elements?)) - (define doc (if (is-doc-value? doc-source) - doc-source - (get-doc doc-source caller))) - (define result (se-path*/list (list key) doc)) - (and (pair? result) result)) + (match (se-path*/list (list key) (match doc-source + [(? is-doc-value?) doc-source] + [_ (get-doc doc-source caller)])) + [(? pair? result) result] + [_ #false])) (module-test-external (check-equal? (select-from-doc 'key '(root (key "value"))) '("value")) @@ -85,27 +88,23 @@ (check-equal? (select-from-doc 'key doc) '("value")) (check-false (select-from-doc 'absent-key doc)))) - (define (convert+validate-path pagenode-or-path caller) - (let* ([path (if (pagenode? pagenode-or-path) + (define path (if (pagenode? pagenode-or-path) (build-path (current-project-root) (symbol->string pagenode-or-path)) - pagenode-or-path)] - [path (or (get-source path) path)]) - (unless (file-exists? path) - (raise-argument-error caller "existing Pollen source, or name of its output path" path)) - path)) - + pagenode-or-path)) + (define src-path (or (get-source path) path)) + (unless (file-exists? src-path) + (raise-argument-error caller "existing Pollen source, or name of its output path" src-path)) + src-path) (define+provide/contract (get-metas pagenode-or-path [caller 'get-metas]) (((or/c pagenode? pathish?)) (symbol?) . ->* . is-meta-value?) (cached-metas (convert+validate-path pagenode-or-path caller))) - (define+provide/contract (get-doc pagenode-or-path [caller 'get-doc]) (((or/c pagenode? pathish?)) (symbol?) . ->* . (or/c is-doc-value? string?)) (cached-doc (convert+validate-path pagenode-or-path caller))) - ;; This `@` definition is here to provide a hook for the docs. ;; But this is just default tag behavior, and thus would work without the definition. ;; Which is why the splicing tag can be renamed: @@ -125,7 +124,6 @@ (SPLICING-TAG . BODY) (SPLICING-TAG)))])) - (provide for/splice for*/splice) (define-syntax (for/splice/base stx) @@ -141,6 +139,5 @@ (syntax-case stx () [(_ . BODY) (syntax-property #'(for/splice/base . BODY) 'form #'for*/list)])) - (provide when/block) ; bw compat (define-syntax when/block (make-rename-transformer #'when/splice)) \ No newline at end of file diff --git a/pollen/decode.rkt b/pollen/decode.rkt index 980d43e..0cd497d 100644 --- a/pollen/decode.rkt +++ b/pollen/decode.rkt @@ -2,6 +2,7 @@ (require xml txexpr/base racket/list + racket/match sugar/list sugar/define sugar/test @@ -48,27 +49,29 @@ #:exclude-tags txexpr-tags? #:exclude-attrs txexpr-attrs?) . ->* . decode-proc-output-contract) (let loop ([x tx-in]) - (cond - [(txexpr? x) (define-values (tag attrs elements) (txexpr->values x)) - (cond - [(or (memq tag excluded-tags) - (for/or ([attr (in-list attrs)]) - (member attr excluded-attrs))) - x] ; because it's excluded - [else - ;; we apply processing here rather than do recursive descent on the pieces - ;; because if we send them back through loop, certain element types are ambiguous - ;; e.g., ((p "foo")) tests out as both txexpr-attrs and txexpr-elements - (define decoded-txexpr (make-txexpr (txexpr-tag-proc tag) - (txexpr-attrs-proc attrs) - (txexpr-elements-proc (append-map (λ (x) (->list/tx (loop x))) elements)))) - (txexpr-proc ((if (block-txexpr? decoded-txexpr) - block-txexpr-proc - inline-txexpr-proc) decoded-txexpr))])] - [(string? x) (string-proc x)] - [(or (symbol? x) (valid-char? x)) (entity-proc x)] - [(cdata? x) (cdata-proc x)] - [else (error "decode: can't decode" x)]))) + (match x + [(? txexpr?) + (define-values (tag attrs elements) (txexpr->values x)) + (cond + [(or (memq tag excluded-tags) + (for/or ([attr (in-list attrs)]) + (member attr excluded-attrs))) x] ; because it's excluded + [else + ;; we apply processing here rather than do recursive descent on the pieces + ;; because if we send them back through loop, certain element types are ambiguous + ;; e.g., ((p "foo")) tests out as both txexpr-attrs and txexpr-elements + (define decoded-txexpr + (make-txexpr (txexpr-tag-proc tag) + (txexpr-attrs-proc attrs) + (txexpr-elements-proc (append-map (λ (x) (->list/tx (loop x))) elements)))) + (txexpr-proc ((if (block-txexpr? decoded-txexpr) + block-txexpr-proc + inline-txexpr-proc) decoded-txexpr))])] + [(? string?) (string-proc x)] + [(? symbol?) (entity-proc x)] + [(? valid-char?) (entity-proc x)] + [(? cdata?) (cdata-proc x)] + [else (raise-argument-error 'decode "decodable thing" x)]))) (module-test-external (require racket/list txexpr racket/function) @@ -115,10 +118,8 @@ (make-keyword-procedure (λ (kws kwargs . args) (define temp-tag (gensym "temp-tag")) - (define elements (car args)) - (define decode-result (keyword-apply decode kws kwargs (list (cons temp-tag elements)))) - (get-elements decode-result)))) - + (define elements (first args)) + (get-elements (keyword-apply decode kws kwargs (list (cons temp-tag elements))))))) (define+provide/contract (block-txexpr? x) (any/c . -> . boolean?) @@ -129,27 +130,30 @@ (define+provide/contract (decode-linebreaks elems [maybe-linebreak-proc '(br)] #:separator [newline (setup:linebreak-separator)]) - ((txexpr-elements?) ((or/c #f txexpr-element? (txexpr-element? txexpr-element? . -> . (or/c #f txexpr-element?))) #:separator string?) . ->* . txexpr-elements?) + ((txexpr-elements?) + ((or/c #f txexpr-element? + (txexpr-element? txexpr-element? . -> . (or/c #f txexpr-element?))) #:separator string?) + . ->* . txexpr-elements?) (unless (string? newline) (raise-argument-error 'decode-linebreaks "string" newline)) - (define linebreak-proc (if (procedure? maybe-linebreak-proc) - maybe-linebreak-proc - (λ (e1 e2) maybe-linebreak-proc))) + (define linebreak-proc (match maybe-linebreak-proc + [(? procedure? proc) proc] + [val (λ (e1 e2) val)])) (define elems-vec (list->vector elems)) (filter values (for/list ([(elem idx) (in-indexed elems-vec)]) - (cond - [(= idx 0) elem] ; pass first item - [(= idx (sub1 (vector-length elems-vec))) elem] ; pass through last item - [(equal? elem newline) - (define prev (vector-ref elems-vec (sub1 idx))) - (define next (vector-ref elems-vec (add1 idx))) - ;; only convert if neither adjacent tag is a block - ;; (because blocks automatically force a newline before & after) - (if (or (block-txexpr? prev) (block-txexpr? next)) - #f ; flag for filtering - (linebreak-proc prev next))] - [else elem])))) + (cond + [(zero? idx) elem] ; pass first item + [(= idx (sub1 (vector-length elems-vec))) elem] ; pass through last item + [(equal? elem newline) + (define prev (vector-ref elems-vec (sub1 idx))) + (define next (vector-ref elems-vec (add1 idx))) + ;; only convert if neither adjacent tag is a block + ;; (because blocks automatically force a newline before & after) + (if (or (block-txexpr? prev) (block-txexpr? next)) + #false ; flag for filtering + (linebreak-proc prev next))] + [else elem])))) (module-test-external (check-equal? (decode-linebreaks '("foo" "\n" "bar")) '("foo" (br) "bar")) @@ -169,17 +173,21 @@ (define+provide/contract (merge-newlines x) (txexpr-elements? . -> . txexpr-elements?) (define newline-pat (regexp (format "^~a+$" (setup:newline)))) - (define (newline? x) (and (string? x) (regexp-match newline-pat x))) + (define (newline? x) (match x + [(regexp newline-pat) #true] + [_ #false])) (define (merge-newline-slice xs) - (if (newline? (car xs)) ; if first member of slice is newline, they all are - (list (apply string-append xs)) - xs)) - (define empty-string? (λ (x) (equal? x ""))) + (match xs + ;; if first member of slice is newline, they all are + [(cons (? newline?) _) (list (apply string-append xs))] + [_ xs])) + (define (empty-string? x) (equal? x "")) (let loop ([x x]) - (if (and (pair? x) (not (attrs? x))) - (let ([xs (map loop (filter-not empty-string? x))]) - (append-map merge-newline-slice (slicef xs newline?))) - x))) + (match x + [(? pair? x) #:when (not (attrs? x)) + (define xs (map loop (filter-not empty-string? x))) + (append-map merge-newline-slice (slicef xs newline?))] + [_ x]))) (module-test-external (require racket/list) @@ -189,7 +197,6 @@ (check-equal? (merge-newlines '(p "\n" "\n" "foo" "\n" "\n\n" "bar" (em "\n" "\n" "\n"))) '(p "\n\n" "foo" "\n\n\n" "bar" (em "\n\n\n")))) - (define+provide/contract (decode-paragraphs elements-in [maybe-wrap-proc 'p] #:linebreak-proc [linebreak-proc decode-linebreaks] #:force? [force-paragraph #f]) @@ -206,26 +213,30 @@ (define (paragraph-break? x) (define paragraph-pattern (pregexp (format "^~a+$" paragraph-separator))) - (and (string? x) (regexp-match paragraph-pattern x))) + (match x + [(pregexp paragraph-pattern) #true] + [_ #false])) (define (explicit-or-implicit-paragraph-break? x) (or (paragraph-break? x) (block-txexpr? x))) - (define wrap-proc (if (procedure? maybe-wrap-proc) - maybe-wrap-proc - (λ (elems) (list* maybe-wrap-proc elems)))) + (define wrap-proc (match maybe-wrap-proc + [(? procedure? proc) proc] + [_ (λ (elems) (list* maybe-wrap-proc elems))])) (define (wrap-paragraph elems) - (if (andmap block-txexpr? elems) - elems ; leave a series of block xexprs alone - (list (wrap-proc elems)))) ; otherwise wrap in p tag + (match elems + [(list (? block-txexpr?) ...) elems] ; leave a series of block xexprs alone + [_ (list (wrap-proc elems))])) ; otherwise wrap in p tag (define elements (prep-paragraph-flow elements-in)) (if (ormap explicit-or-implicit-paragraph-break? elements) ; need this condition to prevent infinite recursion - ;; use append-map on wrap-paragraph rather than map to permit return of multiple elements - (append-map wrap-paragraph (append-map (λ (es) (filter-split es paragraph-break?)) (slicef elements block-txexpr?))) ; split into ¶¶, using both implied and explicit paragraph breaks + ;; use `append-map` on `wrap-paragraph` rather than `map` to permit return of multiple elements + (append-map wrap-paragraph + (append-map (λ (es) (filter-split es paragraph-break?)) (slicef elements block-txexpr?))) ; split into ¶¶, using both implied and explicit paragraph breaks (if force-paragraph - (append-map wrap-paragraph (slicef elements block-txexpr?)) ; upconverts non-block elements to paragraphs + ;; upconverts non-block elements to paragraphs + (append-map wrap-paragraph (slicef elements block-txexpr?)) elements))) (module-test-external @@ -246,7 +257,6 @@ '((p "foo") (div "bar") (div "zam"))) (check-equal? (decode-paragraphs '("foo" "\n\n" (div "bar") "\n\n" (div "zam"))) '((p "foo") (div "bar") (div "zam"))) - (check-equal? (decode-paragraphs '("foo")) '("foo")) (check-equal? (decode-paragraphs '("foo") #:force? #t) '((p "foo"))) (check-equal? (decode-paragraphs '((div "foo"))) '((div "foo"))) diff --git a/pollen/mode.rkt b/pollen/mode.rkt index 2f2fcd5..463b006 100644 --- a/pollen/mode.rkt +++ b/pollen/mode.rkt @@ -96,7 +96,7 @@ Intractable problem; unavoidable limitation. (lexer-maker #:command-char #\◊) (fallback))] [(drracket:indentation) - (dynamic-require 'pollen/private/mode-indentation 'determine-spaces)] + (dynamic-require 'pollen/private/external/mode-indentation 'determine-spaces)] [else (fallback)])))))) (module at-reader racket/base diff --git a/pollen/pagetree.rkt b/pollen/pagetree.rkt index 02f039b..32c6292 100644 --- a/pollen/pagetree.rkt +++ b/pollen/pagetree.rkt @@ -30,8 +30,7 @@ ;; for contracts: faster than (listof pagenode?) -(define (pagenodes? x) - (and (list? x) (andmap pagenode? x))) +(define (pagenodes? x) (and (list? x) (andmap pagenode? x))) (define+provide (pagenodeish? x) @@ -49,9 +48,9 @@ (define pt-root-tag (setup:pagetree-root-node)) (define (splice-nested-pagetree xs) (apply append (for/list ([x (in-list xs)]) - (if (and (txexpr? x) (eq? (get-tag x) pt-root-tag)) - (get-elements x) - (list x))))) + (if (and (txexpr? x) (eq? (get-tag x) pt-root-tag)) + (get-elements x) + (list x))))) (validate-pagetree (decode (cons pt-root-tag xs) #:txexpr-elements-proc (compose1 splice-nested-pagetree (λ (xs) (filter-not whitespace? xs))) @@ -60,10 +59,11 @@ (define+provide (validate-pagetree x) (and (txexpr? x) - (let ([pagenodes (pagetree-strict->list x)]) - (for/and ([p (in-list pagenodes)] - #:unless (pagenode? p)) - (error 'validate-pagetree "~v is not a valid pagenode" p)) + (let () + (define pagenodes (pagetree-strict->list x)) + (for ([p (in-list pagenodes)] + #:unless (pagenode? p)) + (raise-argument-error 'validate-pagetree "valid pagenodes" p)) (with-handlers ([exn:fail? (λ (e) (error 'validate-pagetree "~a" (exn-message e)))]) (members-unique?/error pagenodes)) x))) @@ -89,7 +89,7 @@ (define (unique-sorted-output-paths xs) (define output-paths (map ->output-path xs)) (define all-paths (filter path-visible? (remove-duplicates output-paths))) - (define path-is-directory? (λ (f) (directory-exists? (build-path dir f)))) + (define (path-is-directory? f) (directory-exists? (build-path dir f))) (define-values (subdirectories files) (partition path-is-directory? all-paths)) (define-values (pagetree-sources other-files) (partition pagetree-source? files)) (define (sort-names xs) (sort xs #:key ->string stringstring path) default-cache-names)) (unless (directory-exists? dir) - (error 'directory->pagetree "directory ~v doesn't exist" dir)) + (raise-argument-error 'directory->pagetree "existing directory" dir)) (decode-pagetree (map ->pagenode (unique-sorted-output-paths (filter-not cache-dir? (directory-list dir)))))) @@ -125,7 +125,7 @@ (load-pagetree pagetree-source))) -(define (topmost-node x) (car (->list x))) +(define (topmost-node x) (first (->list x))) (define+provide/contract (parent pnish [pt-or-path (current-pagetree)] #:allow-root [allow-root? #f]) @@ -138,8 +138,8 @@ (if (memq pagenode (map topmost-node current-children)) current-parent (for/or ([st (in-list (filter list? current-children))]) - (loop pagenode st)))))) - (if (eq? result (car pt)) + (loop pagenode st)))))) + (if (eq? result (first pt)) (and allow-root? result) result)) @@ -156,12 +156,11 @@ (define+provide/contract (children p [pt-or-path (current-pagetree)]) (((or/c #f pagenodeish?)) ((or/c pagetree? pathish?)) . ->* . (or/c #f pagenodes?)) (and pt-or-path p - (let loop ([pagenode (->pagenode p)] - [pt (get-pagetree pt-or-path)]) - (if (eq? pagenode (car pt)) - (map topmost-node (cdr pt)) - (for/or ([subtree (in-list (filter pair? pt))]) - (loop pagenode subtree)))))) + (let loop ([pagenode (->pagenode p)][pt (get-pagetree pt-or-path)]) + (match pagenode + [(== (first pt) eq?) (map topmost-node (rest pt))] + [_ (for/or ([subtree (in-list (filter pair? pt))]) + (loop pagenode subtree))])))) (module-test-external @@ -192,9 +191,9 @@ (((or/c #f pagenodeish?)) ((or/c pagetree? pathish?)) . ->* . (or/c #f pagenodes?)) (match (for/list ([sib (in-list (or (siblings pnish pt-or-path) empty))] #:unless (eq? sib (->pagenode pnish))) - sib) + sib) [(? pair? sibs) sibs] - [else #f])) + [_ #false])) (module-test-external @@ -210,13 +209,13 @@ ;; private helper function. ;; only takes pt as input. ;; used by `pagetree?` predicate, so can't use `pagetree?` contract. -(define (pagetree-strict->list pt) (flatten (cdr pt))) +(define (pagetree-strict->list pt) (flatten (rest pt))) ;; flatten tree to sequence (define+provide/contract (pagetree->list pt-or-path) ((or/c pagetree? pathish?) . -> . pagenodes?) - ; use cdr to get rid of root tag at front + ; use rest to get rid of root tag at front (pagetree-strict->list (get-pagetree pt-or-path))) @@ -230,14 +229,13 @@ (let loop ([side side] [pagenode (->pagenode pnish)] [pagetree-nodes (pagetree->list (get-pagetree pt-or-path))]) - (if (eq? side 'right) - (match (memq pagenode pagetree-nodes) - [(list _ rest ...) rest] - [else #f]) - (match (loop 'right pagenode (reverse pagetree-nodes)) - [(? pair? result) (reverse result)] - [else #f]))))) - + (case side + [(right) (match (memq pagenode pagetree-nodes) + [(list _ rest ...) rest] + [_ #false])] + [else (match (loop 'right pagenode (reverse pagetree-nodes)) + [(? pair? result) (reverse result)] + [_ #false])])))) (module-test-internal (require rackunit) @@ -266,7 +264,7 @@ (((or/c #f pagenodeish?)) ((or/c pagetree? pathish?)) . ->* . (or/c #f pagenode?)) (match (previous* pnish pt-or-path) [(list _ ... result) result] - [else #f])) + [_ #false])) (module-test-external @@ -280,7 +278,7 @@ (((or/c #f pagenodeish?)) ((or/c pagetree? pathish?)) . ->* . (or/c #f pagenode?)) (match (next* pnish pt-or-path) [(list result _ ...) result] - [else #f])) + [_ #false])) (module-test-external @@ -292,10 +290,9 @@ (define/contract+provide (path->pagenode path [starting-path (current-project-root)]) ((coerce/path?) (coerce/path?) . ->* . coerce/symbol?) - (define starting-dir - (if (directory-exists? starting-path) - starting-path - (dirname starting-path))) + (define starting-dir (match starting-path + [(? directory-exists?) starting-path] + [_ (dirname starting-path)])) (->output-path (find-relative-path (->complete-path starting-dir) (->complete-path path)))) diff --git a/pollen/private/cache-utils.rkt b/pollen/private/cache-utils.rkt index 84fd794..19e4398 100644 --- a/pollen/private/cache-utils.rkt +++ b/pollen/private/cache-utils.rkt @@ -10,63 +10,60 @@ compiler/cm) (provide (all-defined-out)) -(define (paths->key source-path [template-path #f] [output-path #f]) - ;; can't use relative paths for cache keys because source files include `here-path` which is absolute. - ;; problem is that cache could appear valid on another filesystem (based on relative pathnames & mod dates) - ;; but would actually be invalid (because the `here-path` names are wrong). - ;; key is list of file + mod-time pairs, use #f for missing - - ;; we don't include output-path in path-strings-to-track - ;; because we don't want to attach a mod date - ;; because cache validity is not sensitive to mod date of output path - ;; (in fact we would expect it to be earlier, since we want to rely on an earlier version) - (define path-strings-to-track (list* source-path - ;; if template has a source file, track that instead - (and template-path (or (get-source template-path) template-path)) - ;; is either list of files or (list #f) - (append (->list (get-directory-require-files source-path)) - ;; user-designated files to track - (map ->string (setup:cache-watchlist source-path))))) +;; can't use relative paths for cache keys because source files include `here-path` which is absolute. +;; problem is that cache could appear valid on another filesystem (based on relative pathnames & mod dates) +;; but would actually be invalid (because the `here-path` names are wrong). +;; key is list of file + mod-time pairs, use #f for missing +;; we don't include output-path in path-strings-to-track +;; because we don't want to attach a mod date +;; because cache validity is not sensitive to mod date of output path +;; (in fact we would expect it to be earlier, since we want to rely on an earlier version) +(define (paths->key source-path [template-path #false] [output-path #false]) + (define path-strings-to-track + (list* source-path + ;; if template has a source file, track that instead + (and template-path (or (get-source template-path) template-path)) + ;; is either list of files or (list #f) + (append (->list (get-directory-require-files source-path)) + ;; user-designated files to track + (map ->string (setup:cache-watchlist source-path))))) (define pollen-env (getenv default-env-name)) (define poly-flag (and (has-inner-poly-ext? source-path) (current-poly-target))) (define path+mod-time-pairs (for/list ([ps (in-list path-strings-to-track)]) - (cond - [ps (define cp (->complete-path ps)) - (cons (path->string cp) (file-or-directory-modify-seconds cp #f (λ () 0)))] - [else #f]))) + (cond + [ps (define cp (->complete-path ps)) + (cons (path->string cp) (file-or-directory-modify-seconds cp #false (λ () 0)))] + [else #false]))) (list* pollen-env poly-flag (and output-path (path->string output-path)) path+mod-time-pairs)) - (define (key->source-path key) (car (fourth key))) - (define (key->output-path key) (third key)) - (module-test-internal (define ps "/users/nobody/project/source.html.pm") (check-equal? (key->source-path (paths->key ps)) ps)) - (define-namespace-anchor cache-utils-module-ns) + (define (path->hash path) (for-each managed-compile-zo (or (get-directory-require-files path) null)) - (define path-dir (dirname path)) (apply hasheq - (let ([doc-key (setup:main-export)] - [meta-key (setup:meta-export)]) + (let ([doc-key (setup:main-export)] [meta-key (setup:meta-export)]) (unless (and (symbol? doc-key) (symbol? meta-key)) (raise-argument-error 'path->hash "symbols for doc and meta key" (cons doc-key meta-key))) - ;; new namespace forces `dynamic-require` to re-instantiate 'path' + ;; I monkeyed around with using the metas submodule to pull out the metas (for speed) + ;; but in practice most files get their doc requested too. + ;; so it's just simpler to get both at once and be done with it. + ;; the savings of avoiding two cache fetches at the outset outweighs + ;; the benefit of not reloading doc when you just need metas. + ;; new namespace forces `dynamic-require` to re-instantiate `path` ;; otherwise it gets cached in current namespace. (parameterize ([current-namespace (make-base-namespace)] - [current-directory path-dir]) - ;; I monkeyed around with using the metas submodule to pull out the metas (for speed) - ;; but in practice most files get their doc requested too. - ;; so it's just simpler to get both at once and be done with it. - ;; the savings of avoiding two cache fetches at the outset outweighs - ;; the benefit of not reloading doc when you just need metas. - (namespace-attach-module (namespace-anchor->namespace cache-utils-module-ns) 'pollen/setup) ; brings in params + [current-directory (dirname path)]) + ;; brings in currently instantiated params (unlike namespace-require) + (define outer-ns (namespace-anchor->namespace cache-utils-module-ns)) + (namespace-attach-module outer-ns 'pollen/setup) (define doc-missing-thunk (λ () "")) (define metas-missing-thunk (λ () (hasheq))) (list doc-key (dynamic-require path doc-key doc-missing-thunk) @@ -96,16 +93,16 @@ (define-values (cache-dir private-cache-dir) (make-cache-dirs dest-path)) (define-values (dest-path-dir dest-path-filename _) (split-path dest-path)) (define dest-file (build-path cache-dir (format "~a.rktd" dest-path-filename))) - (define (fetch-dest-file) (write-to-file (path-hash-thunk) dest-file #:exists 'replace)) - #| -`cache-file` looks for a file in private-cache-dir previously cached with key -(which in this case carries modification dates and POLLEN env). -If a cached file is found, copies it to dest-file (which must not exist already, unless exists-ok? is true) -Otherwise, fetch-dest-file is called; if dest-file exists after calling fetch-dest-file, -it is copied to private-cache-dir and recorded with key. -|# + (define (fetch-dest-file) + (write-to-file (path-hash-thunk) dest-file #:exists 'replace)) + + ;; `cache-file` looks for a file in private-cache-dir previously cached with key + ;; (which in this case carries modification dates and POLLEN env). + ;; If a cached file is found, copies it to dest-file (which must not exist already, unless exists-ok? is true) + ;; Otherwise, fetch-dest-file is called; if dest-file exists after calling fetch-dest-file, + ;; it is copied to private-cache-dir and recorded with key. (cache-file dest-file - #:exists-ok? #t + #:exists-ok? #true key private-cache-dir fetch-dest-file diff --git a/pollen/private/command.rkt b/pollen/private/command.rkt index 0b9eb16..1a00002 100644 --- a/pollen/private/command.rkt +++ b/pollen/private/command.rkt @@ -5,8 +5,10 @@ racket/list racket/vector racket/cmdline + racket/match sugar/coerce "file-utils.rkt" + "log.rkt" "../setup.rkt" "../render.rkt" "../pagetree.rkt") @@ -18,30 +20,34 @@ ;; todo: investigate this (module+ raco - (define command-name (with-handlers ([exn:fail? (λ _ #f)]) + (define command-name (with-handlers ([exn:fail? (λ () #f)]) (vector-ref (current-command-line-arguments) 0))) (dispatch command-name)) - (define (get-first-arg-or-current-dir [args (cdr (vector->list (current-command-line-arguments)))]) ; cdr to strip command name from front (normalize-path (with-handlers ([exn:fail? (λ (exn) (current-directory))]) ;; incoming path argument is handled as described in docs for current-directory (very-nice-path (car args))))) - (define (dispatch command-name) - (case command-name - [("test" "xyzzy") (handle-test)] - [(#f "help") (handle-help)] - [("start") (handle-start)] ; parses its own args - ;; "second" arg is actually third in command line args, so use cddr not cdr - [("render") (handle-render)] ; render parses its own args from current-command-line-arguments - [("version") (handle-version)] - [("reset") (handle-reset (get-first-arg-or-current-dir))] - [("setup") (handle-setup (get-first-arg-or-current-dir))] - [("clone" "publish") (handle-publish)] - [else (handle-unknown command-name)])) + (with-logging-to-port + (current-error-port) + (λ () + (case command-name + [("test" "xyzzy") (handle-test)] + [(#f "help") (handle-help)] + [("start") (handle-start)] ; parses its own args + ;; "second" arg is actually third in command line args, so use cddr not cdr + [("render") (handle-render)] ; render parses its own args from current-command-line-arguments + [("version") (handle-version)] + [("reset") (handle-reset (get-first-arg-or-current-dir))] + [("setup") (handle-setup (get-first-arg-or-current-dir))] + [("clone" "publish") (handle-publish)] + [else (handle-unknown command-name)])) + #:logger pollen-logger + 'info + 'pollen)) (define (very-nice-path x) (path->complete-path (simplify-path (cleanse-path (->path x))))) @@ -67,108 +73,102 @@ version print the version" (current-server-port) (make-publish-di (define (handle-version) (displayln (dynamic-require 'pollen/private/version 'pollen:version))) - (define (handle-reset directory-maybe) (displayln "resetting cache ...") ((dynamic-require 'pollen/cache 'reset-cache) directory-maybe)) - (define (handle-setup directory-maybe) (displayln "preheating cache ...") ((dynamic-require 'pollen/private/preheat-cache 'preheat-cache) directory-maybe)) - (define (handle-render) (define render-target-wanted (make-parameter (current-poly-target))) (define render-with-subdirs? (make-parameter #f)) - (define parsed-args (command-line #:program "raco pollen render" - #:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'render' from the front - #:once-each - [("-t" "--target") target-arg "Render target for poly sources" - (render-target-wanted (->symbol target-arg))] - [("-r" "--recursive") "Render subdirectories recursively" - (render-with-subdirs? 'recursive)] - [("-s" "--subdir") "Render subdirectories nonrecursively" (render-with-subdirs? 'include)] - #:args other-args - other-args)) - (define path-args (if (empty? parsed-args) - (list (current-directory)) - parsed-args)) + (define parsed-args + (command-line #:program "raco pollen render" + #:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'render' from the front + #:once-each + [("-t" "--target") target-arg "Render target for poly sources" + (render-target-wanted (->symbol target-arg))] + [("-r" "--recursive") "Render subdirectories recursively" + (render-with-subdirs? 'recursive)] + [("-s" "--subdir") "Render subdirectories nonrecursively" (render-with-subdirs? 'include)] + #:args other-args + other-args)) (parameterize ([current-poly-target (render-target-wanted)]) ;; applies to both cases - (cond - ;; directory mode: one directory as argument - [(and (= 1 (length path-args)) (directory-exists? (car path-args))) - (define top-dir (very-nice-path (car path-args))) - (let render-one-dir ([dir top-dir]) - (parameterize ([current-directory dir] - [current-project-root (if (eq? (render-with-subdirs?) 'recursive) - dir - top-dir)]) - (define dirlist (directory-list dir)) - (define preprocs (filter preproc-source? dirlist)) - (define static-pagetrees (filter pagetree-source? dirlist)) - ;; if there are no static pagetrees, use make-project-pagetree - ;; (which will synthesize a pagetree if needed, which includes all sources) - (define batch-to-render - (map very-nice-path - (cond - [(null? static-pagetrees) - (displayln (format "rendering generated pagetree for directory ~a" dir)) - (cdr (make-project-pagetree dir))] - [else - (displayln (format "rendering preproc & pagetree files in directory ~a" dir)) - (append preprocs static-pagetrees)]))) - (apply render-batch batch-to-render) - (when (render-with-subdirs?) - (for ([path (in-list dirlist)] - #:when (and (directory-exists? path) - (not (omitted-path? path)))) - (render-one-dir (->complete-path path))))))] - [else ;; path mode - (displayln (format "rendering ~a" (string-join (map ->string path-args) " "))) - (apply render-batch (map very-nice-path path-args))]))) - + (let loop ([args parsed-args]) + (match args + [(== empty) (loop (list (current-directory)))] + [(list dir) ;; directory mode: one directory as argument + #:when (directory-exists? dir) + (define top-dir (very-nice-path dir)) + (let render-one-dir ([dir top-dir]) + (parameterize ([current-directory dir] + [current-project-root (case (render-with-subdirs?) + [(recursive) dir] + [else top-dir])]) + (define dirlist (directory-list dir)) + (define preprocs (filter preproc-source? dirlist)) + (define static-pagetrees (filter pagetree-source? dirlist)) + ;; if there are no static pagetrees, use make-project-pagetree + ;; (which will synthesize a pagetree if needed, which includes all sources) + (define batch-to-render + (map very-nice-path + (cond + [(null? static-pagetrees) + (displayln (format "rendering generated pagetree for directory ~a" dir)) + (cdr (make-project-pagetree dir))] + [else + (displayln (format "rendering preproc & pagetree files in directory ~a" dir)) + (append preprocs static-pagetrees)]))) + (apply render-batch batch-to-render) + (when (render-with-subdirs?) + (for ([path (in-list dirlist)] + #:when (and (directory-exists? path) + (not (omitted-path? path)))) + (render-one-dir (->complete-path path))))))] + [path-args ;; path mode + (displayln (format "rendering ~a" (string-join (map ->string path-args) " "))) + (apply render-batch (map very-nice-path path-args))])))) (define (handle-start) (define launch-wanted #f) (define localhost-wanted #f) - (define clargs (command-line #:program "raco pollen start" - #:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'start' from the front - #:once-each - [("--launch" "-l") "Launch browser after start" (set! launch-wanted #t)] - [("--local") "Restrict access to localhost" (set! localhost-wanted #t)] - #:args other-args - other-args)) + (define clargs + (command-line #:program "raco pollen start" + #:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'start' from the front + #:once-each + [("--launch" "-l") "Launch browser after start" (set! launch-wanted #t)] + [("--local") "Restrict access to localhost" (set! localhost-wanted #t)] + #:args other-args + other-args)) (define dir (path->directory-path (get-first-arg-or-current-dir clargs))) (unless (directory-exists? dir) (error (format "~a is not a directory" dir))) - (define port (with-handlers ([exn:fail? (λ (e) #f)]) - (string->number (cadr clargs)))) - (when (and port (not (exact-positive-integer? port))) - (error (format "~a is not a valid port number" port))) + (define http-port (with-handlers ([exn:fail? (λ (e) #f)]) + (string->number (cadr clargs)))) + (when (and http-port (not (exact-positive-integer? http-port))) + (error (format "~a is not a valid port number" http-port))) (parameterize ([current-project-root dir] - [current-server-port (or port (setup:project-server-port))] + [current-server-port (or http-port (setup:project-server-port))] [current-server-listen-ip (and localhost-wanted "127.0.0.1")]) - (displayln "Starting project server ...") + (message "starting project server ...") ((dynamic-require 'pollen/private/project-server 'start-server) (format "/~a" (setup:main-pagetree dir)) launch-wanted))) - (define (make-publish-dir-name [project-root (current-directory)] [arg-command-name #f]) (define user-publish-path (expand-user-path (->path (setup:publish-directory project-root)))) (if (complete-path? user-publish-path) user-publish-path (build-path (find-system-path 'desk-dir) - (->path (if (equal? arg-command-name "clone") ; bw compat - "clone" - user-publish-path))))) - + (->path (case arg-command-name + [("clone") "clone"] ; bw compat + [else user-publish-path]))))) (define (delete-it path) - (cond - [(directory-exists? path) (delete-directory/files path)] - [(file-exists? path) (delete-file path)])) - + (match path + [(? directory-exists?) (delete-directory/files path)] + [(? file-exists?) (delete-file path)])) (define (contains-directory? possible-superdir possible-subdir) (define (has-prefix? xs prefix) @@ -176,11 +176,10 @@ version print the version" (current-server-port) (make-publish-di (andmap equal? prefix (take xs (length prefix))))) ((explode-path possible-subdir) . has-prefix? . (explode-path possible-superdir))) - (define (handle-publish) (define command-name ; either "publish" or "clone" (vector-ref (current-command-line-arguments) 0)) - (define force-target-overwrite? (make-parameter #t)) + (define force-target-overwrite? (make-parameter #true)) (define other-args (command-line ;; drop command name #:argv (vector-drop (current-command-line-arguments) 1) @@ -217,8 +216,8 @@ version print the version" (current-server-port) (make-publish-di (begin (display (format "destination directory ~a exists. Overwrite? [yes/no] " dest-dir)) (case (read) - [(y yes) #t] - [else #f])))) + [(y yes) #true] + [else #false])))) (cond [do-publish-operation? (when (directory-exists? dest-dir) @@ -236,11 +235,11 @@ version print the version" (current-server-port) (make-publish-di [else (displayln "publish aborted")])) (define (handle-unknown command) - (if (regexp-match #rx"(shit|fuck)" command) - (displayln (let ([responses '("Cursing at free software? Really?" "How uncouth." "Same to you, buddy.")]) - (list-ref responses (random (length responses))))) - (begin - (displayln (format "`~a` is an unknown command." command)) - (display "These are the available ") ; ... "Pollen commands:" - (handle-help) - (exit 1)))) + (match command + [(regexp #rx"(shit|fuck)") + (define responses '("Cursing at free software? Really?" "How uncouth." "Same to you, buddy.")) + (displayln (list-ref responses (random (length responses))))] + [_ (displayln (format "`~a` is an unknown command." command)) + (display "These are the available ") ; ... "Pollen commands:" + (handle-help) + (exit 1)])) diff --git a/pollen/private/debug.rkt b/pollen/private/debug.rkt deleted file mode 100644 index 8f015f6..0000000 --- a/pollen/private/debug.rkt +++ /dev/null @@ -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))))) diff --git a/pollen/private/doclang-raw.rkt b/pollen/private/external/doclang-raw.rkt similarity index 100% rename from pollen/private/doclang-raw.rkt rename to pollen/private/external/doclang-raw.rkt diff --git a/pollen/private/external/include-template.rkt b/pollen/private/external/include-template.rkt new file mode 100644 index 0000000..d71bce8 --- /dev/null +++ b/pollen/private/external/include-template.rkt @@ -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)))])) + + diff --git a/pollen/private/external/logging.rkt b/pollen/private/external/logging.rkt new file mode 100644 index 0000000..70c001b --- /dev/null +++ b/pollen/private/external/logging.rkt @@ -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)) diff --git a/pollen/private/manual-history.rkt b/pollen/private/external/manual-history.rkt similarity index 97% rename from pollen/private/manual-history.rkt rename to pollen/private/external/manual-history.rkt index 67c5467..f038e0c 100644 --- a/pollen/private/manual-history.rkt +++ b/pollen/private/external/manual-history.rkt @@ -10,7 +10,7 @@ #| Need this to make pollen docs buildable on v6.0. -`history` not added to scribble/manul till v6.1. +`history` not added to scribble/manual till v6.1. |# (provide pollen-history) diff --git a/pollen/private/mode-indentation.rkt b/pollen/private/external/mode-indentation.rkt similarity index 100% rename from pollen/private/mode-indentation.rkt rename to pollen/private/external/mode-indentation.rkt diff --git a/pollen/private/output.rkt b/pollen/private/external/output.rkt similarity index 100% rename from pollen/private/output.rkt rename to pollen/private/external/output.rkt diff --git a/pollen/private/pipe.py b/pollen/private/external/pipe.py similarity index 100% rename from pollen/private/pipe.py rename to pollen/private/external/pipe.py diff --git a/pollen/private/include-template.rkt b/pollen/private/include-template.rkt deleted file mode 100644 index 3e6ca77..0000000 --- a/pollen/private/include-template.rkt +++ /dev/null @@ -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) diff --git a/pollen/private/log.rkt b/pollen/private/log.rkt new file mode 100644 index 0000000..d8ae533 --- /dev/null +++ b/pollen/private/log.rkt @@ -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) " "))) diff --git a/pollen/private/main-base.rkt b/pollen/private/main-base.rkt index 60be44a..1cee0eb 100644 --- a/pollen/private/main-base.rkt +++ b/pollen/private/main-base.rkt @@ -1,29 +1,34 @@ #lang racket/base -(require (for-syntax racket/base syntax/strip-context "../setup.rkt" "split-metas.rkt") - "to-string.rkt" "../pagetree.rkt" "splice.rkt" "../setup.rkt" "../core.rkt" - (prefix-in doclang: "doclang-raw.rkt")) +(require (for-syntax racket/base + syntax/strip-context + "../setup.rkt" + "split-metas.rkt") + racket/match + racket/list + "to-string.rkt" + "../pagetree.rkt" + "splice.rkt" + "../setup.rkt" + "../core.rkt" + (prefix-in doclang: "external/doclang-raw.rkt")) (provide (except-out (all-from-out racket/base) #%module-begin) (rename-out [pollen-module-begin #%module-begin])) - (define ((make-parse-proc parser-mode root-proc) xs) (define (stringify xs) (apply string-append (map to-string xs))) - (cond - [(eq? parser-mode default-mode-pagetree) (decode-pagetree xs)] - [(eq? parser-mode default-mode-markup) (apply root-proc (remove-voids xs))] - [(eq? parser-mode default-mode-markdown) + (match parser-mode + [(== default-mode-pagetree) (decode-pagetree xs)] + [(== default-mode-markup) (apply root-proc (remove-voids xs))] + [(== default-mode-markdown) (let* ([xs (stringify xs)] [xs ((dynamic-require 'markdown 'parse-markdown) xs)] [xs (map strip-empty-attrs xs)]) (apply root-proc xs))] - [else (stringify xs)])) ; preprocessor mode - + [_ (stringify xs)])) ; preprocessor mode (define (strip-leading-newlines doc) ;; drop leading newlines, as they're often the result of `defines` and `requires` - (or (memf (λ (ln) (and (not (equal? ln (setup:newline))) - (not (equal? ln "")))) doc) null)) - + (dropf doc (λ (ln) (member ln (list (setup:newline) ""))))) (define-syntax (pollen-module-begin stx) (syntax-case stx () @@ -38,7 +43,7 @@ DOC-ID ; positional arg for doclang-raw: name of export (λ (xs) (define proc (make-parse-proc PARSER-MODE ROOT-ID)) - (define trimmed-xs (if (setup:trim-whitespace?) (strip-leading-newlines xs) xs)) + (define trimmed-xs ((if (setup:trim-whitespace?) strip-leading-newlines values) xs)) (define doc-elements (splice trimmed-xs (setup:splicing-tag))) (proc doc-elements)) ; positional arg for doclang-raw: post-processor (module META-MOD-ID racket/base diff --git a/pollen/private/preheat-cache.rkt b/pollen/private/preheat-cache.rkt index 08e86a7..c7c563b 100644 --- a/pollen/private/preheat-cache.rkt +++ b/pollen/private/preheat-cache.rkt @@ -1,55 +1,62 @@ #lang racket/base -(require "file-utils.rkt" racket/file "cache-utils.rkt" "debug.rkt" racket/path racket/place sugar/list) +(require racket/file + racket/path + racket/place + racket/list + sugar/list + "file-utils.rkt" + "cache-utils.rkt" + "log.rkt") (provide preheat-cache) +(define (path-cached? path) + ;; #true = already cached; #false = not cached + ;; seems like it would be slow to load cache.rktd but it's not. + (define-values (_ private-cache-dir) (make-cache-dirs path)) + (define cache-db-file (build-path private-cache-dir "cache.rktd")) + (and (file-exists? cache-db-file) + (hash-has-key? (file->value cache-db-file) (paths->key path)))) + +;; compile a path inside a place (= parallel processing) +(define (path-into-place starting-dir path) + (message (format "caching: ~a" (find-relative-path starting-dir path))) + (define p + (place ch + (define path (place-channel-get ch)) + (define-values (_ path-name __) (split-path path)) + (message (format "compiling: ~a" path)) + ;; use #false to signal compile error. Otherwise allow errors to pass. + (define result + (with-handlers ([exn:fail? (λ (e) (message (format "compile failed: ~a" path-name)) #false)]) + (path->hash path))) + (place-channel-put ch result))) + (place-channel-put p path) + p) + (define (preheat-cache starting-dir) (unless (and (path-string? starting-dir) (directory-exists? starting-dir)) - (error 'preheat-cache (format "~a is not a directory" starting-dir))) - + (raise-argument-error 'preheat-cache "directory" starting-dir)) (define max-places (processor-count)) ; number of parallel processes to spawn at a time - - (define paths-that-should-be-cached (for/list ([path (in-directory starting-dir)] - #:when (for/or ([proc (in-list (list preproc-source? - markup-source? - markdown-source? - pagetree-source?))]) - (proc path))) - path)) - + (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. - (define-values (_ private-cache-dir) (make-cache-dirs path)) - (define cache-db-file (build-path private-cache-dir "cache.rktd")) - (cond - [(not (file-exists? cache-db-file)) #t] - [else (define cache-db (file->value cache-db-file)) - (not (hash-has-key? cache-db (paths->key path)))])) paths-that-should-be-cached)) - - ;; compile a path inside a place (= parallel processing) - (define (path-into-place path) - (message (format "caching: ~a" (find-relative-path starting-dir path))) - (define p (place ch - (define path (place-channel-get ch)) - (define-values (path-dir path-name _) (split-path path)) - (message (format "compiling: ~a" path)) - ;; use #f to signal compile error. Otherwise allow errors to pass. - (define result (with-handlers ([exn:fail? (λ _ (message (format "compile failed: ~a" path-name)) #f)]) - (path->hash path))) - (place-channel-put ch result))) - (place-channel-put p path) - p) + (define uncached-paths (filter-not path-cached? paths-that-should-be-cached)) ;; compile the paths in groups, so they can be incrementally saved. ;; that way, if there's a failure, the progress is preserved. ;; but the slowest file in a group will prevent further progress. (for ([path-group (in-list (slice-at uncached-paths max-places))]) - (define path-places (map path-into-place path-group)) + (define path-places (map (λ (pg) (path-into-place starting-dir pg)) path-group)) (for ([path (in-list path-group)] [ppl (in-list path-places)]) (define result (place-channel-get ppl)) - (when result ; #f is used to signal compile error - (cache-ref! (paths->key path) (λ _ result)))))) \ No newline at end of file + (when result ; #false is used to signal compile error + (cache-ref! (paths->key path) (λ () result)))))) \ No newline at end of file diff --git a/pollen/private/project-server-routes.rkt b/pollen/private/project-server-routes.rkt index d591d10..271181c 100644 --- a/pollen/private/project-server-routes.rkt +++ b/pollen/private/project-server-routes.rkt @@ -1,14 +1,32 @@ #lang racket/base -(require racket/list racket/contract racket/file racket/format xml racket/match racket/set racket/string racket/promise racket/path) -(require web-server/http/xexpr web-server/dispatchers/dispatch) -(require net/url) -(require web-server/http/request-structs) -(require web-server/http/response-structs) -(require web-server/http/redirect) -(require 2htdp/image) -(require "../setup.rkt" "../render.rkt" sugar sugar/unstable/string sugar/unstable/misc sugar/unstable/container txexpr/base "file-utils.rkt" "debug.rkt" "../pagetree.rkt" "../cache.rkt") - -(module+ test (require rackunit)) +(require racket/list + racket/contract + racket/file + racket/format + racket/match + racket/string + racket/promise + racket/path + web-server/http/xexpr + web-server/dispatchers/dispatch + net/url + web-server/http/request-structs + web-server/http/response-structs + web-server/http/redirect + 2htdp/image + "../setup.rkt" + "../render.rkt" + sugar + sugar/unstable/string + sugar/unstable/misc + sugar/unstable/container + txexpr/base + "file-utils.rkt" + "log.rkt" + "../pagetree.rkt" + "../cache.rkt") + +(module+ test (require)) ;;; Routes for the server module ;;; separated out for ease of testing @@ -40,14 +58,15 @@ ;; print message to console about a request (define/contract (logger req) (request? . -> . void?) - (define client (request-client-ip req)) (define localhost-client "::1") (define url-string (url->string (request-uri req))) - (when (not (ends-with? url-string "favicon.ico")) - (message "request:" (if (regexp-match #rx"/$" url-string) - (string-append url-string " directory default page") - (string-replace url-string (setup:main-pagetree) " dashboard")) - (if (not (equal? client localhost-client)) (format "from ~a" client) "")))) + (unless (ends-with? url-string "favicon.ico") + (message (match url-string + [(regexp #rx"/$") (string-append url-string " directory default page")] + [_ (string-replace url-string (setup:main-pagetree) " dashboard")]) + (match (request-client-ip req) + [(== localhost-client) ""] + [client (format "from ~a" client)])))) ;; pass string args to route, then ;; package route into right format for web server @@ -146,9 +165,9 @@ (define (make-link-cell href+text) (match-define (cons href text) href+text) (filter-not void? `(cell ,(when text - (if href - `(a ((href ,href)) ,text) - text))))) + (if href + `(a ((href ,href)) ,text) + text))))) (define (make-parent-row) (define title (string-append "Project root" (if (equal? (current-project-root) dashboard-dir) (format " = ~a" dashboard-dir) ""))) @@ -162,51 +181,51 @@ (define (make-path-row filename source indent-level) `(row ,@(map make-link-cell - (append (list - (let ([main-cell (cond ; main cell - [(directory-exists? (build-path dashboard-dir filename)) ; links subdir to its dashboard - (cons (format "~a/~a" filename (setup:main-pagetree)) (format "~a/" filename))] - [(and source (equal? (get-ext source) "scrbl")) ; scribble source - (cons #f `(a ((href ,filename)) ,filename (span ((class "file-ext")) " (from " ,(->string (find-relative-path dashboard-dir source)) ")")))] - [source ; ordinary source. use remove-ext because source may have escaped extension in it - (define source-first-ext (get-ext source)) - (define source-minus-ext (unescape-ext (remove-ext source))) - (define source-second-ext (get-ext source-minus-ext)) - (cond ; multi source. expand to multiple output files. - [(and source-second-ext (equal? source-second-ext (->string (setup:poly-source-ext (->complete-path source))))) - (define source-base (remove-ext source-minus-ext)) - (define output-names (map (λ (ext) (->string (add-ext source-base ext))) (setup:poly-targets (->complete-path source)))) - (cons #f `(div ,@(map (λ (on) `(a ((href ,on)) ,on (span ((class "file-ext")) "." ,source-first-ext ,(format " (from ~a)" (->string (find-relative-path dashboard-dir source)))))) output-names)))] - [else - (define extra-row-string - (if (equal? source-minus-ext (remove-ext source)) ; escaped and unescaped versions are equal - "" ; no extra string needed - (format " (from ~a)" (->string (find-relative-path dashboard-dir source))))) + (append (list + (let ([main-cell (cond ; main cell + [(directory-exists? (build-path dashboard-dir filename)) ; links subdir to its dashboard + (cons (format "~a/~a" filename (setup:main-pagetree)) (format "~a/" filename))] + [(and source (equal? (get-ext source) "scrbl")) ; scribble source + (cons #f `(a ((href ,filename)) ,filename (span ((class "file-ext")) " (from " ,(->string (find-relative-path dashboard-dir source)) ")")))] + [source ; ordinary source. use remove-ext because source may have escaped extension in it + (define source-first-ext (get-ext source)) + (define source-minus-ext (unescape-ext (remove-ext source))) + (define source-second-ext (get-ext source-minus-ext)) + (cond ; multi source. expand to multiple output files. + [(and source-second-ext (equal? source-second-ext (->string (setup:poly-source-ext (->complete-path source))))) + (define source-base (remove-ext source-minus-ext)) + (define output-names (map (λ (ext) (->string (add-ext source-base ext))) (setup:poly-targets (->complete-path source)))) + (cons #f `(div ,@(map (λ (on) `(a ((href ,on)) ,on (span ((class "file-ext")) "." ,source-first-ext ,(format " (from ~a)" (->string (find-relative-path dashboard-dir source)))))) output-names)))] + [else + (define extra-row-string + (if (equal? source-minus-ext (remove-ext source)) ; escaped and unescaped versions are equal + "" ; no extra string needed + (format " (from ~a)" (->string (find-relative-path dashboard-dir source))))) - (cons #f `(a ((href ,filename)) ,(->string source-minus-ext) (span ((class "file-ext")) "." ,source-first-ext ,extra-row-string)))])] - [else ; other non-source file - (cons filename filename)])]) + (cons #f `(a ((href ,filename)) ,(->string source-minus-ext) (span ((class "file-ext")) "." ,source-first-ext ,extra-row-string)))])] + [else ; other non-source file + (cons filename filename)])]) - (cons (car main-cell) - (let* ([cell-content (cdr main-cell)] - [indent-padding (+ 1 indent-level)] - [padding-attr `(class ,(format "indent_~a" indent-padding))]) - (cond - [(string? cell-content) `(span (,padding-attr) ,cell-content)] - [(txexpr? cell-content) - ;; indent link text by depth in pagetree - `(,(get-tag cell-content) ,(cons padding-attr (get-attrs cell-content)) ,@(get-elements cell-content))] - [else (error 'make-path-row (format "mysterious cell data: ~v" cell-content))])))) + (cons (car main-cell) + (let* ([cell-content (cdr main-cell)] + [indent-padding (+ 1 indent-level)] + [padding-attr `(class ,(format "indent_~a" indent-padding))]) + (cond + [(string? cell-content) `(span (,padding-attr) ,cell-content)] + [(txexpr? cell-content) + ;; indent link text by depth in pagetree + `(,(get-tag cell-content) ,(cons padding-attr (get-attrs cell-content)) ,@(get-elements cell-content))] + [else (error 'make-path-row (format "mysterious cell data: ~v" cell-content))])))) - (cond ; 'in' cell - [source (cons (format "in/~a" source) "in")] - [(or (pagetree-source? filename) (sourceish? filename)) (cons (format "in/~a" filename) "in")] - [else empty-cell]) + (cond ; 'in' cell + [source (cons (format "in/~a" source) "in")] + [(or (pagetree-source? filename) (sourceish? filename)) (cons (format "in/~a" filename) "in")] + [else empty-cell]) - (cond ; 'out' cell - [(directory-exists? (build-path dashboard-dir filename)) (cons #f #f)] - [(pagetree-source? filename) empty-cell] - [else (cons (format "out/~a" filename) "out")])))))) + (cond ; 'out' cell + [(directory-exists? (build-path dashboard-dir filename)) (cons #f #f)] + [(pagetree-source? filename) empty-cell] + [else (cons (format "out/~a" filename) "out")])))))) (define (ineligible-path? x) (member x (setup:paths-excluded-from-dashboard))) @@ -223,32 +242,32 @@ depth))) (apply body-wrapper #:title (format "~a" dashboard-dir) - (cons (make-parent-row) - (cond - [(not (null? project-paths)) - (define path-source-pairs - (map - (λ (p) (define source - (let ([possible-source (get-source (build-path dashboard-dir p))]) - (and possible-source (->string (find-relative-path dashboard-dir possible-source))))) - (cons p source)) - project-paths)) + (cons (make-parent-row) + (cond + [(not (null? project-paths)) + (define path-source-pairs + (map + (λ (p) (define source + (let ([possible-source (get-source (build-path dashboard-dir p))]) + (and possible-source (->string (find-relative-path dashboard-dir possible-source))))) + (cons p source)) + project-paths)) - (define-values (reversed-unique-path-source-pairs seen-paths) ; delete pairs with duplicate sources - (for/fold ([psps empty][seen-source-paths empty]) - ([psp (in-list path-source-pairs)]) - (define source-path (cdr psp)) - (if (and source-path (member source-path seen-source-paths)) - (values psps seen-source-paths) ; skip the pair - (values (cons psp psps) (cons source-path seen-source-paths))))) + (define-values (reversed-unique-path-source-pairs seen-paths) ; delete pairs with duplicate sources + (for/fold ([psps empty][seen-source-paths empty]) + ([psp (in-list path-source-pairs)]) + (define source-path (cdr psp)) + (if (and source-path (member source-path seen-source-paths)) + (values psps seen-source-paths) ; skip the pair + (values (cons psp psps) (cons source-path seen-source-paths))))) - (define unique-path-source-pairs (reverse reversed-unique-path-source-pairs)) - (define filenames (map (compose1 ->string car) unique-path-source-pairs)) - (define sources (map cdr unique-path-source-pairs)) - (define indent-levels (map directory-pagetree-depth filenames)) - (parameterize ([current-directory dashboard-dir]) - (map make-path-row filenames sources indent-levels))] - [else (list '(row (cell ((class "no-files")) "No files yet in this directory") (td) (td)))])))) + (define unique-path-source-pairs (reverse reversed-unique-path-source-pairs)) + (define filenames (map (compose1 ->string car) unique-path-source-pairs)) + (define sources (map cdr unique-path-source-pairs)) + (define indent-levels (map directory-pagetree-depth filenames)) + (parameterize ([current-directory dashboard-dir]) + (map make-path-row filenames sources indent-levels))] + [else (list '(row (cell ((class "no-files")) "No files yet in this directory") (td) (td)))])))) (define route-dashboard (route-wrapper dashboard)) @@ -289,7 +308,7 @@ (define/contract (route-404 req) (request? . -> . response?) (define missing-path-string (path->string (simplify-path (req->path req)))) - (message (format "route-404: Can't find ~a" missing-path-string)) + (message (format "can't find ~a" missing-path-string)) (response/xexpr+doctype `(html (head (title "404 error") (link ((href "/error.css") (rel "stylesheet")))) diff --git a/pollen/private/project-server.rkt b/pollen/private/project-server.rkt index 946dc47..74f3337 100755 --- a/pollen/private/project-server.rkt +++ b/pollen/private/project-server.rkt @@ -1,10 +1,9 @@ #lang web-server/base - (require racket/list web-server/servlet-env - web-server/dispatch) -(require "project-server-routes.rkt" - "debug.rkt" + web-server/dispatch + "project-server-routes.rkt" + "log.rkt" "../setup.rkt" "../file.rkt" "../cache.rkt" @@ -15,19 +14,19 @@ (define (start-server servlet-path [open-browser-window? #f]) (define-values (pollen-servlet _) (dispatch-rules - [((string-arg) ... (? (λ (x) (equal? "" x)))) route-index] ; last element of a "/"-terminated url is "" + [((string-arg) ... (? (λ (x) (string=? "" x)))) route-index] ; last element of a "/"-terminated url is "" [((string-arg) ... (? pagetree-source?)) route-dashboard] [((string-arg) ... "in" (string-arg) ...) route-in] [((string-arg) ... "out" (string-arg) ...) route-out] [else route-default])) - (message (format "Welcome to Pollen ~a" pollen:version) (format "(Racket ~a)" (version))) - (message (format "Project root is ~a" (current-project-root))) + (message (format "welcome to Pollen ~a (Racket ~a)" pollen:version (version))) + (message (format "project root is ~a" (current-project-root))) (define server-name (format "http://localhost:~a" (current-server-port))) - (message (format "Project server is ~a" server-name) "(Ctrl+C to exit)") - (message (format "Project dashboard is ~a/~a" server-name (setup:main-pagetree))) - (message "Ready to rock") + (message (format "project server is ~a (Ctrl+C to exit)" server-name)) + (message (format "project dashboard is ~a/~a" server-name (setup:main-pagetree))) + (message "ready to rock") (parameterize ([error-print-width 1000]) (serve/servlet pollen-servlet diff --git a/pollen/private/project.rkt b/pollen/private/project.rkt index 7a282d5..adf78fc 100644 --- a/pollen/private/project.rkt +++ b/pollen/private/project.rkt @@ -1,19 +1,20 @@ #lang racket/base (require racket/syntax + racket/match sugar/define sugar/coerce "../setup.rkt" "file-utils.rkt") (define+provide/contract (get-directory-require-files source-arg) - (pathish? . -> . (or/c #f (λ (xs) (and (list? xs) (andmap complete-path? xs))))) - (define source-path (->path source-arg)) - (define require-filenames (list default-directory-require)) - (define possible-requires (for*/list ([rf (in-list require-filenames)] - [p (in-value (find-upward-from source-path rf))] - #:when p) - p)) - (and (pair? possible-requires) possible-requires)) + (pathish? . -> . (or/c #false (λ (xs) (and (list? xs) (andmap complete-path? xs))))) + ;; only one file, but we'll leave it in plural form + (match (for*/list ([rf (in-list (list default-directory-require))] + [path (in-value (find-upward-from (->path source-arg) rf))] + #:when path) + path) + [(? pair? possible-requires) possible-requires] + [_ #false])) (define+provide/contract (require+provide-directory-require-files here-arg #:provide [provide? #t]) diff --git a/pollen/private/reader-base.rkt b/pollen/private/reader-base.rkt index 8e84f2e..0756339 100644 --- a/pollen/private/reader-base.rkt +++ b/pollen/private/reader-base.rkt @@ -4,7 +4,9 @@ racket/class racket/string racket/runtime-path + racket/match setup/getinfo + sugar/file (for-syntax racket/base) (only-in scribble/reader make-at-reader) "../setup.rkt" @@ -13,27 +15,20 @@ (define (source-name->pollen-require-path source-name) ;; the `path-string` passed in from `read-syntax` can actually be `any/c` - (if (syntax? source-name) - (syntax-source source-name) - ;; captures paths, strings, "unsaved editor", path-strings, symbols - source-name)) + ;; captures paths, strings, "unsaved editor", path-strings, symbols + ((if (syntax? source-name) syntax-source values) source-name)) (define (infer-parser-mode reader-mode reader-here-path) - (if (eq? reader-mode default-mode-auto) - (let* ([file-ext-pattern (pregexp "\\w+$")] - [here-ext (string->symbol (car (regexp-match file-ext-pattern reader-here-path)))] - [auto-computed-mode (cond - [(eq? here-ext (setup:pagetree-source-ext)) default-mode-pagetree] - [(eq? here-ext (setup:markup-source-ext)) default-mode-markup] - [(eq? here-ext (setup:markdown-source-ext)) default-mode-markdown] - [else default-mode-preproc])]) - auto-computed-mode) - reader-mode)) - - -(define (custom-read p) - (syntax->datum (custom-read-syntax (object-name p) p))) + (match reader-mode + [(== default-mode-auto) + (match (cond [(get-ext reader-here-path) => string->symbol]) + [(== (setup:pagetree-source-ext)) default-mode-pagetree] + [(== (setup:markup-source-ext)) default-mode-markup] + [(== (setup:markdown-source-ext)) default-mode-markdown] + [_ default-mode-preproc])] + [_ reader-mode])) +(define (custom-read p) (syntax->datum (custom-read-syntax (object-name p) p))) (define (custom-read-syntax #:reader-mode [reader-mode #f] source-name input-port) (define source-stx (let ([read-inner (make-at-reader @@ -78,44 +73,44 @@ (define ((custom-get-info mode) in mod line col pos) ;; DrRacket caches source file information per session, ;; so we can do the same to avoid multiple searches for the command char. - (let ([command-char-cache (make-hash)]) - (λ (key default) - (case key - [(color-lexer drracket:toolbar-buttons) ; only do source-path searching if we have one of these keys - (define maybe-source-path (with-handlers ([exn:fail? (λ (exn) #f)]) - ;; Robert Findler does not endorse `get-filename` here, - ;; because it's sneaky and may not always work. - ;; OTOH Scribble relies on it, so IMO it's highly unlikely to change. - (let ([maybe-definitions-frame (object-name in)]) - (send maybe-definitions-frame get-filename)))) ; will be #f if unsaved file - (define my-command-char (hash-ref! command-char-cache maybe-source-path (λ _ (setup:command-char maybe-source-path)))) - (case key - [(color-lexer) - (define my-make-scribble-inside-lexer - (dynamic-require 'syntax-color/scribble-lexer 'make-scribble-inside-lexer (λ () #f))) - (if my-make-scribble-inside-lexer - (my-make-scribble-inside-lexer #:command-char my-command-char) - default)] - [(drracket:toolbar-buttons) - (define my-make-drracket-buttons (dynamic-require 'pollen/private/drracket-buttons 'make-drracket-buttons)) - (my-make-drracket-buttons my-command-char)])] - [(drracket:indentation) - (dynamic-require 'scribble/private/indentation 'determine-spaces)] - [(drracket:default-filters) - ;; derive this from `module-suffixes` entry in main info.rkt file - (define module-suffixes ((get-info/full info-dir) 'module-suffixes)) - (define filter-strings (for/list ([suffix (in-list module-suffixes)]) - (format "*.~a" suffix))) - (list (list "Pollen sources" (string-join filter-strings ";")))] - [(drracket:default-extension) - (symbol->string - (cond - [(eq? mode default-mode-auto) (setup:preproc-source-ext)] - [(eq? mode default-mode-preproc) (setup:preproc-source-ext)] - [(eq? mode default-mode-markdown) (setup:markdown-source-ext)] - [(eq? mode default-mode-markup) (setup:markup-source-ext)] - [(eq? mode default-mode-pagetree) (setup:pagetree-source-ext)]))] - [else default])))) + (define command-char-cache (make-hash)) + (λ (key default) + (case key + ;; only do source-path searching if we have one of these two keys + [(color-lexer drracket:toolbar-buttons) + (define maybe-source-path + (with-handlers ([exn:fail? (λ (exn) #false)]) + ;; Robert Findler does not endorse `get-filename` here, + ;; because it's sneaky and may not always work. + ;; OTOH Scribble relies on it, so IMO it's highly unlikely to change. + (send (object-name in) get-filename))) + (define my-command-char + (hash-ref! command-char-cache maybe-source-path (λ () (setup:command-char maybe-source-path)))) + (case key + [(color-lexer) + (match (dynamic-require 'syntax-color/scribble-lexer 'make-scribble-inside-lexer (λ () #false)) + [(? procedure? make-lexer) (make-lexer #:command-char my-command-char)] + [_ default])] + [(drracket:toolbar-buttons) + (match (dynamic-require 'pollen/private/drracket-buttons 'make-drracket-buttons (λ () #false)) + [(? procedure? make-buttons) (make-buttons my-command-char)])])] + [(drracket:indentation) + (dynamic-require 'scribble/private/indentation 'determine-spaces)] + [(drracket:default-filters) + ;; derive this from `module-suffixes` entry in main info.rkt file + (define module-suffixes ((get-info/full info-dir) 'module-suffixes)) + (define filter-strings (for/list ([suffix (in-list module-suffixes)]) + (format "*.~a" suffix))) + (list (list "Pollen sources" (string-join filter-strings ";")))] + [(drracket:default-extension) + (symbol->string + (match mode + [(== default-mode-auto) (setup:preproc-source-ext)] + [(== default-mode-preproc) (setup:preproc-source-ext)] + [(== default-mode-markdown) (setup:markdown-source-ext)] + [(== default-mode-markup) (setup:markup-source-ext)] + [(== default-mode-pagetree) (setup:pagetree-source-ext)]))] + [else default]))) (define-syntax-rule (reader-module-begin mode . _) (#%module-begin diff --git a/pollen/private/runtime-config.rkt b/pollen/private/runtime-config.rkt index 8170e38..f399b26 100644 --- a/pollen/private/runtime-config.rkt +++ b/pollen/private/runtime-config.rkt @@ -1,35 +1,43 @@ #lang racket/base -(require pollen/setup scribble/reader racket/pretty version/utils racket/port racket/string) -(provide (all-defined-out)) +(require pollen/setup + scribble/reader + racket/pretty + version/utils + racket/port + racket/string + txexpr/base) + +(provide show configure current-top-path) (define current-top-path (make-parameter #f)) +(define (my-pretty-print x) + ;; #:newline option for `pretty-print` was introduced in 6.6.0.3 + (if (versionsymbol (format "~a" #\u200B)) (define splice-signal-tag '@) (define (attrs? x) - (and (list? x) - (andmap (λ (xi) - (and (list? xi) - (= (length xi) 2) - (symbol? (car xi)) - (string? (cadr xi)))) x))) + (match x + [(list (list (? symbol?) (? string?)) ...) #true] + [_ #false])) +(define (null-string? x) (equal? x "")) + +(define ((spliceable? splicing-tag) x) + (match x + [(cons (== splicing-tag eq?) _) #true] + [_ #false])) (define (splice x [splicing-tag splice-signal-tag]) ; (listof txexpr-elements?) . -> . (listof txexpr-elements?)) - (define spliceable? (λ (x) (and (pair? x) (eq? (car x) splicing-tag)))) - (define not-null-string? (λ (x) (not (and (string? x) (zero? (string-length x)))))) (let loop ([x x]) (if (list? x) ; don't exclude `attrs?` here, because it will exclude valid splice input like '((@ "foo")) - (apply append (map (λ (x) (let ([proc (if (spliceable? x) ; drop the splice-signal from front with `cdr` - cdr - list)] - [x (if (not (attrs? x)) ; don't recur on attributes, so null strings are not spliced within - (loop x) - x)]) - (proc x))) (filter not-null-string? x))) + (append-map (λ (x) + ; drop the splice-signal from front with `rest` + ; don't recur on attributes, so null strings are not spliced within + (define proc (if ((spliceable? splicing-tag) x) rest list)) + (proc (if (attrs? x) x (loop x)))) + (filter-not null-string? x)) x))) (module+ test @@ -40,29 +42,25 @@ (check-equal? (splice `((,splice-signal-tag "str"))) '("str"))) +;; this will strip all empty lists. +;; in practice, they would only appear in attrs position (define (strip-empty-attrs x) (let loop ([x x]) - (if (list? x) - ;; this will strip all empty lists. - ;; in practice, they would only appear in attrs position - (map loop (filter (λ (x) (not (null? x))) x)) + (if (pair? x) + (map loop (filter-not null? x)) x))) - (module+ test (check-equal? (strip-empty-attrs '(p ())) '(p)) (check-equal? (strip-empty-attrs '(p () "foo")) '(p "foo")) (check-equal? (strip-empty-attrs '(p () (em () "foo") "bar")) '(p (em "foo") "bar"))) - ;; used with pollen/markup to suppress void arguments, ;; consistent with how pollen/pre and pollen/markdown handle them (define (remove-voids x) (let loop ([x x]) (if (pair? x) - (for/list ([xi (in-list x)] - #:unless (void? xi)) - (loop xi)) + (map loop (filter-not void? x)) x))) (module+ test diff --git a/pollen/private/split-metas.rkt b/pollen/private/split-metas.rkt index fc9df35..973d104 100644 --- a/pollen/private/split-metas.rkt +++ b/pollen/private/split-metas.rkt @@ -1,18 +1,20 @@ #lang racket/base +(require racket/match + racket/list) (provide (all-defined-out)) (define (split-metas x meta-key) (apply hasheq - (let loop ([x (if (syntax? x) (syntax->datum x) x)]) - (cond - [(list? x) (cond - [(and (= (length x) 3) (eq? (car x) meta-key)) - (unless (symbol? (cadr x)) - (raise-argument-error 'define-meta "valid meta key" (cadr x))) - (cdr x)] ; list with meta key and meta value - [else (apply append (map loop x))])] - [else null])))) - + (let loop ([x ((if (syntax? x) syntax->datum values) x)]) + (match x + [(? list? xs) + (match xs + [(list (== meta-key eq?) key val) + (unless (symbol? key) + (raise-argument-error 'define-meta "valid meta key" key)) + (list key val)] + [_ (append-map loop xs)])] + [_ null])))) (module+ test (require rackunit) diff --git a/pollen/private/ts.rktd b/pollen/private/ts.rktd index 0c7bbd1..8d745ea 100644 --- a/pollen/private/ts.rktd +++ b/pollen/private/ts.rktd @@ -1 +1 @@ -1540875704 +1540958640 diff --git a/pollen/private/update-info.rkt b/pollen/private/update-info.rkt deleted file mode 100644 index 1cd7fed..0000000 --- a/pollen/private/update-info.rkt +++ /dev/null @@ -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)) \ No newline at end of file diff --git a/pollen/private/whitespace.rkt b/pollen/private/whitespace.rkt index 7eb260e..59be871 100644 --- a/pollen/private/whitespace.rkt +++ b/pollen/private/whitespace.rkt @@ -1,34 +1,29 @@ #lang racket/base +(require racket/match) (provide (all-defined-out)) (define (whitespace-base x #:nbsp-is-white? nbsp-white?) - (define pat (pregexp (format "^[\\s~a]+$" (if nbsp-white? #\u00A0 "")))) - (and (let loop ([x x]) - (cond - [(string? x) (or (zero? (string-length x)) (regexp-match pat x))] ; empty string is deemed whitespace - [(symbol? x) (loop (symbol->string x))] - [(pair? x) (andmap loop x)] - [(vector? x) (loop (vector->list x))] - [else #f])) - #t)) + (define white-pat (pregexp (format "^[\\s~a]+$" (if nbsp-white? #\u00A0 "")))) + (let loop ([x x]) + (match x + ["" #true] ; empty string is deemed whitespace + [(pregexp white-pat) #true] + [(? symbol?) (loop (symbol->string x))] + [(? pair?) (andmap loop x)] + [(? vector?) (loop (vector->list x))] + [_ #false]))) +(define (whitespace? x) (whitespace-base x #:nbsp-is-white? #f)) -(define (whitespace? x) - (whitespace-base x #:nbsp-is-white? #f)) - - -(define not-whitespace? (λ (x) (not (whitespace? x)))) - - -(define (whitespace/nbsp? x) - (whitespace-base x #:nbsp-is-white? #t)) +(define (not-whitespace? x) (not (whitespace? x))) +(define (whitespace/nbsp? x) (whitespace-base x #:nbsp-is-white? #t)) (module+ test - (require rackunit racket/format) - (check-true (whitespace? " ")) - (check-false (whitespace? (~a #\u00A0))) - (check-true (whitespace/nbsp? (~a #\u00A0))) - (check-true (whitespace/nbsp? (vector (~a #\u00A0)))) - (check-false (whitespace? (format " ~a " #\u00A0))) - (check-true (whitespace/nbsp? (format " ~a " #\u00A0)))) \ No newline at end of file + (require rackunit racket/format) + (check-true (whitespace? " ")) + (check-false (whitespace? (~a #\u00A0))) + (check-true (whitespace/nbsp? (~a #\u00A0))) + (check-true (whitespace/nbsp? (vector (~a #\u00A0)))) + (check-false (whitespace? (format " ~a " #\u00A0))) + (check-true (whitespace/nbsp? (format " ~a " #\u00A0)))) \ No newline at end of file diff --git a/pollen/render.rkt b/pollen/render.rkt index 4ce086e..434f812 100644 --- a/pollen/render.rkt +++ b/pollen/render.rkt @@ -1,18 +1,17 @@ #lang racket/base (require racket/file racket/path - compiler/cm + racket/match sugar/test sugar/define sugar/file sugar/coerce "private/file-utils.rkt" "cache.rkt" - "private/debug.rkt" + "private/log.rkt" "private/project.rkt" "private/cache-utils.rkt" "pagetree.rkt" - "template.rkt" "core.rkt" "setup.rkt") @@ -23,7 +22,6 @@ ;; render functions will always go when no mod-date is found. (define (reset-mod-date-hash!) (set! mod-date-hash (make-hash))) - (module-test-internal (require racket/runtime-path) (define-runtime-path sample-dir "test/data/samples") @@ -31,8 +29,6 @@ (map path->complete-path (filter (λ (name) (regexp-match "sample-" name)) (directory-list "."))))) (define-values (sample-01 sample-02 sample-03) (apply values samples))) - - ;; each key for mod-date-hash is a list of file / mod-date pairs (using pollen/cache keymaking function) ;; when a file is rendered, a new key is stored in the hash (with trivial value #t) ;; after that, the hash-key-comparision routine intrinsic to hash lookup @@ -40,15 +36,13 @@ ;; create a new key with current files. If the key is in the hash, the render has happened. ;; if not, a new render is needed. (define (update-mod-date-hash! source-path template-path) - (hash-set! mod-date-hash (paths->key source-path template-path) #t)) + (hash-set! mod-date-hash (paths->key source-path template-path) #true)) (define (mod-date-missing-or-changed? source-path template-path) (not (hash-has-key? mod-date-hash (paths->key source-path template-path)))) - (define (list-of-pathish? x) (and (list? x) (andmap pathish? x))) - (define+provide/contract (render-batch . xs) (() #:rest list-of-pathish? . ->* . void?) ;; Why not just (for-each render ...)? @@ -58,7 +52,6 @@ (reset-mod-date-hash!) (for-each render-from-source-or-output-path xs)) - (define+provide/contract (render-pagenodes pagetree-or-path) ((or/c pagetree? pathish?) . -> . void?) (define pagetree (if (pagetree? pagetree-or-path) @@ -67,7 +60,6 @@ (parameterize ([current-directory (current-project-root)]) (apply render-batch (map ->complete-path (pagetree->list pagetree))))) - (define+provide/contract (render-from-source-or-output-path so-pathish) (pathish? . -> . void?) (define so-path (->complete-path so-pathish)) ; so-path = source or output path (could be either) @@ -77,7 +69,7 @@ has/is-markup-source? has/is-scribble-source? has/is-markdown-source?))]) - (pred so-path)) + (pred so-path)) (define-values (source-path output-path) (->source+output-paths so-path)) (render-to-file-if-needed source-path #f output-path)] [(pagetree-source? so-path) (render-pagenodes so-path)]) @@ -101,7 +93,7 @@ [(not (file-exists? output-path)) 'file-missing] [(mod-date-missing-or-changed? source-path template-path) 'mod-key-missing-or-changed] [(not (setup:render-cache-active source-path)) 'render-cache-deactivated] - [else #f])) + [else #false])) (when render-needed? (define render-result (let ([key (paths->key source-path template-path output-path)]) @@ -115,23 +107,20 @@ #:dest-path 'output #:notify-cache-use (λ (str) - (message (format "rendering: /~a (from cache)" + (message (format "from cache /~a" (find-relative-path (current-project-root) output-path))))))))) ; will either be string or bytes (display-to-file render-result output-path #:exists 'replace #:mode (if (string? render-result) 'text 'binary)))) - (define+provide/contract (render-to-file-if-needed source-path [maybe-template-path #f] [maybe-output-path #f]) ((complete-path?) ((or/c #f complete-path?) (or/c #f complete-path?)) . ->* . void?) (render-to-file-base 'render-to-file-if-needed #f source-path maybe-output-path maybe-template-path)) - (define+provide/contract (render-to-file source-path [maybe-template-path #f] [maybe-output-path #f]) ((complete-path?) ((or/c #f complete-path?) (or/c #f complete-path?)) . ->* . void?) (render-to-file-base 'render-to-file #t source-path maybe-output-path maybe-template-path)) - (define+provide/contract (render source-path [maybe-template-path #f] [maybe-output-path #f]) ((complete-path?) ((or/c #f complete-path?) (or/c #f complete-path?)) . ->* . (or/c string? bytes?)) (define output-path (or maybe-output-path (->output-path source-path))) @@ -151,63 +140,64 @@ (define render-proc (for/first ([test (in-list tests)] [render-proc (in-list render-procs)] #:when (test source-path)) - render-proc)) + render-proc)) (unless 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))) - (message (format "rendering: /~a as /~a" - (find-relative-path (current-project-root) source-path) - (find-relative-path (current-project-root) output-path))) + ;; output-path and template-path may not have an extension, so check them in order with fallback - (define render-result (parameterize ([current-poly-target (->symbol (or (get-ext output-path) - (and template-path (get-ext template-path)) - (current-poly-target)))]) - (apply render-proc (list source-path template-path output-path)))) + (message (format "rendering /~a" + (find-relative-path (current-project-root) source-path))) + (match-define-values ((cons render-result _) _ real _) + (parameterize ([current-poly-target (->symbol (or (get-ext output-path) + (and template-path (get-ext template-path)) + (current-poly-target)))]) + (time-apply render-proc (list source-path template-path output-path)))) ;; wait till last possible moment to store mod dates, because render-proc may also trigger its own subrenders - ;; e.g., of a template. + ;; e.g., of a template. + (message (format "rendered /~a ~a" + (find-relative-path (current-project-root) output-path) + (if (< real 1000) + (format "(~a ms)" real) + (format "(~a s)" (/ real 1000.0))))) (update-mod-date-hash! source-path template-path) render-result) - (define (render-null-source source-path . ignored-paths) ;((complete-path?) #:rest any/c . ->* . bytes?) ;; All this does is copy the source. Hence, "null". ;; todo: add test to avoid copying if unnecessary (good idea in case the file is large) (file->bytes source-path)) - (define (render-scribble-source source-path . _) ;((complete-path?) #:rest any/c . ->* . string?) (local-require scribble/core scribble/manual (prefix-in scribble- scribble/render)) (define source-dir (dirname source-path)) ;; make fresh namespace for scribble rendering (avoids dep/zo caching) - (time (parameterize ([current-namespace (make-base-namespace)] - [current-directory (->complete-path source-dir)]) - (namespace-attach-module (namespace-anchor->namespace render-module-ns) 'scribble/core) - (namespace-attach-module (namespace-anchor->namespace render-module-ns) 'scribble/manual) - - ;; scribble/lp files have their doc export in a 'doc submodule, so check both locations - (define doc - [cond - [(dynamic-require source-path 'doc (λ () #f))] - [(dynamic-require `(submod ,source-path doc) 'doc (λ () #f))] - [else #f]]) - ;; BTW this next action has side effects: scribble will copy in its core files if they don't exist. - (when doc - (scribble-render (list doc) (list source-path))))) - (define result (file->string (->output-path source-path))) - (delete-file (->output-path source-path)) ; because render promises the data, not the side effect - result) - + (parameterize ([current-namespace (make-base-namespace)] + [current-directory (->complete-path source-dir)]) + (define outer-ns (namespace-anchor->namespace render-module-ns)) + (namespace-attach-module outer-ns 'scribble/core) + (namespace-attach-module outer-ns 'scribble/manual) + ;; scribble/lp files have their doc export in a 'doc submodule, so check both locations + (match (cond + [(dynamic-require source-path 'doc (λ () #false))] + [(dynamic-require `(submod ,source-path doc) 'doc (λ () #false))] + [else #false]) + ;; BTW this next action has side effects: scribble will copy in its core files if they don't exist. + [(? part? doc) (scribble-render (list doc) (list source-path))] + [_ (void)])) + (begin0 ; because render promises the data, not the side effect + (file->string (->output-path source-path)) + (delete-file (->output-path source-path)))) (define (render-preproc-source source-path . _) - (time (parameterize ([current-directory (->complete-path (dirname source-path))]) - (render-through-eval (syntax->datum + (parameterize ([current-directory (->complete-path (dirname source-path))]) + (render-datum-through-eval (syntax->datum (with-syntax ([SOURCE-PATH source-path]) #'(begin (require pollen/cache) - (cached-doc SOURCE-PATH)))))))) - + (cached-doc SOURCE-PATH))))))) (define (render-markup-or-markdown-source source-path [maybe-template-path #f] [maybe-output-path #f]) (define output-path (or maybe-output-path (->output-path source-path))) @@ -217,7 +207,7 @@ (unless template-path (raise-argument-error 'render-markup-or-markdown-source "valid template path" template-path)) (render-from-source-or-output-path template-path) ; because template might have its own preprocessor source - (define expr-to-eval + (define datum-to-eval (syntax->datum (with-syntax ([DIRECTORY-REQUIRE-FILES (require-directory-require-files source-path)] [DOC-ID (setup:main-export source-path)] @@ -229,9 +219,9 @@ [TEMPLATE-PATH (->string template-path)]) #'(begin (require (for-syntax racket/base) - pollen/private/include-template + pollen/private/external/include-template pollen/cache - pollen/private/debug + pollen/private/log pollen/pagetree pollen/core) DIRECTORY-REQUIRE-FILES @@ -245,53 +235,47 @@ DOC-ID (include-template #:command-char COMMAND-CHAR (file TEMPLATE-PATH)))))))) ;; set current-directory because include-template wants to work relative to source location - (time (parameterize ([current-directory (->complete-path (dirname source-path))]) - (render-through-eval expr-to-eval)))) - + (parameterize ([current-directory (->complete-path (dirname source-path))]) + (render-datum-through-eval datum-to-eval))) (define (templated-source? path) (or (markup-source? path) (markdown-source? path))) +(define (file-exists-or-has-source? path) ; path could be #f + (and path (for/first ([proc (in-list (list values ->preproc-source-path ->null-source-path))] + #:when (file-exists? (proc path))) + path))) + +(define (get-template-from-metas source-path output-path-ext) + (with-handlers ([exn:fail:contract? (λ (e) #f)]) ; in case source-path doesn't work with cached-require + (parameterize ([current-directory (current-project-root)]) + (define source-metas (cached-metas source-path)) + (define template-name-or-names ; #f or atom or list + (select-from-metas (setup:template-meta-key source-path) source-metas)) + (define template-name (if (list? template-name-or-names) + (findf (λ (tn) (eq? (get-ext tn) output-path-ext)) template-name-or-names) + template-name-or-names)) + (and template-name (build-path (dirname source-path) template-name))))) + +(define (get-default-template source-path output-path-ext) + (and output-path-ext + (let ([default-template-filename (add-ext (setup:template-prefix source-path) output-path-ext)]) + (find-upward-from source-path default-template-filename file-exists-or-has-source?)))) + +(define (get-fallback-template source-path output-path-ext) + (and output-path-ext + (build-path (current-server-extras-path) + (add-ext (setup:fallback-template-prefix source-path) output-path-ext)))) (define+provide/contract (get-template-for source-path [maybe-output-path #f]) ((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 - (parameterize ([current-directory (current-project-root)]) - (define source-metas (cached-metas source-path)) - (define template-name-or-names ; #f or atom or list - (select-from-metas (setup:template-meta-key source-path) source-metas)) - (define template-name (if (list? template-name-or-names) - (findf (λ (tn) (eq? (get-ext tn) output-path-ext)) template-name-or-names) - template-name-or-names)) - (and template-name (build-path (dirname source-path) template-name))))) - - (define (get-default-template) - (and output-path-ext - (let ([default-template-filename (add-ext (setup:template-prefix source-path) output-path-ext)]) - (find-upward-from source-path default-template-filename file-exists-or-has-source?)))) - - (define (get-fallback-template) - (and output-path-ext - (build-path (current-server-extras-path) - (add-ext (setup:fallback-template-prefix source-path) output-path-ext)))) - - (or (file-exists-or-has-source? (get-template-from-metas)) - (file-exists-or-has-source? (get-default-template)) - (file-exists-or-has-source? (get-fallback-template)))) - - (and (templated-source? source-path) (get-template))) - + (and (templated-source? source-path) + (let () + (define output-path (or maybe-output-path (->output-path source-path))) + ;; output-path may not have an extension + (define output-path-ext (or (get-ext output-path) (current-poly-target))) + (for/or ([proc (list get-template-from-metas get-default-template get-fallback-template)]) + (file-exists-or-has-source? (proc source-path output-path-ext)))))) (module-test-external (require pollen/setup sugar/file sugar/coerce) @@ -312,10 +296,10 @@ (check-false (get-template-for (->complete-path "foo.poly.pm"))) (check-equal? (get-template-for (->complete-path "foo.html.pm")) fallback.html))) - (define-namespace-anchor render-module-ns) -(define (render-through-eval expr-to-eval) +(define (render-datum-through-eval datum-to-eval) + ;; render a datum, not a syntax object, so that it can have fresh bindings. (parameterize ([current-namespace (make-base-namespace)] [current-output-port (current-error-port)]) (namespace-attach-module (namespace-anchor->namespace render-module-ns) 'pollen/setup) ; brings in params - (eval expr-to-eval))) + (eval datum-to-eval))) diff --git a/pollen/scribblings/mb-tools.rkt b/pollen/scribblings/mb-tools.rkt index 7f83771..27577f2 100644 --- a/pollen/scribblings/mb-tools.rkt +++ b/pollen/scribblings/mb-tools.rkt @@ -1,7 +1,7 @@ #lang at-exp racket/base -(require (for-syntax racket/base racket/syntax pollen/setup) scribble/core scribble/manual scribble/private/manual-sprop scribble/decode scribble/html-properties racket/runtime-path racket/format "../private/manual-history.rkt" pollen/setup) +(require (for-syntax racket/base racket/syntax pollen/setup) scribble/core scribble/manual scribble/private/manual-sprop scribble/decode scribble/html-properties racket/runtime-path racket/format "../private/external/manual-history.rkt" pollen/setup) -(provide (all-defined-out) (all-from-out racket/runtime-path "../private/manual-history.rkt")) +(provide (all-defined-out) (all-from-out racket/runtime-path "../private/external/manual-history.rkt")) (define-runtime-path mb-css "mb.css") diff --git a/pollen/scribblings/quick.scrbl b/pollen/scribblings/quick.scrbl index 43108cd..e84f67c 100644 --- a/pollen/scribblings/quick.scrbl +++ b/pollen/scribblings/quick.scrbl @@ -116,11 +116,11 @@ Now here's a third: the Pollen project server. To start the project server, retu After a moment, you'll see the startup message: @terminal{ -Welcome to Pollen @|pollen:version| (Racket @(version)) -Project root is /path/to/your/directory -Project server is http://localhost:8080 (Ctrl+C to exit) -Project dashboard is http://localhost:8080/index.ptree -Ready to rock} +pollen: welcome to Pollen @|pollen:version| (Racket @(version)) +pollen: project root is /path/to/your/directory +pollen: project server is http://localhost:8080 (Ctrl+C to exit) +pollen: project dashboard is http://localhost:8080/index.ptree +pollen: ready to rock} Open a web browser and point it at the project dashboard, which by default is @link-tt{http://localhost:8080/index.ptree}. The top line of the window will say @tt{Project root} and show the name of the starting directory. Below that will be a listing of the files in the directory. diff --git a/pollen/scribblings/setup.scrbl b/pollen/scribblings/setup.scrbl index 5dcfeb6..813363a 100644 --- a/pollen/scribblings/setup.scrbl +++ b/pollen/scribblings/setup.scrbl @@ -16,34 +16,34 @@ The values below can be changed by overriding them in your @racket["pollen.rkt"] @itemlist[#:style 'ordered - @item{Within this file, @seclink["submodules" #:doc '(lib "scribblings/guide/guide.scrbl")]{create a submodule} called @racket[setup].} +@item{Within this file, @seclink["submodules" #:doc '(lib "scribblings/guide/guide.scrbl")]{create a submodule} called @racket[setup].} - @item{Within this submodule, use @racket[define] to make a variable with the same name as the one in @racket[pollen/setup], but without the @racket[setup:] prefix.} +@item{Within this submodule, use @racket[define] to make a variable with the same name as the one in @racket[pollen/setup], but without the @racket[setup:] prefix.} - @item{Assign it whatever value you like.} +@item{Assign it whatever value you like.} - @item{Repeat as needed.} +@item{Repeat as needed.} - @item{(Don't forget to @racket[provide] the variables from within your @racket[setup] submodule.)} +@item{(Don't forget to @racket[provide] the variables from within your @racket[setup] submodule.)} - ] + ] When Pollen runs, these definitions will supersede those in @racketmodname[pollen/setup]. For instance, suppose you wanted the main export of every Pollen source file to be called @racket[van-halen] rather than @racket[doc], the extension of Pollen markup files to be @racket[.rock] rather than @racket[.pm], and the command character to be @litchar{🎸} instead of @litchar{◊}. Your @racket["pollen.rkt"] would look like this: @fileblock["pollen.rkt" - @codeblock{ - #lang racket/base +@codeblock{ +#lang racket/base - ;; ... the usual definitions and tag functions ... +;; ... the usual definitions and tag functions ... - (module setup racket/base - (provide (all-defined-out)) - (define main-export 'van-halen) - (define markup-source-ext 'rock) - (define command-char #\🎸)) - }] +(module setup racket/base + (provide (all-defined-out)) + (define main-export 'van-halen) + (define markup-source-ext 'rock) + (define command-char #\🎸)) +}] Of course, you can restore the defaults simply by removing these defined values from @racket["pollen.rkt"]. @@ -52,7 +52,7 @@ Every @racket[setup:]@racket[_name] function will resolve the current value of t @section{Values} @defoverridable[project-server-port integer?]{ - Determines the default HTTP port for the project server.} +Determines the default HTTP port for the project server.} @defoverridable[main-export symbol?]{The main X-expression exported from a compiled Pollen source file.} @@ -63,14 +63,14 @@ Every @racket[setup:]@racket[_name] function will resolve the current value of t @deftogether[( - @defoverridable[preproc-source-ext symbol?] - @defoverridable[markup-source-ext symbol?] - @defoverridable[markdown-source-ext symbol?] - @defoverridable[null-source-ext symbol?] - @defoverridable[pagetree-source-ext symbol?] - @defoverridable[template-source-ext symbol?] - @defoverridable[scribble-source-ext symbol?] - )]{File extensions for Pollen source files.} +@defoverridable[preproc-source-ext symbol?] +@defoverridable[markup-source-ext symbol?] +@defoverridable[markdown-source-ext symbol?] +@defoverridable[null-source-ext symbol?] +@defoverridable[pagetree-source-ext symbol?] +@defoverridable[template-source-ext symbol?] +@defoverridable[scribble-source-ext symbol?] +)]{File extensions for Pollen source files.} @defoverridable[main-pagetree string?]{Pagetree that Pollen dashboard loads by default in each directory.} @@ -81,9 +81,9 @@ Every @racket[setup:]@racket[_name] function will resolve the current value of t @defoverridable[block-tags (listof symbol?)]{Tags that are treated as blocks by @racket[block-txexpr?]. Initialized to the @link["https://developer.mozilla.org/en-US/docs/Web/HTML/Block-level_elements"]{block-level elements in HTML5}, namely: - @racketidfont{@(string-join (map symbol->string (cdr default-block-tags)) " ")} +@racketidfont{@(string-join (map symbol->string (cdr default-block-tags)) " ")} - ... plus @racket[setup:main-root-node].} +... plus @racket[setup:main-root-node].} @@ -93,10 +93,10 @@ Every @racket[setup:]@racket[_name] function will resolve the current value of t @deftogether[( - @(defoverridable newline string?) - @(defoverridable linebreak-separator string?) - @(defoverridable paragraph-separator string?) - )] +@(defoverridable newline string?) +@(defoverridable linebreak-separator string?) +@(defoverridable paragraph-separator string?) +)] Default separators used in decoding. @@ -108,17 +108,17 @@ Default separators used in decoding. @defoverridable[cache-watchlist (listof (or/c path? path-string?))]{List of extra files that the cache (= render cache + compile cache, collectively) watches during a project-server session. If one of the files on the watchlist changes, the cache is invalidated (just as it would be if @racket["pollen.rkt"] changed). - If the cache can't find a certain file on the watchlist, it will be ignored. Therefore, to avoid unexpected behavior, the best policy is to pass in complete paths (or path strings). An easy way to convert a module name into a complete path is with @racket[resolve-module-path]: +If the cache can't find a certain file on the watchlist, it will be ignored. Therefore, to avoid unexpected behavior, the best policy is to pass in complete paths (or path strings). An easy way to convert a module name into a complete path is with @racket[resolve-module-path]: - @fileblock["pollen.rkt" - @codeblock{ - (module+ setup - (require syntax/modresolve) - (provide (all-defined-out)) - (define cache-watchlist (map resolve-module-path '("my-module.rkt")))) - }] - - @pollen-history[#:added "1.4"] +@fileblock["pollen.rkt" +@codeblock{ +(module+ setup + (require syntax/modresolve) + (provide (all-defined-out)) + (define cache-watchlist (map resolve-module-path '("my-module.rkt")))) +}] + +@pollen-history[#:added "1.4"] } @@ -129,13 +129,13 @@ Default separators used in decoding. @defoverridable[omitted-path? (path? . -> . boolean?)]{Predicate that determines whether a path is omitted from @secref{raco_pollen_render} and @secref{raco_pollen_publish} operations. If the predicate evaluated to @racket[#t], then the path is omitted. - @pollen-history[#:added "1.1"]} +@pollen-history[#:added "1.1"]} @defoverridable[extra-published-path? (path? . -> . boolean?)]{@pollen-history[#:changed "1.1" @elem{Deprecated. Please use @racket[setup:extra-path?].}]} @defoverridable[extra-path? (path? . -> . boolean?)]{Predicate that determines if path is rendered & published, overriding @racket[(setup:omitted-path?)] above, and Pollen's default publish settings. For instance, Pollen automatically omits files with a @racket[.rkt] extension. If you wanted to force a @racket[.rkt] file to be published, you could include it here. - @pollen-history[#:added "1.1"]} +@pollen-history[#:added "1.1"]} @defoverridable[splicing-tag symbol?]{Key used to signal that an X-expression should be spliced into its containing X-expression.} @@ -149,9 +149,9 @@ Default separators used in decoding. @defoverridable[index-pages (listof string?)]{List of strings that the project server will use as directory default pages, in order of priority. Has no effect on command-line rendering operations. Also has no effect on your live web server (usually that's a setting you need to make in an @tt{.htaccess} configuration file).} But with this setting, you can simulate the behavior of your live server, so that internal index-page URLs work correctly. -@defoverridable[trim-whitespace? boolean?]{Predicate that controls whether the Pollen source reader trims whitespace from the beginning of a @racket[doc] export. You might set this to @racket[#false] if you're using Pollen as a preprocessor for another programming language and you want to preserve leading whitespace accurately. + @defoverridable[trim-whitespace? boolean?]{Predicate that controls whether the Pollen source reader trims whitespace from the beginning of a @racket[doc] export. You might set this to @racket[#false] if you're using Pollen as a preprocessor for another programming language and you want to preserve leading whitespace accurately. -@pollen-history[#:added "1.5"]} + @pollen-history[#:added "1.5"]} @section{Parameters} @@ -159,16 +159,16 @@ Default separators used in decoding. I mean @italic{parameters} in the Racket sense, i.e. values that can be fed to @racket[parameterize]. @defparam[current-server-port port integer? #:value default-project-server-port]{ - A parameter that sets the HTTP port for the project server.} +A parameter that sets the HTTP port for the project server.} @defparam[current-project-root port path?]{ - A parameter that holds the root directory of the current project (e.g., the directory where you launched @code{raco pollen start}).} +A parameter that holds the root directory of the current project (e.g., the directory where you launched @code{raco pollen start}).} @defparam[current-server-extras-path dir path? #:value #f]{ - A parameter that reports the path to the directory of support files for the project server.} +A parameter that reports the path to the directory of support files for the project server.} @defparam[current-poly-target target symbol? #:value 'html]{ - A parameter that reports the current rendering target for @racket[poly] source files.} +A parameter that reports the current rendering target for @racket[poly] source files.} diff --git a/pollen/scribblings/version-history.scrbl b/pollen/scribblings/version-history.scrbl index df2a649..fc2d49c 100644 --- a/pollen/scribblings/version-history.scrbl +++ b/pollen/scribblings/version-history.scrbl @@ -24,6 +24,11 @@ Beyond keeping the commit history available, I make no promise to maintain the p @section{Changelog} +@subsection{Version 1.5} + +Added @racket[setup:trim-whitespace?]. + + @subsection{Version 1.4} Added @racket[setup:cache-watchlist], @racket[for/splice], @racket[for*/splice], @racket[current-metas]. diff --git a/pollen/tag.rkt b/pollen/tag.rkt index b0fa476..68eeb2b 100644 --- a/pollen/tag.rkt +++ b/pollen/tag.rkt @@ -1,32 +1,37 @@ #lang pollen/mode racket/base -(require (for-syntax racket/base syntax/parse)) -(require txexpr/base racket/string racket/match) +(require (for-syntax + racket/base + syntax/parse) + txexpr/base + racket/string + racket/match) (provide default-tag-function make-default-tag-function define-tag-function) - (define (parse-leading-attrs xs) (match xs [(cons (? txexpr-attrs? leading-attrs) tail) (values leading-attrs tail)] [else (values null xs)])) +(define (colon-attr-name? x) + (match x + [(? symbol?) + (=> resume) + (match (symbol->string x) + [(regexp #rx".*?(?=:$)" (cons res _)) (string->symbol res)] + [_ (resume)])] + [_ #false])) (define (parse-colon-attrs xs) - (define (colon-attr-name? x) - (and (symbol? x) - (let ([result (regexp-match #rx".*?(?=:$)" (symbol->string x))]) - (and (pair? result) (string->symbol (car result)))))) (let parse-next ([xs xs][colon-attrs empty]) (match xs [(list* (? colon-attr-name? name) (? string? val) xs) (parse-next xs (cons (list (colon-attr-name? name) val) colon-attrs))] - [else (values colon-attrs xs)]))) - + [_ (values colon-attrs xs)]))) (define (parse-kw-attrs kw-symbols-in kw-args) (define kw-symbols (map (λ (kw) (string->symbol (string-trim (keyword->string kw) "#:"))) kw-symbols-in)) (map list kw-symbols kw-args)) - (define (make-one-tag-function outer-kws outer-kw-args id) (make-keyword-procedure (λ (inner-kws inner-kw-args . xs) @@ -40,25 +45,23 @@ ;; construct the xexpr result "manually" (i.e., not with `make-txexpr` because it may not be a legit txexpr for now ;; (but it may become one through further processing, so no need to be finicky) ;; however, don't show empty attrs. - (define attrs (append kw-attrs colon-attrs leading-attrs)) - (cons id (if (null? attrs) - xs - (cons attrs xs))))))) - + (cons id (match (append kw-attrs colon-attrs leading-attrs) + [(== empty) xs] + [attrs (cons attrs xs)])))))) (define default-tag-function (make-keyword-procedure - (λ (outer-kws outer-kw-args . ids) - (let ([tag-proc (apply compose1 (for/list ([id (in-list ids)]) - (make-one-tag-function outer-kws outer-kw-args id)))] - [tag-proc-name (string->symbol (format "pollen-tag:~a" (string-join (map symbol->string ids) "+")))]) - (procedure-rename tag-proc tag-proc-name))))) + (λ (outer-kws outer-kw-args . ids) + (define tag-proc (apply compose1 (for/list ([id (in-list ids)]) + (make-one-tag-function outer-kws outer-kw-args id)))) + (define tag-proc-name (string->symbol (format "pollen-tag:~a" (string-join (map symbol->string ids) "+")))) + (procedure-rename tag-proc tag-proc-name)))) (define make-default-tag-function default-tag-function) ; bw compat (module+ test - (require rackunit txexpr/check) + (require txexpr/check) (define outerdiv (default-tag-function 'div #:class "outer" #:style "outer")) (check-txexprs-equal? (outerdiv "foo") '(div ((class "outer") (style "outer")) "foo")) (check-txexprs-equal? (outerdiv) '(div ((class "outer") (style "outer")))) @@ -91,7 +94,7 @@ (module+ test - (require rackunit) + (require) (define foo2 (default-tag-function 'foo)) (define-tag-function (foo attrs elems) diff --git a/pollen/test/data/pixel/pixel.png b/pollen/test/data/pixel/pixel.png new file mode 100644 index 0000000..c5916f2 Binary files /dev/null and b/pollen/test/data/pixel/pixel.png differ diff --git a/pollen/test/data/pixel/template.png.p b/pollen/test/data/pixel/template.png.p new file mode 100644 index 0000000..e0160a1 --- /dev/null +++ b/pollen/test/data/pixel/template.png.p @@ -0,0 +1 @@ +◊doc \ No newline at end of file diff --git a/pollen/test/data/pixel/test-pixel.png.pm b/pollen/test/data/pixel/test-pixel.png.pm new file mode 100644 index 0000000..e269a8f --- /dev/null +++ b/pollen/test/data/pixel/test-pixel.png.pm @@ -0,0 +1,3 @@ +#lang pollen +◊(require racket/file) +◊(file->bytes "pixel.png") \ No newline at end of file diff --git a/pollen/test/test-bytes.rkt b/pollen/test/test-bytes.rkt new file mode 100644 index 0000000..e91ce4d --- /dev/null +++ b/pollen/test/test-bytes.rkt @@ -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)) \ No newline at end of file diff --git a/pollen/test/test-output.rkt b/pollen/test/test-output.rkt index 000e032..28c01d1 100644 --- a/pollen/test/test-output.rkt +++ b/pollen/test/test-output.rkt @@ -1,5 +1,5 @@ #lang racket/base -(require rackunit pollen/private/output racket/port) +(require rackunit pollen/private/external/output racket/port) (define-syntax-rule (check-output outputter string) (check-equal? (with-output-to-string (λ () outputter)) string)) diff --git a/pollen/test/test-poly.rkt b/pollen/test/test-poly.rkt index cd5dbaa..16805c8 100644 --- a/pollen/test/test-poly.rkt +++ b/pollen/test/test-poly.rkt @@ -1,5 +1,8 @@ #lang at-exp racket/base -(require rackunit pollen/setup racket/runtime-path pollen/render) +(require rackunit + pollen/setup + racket/runtime-path + pollen/render) ;; define-runtime-path only allowed at top level (define-runtime-path poly-dir "data/poly") diff --git a/pollen/top.rkt b/pollen/top.rkt index 14ea5c3..cc703a6 100644 --- a/pollen/top.rkt +++ b/pollen/top.rkt @@ -2,19 +2,10 @@ (require (for-syntax racket/base) pollen/tag) (provide def/c (rename-out (top~ #%top))) -;; Changes the default behavior of #%top. -;; Unbound identifiers are allowed, and treated as the -;; tag in a txexpr (with the rest of the expression treated as the body) -;; To suppress this behavior, use def/c to wrap any name. -;; If that name isn't already defined, you'll get the usual syntax error. - (define-syntax-rule (top~ . ID) - ;; #%app shouldn't be necessary, but temp fix for Racket7 (#%app make-default-tag-function 'ID)) (define-syntax (def/c stx) (syntax-case stx () - [(_ X) - (if (identifier-binding #'X ) - #'X - #'(#%top . X))])) \ No newline at end of file + [(_ X) (identifier-binding #'X) #'X] + [(_ X) #'(#%top . X)])) \ No newline at end of file diff --git a/pollen/unstable/pygments.rkt b/pollen/unstable/pygments.rkt index 68fc3c2..9204767 100644 --- a/pollen/unstable/pygments.rkt +++ b/pollen/unstable/pygments.rkt @@ -10,7 +10,7 @@ rackjure/str xml (only-in html read-html-as-xml) - "../private/debug.rkt" + "../private/log.rkt" "../private/splice.rkt") (provide highlight make-highlight-css) @@ -86,7 +86,7 @@ if zero is False: (define-values (pyg-in pyg-out pyg-pid pyg-err pyg-proc) (values #f #f #f #f #f)) -(define-runtime-path pipe.py "../private/pipe.py") +(define-runtime-path pipe.py "../private/external/pipe.py") (define start (let ([start-attempted? #f])