1.5 update

pollen/cache.rkt

@@ -1,9 +1,10 @@
 #lang racket/base
 (require racket/file
          racket/list
+         racket/fasl
          sugar/define
          "private/cache-utils.rkt"
-         "private/debug.rkt"
+         "private/log.rkt"
          "setup.rkt")
 
 ;; The cache is a hash with paths as keys.
@@ -21,37 +22,42 @@
        (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))])
+      (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 (convert-path-to-cache-record) ((if use-fasl? s-exp->fasl values) (path->hash path)))
-         (define (get-cache-record) (cache-ref! key convert-path-to-cache-record))
+         (define (get-cache-record) ((if use-fasl? fasl->s-exp values) (cache-ref! key convert-path-to-cache-record)))
          (define ram-cache-record (hash-ref! ram-cache key get-cache-record))
          (hash-ref ram-cache-record subkey)]
-        [else (parameterize ([current-namespace (make-base-namespace)])
+        [else
-                (namespace-attach-module (namespace-anchor->namespace cache-module-ns) 'pollen/setup) ; brings in params
+         (parameterize ([current-namespace (make-base-namespace)])
+           ;; brings in currently instantiated params (unlike namespace-require)
+           (define outer-ns (namespace-anchor->namespace cache-module-ns))
+           (namespace-attach-module outer-ns 'pollen/setup) 
            (dynamic-require path subkey))]))))
 
-
 (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))

pollen/core.rkt

@@ -1,12 +1,18 @@
 #lang racket/base
-(require (for-syntax racket/base "setup.rkt" "private/splice.rkt"))
+(require (for-syntax
-(require txexpr/base xml/path sugar/define sugar/coerce sugar/test racket/string)
+          racket/base
-(require "private/file-utils.rkt"
+          "setup.rkt")
+         racket/match
+         txexpr/base
+         xml/path
+         sugar/define
+         sugar/coerce
+         sugar/test
+         "private/file-utils.rkt"
          "setup.rkt"
          "cache.rkt"
          "pagetree.rkt"
-         "tag.rkt"
+         "tag.rkt")
-         "private/splice.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)))))
+  (match (filter values (apply append (map ->list (list metas-result doc-result))))
-  (and (pair? result) result))
+    [(? pair? res) res]
-
+    [_ #false]))
 
 (define+provide/contract (select key value-source)
   (coerce/symbol? (or/c is-meta-value? is-doc-value? pagenode? pathish?) . -> . (or/c #f txexpr-element?))
-  (define result (select* key value-source 'select))
+  (match (select* key value-source 'select)
-  (and (pair? result) (car result)))
+    [(cons res _) res]
-
+    [_ #false]))
 
 (module-test-external
  (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)
+  (hash-ref (match metas-source
-                    metas-source
+              [(? is-meta-value? ms) ms]
-                    (get-metas metas-source caller)))
+              [_  (get-metas metas-source caller)]) key #false))
-  (and (hash-has-key? metas key) (hash-ref metas key)))
 
 (module-test-external
  (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)
+  (match (se-path*/list (list key) (match doc-source
-                  doc-source
+                                     [(? is-doc-value?) doc-source]
-                  (get-doc doc-source caller)))
+                                     [_ (get-doc doc-source caller)]))
-  (define result (se-path*/list (list key) doc))
+    [(? pair? result) result]
-  (and (pair? result) result))
+    [_ #false]))
 
 (module-test-external
  (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)]
+                   pagenode-or-path))
-         [path (or (get-source path) path)])
+  (define src-path (or (get-source path) path))
-    (unless (file-exists? path)
+  (unless (file-exists? src-path)
-      (raise-argument-error caller "existing Pollen source, or name of its output path" path))
+    (raise-argument-error caller "existing Pollen source, or name of its output path" src-path))
-    path))
+  src-path)
-
 
 (define+provide/contract (get-metas pagenode-or-path [caller 'get-metas])
   (((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))

pollen/decode.rkt

@@ -2,6 +2,7 @@
 (require xml
          txexpr/base
          racket/list
+         racket/match
          sugar/list
          sugar/define
          sugar/test
@@ -48,27 +49,29 @@
     #:exclude-tags txexpr-tags?
     #:exclude-attrs txexpr-attrs?) . ->* . decode-proc-output-contract)
   (let loop ([x tx-in])
-    (cond
+    (match x
-      [(txexpr? x) (define-values (tag attrs elements) (txexpr->values 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))) 
+                      (member attr excluded-attrs))) x] ; because it's excluded
-                      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) 
+          (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)]
+      [(? string?) (string-proc x)]
-      [(or (symbol? x) (valid-char? x)) (entity-proc x)]
+      [(? symbol?) (entity-proc x)]
-      [(cdata? x) (cdata-proc x)]
+      [(? valid-char?) (entity-proc x)]
-      [else (error "decode: can't decode" x)])))
+      [(? cdata?) (cdata-proc x)]
+      [else (raise-argument-error 'decode "decodable thing" x)])))
 
 (module-test-external
  (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 elements (first args))
-     (define decode-result (keyword-apply decode kws kwargs (list (cons temp-tag elements))))
+     (get-elements (keyword-apply decode kws kwargs (list (cons temp-tag elements)))))))
-     (get-elements decode-result))))
-
 
 (define+provide/contract (block-txexpr? x)
   (any/c . -> . boolean?)
@@ -129,17 +130,20 @@
 
 (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)
+  (define linebreak-proc (match maybe-linebreak-proc
-                             maybe-linebreak-proc
+                           [(? procedure? proc) proc]
-                             (λ (e1 e2) maybe-linebreak-proc)))
+                           [val (λ (e1 e2) val)]))
   (define elems-vec (list->vector elems))
   (filter values
           (for/list ([(elem idx) (in-indexed elems-vec)])
                     (cond
-              [(= idx 0) elem] ; pass first item
+                      [(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)))
@@ -147,7 +151,7 @@
                        ;; 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
+                           #false ; flag for filtering
                            (linebreak-proc prev next))]
                       [else elem]))))
 
