speed improvements

decode/typography-fast.rkt

@@ -151,11 +151,10 @@
 
 
 ;; recursive whitespace test
-(define (whitespace? x)
-  
+(define (whitespace? x)  
   (cond
-    [(or (string? x) (symbol? x)) (->boolean (regexp-match #px"^\\s+$" (->string x)))]
     [(equal? "" x) #t] ; empty string is deemed whitespace
+    [(or (string? x) (symbol? x)) (->boolean (regexp-match #px"^\\s+$" (->string x)))]
     [(or (list? x) (vector? x)) (andmap whitespace? (->list x))]
     [else #f]))
 

lang/inner-lang-helper.rkt

@@ -70,7 +70,7 @@
 ;
 ; Copied out from racket/path to avoid import
 ;
-(define (find-relative-path directory filename #:more-than-root? [more-than-root? #f])
+(define (pollen-find-relative-path directory filename #:more-than-root? [more-than-root? #f])
   
   (define (do-explode-path who orig-path)
     (define l (explode-path orig-path))
@@ -104,24 +104,6 @@
 
 
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;
-; Copied out from racket/list to avoid import
-;
-(define (filter-not f list)
-  (unless (and (procedure? f)
-               (procedure-arity-includes? f 1))
-    (raise-argument-error 'filter-not "(any/c . -> . any/c)" 0 f list))
-  (unless (list? list)
-    (raise-argument-error 'filter-not "list?" 1 f list))
-  ;; accumulating the result and reversing it is currently slightly
-  ;; faster than a plain loop
-  (let loop ([l list] [result null])
-    (if (null? l)
-      (reverse result)
-      (loop (cdr l) (if (f (car l)) result (cons (car l) result))))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
 
 (define-syntax (get-here-path stx)
   #'(begin 

main.rkt

@@ -25,7 +25,7 @@
      
      ;; Build 'inner-here-path and 'inner-here
      (define (here-path->here here-path)
-       (path->string (path-replace-suffix (find-relative-path PROJECT_ROOT here-path) "")))
+       (path->string (path-replace-suffix (pollen-find-relative-path PROJECT_ROOT here-path) "")))
      (define inner-here-path (get-here-path))
      (define inner-here (here-path->here inner-here-path))
      
@@ -36,7 +36,7 @@
    (require 'inner)
    
    ;; Split out the metas.   
-   (require txexpr/fast)   
+   (require txexpr)   
    (define (split-metas-to-hash tx)
      ;; return tx without metas, and meta hash
      (define is-meta-element? (λ(x) (and (txexpr? x) (equal? 'meta (car x)))))
@@ -55,7 +55,7 @@
    
    
    ;; set up the 'main export
-   (require pollen/decode/fast)
+   (require pollen/decode)
    (define here-ext (car (regexp-match #px"\\w+$" inner-here-path)))
    (define wants-decoder? (member here-ext (map to-string DECODABLE_EXTENSIONS)))
    (define main (apply (cond

ptree.rkt

@@ -1,17 +1,17 @@
 #lang racket/base
-(require racket/contract racket/match racket/path xml/path racket/bool racket/rerequire)
-(require "tools.rkt" "world.rkt" "debug.rkt" "decode.rkt" sugar txexpr)
+(require (for-syntax racket/base))
+(require racket/path racket/bool racket/rerequire racket/contract)
+(require "tools.rkt" "world.rkt" "decode.rkt" sugar txexpr)
 
 (module+ test (require rackunit))
 
-(provide pnode? ptree? parent children previous next pnode->url ptree-source-decode path->pnode ptree->list file->ptree make-project-ptree current-ptree current-url-context)
 
-(define/contract (pnode? x)
+(define+provide/contract (pnode? x)
   (any/c . -> . boolean?)
   (try (not (whitespace? (->string x)))
        (except [exn:fail? (λ(e) #f)])))
 
-(define/contract (pnode?/error x)
+(define+provide/contract (pnode?/error x)
   (any/c . -> . boolean?)
   (or (pnode? x) (error "Not a valid pnode:" x)))
 
@@ -26,7 +26,7 @@
   (check-false (pnode? " ")))
 
 
-(define/contract (ptree? x)
+(define+provide/contract (ptree? x)
   (any/c . -> . boolean?)
   (and (txexpr? x) (andmap (λ(i) (or (pnode? i) (ptree? i))) x)))
 
@@ -45,21 +45,20 @@
   (and (hash-has-key? ptree-source-mod-dates ptree-source-path) 
        ((file-or-directory-modify-seconds ptree-source-path) . = . (hash-ref ptree-source-mod-dates ptree-source-path))))
 
-(define/contract (file->ptree p)
+(define+provide/contract (file->ptree p)
   (pathish? . -> . ptree?)
   (define path (->path p))
 ;;  (message "Loading ptree file" (->string (file-name-from-path path)))
   (dynamic-rerequire path)
   (dynamic-require path MAIN_POLLEN_EXPORT))
 
-(define/contract (directory->ptree dir)
+(define+provide/contract (directory->ptree dir)
   (directory-pathish? . -> . ptree?)
   (let ([files (map remove-ext (filter (λ(x) (has-ext? x DECODER_SOURCE_EXT)) (directory-list dir)))])
-    (message "Generating ptree from file listing of" dir)
     (ptree-root->ptree (cons PTREE_ROOT_NODE files))))
 
 ;; Try loading from ptree file, or failing that, synthesize ptree.
-(define/contract (make-project-ptree project-dir)
+(define+provide/contract (make-project-ptree project-dir)
   (directory-pathish? . -> . ptree?)
   (define ptree-source (build-path project-dir DEFAULT_PTREE))
   (if (file-exists? ptree-source)
@@ -77,7 +76,7 @@
                   `(POLLEN_TREE_ROOT_NAME "foo" "bar" (one (two "three"))))))
 
 
-(define/contract (parent pnode [ptree (current-ptree)])
+(define+provide/contract (parent pnode [ptree (current-ptree)])
   (((or/c false? pnode?)) (ptree?) . ->* . (or/c false? pnode?)) 
   (and pnode
        (if (member (->string pnode) (map (λ(x) (->string (if (list? x) (car x) x))) (cdr ptree)))
@@ -94,7 +93,7 @@
   (check-false (parent 'nonexistent-name test-ptree)))
 
 
-(define/contract (children pnode [ptree (current-ptree)])
+(define+provide/contract (children pnode [ptree (current-ptree)])
   (((or/c false? pnode?)) (ptree?) . ->* . (or/c false? (listof pnode?)))  
   (and pnode 
        (if (equal? (->string pnode) (->string (car ptree)))
@@ -109,7 +108,7 @@
   (check-false (children 'fooburger test-ptree)))
 
 
-(define/contract (siblings pnode [ptree (current-ptree)])
+(define+provide/contract (siblings pnode [ptree (current-ptree)])
   (((or/c false? pnode?)) (ptree?) . ->* . (or/c false? (listof string?)))  
   (children (parent pnode ptree) ptree))
 
@@ -124,7 +123,7 @@
 
 
 ;; flatten tree to sequence
-(define/contract (ptree->list [ptree (current-ptree)])
+(define+provide/contract (ptree->list [ptree (current-ptree)])
   (ptree? . -> . (listof string?))
   ; use cdr to get rid of root tag at front
   (map ->string (cdr (flatten ptree)))) 
@@ -134,14 +133,15 @@
 
 
 
-(define (adjacents side pnode [ptree (current-ptree)])
+(define+provide/contract (adjacents side pnode [ptree (current-ptree)])
+  ((symbol? (or/c false? pnode?)) (ptree?) . ->* . (or/c false? (listof pnode?)))
   (and pnode
        (let* ([proc (if (equal? side 'left) takef takef-right)]
               [result (proc (ptree->list ptree) (λ(x) (not (equal? (->string pnode) (->string x)))))])
          (and (not (empty? result)) result))))
 
 
-(define/contract (left-adjacents pnode [ptree (current-ptree)]) 
+(define+provide/contract (left-adjacents pnode [ptree (current-ptree)]) 
   (((or/c false? pnode?)) (ptree?) . ->* . (or/c false? (listof pnode?)))
   (adjacents 'left pnode ptree))
 
@@ -150,11 +150,11 @@
   (check-equal? (left-adjacents 'three test-ptree) '("foo" "bar" "one" "two"))
   (check-false (left-adjacents 'foo test-ptree)))
 
-(define/contract (right-adjacents pnode [ptree (current-ptree)]) 
+(define+provide/contract (right-adjacents pnode [ptree (current-ptree)]) 
   (((or/c false? pnode?)) (ptree?) . ->* . (or/c false? (listof pnode?)))
   (adjacents 'right pnode ptree))
 
-(define/contract (previous pnode [ptree (current-ptree)])
+(define+provide/contract (previous pnode [ptree (current-ptree)])
   (((or/c false? pnode?)) (ptree?) . ->* . (or/c false? pnode?))
   (let ([result (left-adjacents pnode ptree)])
     (and result (last result))))
@@ -165,7 +165,7 @@
   (check-false (previous 'foo test-ptree)))
 
 
-(define (next pnode [ptree (current-ptree)])
+(define+provide/contract (next pnode [ptree (current-ptree)])
   (((or/c false? pnode?)) (ptree?) . ->* . (or/c false? pnode?))
   (let ([result (right-adjacents pnode ptree)])
     (and result (first result))))
@@ -178,7 +178,7 @@
 
 
 ;; this is a helper function to permit unit tests
-(define (pnode->url/paths pnode url-list)
+(define+provide (pnode->url/paths pnode url-list)
   ;; check for duplicates because some sources might have already been rendered
   (define output-paths (remove-duplicates (map ->output-path url-list) equal?))
   (define matching-paths (filter (λ(x) (equal? (->string x) (->string pnode))) output-paths))
@@ -196,7 +196,7 @@
   (check-false (pnode->url/paths 'hee files)))
 
 
-(define/contract (pnode->url pnode [url-context (current-url-context)])
+(define+provide/contract (pnode->url pnode [url-context (current-url-context)])
   ((pnode?) (pathish?) . ->* . (or/c false? pnode?))
   (parameterize ([current-url-context url-context])
     (pnode->url/paths pnode (directory-list (current-url-context)))))
@@ -205,7 +205,7 @@
 
 
 ;; this sets default input for following functions
-(define/contract (ptree-root->ptree tx)
+(define+provide/contract (ptree-root->ptree tx)
   ;; (not/c ptree) prevents ptrees from being accepted as input
   ((and/c txexpr?) . -> . ptree?)
   tx)
@@ -217,13 +217,13 @@
                 `(,PTREE_ROOT_NODE "foo" "bar" (one (two "three")))))
 
 
-(define/contract (pnodes-unique?/error x)
+(define+provide/contract (pnodes-unique?/error x)
   (any/c . -> . boolean?)
   (define members (filter-not whitespace? (flatten x)))
   (and (andmap pnode?/error members)
        (members-unique?/error (map ->string members))))
 
-(define/contract (ptree-source-decode . elements)
+(define+provide/contract (ptree-source-decode . elements)
   (() #:rest pnodes-unique?/error . ->* . ptree?)
   (ptree-root->ptree (decode (cons PTREE_ROOT_NODE elements)
                              #:xexpr-elements-proc (λ(xs) (filter-not whitespace? xs)))))
@@ -231,10 +231,11 @@
 
 (define current-ptree (make-parameter `(,PTREE_ROOT_NODE)))
 (define current-url-context (make-parameter PROJECT_ROOT))
+(provide current-ptree current-url-context)
 
 
 ;; used to convert here-path into here
-(define/contract (path->pnode path)
+(define+provide/contract (path->pnode path)
   (pathish? . -> . pnode?)
   (->string (->output-path (find-relative-path PROJECT_ROOT (->path path)))))
 

render.rkt

@@ -1,5 +1,6 @@
 #lang racket/base
 (require racket/port racket/file racket/rerequire racket/contract racket/path)
+(require sugar)
 
 (module+ test (require rackunit))
 
@@ -33,9 +34,10 @@
   (and (file-exists? path) ; returns #f if a file doesn't exist
        (file-or-directory-modify-seconds path)))
 
+
 (module+ test
   (check-false (path->mod-date-value (->path "foobarfoo.rkt")))
-  (check-true (exact-integer? (path->mod-date-value (build-path (current-directory) (->path "render.rkt"))))))
+  (check-true (exact-integer? (path->mod-date-value (build-path (current-directory) (string->path "render.rkt"))))))
 
 ;; put list of paths into mod-dates
 ;; need list as input (rather than individual path)
@@ -280,81 +282,74 @@
 ;; cache some modules inside this namespace so they can be shared by namespace for eval
 ;; todo: macrofy this to avoid repeating names
 (require web-server/templates 
-         xml/path
+         xml
          racket/port 
          racket/file 
          racket/rerequire 
          racket/contract 
          racket/list
-         xml/path
+         racket/match
          pollen/debug
          pollen/decode
          pollen/file-tools
+         pollen/main
+         pollen/lang/inner-lang-helper
          pollen/predicates
          pollen/ptree
          sugar
+         txexpr
          pollen/template
          pollen/tools
+         ;; not pollen/top, because we don't want it in the current ns
          pollen/world
          pollen/project-requires)
 (define original-ns (current-namespace))
 
-(define/contract (render-through-eval base-dir eval-string)
-  (directory-pathish? list? . -> . string?)
-  (parameterize ([current-namespace (make-base-empty-namespace)]
+(define (render-through-eval base-dir eval-string)
+  ; (directory-pathish? list? . -> . string?)
+  (parameterize ([current-namespace (make-base-namespace)]
                  [current-directory (->complete-path base-dir)]
-                 [current-output-port (current-error-port)])
-    ;; attach already-imported modules 
-    ;; this is a performance optimization: this way,
-    ;; the eval namespace doesn't have to re-import these
-    ;; because otherwise, most of its time is spent traversing imports.
+                 [current-output-port (current-error-port)]
+                 [current-ptree (make-project-ptree PROJECT_ROOT)]
+                 [current-url-context PROJECT_ROOT])
     (for-each (λ(mod-name) (namespace-attach-module original-ns mod-name)) 
               '(web-server/templates 
-                xml/path
+                xml
                 racket/port 
                 racket/file 
                 racket/rerequire 
                 racket/contract 
                 racket/list
+                racket/match
                 pollen/debug
                 pollen/decode
                 pollen/file-tools
+                pollen/main
+                pollen/lang/inner-lang-helper
                 pollen/predicates
                 pollen/ptree
                 sugar
+                txexpr
                 pollen/template
                 pollen/tools
                 pollen/world
-                pollen/project-requires))
-    (namespace-require 'racket/base) ; use namespace-require for FIRST require, then eval after
-    
+                pollen/project-requires))   
     (eval eval-string (current-namespace))))
 
-(define/contract (render-source-with-template source-path template-path)
-  (file-exists? file-exists? . -> . string?)
-  
-  ;; set up information about source and template paths
-  ;; todo: how to write these without blanks?
-  (define-values (source-dir source-name _) (split-path source-path))
-  (define-values (___ template-name __) (split-path template-path))
+
+(define (render-source-with-template source-path template-path)
+  ;  (file-exists? file-exists? . -> . string?)
   
-  ;; Templates are part of the compile operation.
-  ;; Therefore no way to arbitrarily invoke template at run-time.
-  ;; This routine creates a new namespace and compiles the template within it.
+  (match-define-values (source-dir source-name _) (split-path source-path))
+  (match-define-values (_ template-name _) (split-path template-path))
   
   (define string-to-eval 
     `(begin 
-       ;; enables macrofication
        (require (for-syntax racket/base))
-       ;; for include-template (used below)
        (require web-server/templates)
-       ;; for ptree navigation functions, and template commands
        (require pollen/debug pollen/ptree pollen/template pollen/top)
-       ;; import source into eval space. This sets up main & metas
        (require ,(->string source-name))
-       (parameterize ([current-ptree (make-project-ptree ,PROJECT_ROOT)]
-                      [current-url-context ,PROJECT_ROOT])
-         (include-template #:command-char ,TEMPLATE_FIELD_DELIMITER ,(->string template-name)))))
+       (include-template #:command-char ,TEMPLATE_FIELD_DELIMITER ,(->string template-name))))
   
   (render-through-eval source-dir string-to-eval))