mbutterick
/
pollen
3
3
Fork 0
Code Issues 1 Pull Requests Projects Releases Wiki Activity

speed improvements

Browse Source
pull/9/head
Matthew Butterick 11 years ago
parent 4218102aed
commit 236b810fe6
5 changed files with 59 additions and 82 deletions
Show Stats Download Patch File Download Diff File

3
decode/typography-fast.rkt
Unescape Escape View File

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

20
lang/inner-lang-helper.rkt
Unescape Escape View File

@ -70,7 +70,7 @@
; ;
; Copied out from racket/path to avoid import ; 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 (do-explode-path who orig-path)
(define l (explode-path 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) (define-syntax (get-here-path stx)
#'(begin #'(begin

6
main.rkt
Unescape Escape View File

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

51
ptree.rkt
Unescape Escape View File

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

55
render.rkt
Unescape Escape View File

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

Write Preview
Loading…
Cancel
Save