@@ -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
+    (match xs
-        (list (apply string-append xs))
+      ;; if first member of slice is newline, they all are
-        xs))
+      [(cons (? newline?) _) (list (apply string-append xs))]
-  (define empty-string? (λ (x) (equal? x "")))
+      [_ xs]))
+  (define (empty-string? x) (equal? x ""))
   (let loop ([x x])
-    (if (and (pair? x) (not (attrs? x)))
+    (match x
-        (let ([xs (map loop (filter-not empty-string? x))])
+      [(? pair? x) #:when (not (attrs? x))
-          (append-map merge-newline-slice (slicef xs newline?)))
+                   (define xs (map loop (filter-not empty-string? x)))
-        x)))
+                   (append-map merge-newline-slice (slicef xs newline?))]
+      [_ x])))
 
 (module-test-external
  (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)
+  (define wrap-proc (match maybe-wrap-proc
-                        maybe-wrap-proc
+                      [(? procedure? proc) proc]
-                        (λ (elems) (list* maybe-wrap-proc elems))))
+                      [_ (λ (elems) (list* maybe-wrap-proc elems))]))
 
   (define (wrap-paragraph elems)
-    (if (andmap block-txexpr? elems)
+    (match elems
-        elems ; leave a series of block xexprs alone
+      [(list (? block-txexpr?) ...) elems] ; leave a series of block xexprs alone
-        (list (wrap-proc elems)))) ; otherwise wrap in p tag 
+      [_ (list (wrap-proc elems))])) ; otherwise wrap in p tag
 
   (define elements (prep-paragraph-flow elements-in))
   (if (ormap explicit-or-implicit-paragraph-break? elements) ; need this condition to prevent infinite recursion
-      ;; use append-map on wrap-paragraph rather than map to permit return of multiple elements
+      ;; use `append-map` on `wrap-paragraph` rather than `map` to permit return of multiple elements
-      (append-map wrap-paragraph (append-map (λ (es) (filter-split es paragraph-break?)) (slicef elements block-txexpr?))) ; split into ¶¶, using both implied and explicit paragraph breaks
+      (append-map wrap-paragraph
+                  (append-map (λ (es) (filter-split es paragraph-break?)) (slicef elements block-txexpr?))) ; split into ¶¶, using both implied and explicit paragraph breaks
       (if force-paragraph
-          (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")))

pollen/mode.rkt

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

pollen/pagetree.rkt

@@ -30,8 +30,7 @@
 
 
 ;; for contracts: faster than (listof pagenode?)
-(define (pagenodes? x)
+(define (pagenodes? x) (and (list? x) (andmap pagenode? x)))
-  (and (list? x) (andmap pagenode? x)))
 
 
 (define+provide (pagenodeish? x)
@@ -60,10 +59,11 @@
 
 (define+provide (validate-pagetree x)
   (and (txexpr? x)
-       (let ([pagenodes (pagetree-strict->list x)])
+       (let ()
-         (for/and ([p (in-list pagenodes)]
+         (define pagenodes (pagetree-strict->list x))
+         (for ([p (in-list pagenodes)]
                #:unless (pagenode? p))
-           (error 'validate-pagetree "~v is not a valid pagenode" p))
+              (raise-argument-error 'validate-pagetree "valid pagenodes" p))
          (with-handlers ([exn:fail? (λ (e) (error 'validate-pagetree "~a" (exn-message e)))])
            (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])
@@ -139,7 +139,7 @@
                current-parent
                (for/or ([st (in-list (filter list? current-children))])
                        (loop pagenode st))))))
-  (if (eq? result (car pt))
+  (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)]
+       (let loop ([pagenode (->pagenode p)][pt (get-pagetree pt-or-path)])
-                  [pt (get-pagetree pt-or-path)])
+         (match pagenode
-         (if (eq? pagenode (car pt))
+           [(== (first pt) eq?) (map topmost-node (rest pt))]
-             (map topmost-node (cdr pt))
+           [_ (for/or ([subtree (in-list (filter pair? pt))])
-             (for/or ([subtree (in-list (filter pair? pt))])
+                      (loop pagenode subtree))]))))
-               (loop pagenode subtree))))))
 
 
 (module-test-external
@@ -194,7 +193,7 @@
                     #:unless (eq? sib (->pagenode pnish)))
                    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)
+         (case side
-             (match (memq pagenode pagetree-nodes)
+           [(right) (match (memq pagenode pagetree-nodes)
                       [(list _ rest ...) rest]
-               [else #f])
+                      [_ #false])]
-             (match (loop 'right pagenode (reverse pagetree-nodes))
+           [else (match (loop 'right pagenode (reverse pagetree-nodes))
                    [(? pair? result) (reverse result)]
-               [else #f])))))
+                   [_ #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
+  (define starting-dir (match starting-path
-    (if (directory-exists? starting-path)
+                         [(? directory-exists?) starting-path]
-        starting-path
+                         [_ (dirname starting-path)]))
-        (dirname starting-path)))
   (->output-path (find-relative-path (->complete-path starting-dir) (->complete-path path))))
 
 

pollen/private/cache-utils.rkt

@@ -10,17 +10,17 @@
          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
+(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)
@@ -33,40 +33,37 @@
     (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)))]
+                    (cons (path->string cp) (file-or-directory-modify-seconds cp #false (λ () 0)))]
-        [else #f])))
+                [else #false])))
   (list* pollen-env poly-flag (and output-path (path->string output-path)) path+mod-time-pairs))
 
-
 (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)]
+         (let ([doc-key (setup:main-export)] [meta-key (setup:meta-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'
-           ;; 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
+           ;; new namespace forces `dynamic-require` to re-instantiate `path`
+           ;; otherwise it gets cached in current namespace.
+           (parameterize ([current-namespace (make-base-namespace)]
+                          [current-directory (dirname path)])
+             ;; brings in currently instantiated params (unlike namespace-require)
+             (define outer-ns (namespace-anchor->namespace cache-utils-module-ns))
+             (namespace-attach-module outer-ns 'pollen/setup) 
              (define doc-missing-thunk (λ () ""))
              (define 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))
+  (define (fetch-dest-file)
-  #|
+    (write-to-file (path-hash-thunk) dest-file #:exists 'replace))
-`cache-file` looks for a file in private-cache-dir previously cached with key
+
-(which in this case carries modification dates and POLLEN env).
+  ;; `cache-file` looks for a file in private-cache-dir previously cached with key
-If a cached file is found, copies it to dest-file (which must not exist already, unless exists-ok? is true)
+  ;; (which in this case carries modification dates and POLLEN env).
-Otherwise, fetch-dest-file is called; if dest-file exists after calling fetch-dest-file,
+  ;; If a cached file is found, copies it to dest-file (which must not exist already, unless exists-ok? is true)
-it is copied to private-cache-dir and recorded with key.
+  ;; Otherwise, fetch-dest-file is called; if dest-file exists after calling fetch-dest-file,
-|#
+  ;; it is copied to private-cache-dir and recorded with key.
   (cache-file dest-file
-              #:exists-ok? #t
+              #:exists-ok? #true
               key
               private-cache-dir
               fetch-dest-file

pollen/private/command.rkt

@@ -5,8 +5,10 @@
          racket/list
          racket/vector
          racket/cmdline
+         racket/match
          sugar/coerce
          "file-utils.rkt"
+         "log.rkt"
          "../setup.rkt"
          "../render.rkt"
          "../pagetree.rkt")
@@ -18,19 +20,20 @@
 ;; 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)
+  (with-logging-to-port
+   (current-error-port)
+   (λ ()
      (case command-name
        [("test" "xyzzy") (handle-test)]
        [(#f "help") (handle-help)]
@@ -42,6 +45,9 @@
        [("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,21 +73,19 @@ 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"
+  (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"
@@ -91,19 +95,18 @@ version                print the version" (current-server-port) (make-publish-di
                   [("-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))
   (parameterize ([current-poly-target (render-target-wanted)]) ;; applies to both cases
-    (cond
+    (let loop ([args parsed-args])
-      ;; directory mode: one directory as argument
+      (match args
-      [(and (= 1 (length path-args)) (directory-exists? (car path-args)))
+        [(== empty) (loop (list (current-directory)))]
-       (define top-dir (very-nice-path (car path-args)))
+        [(list dir) ;; directory mode: one directory as argument
+         #:when (directory-exists? dir)
+         (define top-dir (very-nice-path dir))
          (let render-one-dir ([dir top-dir])
            (parameterize ([current-directory dir]
-                        [current-project-root (if (eq? (render-with-subdirs?) 'recursive)
+                          [current-project-root (case (render-with-subdirs?)
-                                                  dir
+                                                  [(recursive) dir]
-                                                  top-dir)])
+                                                  [else top-dir])])
              (define dirlist (directory-list dir))
              (define preprocs (filter preproc-source? dirlist))
              (define static-pagetrees (filter pagetree-source? dirlist))
@@ -124,15 +127,15 @@ version                print the version" (current-server-port) (make-publish-di
                      #:when (and (directory-exists? path)
                                  (not (omitted-path? path))))
                     (render-one-dir (->complete-path path))))))]
-      [else ;; path mode
+        [path-args ;; path mode
          (displayln (format "rendering ~a" (string-join (map ->string path-args) " ")))
-       (apply render-batch (map very-nice-path 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"
+  (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)]
@@ -142,33 +145,30 @@ version                print the version" (current-server-port) (make-publish-di
   (define dir (path->directory-path (get-first-arg-or-current-dir clargs)))
   (unless (directory-exists? dir)
     (error (format "~a is not a directory" dir)))
-  (define port (with-handlers ([exn:fail? (λ (e) #f)])
+  (define http-port (with-handlers ([exn:fail? (λ (e) #f)])
                       (string->number (cadr clargs))))
-  (when (and port (not (exact-positive-integer? port)))
+  (when (and http-port (not (exact-positive-integer? http-port)))
-    (error (format "~a is not a valid port number" port)))
+    (error (format "~a is not a valid port number" http-port)))
   (parameterize ([current-project-root dir]
-                 [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
+                  (->path (case arg-command-name
-                              "clone"
+                            [("clone") "clone"] ; bw compat
-                              user-publish-path)))))
+                            [else user-publish-path])))))
-
 
 (define (delete-it path)
-  (cond
+  (match path
-    [(directory-exists? path) (delete-directory/files path)]
+    [(? directory-exists?) (delete-directory/files path)]
-    [(file-exists? path) (delete-file path)]))
+    [(? file-exists?) (delete-file path)]))
-  
 
 (define (contains-directory? possible-superdir possible-subdir)
   (define (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]
+            [(y yes) #true]
-            [else #f]))))
+            [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)
+  (match command
-      (displayln (let ([responses '("Cursing at free software? Really?" "How uncouth." "Same to you, buddy.")])
+    [(regexp #rx"(shit|fuck)")
-                   (list-ref responses (random (length responses)))))
+     (define responses '("Cursing at free software? Really?" "How uncouth." "Same to you, buddy."))
-      (begin
+     (displayln (list-ref responses (random (length responses))))]
-        (displayln (format "`~a` is an unknown command." command))
+    [_ (displayln (format "`~a` is an unknown command." command))
        (display "These are the available ") ; ... "Pollen commands:"
        (handle-help)
-        (exit 1))))
+       (exit 1)]))

pollen/private/debug.rkt

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

pollen/private/external/include-template.rkt

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

pollen/private/external/logging.rkt

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

pollen/private/external/manual-history.rkt

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

pollen/private/include-template.rkt

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

pollen/private/log.rkt

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

pollen/private/main-base.rkt

@@ -1,29 +1,34 @@
 #lang racket/base
-(require (for-syntax racket/base syntax/strip-context "../setup.rkt" "split-metas.rkt")
+(require (for-syntax racket/base
-         "to-string.rkt" "../pagetree.rkt" "splice.rkt" "../setup.rkt" "../core.rkt"
+                     syntax/strip-context
-         (prefix-in doclang: "doclang-raw.rkt"))
+                     "../setup.rkt"
+                     "split-metas.rkt")
+         racket/match
+         racket/list
+         "to-string.rkt"
+         "../pagetree.rkt"
+         "splice.rkt"
+         "../setup.rkt"
+         "../core.rkt"
+         (prefix-in doclang: "external/doclang-raw.rkt"))
 (provide (except-out (all-from-out racket/base) #%module-begin)
          (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
+  (match parser-mode
-    [(eq? parser-mode default-mode-pagetree) (decode-pagetree xs)]
+    [(== default-mode-pagetree) (decode-pagetree xs)]
-    [(eq? parser-mode default-mode-markup) (apply root-proc (remove-voids xs))] 
+    [(== default-mode-markup) (apply root-proc (remove-voids xs))] 
-    [(eq? parser-mode default-mode-markdown)
+    [(== default-mode-markdown)
      (let* ([xs (stringify xs)]
             [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)))
+  (dropf doc (λ (ln) (member ln (list (setup:newline) "")))))
-                         (not (equal? ln "")))) doc) null))
-
 
 (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

pollen/private/preheat-cache.rkt

@@ -1,55 +1,62 @@
 #lang racket/base
-(require "file-utils.rkt" racket/file "cache-utils.rkt" "debug.rkt" racket/path racket/place sugar/list)
+(require racket/file
+         racket/path
+         racket/place
+         racket/list
+         sugar/list
+         "file-utils.rkt"
+         "cache-utils.rkt"
+         "log.rkt")
 (provide preheat-cache)
 
-(define (preheat-cache starting-dir)
+(define (path-cached? path)
-  (unless (and (path-string? starting-dir) (directory-exists? starting-dir))
+  ;; #true = already cached; #false = not cached
-    (error 'preheat-cache (format "~a is not a directory" starting-dir)))
-  
-  (define max-places (processor-count)) ; number of parallel processes to spawn at a time
-  
-  (define paths-that-should-be-cached (for/list ([path (in-directory starting-dir)]
-                                                 #:when (for/or ([proc (in-list (list preproc-source?
-                                                                                      markup-source?
-                                                                                      markdown-source?
-                                                                                      pagetree-source?))])
-                                                                (proc path)))
-                                                path))
-  
-  ;; if a file is already in the cache, no need to hit it again.
-  ;; this allows partially completed preheat jobs to resume.
-  (define uncached-paths (filter
-                          (λ (path)
-                            ;; #t = not cached; #f = already cached
   ;; seems like it would be slow to load cache.rktd but it's not.
   (define-values (_ private-cache-dir) (make-cache-dirs path))
   (define cache-db-file (build-path private-cache-dir "cache.rktd"))
-                            (cond
+  (and (file-exists? cache-db-file)
-                              [(not (file-exists? cache-db-file)) #t]
+       (hash-has-key? (file->value cache-db-file) (paths->key path))))
-                              [else (define cache-db (file->value cache-db-file))
-                                    (not (hash-has-key? cache-db (paths->key path)))])) paths-that-should-be-cached))
 
 ;; compile a path inside a place (= parallel processing)
-  (define (path-into-place path)
+(define (path-into-place starting-dir path)
   (message (format "caching: ~a" (find-relative-path starting-dir path)))
-    (define p (place ch
+  (define p
+    (place ch
            (define path (place-channel-get ch))
-                     (define-values (path-dir path-name _) (split-path path))
+           (define-values (_ path-name __) (split-path path))
            (message (format "compiling: ~a" path))
-                     ;; use #f to signal compile error. Otherwise allow errors to pass.
+           ;; use #false to signal compile error. Otherwise allow errors to pass.
-                     (define result (with-handlers ([exn:fail? (λ _ (message (format "compile failed: ~a" path-name)) #f)])
+           (define result
+             (with-handlers ([exn:fail? (λ (e) (message (format "compile failed: ~a" path-name)) #false)])
                (path->hash path)))
            (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))
+    (raise-argument-error 'preheat-cache "directory" starting-dir))
+  (define max-places (processor-count)) ; number of parallel processes to spawn at a time
+  (define paths-that-should-be-cached
+    (for/list ([path (in-directory starting-dir)]
+               #:when (for/or ([proc (in-list (list preproc-source?
+                                                    markup-source?
+                                                    markdown-source?
+                                                    pagetree-source?))])
+                              (proc path)))
+              path))
+
+  ;; if a file is already in the cache, no need to hit it again.
+  ;; this allows partially completed preheat jobs to resume.
+  (define uncached-paths (filter-not path-cached? paths-that-should-be-cached))
+  
   ;; compile the paths in groups, so they can be incrementally saved.
   ;; 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
+            (when result ; #false is used to signal compile error
-              (cache-ref! (paths->key path) (λ _ result))))))
+              (cache-ref! (paths->key path) (λ () result))))))

pollen/private/project-server-routes.rkt

@@ -1,14 +1,32 @@
 #lang racket/base
-(require racket/list racket/contract racket/file racket/format xml racket/match racket/set racket/string racket/promise racket/path)
+(require racket/list
-(require web-server/http/xexpr web-server/dispatchers/dispatch)
+         racket/contract
-(require net/url)
+         racket/file
-(require web-server/http/request-structs)
+         racket/format
-(require web-server/http/response-structs)
+         racket/match
-(require web-server/http/redirect)
+         racket/string
-(require 2htdp/image)
+         racket/promise
-(require "../setup.rkt" "../render.rkt" sugar sugar/unstable/string sugar/unstable/misc sugar/unstable/container txexpr/base "file-utils.rkt" "debug.rkt" "../pagetree.rkt" "../cache.rkt")
+         racket/path
-
+         web-server/http/xexpr
-(module+ test (require rackunit))
+         web-server/dispatchers/dispatch
+         net/url
+         web-server/http/request-structs
+         web-server/http/response-structs
+         web-server/http/redirect
+         2htdp/image
+         "../setup.rkt"
+         "../render.rkt"
+         sugar
+         sugar/unstable/string
+         sugar/unstable/misc
+         sugar/unstable/container
+         txexpr/base
+         "file-utils.rkt"
+         "log.rkt"
+         "../pagetree.rkt"
+         "../cache.rkt")
+
+(module+ test (require))
 
 ;;; Routes for the server module
 ;;; 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"))
+  (unless (ends-with? url-string "favicon.ico")
-    (message "request:" (if (regexp-match #rx"/$" url-string)
+    (message (match url-string
-                            (string-append url-string " directory default page")
+               [(regexp #rx"/$") (string-append url-string " directory default page")]
-                            (string-replace url-string (setup:main-pagetree) " dashboard"))
+               [_ (string-replace url-string (setup:main-pagetree) " dashboard")])
-             (if (not (equal? client localhost-client)) (format "from ~a" client) ""))))
+             (match (request-client-ip req)
+               [(== localhost-client) ""]
+               [client (format "from ~a" client)]))))
 
 ;; pass string args to route, then
 ;; package route into right format for web server
@@ -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"))))

pollen/private/project-server.rkt

@@ -1,10 +1,9 @@
 #lang web-server/base
-
 (require racket/list
          web-server/servlet-env 
-         web-server/dispatch)
+         web-server/dispatch
-(require "project-server-routes.rkt" 
+         "project-server-routes.rkt" 
-         "debug.rkt" 
+         "log.rkt" 
          "../setup.rkt"
          "../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 "welcome to Pollen ~a (Racket ~a)" pollen:version (version)))
-  (message (format "Project root is ~a" (current-project-root)))
+  (message (format "project root is ~a" (current-project-root)))
   
   (define server-name (format "http://localhost:~a" (current-server-port)))
-  (message (format "Project server is ~a" server-name) "(Ctrl+C to exit)")
+  (message (format "project server is ~a (Ctrl+C to exit)" server-name))
-  (message (format "Project dashboard is ~a/~a" server-name (setup:main-pagetree)))
+  (message (format "project dashboard is ~a/~a" server-name (setup:main-pagetree)))
-  (message "Ready to rock")
+  (message "ready to rock")
   
   (parameterize ([error-print-width 1000])
     (serve/servlet pollen-servlet

pollen/private/project.rkt

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

pollen/private/reader-base.rkt

@@ -4,7 +4,9 @@
          racket/class
          racket/string
          racket/runtime-path
+         racket/match
          setup/getinfo
+         sugar/file
          (for-syntax racket/base)
          (only-in scribble/reader make-at-reader)
          "../setup.rkt"
@@ -13,27 +15,20 @@
 
 (define (source-name->pollen-require-path source-name)
   ;; the `path-string` passed in from `read-syntax` can actually be `any/c`
-  (if (syntax? source-name)
-      (syntax-source source-name)
   ;; captures paths, strings, "unsaved editor", path-strings, symbols
-      source-name))
+  ((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)
+  (match reader-mode
-      (let* ([file-ext-pattern (pregexp "\\w+$")]
+    [(== default-mode-auto)
-             [here-ext (string->symbol (car (regexp-match file-ext-pattern reader-here-path)))]
+     (match (cond [(get-ext reader-here-path) => string->symbol])
-             [auto-computed-mode (cond
+       [(== (setup:pagetree-source-ext)) default-mode-pagetree]
-                                   [(eq? here-ext (setup:pagetree-source-ext)) default-mode-pagetree]
+       [(== (setup:markup-source-ext)) default-mode-markup]
-                                   [(eq? here-ext (setup:markup-source-ext)) default-mode-markup]
+       [(== (setup:markdown-source-ext)) default-mode-markdown]
-                                   [(eq? here-ext (setup:markdown-source-ext)) default-mode-markdown]
+       [_ default-mode-preproc])]
-                                   [else default-mode-preproc])])
+    [_ reader-mode]))
-        auto-computed-mode)
-      reader-mode))
-
-
-(define (custom-read p)
-  (syntax->datum (custom-read-syntax (object-name p) p)))
 
+(define (custom-read p) (syntax->datum (custom-read-syntax (object-name p) p)))
 
 (define (custom-read-syntax #:reader-mode [reader-mode #f] source-name input-port)
   (define source-stx (let ([read-inner (make-at-reader 
@@ -78,27 +73,27 @@
 (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)])
+  (define 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
+      ;; only do source-path searching if we have one of these two keys
-         (define maybe-source-path (with-handlers ([exn:fail? (λ (exn) #f)])
+      [(color-lexer drracket:toolbar-buttons) 
+       (define maybe-source-path
+         (with-handlers ([exn:fail? (λ (exn) #false)])
            ;; Robert Findler does not endorse `get-filename` here,
            ;; 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 (object-name in) get-filename)))
-                                       (send maybe-definitions-frame get-filename)))) ; will be #f if unsaved file
+       (define my-command-char
-         (define my-command-char (hash-ref! command-char-cache maybe-source-path (λ _ (setup:command-char maybe-source-path))))
+         (hash-ref! command-char-cache maybe-source-path (λ () (setup:command-char maybe-source-path))))
        (case key
          [(color-lexer)
-            (define my-make-scribble-inside-lexer
+          (match (dynamic-require 'syntax-color/scribble-lexer 'make-scribble-inside-lexer (λ () #false))
-              (dynamic-require 'syntax-color/scribble-lexer 'make-scribble-inside-lexer (λ () #f)))
+            [(? procedure? make-lexer) (make-lexer #:command-char my-command-char)]
-            (if my-make-scribble-inside-lexer
+            [_ default])]
-                (my-make-scribble-inside-lexer #:command-char my-command-char)
-                default)]
          [(drracket:toolbar-buttons)
-            (define my-make-drracket-buttons (dynamic-require 'pollen/private/drracket-buttons 'make-drracket-buttons))
+          (match (dynamic-require 'pollen/private/drracket-buttons 'make-drracket-buttons (λ () #false))
-            (my-make-drracket-buttons my-command-char)])]
+            [(? procedure? make-buttons) (make-buttons my-command-char)])])]
       [(drracket:indentation)
        (dynamic-require 'scribble/private/indentation 'determine-spaces)]
       [(drracket:default-filters)
@@ -109,13 +104,13 @@
        (list (list "Pollen sources" (string-join filter-strings ";")))]
       [(drracket:default-extension)
        (symbol->string
-          (cond
+        (match mode
-            [(eq? mode default-mode-auto) (setup:preproc-source-ext)]
+          [(== default-mode-auto) (setup:preproc-source-ext)]
-            [(eq? mode default-mode-preproc) (setup:preproc-source-ext)]
+          [(== default-mode-preproc) (setup:preproc-source-ext)]
-            [(eq? mode default-mode-markdown) (setup:markdown-source-ext)]
+          [(== default-mode-markdown) (setup:markdown-source-ext)]
-            [(eq? mode default-mode-markup) (setup:markup-source-ext)]
+          [(== default-mode-markup) (setup:markup-source-ext)]
-            [(eq? mode default-mode-pagetree) (setup:pagetree-source-ext)]))]
+          [(== default-mode-pagetree) (setup:pagetree-source-ext)]))]
-        [else default]))))
+      [else default])))
 
 (define-syntax-rule (reader-module-begin mode . _)
   (#%module-begin

pollen/private/runtime-config.rkt

@@ -1,35 +1,43 @@
 #lang racket/base
-(require pollen/setup scribble/reader racket/pretty version/utils racket/port racket/string)  
+(require pollen/setup
-(provide (all-defined-out))
+         scribble/reader
+         racket/pretty
+         version/utils
+         racket/port
+         racket/string
+         txexpr/base)
+
+(provide show configure current-top-path)
 
 (define current-top-path (make-parameter #f))
 
+(define (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 (equal? here-path (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,
+        (with-handlers ([exn:fail? my-error-handler])
-          ;; so trim trailing newline manually
+          (my-pretty-print (validate-txexpr doc))))))
-          (let ([pretty-print-proc (if (version<? (version) "6.7")
-                                       (λ (x) (display (string-trim #:left? #f (with-output-to-string (λ () (pretty-print x))) "\n")))
-                                       (λ (x) (pretty-print #:newline? #f x)))])
-            ;; OK to use dynamic-require because runtime-config itself is dynamic-required
-            (pretty-print-proc (with-handlers ([exn:fail? (λ (exn) ((error '|pollen markup error|
-                                                                           ((dynamic-require 'racket/string 'string-join) (cdr ((dynamic-require 'racket/string 'string-split) (exn-message exn) ": ")) ": "))))])
-                                 ((dynamic-require 'txexpr/base 'validate-txexpr) doc))))))))
 
 (define (configure top-here-path)
-  (current-top-path top-here-path)  ;; puts `show` into the right mode
+  (current-top-path top-here-path) ; puts `show` into the right mode
-
-  ;; wrap REPL interactions with pollen expression support
   (define old-read (current-read-interaction))
+  (define (pollen-repl-read src in)
+    ;; wrap repl interactions with pollen expression support
     (define pollen-readtable (make-at-readtable #:command-char (setup:command-char)))
-  (define (new-read src in)
     (parameterize ([current-readtable pollen-readtable])
       (old-read src in)))
-  (current-read-interaction new-read))
+  (current-read-interaction pollen-repl-read))
 

pollen/private/splice.rkt

@@ -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)
+  (match x
-       (andmap (λ (xi)
+    [(list (list (? symbol?) (? string?)) ...) #true]
-                 (and (list? xi)
+    [_ #false]))
-                      (= (length xi) 2)
-                      (symbol? (car xi))
-                      (string? (cadr xi)))) x)))
 
+(define (null-string? x) (equal? x ""))
+
+(define ((spliceable? splicing-tag) x)
+  (match x
+    [(cons (== splicing-tag eq?) _) #true]
+    [_ #false]))
 
 (define (splice x [splicing-tag splice-signal-tag])
   ;  (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`
+        (append-map (λ (x)
-                                                  cdr
+                      ; drop the splice-signal from front with `rest`
-                                                  list)]
+                      ; don't recur on attributes, so null strings are not spliced within
-                                        [x (if (not (attrs? x)) ; don't recur on attributes, so null strings are not spliced within
+                      (define proc (if ((spliceable? splicing-tag) x) rest list))
-                                               (loop x)
+                      (proc (if (attrs? x) x (loop x))))
-                                               x)])
+                    (filter-not null-string? x))
-                                    (proc x))) (filter not-null-string? x)))
         x)))
 
 (module+ test
@@ -40,29 +42,25 @@
   (check-equal? (splice `((,splice-signal-tag "str"))) '("str")))
 
 
-(define (strip-empty-attrs x)
-  (let loop ([x x])
-    (if (list? x)
 ;; this will strip all empty lists.
 ;; in practice, they would only appear in attrs position 
-        (map loop (filter (λ (x) (not (null? x))) x))
+(define (strip-empty-attrs x)
+  (let loop ([x x])
+    (if (pair? x)
+        (map loop (filter-not null? x))
         x)))
 
-
 (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)]
+        (map loop (filter-not void? x))
-                   #:unless (void? xi))
-                  (loop xi))
         x)))
 
 (module+ test

pollen/private/split-metas.rkt

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

pollen/private/ts.rktd

@@ -1 +1 @@
-1540875704
+1540958640

pollen/private/update-info.rkt

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

pollen/private/whitespace.rkt

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

pollen/render.rkt

@@ -1,18 +1,17 @@
 #lang racket/base
 (require racket/file
          racket/path
-         compiler/cm
+         racket/match
          sugar/test
          sugar/define
          sugar/file
          sugar/coerce
          "private/file-utils.rkt"
          "cache.rkt"
-         "private/debug.rkt"
+         "private/log.rkt"
          "private/project.rkt"
          "private/cache-utils.rkt"
          "pagetree.rkt"
-         "template.rkt"
          "core.rkt"
          "setup.rkt")
 
@@ -23,7 +22,6 @@
 ;; render functions will always go when no mod-date is found.
 (define (reset-mod-date-hash!) (set! mod-date-hash (make-hash)))
 
-
 (module-test-internal
  (require racket/runtime-path)
  (define-runtime-path sample-dir "test/data/samples")
@@ -31,8 +29,6 @@
                    (map path->complete-path (filter (λ (name) (regexp-match "sample-" name)) (directory-list ".")))))
  (define-values (sample-01 sample-02 sample-03) (apply values samples)))
 
-
-
 ;; each key for mod-date-hash is a list of file / mod-date pairs (using pollen/cache keymaking function)
 ;; when a file is rendered, a new key is stored in the hash (with trivial value #t)
 ;; after that, the hash-key-comparision routine intrinsic to hash lookup
@@ -40,15 +36,13 @@
 ;; create a new key with current files. If the key is in the hash, the render has happened.
 ;; if not, a new render is needed.
 (define (update-mod-date-hash! source-path template-path)
-  (hash-set! mod-date-hash (paths->key source-path template-path) #t))
+  (hash-set! mod-date-hash (paths->key source-path template-path) #true))
 
 (define (mod-date-missing-or-changed? source-path template-path)
   (not (hash-has-key? mod-date-hash (paths->key source-path template-path))))
 
-
 (define (list-of-pathish? x) (and (list? x) (andmap pathish? x)))
 
-
 (define+provide/contract (render-batch . xs)
   (() #:rest list-of-pathish? . ->* . void?)
   ;; Why not just (for-each render ...)?
@@ -58,7 +52,6 @@
   (reset-mod-date-hash!) 
   (for-each render-from-source-or-output-path xs))
 
-
 (define+provide/contract (render-pagenodes pagetree-or-path)
   ((or/c pagetree? pathish?) . -> . void?)
   (define pagetree (if (pagetree? pagetree-or-path)
@@ -67,7 +60,6 @@
   (parameterize ([current-directory (current-project-root)])
     (apply render-batch (map ->complete-path (pagetree->list pagetree)))))
 
-
 (define+provide/contract (render-from-source-or-output-path so-pathish)
   (pathish? . -> . void?)
   (define so-path (->complete-path so-pathish)) ; so-path = source or output path (could be either) 
@@ -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)))
@@ -156,58 +145,59 @@
     (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)
+    (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)))])
-                          (apply render-proc (list source-path template-path output-path))))
+      (time-apply render-proc (list source-path template-path output-path))))
   ;; wait till last possible moment to store mod dates, because render-proc may also trigger its own subrenders
   ;; 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)]
+  (parameterize ([current-namespace (make-base-namespace)]
                  [current-directory (->complete-path source-dir)])
-          (namespace-attach-module (namespace-anchor->namespace render-module-ns) 'scribble/core)
+    (define outer-ns (namespace-anchor->namespace render-module-ns))
-          (namespace-attach-module (namespace-anchor->namespace render-module-ns) 'scribble/manual)
+    (namespace-attach-module outer-ns 'scribble/core)
-          
+    (namespace-attach-module outer-ns 'scribble/manual)
     ;; scribble/lp files have their doc export in a 'doc submodule, so check both locations
-          (define doc
+    (match (cond
-            [cond
+             [(dynamic-require source-path 'doc (λ () #false))]
-              [(dynamic-require source-path 'doc (λ () #f))]
+             [(dynamic-require `(submod ,source-path doc) 'doc (λ () #false))]
-              [(dynamic-require `(submod ,source-path doc) 'doc (λ () #f))]
+             [else #false])
-              [else #f]])
       ;; BTW this next action has side effects: scribble will copy in its core files if they don't exist.
-          (when doc
+      [(? part? doc) (scribble-render (list doc) (list source-path))]
-            (scribble-render (list doc) (list source-path)))))
+      [_ (void)]))
-  (define result (file->string (->output-path source-path)))
+  (begin0 ; because render promises the data, not the side effect
-  (delete-file (->output-path source-path)) ; because render promises the data, not the side effect
+    (file->string (->output-path source-path))
-  result)
+    (delete-file (->output-path source-path))))
-
 
 (define (render-preproc-source source-path . _)
-  (time (parameterize ([current-directory (->complete-path (dirname source-path))])
+  (parameterize ([current-directory (->complete-path (dirname source-path))])
-          (render-through-eval (syntax->datum
+    (render-datum-through-eval (syntax->datum
                                 (with-syntax ([SOURCE-PATH source-path])
                                   #'(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,27 +235,18 @@
                  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))]) 
+  (parameterize ([current-directory (->complete-path (dirname source-path))]) 
-          (render-through-eval expr-to-eval))))
+    (render-datum-through-eval datum-to-eval)))
-
 
 (define (templated-source? path)
   (or (markup-source? path) (markdown-source? path)))
 
+(define (file-exists-or-has-source? path) ; path could be #f
+  (and path (for/first ([proc (in-list (list values ->preproc-source-path ->null-source-path))]
+                        #:when (file-exists? (proc path)))
+                       path)))
 
-(define+provide/contract (get-template-for source-path [maybe-output-path #f])
+(define (get-template-from-metas source-path output-path-ext)
-  ((complete-path?)((or/c #f complete-path?)) . ->* . (or/c #f complete-path?))
-  
-  (define (file-exists-or-has-source? p) ; p could be #f
-    (and p (for/first ([proc (in-list (list values ->preproc-source-path ->null-source-path))]
-                       #:when (file-exists? (proc p)))
-             p)))
-  
-  (define (get-template)
-    (define output-path (or maybe-output-path (->output-path source-path)))
-    (define output-path-ext (or (get-ext output-path) (current-poly-target))) ; output-path may not have an extension
-    
-    (define (get-template-from-metas)
   (with-handlers ([exn:fail:contract? (λ (e) #f)]) ; in case source-path doesn't work with cached-require
     (parameterize ([current-directory (current-project-root)])
       (define source-metas (cached-metas source-path))
@@ -276,22 +257,25 @@
                                 template-name-or-names))
       (and template-name (build-path (dirname source-path) template-name)))))
 
-    (define (get-default-template)
+(define (get-default-template source-path output-path-ext)
   (and output-path-ext
        (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)
+(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))))
 
-    (or (file-exists-or-has-source? (get-template-from-metas))
+(define+provide/contract (get-template-for source-path [maybe-output-path #f])
-        (file-exists-or-has-source? (get-default-template))
+  ((complete-path?)((or/c #f complete-path?)) . ->* . (or/c #f complete-path?))
-        (file-exists-or-has-source? (get-fallback-template))))   
+  (and (templated-source? source-path)
-  
+       (let ()
-  (and (templated-source? source-path) (get-template)))
+         (define output-path (or maybe-output-path (->output-path source-path)))
-
+         ;; output-path may not have an extension
+         (define output-path-ext (or (get-ext output-path) (current-poly-target)))
+         (for/or ([proc (list get-template-from-metas get-default-template get-fallback-template)])
+                 (file-exists-or-has-source? (proc source-path output-path-ext))))))
 
 (module-test-external
  (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)))

pollen/scribblings/mb-tools.rkt

@@ -1,7 +1,7 @@
 #lang at-exp racket/base
-(require (for-syntax racket/base racket/syntax pollen/setup) scribble/core scribble/manual scribble/private/manual-sprop scribble/decode scribble/html-properties racket/runtime-path racket/format "../private/manual-history.rkt" pollen/setup)
+(require (for-syntax racket/base racket/syntax pollen/setup) scribble/core scribble/manual scribble/private/manual-sprop scribble/decode scribble/html-properties racket/runtime-path racket/format "../private/external/manual-history.rkt" pollen/setup)
 
-(provide (all-defined-out) (all-from-out racket/runtime-path "../private/manual-history.rkt"))
+(provide (all-defined-out) (all-from-out racket/runtime-path "../private/external/manual-history.rkt"))
 
 (define-runtime-path mb-css "mb.css")
 

pollen/scribblings/quick.scrbl

@@ -116,11 +116,11 @@ Now here's a third: the Pollen project server. To start the project server, retu
 After a moment, you'll see the startup message:
 
 @terminal{
-Welcome to Pollen @|pollen:version| (Racket @(version))
+pollen: welcome to Pollen @|pollen:version| (Racket @(version))
-Project root is /path/to/your/directory
+pollen: project root is /path/to/your/directory
-Project server is http://localhost:8080 (Ctrl+C to exit)
+pollen: project server is http://localhost:8080 (Ctrl+C to exit)
-Project dashboard is http://localhost:8080/index.ptree
+pollen: project dashboard is http://localhost:8080/index.ptree
-Ready to rock}
+pollen: ready to rock}
 
 Open a web browser and point it at the project dashboard, which by default is @link-tt{http://localhost:8080/index.ptree}. The top line of the window will say @tt{Project root} and show the name of the starting directory. Below that will be a listing of the files in the directory. 
 

pollen/scribblings/version-history.scrbl

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

pollen/tag.rkt

@@ -1,32 +1,37 @@
 #lang pollen/mode racket/base
-(require (for-syntax racket/base syntax/parse))
+(require (for-syntax
-(require txexpr/base racket/string racket/match)
+          racket/base
+          syntax/parse)
+         txexpr/base
+         racket/string
+         racket/match)
 (provide default-tag-function make-default-tag-function define-tag-function)
 
-
 (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 (match (append kw-attrs colon-attrs leading-attrs)
-       (cons id (if (null? attrs)
+                  [(== empty) xs]
-                    xs
+                  [attrs (cons attrs xs)]))))))
-                    (cons attrs xs)))))))
-
 
 (define default-tag-function
   (make-keyword-procedure
    (λ (outer-kws outer-kw-args . ids)
-     (let ([tag-proc (apply compose1 (for/list ([id (in-list ids)])
+     (define tag-proc (apply compose1 (for/list ([id (in-list ids)])
-                                               (make-one-tag-function outer-kws outer-kw-args id)))]
+                                               (make-one-tag-function outer-kws outer-kw-args id))))
-           [tag-proc-name (string->symbol (format "pollen-tag:~a" (string-join (map symbol->string ids) "+")))])
+     (define tag-proc-name (string->symbol (format "pollen-tag:~a" (string-join (map symbol->string ids) "+"))))
-       (procedure-rename tag-proc tag-proc-name)))))
+     (procedure-rename tag-proc tag-proc-name))))
 
 (define make-default-tag-function default-tag-function) ; bw compat
 
 
 (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)

pollen/test/data/pixel/template.png.p

@@ -0,0 +1 @@
+◊doc

pollen/test/data/pixel/test-pixel.png.pm

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

pollen/test/test-bytes.rkt

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

pollen/test/test-output.rkt

@@ -1,5 +1,5 @@
 #lang racket/base
-(require rackunit pollen/private/output racket/port)
+(require rackunit pollen/private/external/output racket/port)
 
 (define-syntax-rule (check-output outputter string)
   (check-equal? (with-output-to-string (λ () outputter)) string))

pollen/test/test-poly.rkt

@@ -1,5 +1,8 @@
 #lang at-exp racket/base
-(require rackunit pollen/setup racket/runtime-path pollen/render)
+(require rackunit
+         pollen/setup
+         racket/runtime-path
+         pollen/render)
 
 ;; define-runtime-path only allowed at top level
 (define-runtime-path poly-dir "data/poly")

pollen/top.rkt

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

pollen/unstable/pygments.rkt

@@ -10,7 +10,7 @@
          rackjure/str
           xml
          (only-in html read-html-as-xml)
-         "../private/debug.rkt"
+         "../private/log.rkt"
          "../private/splice.rkt")
 
 (provide highlight make-highlight-css)
@@ -86,7 +86,7 @@ if zero is False:
 
 (define-values (pyg-in pyg-out pyg-pid pyg-err pyg-proc)
   (values #f #f #f #f #f))
-(define-runtime-path pipe.py "../private/pipe.py")
+(define-runtime-path pipe.py "../private/external/pipe.py")
 
 (define start
   (let ([start-attempted? #f])