Compare commits

...

55 Commits

Author SHA1 Message Date
Matthew Butterick 6571959b6e Revert "workaround"
This reverts commit 894ace3dba.
6 years ago
Matthew Butterick 894ace3dba workaround 6 years ago
Matthew Butterick 9ff3eabb03 motion 6 years ago
Matthew Butterick a18ff81abb Revert "reinstate"
This reverts commit 8079d226f8.
6 years ago
Matthew Butterick 8079d226f8 reinstate 6 years ago
Matthew Butterick 5e85eaa103 out 6 years ago
Matthew Butterick 16481da587 fasl experiment 6 years ago
Matthew Butterick f9139c1772 that 6 years ago
Matthew Butterick 3775a24bba avoidance 6 years ago
Matthew Butterick 0812086da8 better 6 years ago
Matthew Butterick 72c6fbc3e0 better time 6 years ago
Matthew Butterick 1a0e9d1484 oops 6 years ago
Matthew Butterick 5b2c9bb7ac touch 6 years ago
Matthew Butterick 724ec4be50 mo message 6 years ago
Matthew Butterick de1e724897 unstick 6 years ago
Matthew Butterick 61f52c01e7 typo 6 years ago
Matthew Butterick 8b1c707e67 whitespacer 6 years ago
Matthew Butterick daacd970d1 adjust msg 6 years ago
Matthew Butterick 830ca4960e neater 6 years ago
Matthew Butterick a7c4733e58 simplify messages 6 years ago
Matthew Butterick fff6c3f5e9 update welcome msg 6 years ago
Matthew Butterick a27d93ea80 1.5 notes 6 years ago
Matthew Butterick c5b85a864e bump ver 6 years ago
Matthew Butterick f1ef2eeabe fix paths 6 years ago
Matthew Butterick a313dacae4 update with log 6 years ago
Matthew Butterick 38fc75c7a7 pixel test 6 years ago
Matthew Butterick a553996059 add racket/logging 6 years ago
Matthew Butterick 89efeabe6c move to external 6 years ago
Matthew Butterick f558b641e7 logging the right way 6 years ago
Matthew Butterick 6e41ca3033 move to external 6 years ago
Matthew Butterick 7ca028bb70 remove debug 6 years ago
Matthew Butterick 8e72919def naming 6 years ago
Matthew Butterick ce0ebf2349 cache 6 years ago
Matthew Butterick 632a501333 code 6 years ago
Matthew Butterick f6d3b6cdbf decode 6 years ago
Matthew Butterick ab2e25e663 pagetree 6 years ago
Matthew Butterick a4c603d039 cacheutils 6 years ago
Matthew Butterick 8f3de0d73c command 6 years ago
Matthew Butterick 02f6c1e83b debug 6 years ago
Matthew Butterick 77ef947d6b main-base 6 years ago
Matthew Butterick e304840fb6 hist 6 years ago
Matthew Butterick 7f73c03da3 preheat 6 years ago
Matthew Butterick 3e0f6c2398 routes 6 years ago
Matthew Butterick 8e61909aa3 project-server 6 years ago
Matthew Butterick 99e08724f4 project 6 years ago
Matthew Butterick 16a924c92f reader-base 6 years ago
Matthew Butterick 8ad4eb1180 runtime-config 6 years ago
Matthew Butterick d2fe2073f0 splice 6 years ago
Matthew Butterick a26670c009 split-metas 6 years ago
Matthew Butterick 829f049420 gone 6 years ago
Matthew Butterick 38e2125803 whitespace 6 years ago
Matthew Butterick d3fc9fbddf render 6 years ago
Matthew Butterick 8bdcd56e1e tag 6 years ago
Matthew Butterick 3015da66ef test-poly 6 years ago
Matthew Butterick 4102e7e623 top 6 years ago

@ -1,7 +1,7 @@
#lang info
(define collection 'multi)
(define version "1.4")
(define version "1.5")
(define deps '("base"
["txexpr" #:version "0.2"]
["sugar" #:version "0.2"]

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

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

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

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

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

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

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

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

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

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

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

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

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

@ -1,29 +1,34 @@
#lang racket/base
(require (for-syntax racket/base syntax/strip-context "../setup.rkt" "split-metas.rkt")
"to-string.rkt" "../pagetree.rkt" "splice.rkt" "../setup.rkt" "../core.rkt"
(prefix-in doclang: "doclang-raw.rkt"))
(require (for-syntax racket/base
syntax/strip-context
"../setup.rkt"
"split-metas.rkt")
racket/match
racket/list
"to-string.rkt"
"../pagetree.rkt"
"splice.rkt"
"../setup.rkt"
"../core.rkt"
(prefix-in doclang: "external/doclang-raw.rkt"))
(provide (except-out (all-from-out racket/base) #%module-begin)
(rename-out [pollen-module-begin #%module-begin]))
(define ((make-parse-proc parser-mode root-proc) xs)
(define (stringify xs) (apply string-append (map to-string xs)))
(cond
[(eq? parser-mode default-mode-pagetree) (decode-pagetree xs)]
[(eq? parser-mode default-mode-markup) (apply root-proc (remove-voids xs))]
[(eq? parser-mode default-mode-markdown)
(match parser-mode
[(== default-mode-pagetree) (decode-pagetree xs)]
[(== 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

@ -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))))))
(when result ; #false is used to signal compile error
(cache-ref! (paths->key path) (λ () result))))))

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

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

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

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

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

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

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

@ -1 +1 @@
1537996006
1540858431

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

@ -1,34 +1,29 @@
#lang racket/base
(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))))
(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))))

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

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

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

@ -149,7 +149,9 @@ If the cache can't find a certain file on the watchlist, it will be ignored. The
@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.
@pollen-history[#:added "1.5"]}
@section{Parameters}

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

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

Binary file not shown.

After

Width:  |  Height:  |  Size: 95 B

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

@ -0,0 +1,7 @@
#lang racket/base
(require pollen/setup)
(provide (all-defined-out))
(module setup racket/base
(provide (all-defined-out))
(define trim-whitespace? #false))

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

@ -1,5 +1,5 @@
#lang racket/base
(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))

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

@ -0,0 +1,11 @@
#lang at-exp racket/base
(require rackunit pollen/setup racket/runtime-path pollen/render)
;; define-runtime-path only allowed at top level
(define-runtime-path whitespace-dir "data/whitespace")
(define-runtime-path whitespace-source "data/whitespace/whitespace-test.txt.pp")
(parameterize ([current-directory whitespace-dir]
[current-project-root whitespace-dir]
[current-output-port (open-output-string)])
(check-equal? (render whitespace-source) "\n\n\n\n\n\n\n\n\none"))

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

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

Loading…
Cancel
Save