Revert "workaround"

This reverts commit 894ace3dba.

info.rkt

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

pollen/cache.rkt

@@ -1,9 +1,10 @@
 #lang racket/base
 (require racket/file
          racket/list
+         racket/fasl
          sugar/define
          "private/cache-utils.rkt"
-         "private/debug.rkt"
+         "private/log.rkt"
          "setup.rkt")
 
 ;; The cache is a hash with paths as keys.
@@ -18,40 +19,45 @@
     (raise-argument-error 'reset-cache "path-string to existing directory" starting-dir))
   (for ([path (in-directory starting-dir)]
         #:when (cache-directory? path))
-    (message (format "removing cache directory: ~a" path))
+       (message (format "removing cache directory: ~a" path))
-    (delete-directory/files path)))
+       (delete-directory/files path)))
+
+(define ((path-error-handler caller-name path-or-path-string) e)
+  (raise-argument-error caller-name "valid path or path-string" path-or-path-string))
 
 (define-namespace-anchor cache-module-ns)
+
+(define 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
-                     (path->complete-path (if (path? path-or-path-string)
+        (with-handlers ([exn:fail? (path-error-handler caller-name path-or-path-string)])
-                                              path-or-path-string
+          (path->complete-path (if (path? path-or-path-string)
-                                              (string->path path-or-path-string)))))
+                                   path-or-path-string
-      
+                                   (string->path path-or-path-string)))))
       (unless (file-exists? path)
         (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)])
-                (dynamic-require path subkey))]))))
+           ;; brings in currently instantiated params (unlike namespace-require)
-
+           (define outer-ns (namespace-anchor->namespace cache-module-ns))
+           (namespace-attach-module outer-ns 'pollen/setup) 
+           (dynamic-require path subkey))]))))
 
 (define+provide (cached-require path-string subkey)
   (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?)
-                   (cond
+       (define-values (tag attrs elements) (txexpr->values x))
-                     [(or (memq tag excluded-tags)
+       (cond
-                          (for/or ([attr (in-list attrs)])
+         [(or (memq tag excluded-tags)
-                            (member attr excluded-attrs))) 
+              (for/or ([attr (in-list attrs)])
-                      x] ; because it's excluded
+                      (member attr excluded-attrs))) x] ; because it's excluded
-                     [else
+         [else
-                      ;; we apply processing here rather than do recursive descent on the pieces
+          ;; we apply processing here rather than do recursive descent on the pieces
-                      ;; because if we send them back through loop, certain element types are ambiguous
+          ;; because if we send them back through loop, certain element types are ambiguous
-                      ;; e.g., ((p "foo")) tests out as both txexpr-attrs and txexpr-elements
+          ;; e.g., ((p "foo")) tests out as both txexpr-attrs and txexpr-elements
-                      (define decoded-txexpr (make-txexpr (txexpr-tag-proc tag) 
+          (define decoded-txexpr
-                                                          (txexpr-attrs-proc attrs) 
+            (make-txexpr (txexpr-tag-proc tag) 
-                                                          (txexpr-elements-proc (append-map (λ (x) (->list/tx (loop x))) elements))))
+                         (txexpr-attrs-proc attrs) 
-                      (txexpr-proc ((if (block-txexpr? decoded-txexpr)
+                         (txexpr-elements-proc (append-map (λ (x) (->list/tx (loop x))) elements))))
-                                        block-txexpr-proc
+          (txexpr-proc ((if (block-txexpr? decoded-txexpr)
-                                        inline-txexpr-proc) decoded-txexpr))])]
+                            block-txexpr-proc
-      [(string? x) (string-proc x)]
+                            inline-txexpr-proc) decoded-txexpr))])]
-      [(or (symbol? x) (valid-char? x)) (entity-proc x)]
+      [(? string?) (string-proc x)]
-      [(cdata? x) (cdata-proc x)]
+      [(? symbol?) (entity-proc x)]
-      [else (error "decode: can't decode" x)])))
+      [(? valid-char?) (entity-proc x)]
+      [(? cdata?) (cdata-proc x)]
+      [else (raise-argument-error 'decode "decodable thing" x)])))
 
 (module-test-external
  (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,27 +130,30 @@
 
 (define+provide/contract (decode-linebreaks elems [maybe-linebreak-proc '(br)]
                                             #:separator [newline (setup:linebreak-separator)])
-  ((txexpr-elements?) ((or/c #f txexpr-element? (txexpr-element? txexpr-element? . -> . (or/c #f txexpr-element?))) #:separator string?) . ->* . txexpr-elements?)
+  ((txexpr-elements?)
+   ((or/c #f txexpr-element?
+          (txexpr-element? txexpr-element? . -> . (or/c #f txexpr-element?))) #:separator string?)
+   . ->* . txexpr-elements?)
   (unless (string? newline)
     (raise-argument-error 'decode-linebreaks "string" newline))
-  (define linebreak-proc (if (procedure? maybe-linebreak-proc)
+  (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
+                    (cond
-              [(= idx 0) elem] ; pass first item
+                      [(zero? idx) elem] ; pass first item
-              [(= idx (sub1 (vector-length elems-vec))) elem] ; pass through last item
+                      [(= idx (sub1 (vector-length elems-vec))) elem] ; pass through last item
-              [(equal? elem newline)
+                      [(equal? elem newline)
-               (define prev (vector-ref elems-vec (sub1 idx)))
+                       (define prev (vector-ref elems-vec (sub1 idx)))
-               (define next (vector-ref elems-vec (add1 idx)))
+                       (define next (vector-ref elems-vec (add1 idx)))
-               ;; only convert if neither adjacent tag is a block
+                       ;; only convert if neither adjacent tag is a block
-               ;; (because blocks automatically force a newline before & after)
+                       ;; (because blocks automatically force a newline before & after)
-               (if (or (block-txexpr? prev) (block-txexpr? next))
+                       (if (or (block-txexpr? prev) (block-txexpr? next))
-                   #f ; flag for filtering
+                           #false ; flag for filtering
-                   (linebreak-proc prev next))]
+                           (linebreak-proc prev next))]
-              [else elem]))))
+                      [else elem]))))
 
 (module-test-external
  (check-equal? (decode-linebreaks '("foo" "\n" "bar")) '("foo" (br) "bar"))
@@ -169,17 +173,21 @@
 (define+provide/contract (merge-newlines x)
   (txexpr-elements? . -> . txexpr-elements?)
   (define newline-pat (regexp (format "^~a+$" (setup:newline))))
-  (define (newline? x) (and (string? x) (regexp-match newline-pat x)))  
+  (define (newline? x) (match x
+                         [(regexp newline-pat) #true]
+                         [_ #false]))  
   (define (merge-newline-slice xs)
-    (if (newline? (car xs)) ; if first member of slice is newline, they all are
+    (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)
@@ -49,9 +48,9 @@
   (define pt-root-tag (setup:pagetree-root-node))
   (define (splice-nested-pagetree xs)
     (apply append (for/list ([x (in-list xs)])
-                    (if (and (txexpr? x) (eq? (get-tag x) pt-root-tag))
+                            (if (and (txexpr? x) (eq? (get-tag x) pt-root-tag))
-                        (get-elements x)
+                                (get-elements x)
-                        (list x)))))
+                                (list x)))))
   (validate-pagetree 
    (decode (cons pt-root-tag xs)
            #:txexpr-elements-proc (compose1 splice-nested-pagetree (λ (xs) (filter-not whitespace? xs))) 
@@ -60,10 +59,11 @@
 
 (define+provide (validate-pagetree x)
   (and (txexpr? x)
-       (let ([pagenodes (pagetree-strict->list x)])
+       (let ()
-         (for/and ([p (in-list pagenodes)]
+         (define pagenodes (pagetree-strict->list x))
-                   #:unless (pagenode? p))
+         (for ([p (in-list pagenodes)]
-           (error 'validate-pagetree "~v is not a valid pagenode" p))
+               #:unless (pagenode? p))
+              (raise-argument-error 'validate-pagetree "valid pagenodes" p))
          (with-handlers ([exn:fail? (λ (e) (error 'validate-pagetree "~a" (exn-message e)))])
            (members-unique?/error pagenodes))
          x)))
@@ -89,7 +89,7 @@
   (define (unique-sorted-output-paths xs)
     (define output-paths (map ->output-path xs))
     (define all-paths (filter path-visible? (remove-duplicates output-paths)))
-    (define path-is-directory? (λ (f) (directory-exists? (build-path dir f))))
+    (define (path-is-directory? f) (directory-exists? (build-path dir f)))
     (define-values (subdirectories files) (partition path-is-directory? all-paths))
     (define-values (pagetree-sources other-files) (partition pagetree-source? files))
     (define (sort-names xs) (sort xs #:key ->string string<?))
@@ -104,7 +104,7 @@
   (define (cache-dir? path) (member (->string path) default-cache-names))
   
   (unless (directory-exists? dir)
-    (error 'directory->pagetree "directory ~v doesn't exist" dir))
+    (raise-argument-error 'directory->pagetree "existing directory" dir))
   
   (decode-pagetree (map ->pagenode (unique-sorted-output-paths (filter-not cache-dir? (directory-list dir)))))) 
 
@@ -125,7 +125,7 @@
     (load-pagetree pagetree-source)))
 
 
-(define (topmost-node x) (car (->list x)))
+(define (topmost-node x) (first (->list x)))
 
 
 (define+provide/contract (parent pnish [pt-or-path (current-pagetree)] #:allow-root [allow-root? #f])
@@ -138,8 +138,8 @@
            (if (memq pagenode (map topmost-node current-children))
                current-parent
                (for/or ([st (in-list (filter list? current-children))])
-                 (loop pagenode st))))))
+                       (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
@@ -192,9 +191,9 @@
   (((or/c #f pagenodeish?)) ((or/c pagetree? pathish?)) . ->* . (or/c #f pagenodes?))  
   (match (for/list ([sib (in-list (or (siblings pnish pt-or-path) empty))]
                     #:unless (eq? sib (->pagenode pnish)))
-           sib)
+                   sib)
     [(? pair? sibs) sibs]
-    [else #f]))
+    [_ #false]))
 
 
 (module-test-external
@@ -210,13 +209,13 @@
 ;; private helper function.
 ;; only takes pt as input.
 ;; used by `pagetree?` predicate, so can't use `pagetree?` contract.
-(define (pagetree-strict->list pt) (flatten (cdr pt)))
+(define (pagetree-strict->list pt) (flatten (rest pt)))
 
 
 ;; flatten tree to sequence
 (define+provide/contract (pagetree->list pt-or-path)
   ((or/c pagetree? pathish?) . -> . pagenodes?)
-  ; use cdr to get rid of root tag at front
+  ; use rest to get rid of root tag at front
   (pagetree-strict->list (get-pagetree pt-or-path))) 
 
 
@@ -230,14 +229,13 @@
        (let loop ([side side]
                   [pagenode (->pagenode pnish)]
                   [pagetree-nodes (pagetree->list (get-pagetree pt-or-path))])
-         (if (eq? side 'right)
+         (case side
-             (match (memq pagenode pagetree-nodes)
+           [(right) (match (memq pagenode pagetree-nodes)
-               [(list _ rest ...) rest]
+                      [(list _ rest ...) rest]
-               [else #f])
+                      [_ #false])]
-             (match (loop 'right pagenode (reverse pagetree-nodes))
+           [else (match (loop 'right pagenode (reverse pagetree-nodes))
-               [(? pair? result) (reverse result)]
+                   [(? pair? result) (reverse result)]
-               [else #f])))))
+                   [_ #false])]))))
-
 
 (module-test-internal
  (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,63 +10,60 @@
          compiler/cm)
 (provide (all-defined-out))
 
-(define (paths->key source-path [template-path #f] [output-path #f])
+;; can't use relative paths for cache keys because source files include `here-path` which is absolute.
-  ;; can't use relative paths for cache keys because source files include `here-path` which is absolute.
+;; problem is that cache could appear valid on another filesystem (based on relative pathnames & mod dates)
-  ;; problem is that cache could appear valid on another filesystem (based on relative pathnames & mod dates)
+;; but would actually be invalid (because the `here-path` names are wrong).
-  ;; but would actually be invalid (because the `here-path` names are wrong).
+;; key is list of file + mod-time pairs, use #f for missing  
-  ;; key is list of file + mod-time pairs, use #f for missing
+;; we don't include output-path in path-strings-to-track
-  
+;; because we don't want to attach a mod date
-  ;; we don't include output-path in path-strings-to-track
+;; because cache validity is not sensitive to mod date of output path
-  ;; because we don't want to attach a mod date
+;; (in fact we would expect it to be earlier, since we want to rely on an earlier version)
-  ;; because cache validity is not sensitive to mod date of output path
+(define (paths->key source-path [template-path #false] [output-path #false])
-  ;; (in fact we would expect it to be earlier, since we want to rely on an earlier version)
+  (define path-strings-to-track
-  (define path-strings-to-track (list* source-path
+    (list* source-path
-                                       ;; if template has a source file, track that instead
+           ;; if template has a source file, track that instead
-                                       (and template-path (or (get-source template-path) template-path))
+           (and template-path (or (get-source template-path) template-path))
-                                       ;; is either list of files or (list #f)
+           ;; is either list of files or (list #f)
-                                       (append (->list (get-directory-require-files source-path))
+           (append (->list (get-directory-require-files source-path))
-                                               ;; user-designated files to track
+                   ;; user-designated files to track
-                                               (map ->string (setup:cache-watchlist source-path)))))
+                   (map ->string (setup:cache-watchlist source-path)))))
   (define pollen-env (getenv default-env-name))
   (define poly-flag (and (has-inner-poly-ext? source-path) (current-poly-target)))
   (define path+mod-time-pairs
     (for/list ([ps (in-list path-strings-to-track)])
-      (cond
+              (cond
-        [ps (define cp (->complete-path ps))
+                [ps (define cp (->complete-path ps))
-            (cons (path->string cp) (file-or-directory-modify-seconds cp #f (λ () 0)))]
+                    (cons (path->string cp) (file-or-directory-modify-seconds cp #false (λ () 0)))]
-        [else #f])))
+                [else #false])))
   (list* pollen-env poly-flag (and output-path (path->string output-path)) path+mod-time-pairs))
 
-
 (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'
+           ;; I monkeyed around with using the metas submodule to pull out the metas (for speed)
+           ;; but in practice most files get their doc requested too.
+           ;; so it's just simpler to get both at once and be done with it.
+           ;; the savings of avoiding two cache fetches at the outset outweighs
+           ;; the benefit of not reloading doc when you just need metas.
+           ;; new namespace forces `dynamic-require` to re-instantiate `path`
            ;; otherwise it gets cached in current namespace.
            (parameterize ([current-namespace (make-base-namespace)]
-                          [current-directory path-dir])
+                          [current-directory (dirname path)])
-             ;; I monkeyed around with using the metas submodule to pull out the metas (for speed)
+             ;; brings in currently instantiated params (unlike namespace-require)
-             ;; but in practice most files get their doc requested too.
+             (define outer-ns (namespace-anchor->namespace cache-utils-module-ns))
-             ;; so it's just simpler to get both at once and be done with it.
+             (namespace-attach-module outer-ns 'pollen/setup) 
-             ;; the savings of avoiding two cache fetches at the outset outweighs
-             ;; the benefit of not reloading doc when you just need metas.
-             (namespace-attach-module (namespace-anchor->namespace cache-utils-module-ns) 'pollen/setup) ; brings in params
              (define doc-missing-thunk (λ () ""))
              (define 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,30 +20,34 @@
 ;; todo: investigate this
 
 (module+ raco
-  (define command-name (with-handlers ([exn:fail? (λ _ #f)])
+  (define command-name (with-handlers ([exn:fail? (λ () #f)])
                          (vector-ref (current-command-line-arguments) 0)))
   (dispatch command-name))
 
-
 (define (get-first-arg-or-current-dir [args (cdr (vector->list (current-command-line-arguments)))]) ; cdr to strip command name from front
   (normalize-path
    (with-handlers ([exn:fail? (λ (exn) (current-directory))])
      ;; incoming path argument is handled as described in docs for current-directory
      (very-nice-path (car args)))))
 
-
 (define (dispatch command-name)
-  (case command-name
+  (with-logging-to-port
-    [("test" "xyzzy") (handle-test)]
+   (current-error-port)
-    [(#f "help") (handle-help)]
+   (λ ()
-    [("start") (handle-start)] ; parses its own args
+     (case command-name
-    ;; "second" arg is actually third in command line args, so use cddr not cdr
+       [("test" "xyzzy") (handle-test)]
-    [("render") (handle-render)] ; render parses its own args from current-command-line-arguments
+       [(#f "help") (handle-help)]
-    [("version") (handle-version)]
+       [("start") (handle-start)] ; parses its own args
-    [("reset") (handle-reset (get-first-arg-or-current-dir))]
+       ;; "second" arg is actually third in command line args, so use cddr not cdr
-    [("setup") (handle-setup (get-first-arg-or-current-dir))]
+       [("render") (handle-render)] ; render parses its own args from current-command-line-arguments
-    [("clone" "publish") (handle-publish)]
+       [("version") (handle-version)]
-    [else (handle-unknown command-name)]))
+       [("reset") (handle-reset (get-first-arg-or-current-dir))]
+       [("setup") (handle-setup (get-first-arg-or-current-dir))]
+       [("clone" "publish") (handle-publish)]
+       [else (handle-unknown command-name)]))
+   #:logger pollen-logger
+   'info
+   'pollen))
 
 (define (very-nice-path x)
   (path->complete-path (simplify-path (cleanse-path (->path x)))))
@@ -67,108 +73,102 @@ version                print the version" (current-server-port) (make-publish-di
 (define (handle-version)
   (displayln (dynamic-require 'pollen/private/version 'pollen:version)))
 
-
 (define (handle-reset directory-maybe)
   (displayln "resetting cache ...")
   ((dynamic-require 'pollen/cache 'reset-cache) directory-maybe))
 
-
 (define (handle-setup directory-maybe)
   (displayln "preheating cache ...")
   ((dynamic-require 'pollen/private/preheat-cache 'preheat-cache) directory-maybe)) 
 
-
 (define (handle-render)
   (define render-target-wanted (make-parameter (current-poly-target)))
   (define render-with-subdirs? (make-parameter #f))
-  (define parsed-args (command-line #:program "raco pollen render"
+  (define parsed-args
-                                    #:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'render' from the front
+    (command-line #:program "raco pollen render"
-                                    #:once-each
+                  #:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'render' from the front
-                                    [("-t" "--target") target-arg "Render target for poly sources"
+                  #:once-each
-                                                       (render-target-wanted (->symbol target-arg))]
+                  [("-t" "--target") target-arg "Render target for poly sources"
-                                    [("-r" "--recursive") "Render subdirectories recursively"
+                                     (render-target-wanted (->symbol target-arg))]
-                                                          (render-with-subdirs? 'recursive)]
+                  [("-r" "--recursive") "Render subdirectories recursively"
-                                    [("-s" "--subdir") "Render subdirectories nonrecursively" (render-with-subdirs? 'include)]
+                                        (render-with-subdirs? 'recursive)]
-                                    #:args other-args
+                  [("-s" "--subdir") "Render subdirectories nonrecursively" (render-with-subdirs? 'include)]
-                                    other-args))  
+                  #:args other-args
-  (define path-args (if (empty? parsed-args)
+                  other-args)) 
-                        (list (current-directory))
-                        parsed-args))
   (parameterize ([current-poly-target (render-target-wanted)]) ;; applies to both cases
-    (cond
+    (let loop ([args parsed-args])
-      ;; directory mode: one directory as argument
+      (match args
-      [(and (= 1 (length path-args)) (directory-exists? (car path-args)))
+        [(== empty) (loop (list (current-directory)))]
-       (define top-dir (very-nice-path (car path-args)))
+        [(list dir) ;; directory mode: one directory as argument
-       (let render-one-dir ([dir top-dir])
+         #:when (directory-exists? dir)
-         (parameterize ([current-directory dir]
+         (define top-dir (very-nice-path dir))
-                        [current-project-root (if (eq? (render-with-subdirs?) 'recursive)
+         (let render-one-dir ([dir top-dir])
-                                                  dir
+           (parameterize ([current-directory dir]
-                                                  top-dir)])
+                          [current-project-root (case (render-with-subdirs?)
-           (define dirlist (directory-list dir))
+                                                  [(recursive) dir]
-           (define preprocs (filter preproc-source? dirlist))
+                                                  [else top-dir])])
-           (define static-pagetrees (filter pagetree-source? dirlist))
+             (define dirlist (directory-list dir))
-           ;; if there are no static pagetrees, use make-project-pagetree
+             (define preprocs (filter preproc-source? dirlist))
-           ;; (which will synthesize a pagetree if needed, which includes all sources)
+             (define static-pagetrees (filter pagetree-source? dirlist))
-           (define batch-to-render
+             ;; if there are no static pagetrees, use make-project-pagetree
-             (map very-nice-path
+             ;; (which will synthesize a pagetree if needed, which includes all sources)
-                  (cond
+             (define batch-to-render
-                    [(null? static-pagetrees)
+               (map very-nice-path
-                     (displayln (format "rendering generated pagetree for directory ~a" dir))
+                    (cond
-                     (cdr (make-project-pagetree dir))]
+                      [(null? static-pagetrees)
-                    [else
+                       (displayln (format "rendering generated pagetree for directory ~a" dir))
-                     (displayln (format "rendering preproc & pagetree files in directory ~a" dir))
+                       (cdr (make-project-pagetree dir))]
-                     (append preprocs static-pagetrees)])))
+                      [else
-           (apply render-batch batch-to-render)
+                       (displayln (format "rendering preproc & pagetree files in directory ~a" dir))
-           (when (render-with-subdirs?)
+                       (append preprocs static-pagetrees)])))
-             (for ([path (in-list dirlist)]
+             (apply render-batch batch-to-render)
-                   #:when (and (directory-exists? path)
+             (when (render-with-subdirs?)
-                               (not (omitted-path? path))))
+               (for ([path (in-list dirlist)]
-               (render-one-dir (->complete-path path))))))]
+                     #:when (and (directory-exists? path)
-      [else ;; path mode
+                                 (not (omitted-path? path))))
-       (displayln (format "rendering ~a" (string-join (map ->string path-args) " ")))
+                    (render-one-dir (->complete-path path))))))]
-       (apply render-batch (map very-nice-path path-args))])))
+        [path-args ;; path mode
-
+         (displayln (format "rendering ~a" (string-join (map ->string path-args) " ")))
+         (apply render-batch (map very-nice-path path-args))]))))
 
 (define (handle-start)
   (define launch-wanted #f)
   (define localhost-wanted #f)
-  (define clargs (command-line #:program "raco pollen start"
+  (define clargs
-                               #:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'start' from the front
+    (command-line #:program "raco pollen start"
-                               #:once-each
+                  #:argv (vector-drop (current-command-line-arguments) 1) ; snip the 'start' from the front
-                               [("--launch" "-l") "Launch browser after start" (set! launch-wanted #t)]
+                  #:once-each
-                               [("--local") "Restrict access to localhost" (set! localhost-wanted #t)]
+                  [("--launch" "-l") "Launch browser after start" (set! launch-wanted #t)]
-                               #:args other-args
+                  [("--local") "Restrict access to localhost" (set! localhost-wanted #t)]
-                               other-args))
+                  #:args other-args
+                  other-args))
   (define dir (path->directory-path (get-first-arg-or-current-dir clargs)))
   (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))))
+                      (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:"
+       (display "These are the available ") ; ... "Pollen commands:"
-        (handle-help)
+       (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 (path-cached? path)
+  ;; #true = already cached; #false = not cached
+  ;; seems like it would be slow to load cache.rktd but it's not.
+  (define-values (_ private-cache-dir) (make-cache-dirs path))
+  (define cache-db-file (build-path private-cache-dir "cache.rktd"))
+  (and (file-exists? cache-db-file)
+       (hash-has-key? (file->value cache-db-file) (paths->key path))))
+
+;; compile a path inside a place (= parallel processing)
+(define (path-into-place starting-dir path)
+  (message (format "caching: ~a" (find-relative-path starting-dir path)))
+  (define p
+    (place ch
+           (define path (place-channel-get ch))
+           (define-values (_ path-name __) (split-path path))
+           (message (format "compiling: ~a" path))
+           ;; use #false to signal compile error. Otherwise allow errors to pass.
+           (define result
+             (with-handlers ([exn:fail? (λ (e) (message (format "compile failed: ~a" path-name)) #false)])
+               (path->hash path)))
+           (place-channel-put ch result)))
+  (place-channel-put p path)
+  p)
+
 (define (preheat-cache starting-dir)
   (unless (and (path-string? starting-dir) (directory-exists? starting-dir))
-    (error 'preheat-cache (format "~a is not a directory" starting-dir)))
+    (raise-argument-error 'preheat-cache "directory" starting-dir))
-  
   (define max-places (processor-count)) ; number of parallel processes to spawn at a time
-  
+  (define paths-that-should-be-cached
-  (define paths-that-should-be-cached (for/list ([path (in-directory starting-dir)]
+    (for/list ([path (in-directory starting-dir)]
-                                                 #:when (for/or ([proc (in-list (list preproc-source?
+               #:when (for/or ([proc (in-list (list preproc-source?
-                                                                                      markup-source?
+                                                    markup-source?
-                                                                                      markdown-source?
+                                                    markdown-source?
-                                                                                      pagetree-source?))])
+                                                    pagetree-source?))])
-                                                                (proc path)))
+                              (proc path)))
-                                                path))
+              path))
-  
+
   ;; if a file is already in the cache, no need to hit it again.
   ;; this allows partially completed preheat jobs to resume.
-  (define uncached-paths (filter
+  (define uncached-paths (filter-not path-cached? paths-that-should-be-cached))
-                          (λ (path)
-                            ;; #t = not cached; #f = already cached
-                            ;; seems like it would be slow to load cache.rktd but it's not.
-                            (define-values (_ private-cache-dir) (make-cache-dirs path))
-                            (define cache-db-file (build-path private-cache-dir "cache.rktd"))
-                            (cond
-                              [(not (file-exists? cache-db-file)) #t]
-                              [else (define cache-db (file->value cache-db-file))
-                                    (not (hash-has-key? cache-db (paths->key path)))])) paths-that-should-be-cached))
-  
-  ;; compile a path inside a place (= parallel processing)
-  (define (path-into-place path)
-    (message (format "caching: ~a" (find-relative-path starting-dir path)))
-    (define p (place ch
-                     (define path (place-channel-get ch))
-                     (define-values (path-dir path-name _) (split-path path))
-                     (message (format "compiling: ~a" path))
-                     ;; use #f to signal compile error. Otherwise allow errors to pass.
-                     (define result (with-handlers ([exn:fail? (λ _ (message (format "compile failed: ~a" path-name)) #f)])
-                                      (path->hash path)))
-                     (place-channel-put ch result)))
-    (place-channel-put p path)
-    p)
   
   ;; compile the paths in groups, so they can be incrementally saved.
   ;; 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
@@ -146,9 +165,9 @@
   (define (make-link-cell href+text)
     (match-define (cons href text) href+text) 
     (filter-not void? `(cell ,(when text 
-                              (if href 
+                                (if href 
-                                  `(a ((href ,href)) ,text)
+                                    `(a ((href ,href)) ,text)
-                                  text)))))
+                                    text)))))
   
   (define (make-parent-row)
     (define title (string-append "Project root" (if (equal? (current-project-root) dashboard-dir) (format " = ~a" dashboard-dir) "")))
@@ -162,51 +181,51 @@
   
   (define (make-path-row filename source indent-level)
     `(row ,@(map make-link-cell 
-                (append (list                          
+                 (append (list                          
-                         (let ([main-cell (cond ; main cell
+                          (let ([main-cell (cond ; main cell
-                                            [(directory-exists? (build-path dashboard-dir filename)) ; links subdir to its dashboard
+                                             [(directory-exists? (build-path dashboard-dir filename)) ; links subdir to its dashboard
-                                             (cons (format "~a/~a" filename (setup:main-pagetree)) (format "~a/" filename))]
+                                              (cons (format "~a/~a" filename (setup:main-pagetree)) (format "~a/" filename))]
-                                            [(and source (equal? (get-ext source) "scrbl")) ; scribble source
+                                             [(and source (equal? (get-ext source) "scrbl")) ; scribble source
-                                             (cons #f `(a ((href ,filename)) ,filename (span ((class "file-ext")) " (from " ,(->string (find-relative-path dashboard-dir source)) ")")))]
+                                              (cons #f `(a ((href ,filename)) ,filename (span ((class "file-ext")) " (from " ,(->string (find-relative-path dashboard-dir source)) ")")))]
-                                            [source ; ordinary source. use remove-ext because source may have escaped extension in it
+                                             [source ; ordinary source. use remove-ext because source may have escaped extension in it
-                                             (define source-first-ext (get-ext source))
+                                              (define source-first-ext (get-ext source))
-                                             (define source-minus-ext (unescape-ext (remove-ext source)))
+                                              (define source-minus-ext (unescape-ext (remove-ext source)))
-                                             (define source-second-ext (get-ext source-minus-ext))
+                                              (define source-second-ext (get-ext source-minus-ext))
-                                             (cond ; multi source. expand to multiple output files.
+                                              (cond ; multi source. expand to multiple output files.
-                                               [(and source-second-ext (equal? source-second-ext (->string (setup:poly-source-ext (->complete-path source)))))
+                                                [(and source-second-ext (equal? source-second-ext (->string (setup:poly-source-ext (->complete-path source)))))
-                                                (define source-base (remove-ext source-minus-ext))
+                                                 (define source-base (remove-ext source-minus-ext))
-                                                (define output-names (map (λ (ext) (->string (add-ext source-base ext))) (setup:poly-targets (->complete-path source))))
+                                                 (define output-names (map (λ (ext) (->string (add-ext source-base ext))) (setup:poly-targets (->complete-path source))))
-                                                (cons #f `(div ,@(map (λ (on) `(a ((href ,on)) ,on (span ((class "file-ext")) "." ,source-first-ext ,(format " (from ~a)" (->string (find-relative-path dashboard-dir source)))))) output-names)))]
+                                                 (cons #f `(div ,@(map (λ (on) `(a ((href ,on)) ,on (span ((class "file-ext")) "." ,source-first-ext ,(format " (from ~a)" (->string (find-relative-path dashboard-dir source)))))) output-names)))]
-                                               [else
+                                                [else
-                                                (define extra-row-string
+                                                 (define extra-row-string
-                                                  (if (equal? source-minus-ext (remove-ext source)) ; escaped and unescaped versions are equal
+                                                   (if (equal? source-minus-ext (remove-ext source)) ; escaped and unescaped versions are equal
-                                                      "" ; no extra string needed
+                                                       "" ; no extra string needed
-                                                      (format " (from ~a)" (->string (find-relative-path dashboard-dir source)))))
+                                                       (format " (from ~a)" (->string (find-relative-path dashboard-dir source)))))
                                                 
-                                                (cons #f `(a ((href ,filename)) ,(->string source-minus-ext) (span ((class "file-ext")) "." ,source-first-ext ,extra-row-string)))])]
+                                                 (cons #f `(a ((href ,filename)) ,(->string source-minus-ext) (span ((class "file-ext")) "." ,source-first-ext ,extra-row-string)))])]
-                                            [else ; other non-source file
+                                             [else ; other non-source file
-                                             (cons filename filename)])])
+                                              (cons filename filename)])])
                            
-                           (cons (car main-cell)
+                            (cons (car main-cell)
-                                 (let* ([cell-content (cdr main-cell)]
+                                  (let* ([cell-content (cdr main-cell)]
-                                       [indent-padding (+ 1 indent-level)]
+                                         [indent-padding (+ 1 indent-level)]
-                                       [padding-attr `(class ,(format "indent_~a" indent-padding))])
+                                         [padding-attr `(class ,(format "indent_~a" indent-padding))])
-                                   (cond
+                                    (cond
-                                     [(string? cell-content) `(span (,padding-attr) ,cell-content)]
+                                      [(string? cell-content) `(span (,padding-attr) ,cell-content)]
-                                     [(txexpr? cell-content)
+                                      [(txexpr? cell-content)
-                                      ;; indent link text by depth in pagetree
+                                       ;; indent link text by depth in pagetree
-                                      `(,(get-tag cell-content) ,(cons padding-attr (get-attrs cell-content)) ,@(get-elements cell-content))]
+                                       `(,(get-tag cell-content) ,(cons padding-attr (get-attrs cell-content)) ,@(get-elements cell-content))]
-                                     [else (error 'make-path-row (format "mysterious cell data: ~v" cell-content))]))))
+                                      [else (error 'make-path-row (format "mysterious cell data: ~v" cell-content))]))))
                          
-                         (cond ; 'in' cell
+                          (cond ; 'in' cell
-                           [source  (cons (format "in/~a" source) "in")]
+                            [source  (cons (format "in/~a" source) "in")]
-                           [(or (pagetree-source? filename) (sourceish? filename))  (cons (format "in/~a" filename) "in")]
+                            [(or (pagetree-source? filename) (sourceish? filename))  (cons (format "in/~a" filename) "in")]
-                           [else empty-cell])
+                            [else empty-cell])
                          
-                         (cond ; 'out' cell 
+                          (cond ; 'out' cell 
-                           [(directory-exists? (build-path dashboard-dir filename)) (cons #f #f)]
+                            [(directory-exists? (build-path dashboard-dir filename)) (cons #f #f)]
-                           [(pagetree-source? filename) empty-cell]
+                            [(pagetree-source? filename) empty-cell]
-                           [else (cons (format "out/~a" filename) "out")]))))))
+                            [else (cons (format "out/~a" filename) "out")]))))))
   
   (define (ineligible-path? x) (member x (setup:paths-excluded-from-dashboard)))
   
@@ -223,32 +242,32 @@
           depth)))
   
   (apply body-wrapper #:title (format "~a" dashboard-dir)
-                (cons (make-parent-row) 
+         (cons (make-parent-row) 
-                          (cond
+               (cond
-                            [(not (null? project-paths))
+                 [(not (null? project-paths))
-                             (define path-source-pairs
+                  (define path-source-pairs
-                               (map
+                    (map
-                                (λ (p) (define source
+                     (λ (p) (define source
-                                        (let ([possible-source (get-source (build-path dashboard-dir p))])
+                              (let ([possible-source (get-source (build-path dashboard-dir p))])
-                                          (and possible-source (->string (find-relative-path dashboard-dir possible-source)))))
+                                (and possible-source (->string (find-relative-path dashboard-dir possible-source)))))
-                                  (cons p source))
+                       (cons p source))
-                                project-paths))
+                     project-paths))
                              
-                             (define-values (reversed-unique-path-source-pairs seen-paths) ; delete pairs with duplicate sources
+                  (define-values (reversed-unique-path-source-pairs seen-paths) ; delete pairs with duplicate sources
-                               (for/fold ([psps empty][seen-source-paths empty])
+                    (for/fold ([psps empty][seen-source-paths empty])
-                                         ([psp (in-list path-source-pairs)])
+                              ([psp (in-list path-source-pairs)])
-                                 (define source-path (cdr psp))
+                      (define source-path (cdr psp))
-                                 (if (and source-path (member source-path seen-source-paths))
+                      (if (and source-path (member source-path seen-source-paths))
-                                     (values psps seen-source-paths) ; skip the pair
+                          (values psps seen-source-paths) ; skip the pair
-                                     (values (cons psp psps) (cons source-path seen-source-paths)))))
+                          (values (cons psp psps) (cons source-path seen-source-paths)))))
                              
-                             (define unique-path-source-pairs (reverse reversed-unique-path-source-pairs))
+                  (define unique-path-source-pairs (reverse reversed-unique-path-source-pairs))
-                             (define filenames (map (compose1 ->string car) unique-path-source-pairs))
+                  (define filenames (map (compose1 ->string car) unique-path-source-pairs))
-                             (define sources (map cdr unique-path-source-pairs))
+                  (define sources (map cdr unique-path-source-pairs))
-                             (define indent-levels (map directory-pagetree-depth filenames))
+                  (define indent-levels (map directory-pagetree-depth filenames))
-                             (parameterize ([current-directory dashboard-dir])
+                  (parameterize ([current-directory dashboard-dir])
-                               (map make-path-row filenames sources indent-levels))]
+                    (map make-path-row filenames sources indent-levels))]
-                            [else (list '(row (cell ((class "no-files")) "No files yet in this directory") (td) (td)))]))))
+                 [else (list '(row (cell ((class "no-files")) "No files yet in this directory") (td) (td)))]))))
 
 (define route-dashboard (route-wrapper dashboard))
 
@@ -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)
+  ;; captures paths, strings, "unsaved editor", path-strings, symbols
-      (syntax-source source-name)
+  ((if (syntax? source-name) syntax-source values) source-name))
-      ;; captures paths, strings, "unsaved editor", path-strings, symbols
-      source-name))
 
 (define (infer-parser-mode reader-mode reader-here-path)
-  (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,44 +73,44 @@
 (define ((custom-get-info mode) in mod line col pos)
   ;; DrRacket caches source file information per session,
   ;; so we can do the same to avoid multiple searches for the command char.
-  (let ([command-char-cache (make-hash)])
+  (define command-char-cache (make-hash))
-    (λ (key default)
+  (λ (key default)
-      (case key
+    (case key
-        [(color-lexer drracket:toolbar-buttons) ; only do source-path searching if we have one of these keys
+      ;; only do source-path searching if we have one of these two keys
-         (define maybe-source-path (with-handlers ([exn:fail? (λ (exn) #f)])
+      [(color-lexer drracket:toolbar-buttons) 
-                                     ;; Robert Findler does not endorse `get-filename` here,
+       (define maybe-source-path
-                                     ;; because it's sneaky and may not always work.
+         (with-handlers ([exn:fail? (λ (exn) #false)])
-                                     ;; OTOH Scribble relies on it, so IMO it's highly unlikely to change.
+           ;; Robert Findler does not endorse `get-filename` here,
-                                     (let ([maybe-definitions-frame (object-name in)])
+           ;; because it's sneaky and may not always work.
-                                       (send maybe-definitions-frame get-filename)))) ; will be #f if unsaved file
+           ;; OTOH Scribble relies on it, so IMO it's highly unlikely to change.
-         (define my-command-char (hash-ref! command-char-cache maybe-source-path (λ _ (setup:command-char maybe-source-path))))
+           (send (object-name in) get-filename)))
-         (case key
+       (define my-command-char
-           [(color-lexer)
+         (hash-ref! command-char-cache maybe-source-path (λ () (setup:command-char maybe-source-path))))
-            (define my-make-scribble-inside-lexer
+       (case key
-              (dynamic-require 'syntax-color/scribble-lexer 'make-scribble-inside-lexer (λ () #f)))
+         [(color-lexer)
-            (if my-make-scribble-inside-lexer
+          (match (dynamic-require 'syntax-color/scribble-lexer 'make-scribble-inside-lexer (λ () #false))
-                (my-make-scribble-inside-lexer #:command-char my-command-char)
+            [(? procedure? make-lexer) (make-lexer #:command-char my-command-char)]
-                default)]
+            [_ default])]
-           [(drracket:toolbar-buttons)
+         [(drracket:toolbar-buttons)
-            (define my-make-drracket-buttons (dynamic-require 'pollen/private/drracket-buttons 'make-drracket-buttons))
+          (match (dynamic-require 'pollen/private/drracket-buttons 'make-drracket-buttons (λ () #false))
-            (my-make-drracket-buttons my-command-char)])]
+            [(? procedure? make-buttons) (make-buttons my-command-char)])])]
-        [(drracket:indentation)
+      [(drracket:indentation)
-         (dynamic-require 'scribble/private/indentation 'determine-spaces)]
+       (dynamic-require 'scribble/private/indentation 'determine-spaces)]
-        [(drracket:default-filters)
+      [(drracket:default-filters)
-         ;; derive this from `module-suffixes` entry in main info.rkt file
+       ;; derive this from `module-suffixes` entry in main info.rkt file
-         (define module-suffixes ((get-info/full info-dir) 'module-suffixes))
+       (define module-suffixes ((get-info/full info-dir) 'module-suffixes))
-         (define filter-strings (for/list ([suffix (in-list module-suffixes)])
+       (define filter-strings (for/list ([suffix (in-list module-suffixes)])
-                                          (format "*.~a" suffix)))
+                                        (format "*.~a" suffix)))
-         (list (list "Pollen sources" (string-join filter-strings ";")))]
+       (list (list "Pollen sources" (string-join filter-strings ";")))]
-        [(drracket:default-extension)
+      [(drracket:default-extension)
-         (symbol->string
+       (symbol->string
-          (cond
+        (match mode
-            [(eq? mode default-mode-auto) (setup:preproc-source-ext)]
+          [(== default-mode-auto) (setup:preproc-source-ext)]
-            [(eq? mode default-mode-preproc) (setup:preproc-source-ext)]
+          [(== default-mode-preproc) (setup:preproc-source-ext)]
-            [(eq? mode default-mode-markdown) (setup:markdown-source-ext)]
+          [(== default-mode-markdown) (setup:markdown-source-ext)]
-            [(eq? mode default-mode-markup) (setup:markup-source-ext)]
+          [(== default-mode-markup) (setup:markup-source-ext)]
-            [(eq? mode default-mode-pagetree) (setup:pagetree-source-ext)]))]
+          [(== default-mode-pagetree) (setup:pagetree-source-ext)]))]
-        [else default]))))
+      [else default])))
 
 (define-syntax-rule (reader-module-begin mode . _)
   (#%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))
-      (if (memq parser-mode (list default-mode-preproc default-mode-template))
+        (display doc)
-          (display doc)
+        (with-handlers ([exn:fail? my-error-handler])
-          ;; #:newline option for `pretty-print` was introduced in 6.6.0.3,
+          (my-pretty-print (validate-txexpr doc))))))
-          ;; so trim trailing newline manually
-          (let ([pretty-print-proc (if (version<? (version) "6.7")
-                                       (λ (x) (display (string-trim #:left? #f (with-output-to-string (λ () (pretty-print x))) "\n")))
-                                       (λ (x) (pretty-print #:newline? #f x)))])
-            ;; OK to use dynamic-require because runtime-config itself is dynamic-required
-            (pretty-print-proc (with-handlers ([exn:fail? (λ (exn) ((error '|pollen markup error|
-                                                                           ((dynamic-require 'racket/string 'string-join) (cdr ((dynamic-require 'racket/string 'string-split) (exn-message exn) ": ")) ": "))))])
-                                 ((dynamic-require 'txexpr/base 'validate-txexpr) doc))))))))
 
 (define (configure top-here-path)
-  (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-readtable (make-at-readtable #:command-char (setup:command-char)))
+  (define (pollen-repl-read src in)
-  (define (new-read src in)
+    ;; wrap repl interactions with pollen expression support
+    (define pollen-readtable (make-at-readtable #:command-char (setup:command-char)))
     (parameterize ([current-readtable pollen-readtable])
       (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")))
 
 
+;; this will strip all empty lists.
+;; in practice, they would only appear in attrs position 
 (define (strip-empty-attrs x)
   (let loop ([x x])
-    (if (list? x)
+    (if (pair? x)
-        ;; this will strip all empty lists.
+        (map loop (filter-not null? x))
-        ;; in practice, they would only appear in attrs position 
-        (map loop (filter (λ (x) (not (null? x))) x))
         x)))
 
-
 (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 @@
-1537996006
+1540858431

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,34 +1,29 @@
 #lang racket/base
+(require racket/match)
 (provide (all-defined-out))
 
 (define (whitespace-base x #:nbsp-is-white? nbsp-white?)
-  (define pat (pregexp (format "^[\\s~a]+$" (if nbsp-white? #\u00A0 ""))))
+  (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)
+  (require rackunit racket/format)
- (check-true (whitespace? " "))
+  (check-true (whitespace? " "))
- (check-false (whitespace? (~a #\u00A0)))
+  (check-false (whitespace? (~a #\u00A0)))
- (check-true (whitespace/nbsp? (~a #\u00A0)))
+  (check-true (whitespace/nbsp? (~a #\u00A0)))
- (check-true (whitespace/nbsp? (vector (~a #\u00A0))))
+  (check-true (whitespace/nbsp? (vector (~a #\u00A0))))
- (check-false (whitespace? (format " ~a " #\u00A0)))
+  (check-false (whitespace? (format " ~a " #\u00A0)))
- (check-true (whitespace/nbsp? (format " ~a " #\u00A0))))
+  (check-true (whitespace/nbsp? (format " ~a " #\u00A0))))

pollen/render.rkt

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

@@ -149,7 +149,9 @@ If the cache can't find a certain file on the watchlist, it will be ignored. The
 
 @defoverridable[index-pages (listof string?)]{List of strings that the project server will use as directory default pages, in order of priority. Has no effect on command-line rendering operations. Also has no effect on your live web server (usually  that's a setting you need to make in an @tt{.htaccess} configuration file).} But with this setting, you can simulate the behavior of your live server, so that internal index-page URLs work correctly.
 
- 
+ @defoverridable[trim-whitespace? boolean?]{Predicate that controls whether the Pollen source reader trims whitespace from the beginning of a @racket[doc] export. You might set this to @racket[#false] if you're using Pollen as a preprocessor for another programming language and you want to preserve leading whitespace accurately.
+
+ @pollen-history[#:added "1.5"]}
 
 
 @section{Parameters}

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)     
+   (λ (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/data/whitespace/pollen.rkt

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

pollen/test/data/whitespace/whitespace-test.txt.pp

@@ -0,0 +1,10 @@
+#lang pollen
+
+
+
+
+
+
+
+
+one

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/test/test-trim-whitespace.rkt

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

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