From 382023f61f264576c1fdc612ae912bec1e45055a Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 14 Oct 2013 17:59:59 -0700 Subject: [PATCH] performance improvements: cache modules in main render-module namespace and share them with eval namespace used for the rendering --- main-preproc.rkt | 4 +- main.rkt | 4 +- ptree-decode.rkt | 1 - ptree-nav.rkt | 231 +++++++++++++++++++++++++++++++++++++++++++++++ ptree.rkt | 225 +-------------------------------------------- render.rkt | 74 +++++++++++---- template.rkt | 4 +- tools.rkt | 8 +- 8 files changed, 300 insertions(+), 251 deletions(-) create mode 100644 ptree-nav.rkt diff --git a/main-preproc.rkt b/main-preproc.rkt index 6acf784..627304d 100644 --- a/main-preproc.rkt +++ b/main-preproc.rkt @@ -1,10 +1,10 @@ -#lang racket/base +#lang racket (require (only-in (planet mb/pollen/readability) ->list) (only-in (planet mb/pollen/tools) trim) (only-in (planet mb/pollen/predicates) whitespace?)) -(provide (except-out (all-from-out racket/base) #%module-begin) +(provide (except-out (all-from-out racket) #%module-begin) (rename-out [module-begin #%module-begin])) (require (only-in scribble/text output) diff --git a/main.rkt b/main.rkt index 6231854..747df65 100644 --- a/main.rkt +++ b/main.rkt @@ -1,9 +1,9 @@ -#lang racket/base +#lang racket (require racket/list) (require (planet mb/pollen/tools) (planet mb/pollen/main-helper)) (require (only-in (planet mb/pollen/ptree-decode) ptree-source-decode)) (require (only-in (planet mb/pollen/predicates) ptree?)) -(provide (except-out (all-from-out racket/base) #%module-begin) +(provide (except-out (all-from-out racket) #%module-begin) (rename-out [module-begin #%module-begin])) (define-syntax-rule (module-begin expr ...) diff --git a/ptree-decode.rkt b/ptree-decode.rkt index 7ff7fe4..9b32f67 100644 --- a/ptree-decode.rkt +++ b/ptree-decode.rkt @@ -7,7 +7,6 @@ (provide (all-defined-out)) ;; These functions need to be separated so that they can be accessed by pollen parser (in main.rkt) -;; Other ptree functions are in ptree.rkt. ;; ptree decoder takes ptree source and returns a full ptree structure. ;; recursively processes tree, converting tree locations & their parents into xexprs of this shape: diff --git a/ptree-nav.rkt b/ptree-nav.rkt new file mode 100644 index 0000000..b84cdbb --- /dev/null +++ b/ptree-nav.rkt @@ -0,0 +1,231 @@ +#lang racket/base +(require xml/path racket/contract) +(require "tools.rkt" "world.rkt" "ptree-decode.rkt" "debug.rkt") + +(module+ test (require rackunit)) + +(provide (all-defined-out)) + +;; These functions are separated so that they can be cached outside by pollen page renderer + +;; remove parents from tree (i.e., just remove attrs) +;; is not the inverse of add-parents, i.e., you do not get back your original input. +(define/contract (remove-parents mt) + (ptree? . -> . tagged-xexpr?) + (remove-attrs mt)) + +(module+ test + (check-equal? (remove-parents + `(ptree-main ((,POLLEN_TREE_PARENT_NAME "")) (foo ((,POLLEN_TREE_PARENT_NAME ""))) (bar ((,POLLEN_TREE_PARENT_NAME ""))) (one ((,POLLEN_TREE_PARENT_NAME "")) (two ((,POLLEN_TREE_PARENT_NAME "one")) (three ((,POLLEN_TREE_PARENT_NAME "two"))))))) + '(ptree-main (foo) (bar) (one (two (three)))))) + + +(module+ test + (let ([sample-main `(POLLEN_TREE_ROOT_NAME "foo" "bar" (one (two "three")))]) + (check-equal? (ptree-root->ptree sample-main) + `(POLLEN_TREE_ROOT_NAME ((,POLLEN_TREE_PARENT_NAME "")) (foo ((,POLLEN_TREE_PARENT_NAME "POLLEN_TREE_ROOT_NAME"))) (bar ((,POLLEN_TREE_PARENT_NAME "POLLEN_TREE_ROOT_NAME"))) (one ((,POLLEN_TREE_PARENT_NAME "POLLEN_TREE_ROOT_NAME")) (two ((,POLLEN_TREE_PARENT_NAME "one")) (three ((,POLLEN_TREE_PARENT_NAME "two"))))))))) + + + +;; return the parent of a given name +(define/contract (parent pnode [ptree project-ptree]) + ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) + (and pnode (let ([result (se-path* `(,(->symbol pnode) #:parent) ptree)]) + (and result (->string result))))) ; se-path* returns #f if nothing found + + +(module+ test + (define test-ptree-main `(ptree-main "foo" "bar" (one (two "three")))) + (define test-ptree (ptree-root->ptree test-ptree-main)) + (check-equal? (parent 'three test-ptree) "two") + (check-equal? (parent "three" test-ptree) "two") + (check-false (parent 'nonexistent-name test-ptree))) + + + +; get children of a particular pnode +(define/contract (children pnode [ptree project-ptree]) + ((pnode?) (ptree?) . ->* . (or/c list? boolean?)) + ;; se-path*/list returns '() if nothing found + (and pnode (let ([children (se-path*/list `(,(->symbol pnode)) ptree)]) + ; If there are sublists, just take first pnode + (and (not (empty? children)) (map (λ(i) (->string (if (list? i) (car i) i))) children))))) + +(module+ test + (check-equal? (children 'one test-ptree) (list "two")) + (check-equal? (children 'two test-ptree) (list "three")) + (check-false (children 'three test-ptree)) + (check-false (children 'fooburger test-ptree))) + + +;; find all siblings on current level: go up to parent and ask for children +(define/contract (siblings pnode [ptree project-ptree]) + ;; this never returns false: pnode is always a sibling of itself. + ;; todo: how to use input value in contract? e.g., to check that pnode is part of output list + ((pnode?) (ptree?) . ->* . (or/c list? boolean?)) + (children (parent pnode ptree) ptree)) + +(module+ test + (check-equal? (siblings 'one test-ptree) '("foo" "bar" "one")) + (check-equal? (siblings 'foo test-ptree) '("foo" "bar" "one")) + (check-equal? (siblings 'two test-ptree) '("two")) + (check-false (siblings 'invalid-key test-ptree))) + + + +(define/contract (siblings-split pnode [ptree project-ptree]) + ((pnode?) (ptree?) . ->* . (values (or/c (listof pnode?) boolean?) + (or/c (listof pnode?) boolean?))) + (let-values ([(left right) (splitf-at (siblings pnode ptree) + (λ(e) (not (equal? (->string e) (->string pnode)))))]) + (values (if (empty? left) #f left) (if (empty? (cdr right)) #f (cdr right))))) + +(module+ test + (check-equal? (values->list (siblings-split 'one test-ptree)) '(("foo" "bar") #f)) + (check-equal? (values->list (siblings-split 'bar test-ptree)) (list '("foo") '("one")))) + + +;; siblings to the left of target pnode (i.e., precede in tree order) +(define (siblings-left pnode [ptree project-ptree]) + (let-values ([(left right) (siblings-split pnode ptree)]) + left)) + +(module+ test + (check-equal? (siblings-left 'one test-ptree) '("foo" "bar")) + (check-false (siblings-left 'foo test-ptree))) + +;; siblings to the right of target pnode (i.e., follow in tree order) +(define (siblings-right pnode [ptree project-ptree]) + (let-values ([(left right) (siblings-split pnode ptree)]) + right)) + +(module+ test + (check-false (siblings-right 'one test-ptree)) + (check-equal? (siblings-right 'foo test-ptree) '("bar" "one"))) + + +;; get pnode immediately to the left in tree +(define/contract (sibling-previous pnode [ptree project-ptree]) + ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) + (let ([siblings (siblings-left pnode ptree)]) + (and siblings (last siblings)))) + +(module+ test + (check-equal? (sibling-previous 'bar test-ptree) "foo") + (check-false (sibling-previous 'foo test-ptree))) + +;; get pnode immediately to the right in tree +(define/contract (sibling-next pnode [ptree project-ptree]) + ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) + (let ([siblings (siblings-right pnode ptree)]) + (and siblings (first siblings)))) + +(module+ test + (check-equal? (sibling-next 'foo test-ptree) "bar") + (check-false (sibling-next 'one test-ptree))) + + +;; flatten tree to sequence +(define/contract (all-pages [ptree project-ptree]) + (ptree? . -> . (listof string?)) + ; use cdr to get rid of root tag at front + (map ->string (cdr (flatten (remove-parents ptree))))) + +(module+ test + (check-equal? (all-pages test-ptree) '("foo" "bar" "one" "two" "three"))) + +;; helper function for get-previous-pages and get-next-pages +(define/contract (adjacent-pages side pnode [ptree project-ptree]) + ((symbol? pnode?) (ptree?) . ->* . (or/c list? boolean?)) + (let ([result ((if (equal? side 'left) + takef + takef-right) (all-pages ptree) + (λ(y) (not (equal? (->string pnode) (->string y)))))]) + (and (not (empty? result)) result))) + +(module+ test + (check-equal? (adjacent-pages 'left 'one test-ptree) '("foo" "bar")) + (check-equal? (adjacent-pages 'left 'three test-ptree) '("foo" "bar" "one" "two")) + (check-false (adjacent-pages 'left 'foo test-ptree))) + + +;; get sequence of earlier pages +(define/contract (previous-pages pnode [ptree project-ptree]) + ((pnode?) (ptree?) . ->* . (or/c list? boolean?)) + (adjacent-pages 'left pnode ptree)) + +(module+ test + (check-equal? (previous-pages 'one test-ptree) '("foo" "bar")) + (check-equal? (previous-pages 'three test-ptree) '("foo" "bar" "one" "two")) + (check-false (previous-pages 'foo test-ptree))) + + +;; get sequence of next pages +(define (next-pages pnode [ptree project-ptree]) + ((pnode?) (ptree?) . ->* . (or/c list? boolean?)) + (adjacent-pages 'right pnode ptree)) + +(module+ test + (check-equal? (next-pages 'foo test-ptree) '("bar" "one" "two" "three")) + (check-equal? (next-pages 'one test-ptree) '("two" "three")) + (check-false (next-pages 'three test-ptree))) + +;; get page immediately previous +(define/contract (previous-page pnode [ptree project-ptree]) + ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) + (let ([result (previous-pages pnode ptree)]) + (and result (last result)))) + +(module+ test + (check-equal? (previous-page 'one test-ptree) "bar") + (check-equal? (previous-page 'three test-ptree) "two") + (check-false (previous-page 'foo test-ptree))) + +;; get page immediately next +(define (next-page pnode [ptree project-ptree]) + ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) + (let ([result (next-pages pnode ptree)]) + (and result (first result)))) + +(module+ test + (check-equal? (next-page 'foo test-ptree) "bar") + (check-equal? (next-page 'one test-ptree) "two") + (check-false (next-page 'three test-ptree))) + +;; convert path to pnode +;; used for converting "here" values to pnodes +(define/contract (path->pnode x) + (pathish? . -> . pnode?) + (->string (remove-all-ext (last (explode-path (->path x)))))) + +(module+ test + (check-equal? (path->pnode "bar") "bar") + (check-equal? (path->pnode "foo/bar") "bar") + (check-equal? (path->pnode "foo/bar.html") "bar") + (check-equal? (path->pnode "/Users/this/that/foo/bar.html.pp") "bar")) + +(define here->pnode path->pnode) + +(define/contract (pnode->url pnode) + (pnode? . -> . string?) + (define files (directory-list START_DIR)) + (define (source-matches-pnode? x) + ;; todo: consider this test further. + ;; could pnode refer to files without pollen source? + ;; if so, the test is too narrow. + (and (x . starts-with? . pnode) (pollen-source? x))) + (define file-matches (filter source-matches-pnode? files)) + (if ((length file-matches) . > . 1) + (error "Duplicate source files for pnode" pnode) + (->string (->output-path (car file-matches))))) + +;; todo: make tests + + +;; this project setup must follow definitions to prevent undefined errors +(define project-ptree empty) + +(define/contract (set-project-ptree new-tree) + (ptree? . -> . void?) + (set! project-ptree new-tree)) + diff --git a/ptree.rkt b/ptree.rkt index 997fa89..b4815c5 100644 --- a/ptree.rkt +++ b/ptree.rkt @@ -1,10 +1,11 @@ #lang racket/base -(require xml xml/path racket/list racket/string racket/contract racket/match racket/set racket/path) -(require "tools.rkt" "world.rkt" "ptree-decode.rkt" "debug.rkt") +(require racket/contract) +(require "tools.rkt" "world.rkt" "ptree-nav.rkt" "ptree-decode.rkt" "debug.rkt") (module+ test (require rackunit)) -(provide (all-defined-out)) +(provide (all-defined-out) (all-from-out "ptree-nav.rkt")) + ;; function to set up the project-ptree. ;; this is to make life simpler when using tree navigation functions. @@ -29,220 +30,4 @@ (message "Generating ptree from file listing") (ptree-root->ptree (cons POLLEN_TREE_ROOT_NAME (map path->pnode files)))))) -;; remove parents from tree (i.e., just remove attrs) -;; is not the inverse of add-parents, i.e., you do not get back your original input. -(define/contract (remove-parents mt) - (ptree? . -> . tagged-xexpr?) - (remove-attrs mt)) - -(module+ test - (check-equal? (remove-parents - `(ptree-main ((,POLLEN_TREE_PARENT_NAME "")) (foo ((,POLLEN_TREE_PARENT_NAME ""))) (bar ((,POLLEN_TREE_PARENT_NAME ""))) (one ((,POLLEN_TREE_PARENT_NAME "")) (two ((,POLLEN_TREE_PARENT_NAME "one")) (three ((,POLLEN_TREE_PARENT_NAME "two"))))))) - '(ptree-main (foo) (bar) (one (two (three)))))) - - -(module+ test - (let ([sample-main `(POLLEN_TREE_ROOT_NAME "foo" "bar" (one (two "three")))]) - (check-equal? (ptree-root->ptree sample-main) - `(POLLEN_TREE_ROOT_NAME ((,POLLEN_TREE_PARENT_NAME "")) (foo ((,POLLEN_TREE_PARENT_NAME "POLLEN_TREE_ROOT_NAME"))) (bar ((,POLLEN_TREE_PARENT_NAME "POLLEN_TREE_ROOT_NAME"))) (one ((,POLLEN_TREE_PARENT_NAME "POLLEN_TREE_ROOT_NAME")) (two ((,POLLEN_TREE_PARENT_NAME "one")) (three ((,POLLEN_TREE_PARENT_NAME "two"))))))))) - - - -;; return the parent of a given name -(define/contract (parent pnode [ptree project-ptree]) - ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) - (and pnode (let ([result (se-path* `(,(->symbol pnode) #:parent) ptree)]) - (and result (->string result))))) ; se-path* returns #f if nothing found - - -(module+ test - (define test-ptree-main `(ptree-main "foo" "bar" (one (two "three")))) - (define test-ptree (ptree-root->ptree test-ptree-main)) - (check-equal? (parent 'three test-ptree) "two") - (check-equal? (parent "three" test-ptree) "two") - (check-false (parent 'nonexistent-name test-ptree))) - - - -; get children of a particular pnode -(define/contract (children pnode [ptree project-ptree]) - ((pnode?) (ptree?) . ->* . (or/c list? boolean?)) - ;; se-path*/list returns '() if nothing found - (and pnode (let ([children (se-path*/list `(,(->symbol pnode)) ptree)]) - ; If there are sublists, just take first pnode - (and (not (empty? children)) (map (λ(i) (->string (if (list? i) (car i) i))) children))))) - -(module+ test - (check-equal? (children 'one test-ptree) (list "two")) - (check-equal? (children 'two test-ptree) (list "three")) - (check-false (children 'three test-ptree)) - (check-false (children 'fooburger test-ptree))) - - -;; find all siblings on current level: go up to parent and ask for children -(define/contract (siblings pnode [ptree project-ptree]) - ;; this never returns false: pnode is always a sibling of itself. - ;; todo: how to use input value in contract? e.g., to check that pnode is part of output list - ((pnode?) (ptree?) . ->* . (or/c list? boolean?)) - (children (parent pnode ptree) ptree)) - -(module+ test - (check-equal? (siblings 'one test-ptree) '("foo" "bar" "one")) - (check-equal? (siblings 'foo test-ptree) '("foo" "bar" "one")) - (check-equal? (siblings 'two test-ptree) '("two")) - (check-false (siblings 'invalid-key test-ptree))) - - - -(define/contract (siblings-split pnode [ptree project-ptree]) - ((pnode?) (ptree?) . ->* . (values (or/c (listof pnode?) boolean?) - (or/c (listof pnode?) boolean?))) - (let-values ([(left right) (splitf-at (siblings pnode ptree) - (λ(e) (not (equal? (->string e) (->string pnode)))))]) - (values (if (empty? left) #f left) (if (empty? (cdr right)) #f (cdr right))))) - -(module+ test - (check-equal? (values->list (siblings-split 'one test-ptree)) '(("foo" "bar") #f)) - (check-equal? (values->list (siblings-split 'bar test-ptree)) (list '("foo") '("one")))) - - -;; siblings to the left of target pnode (i.e., precede in tree order) -(define (siblings-left pnode [ptree project-ptree]) - (let-values ([(left right) (siblings-split pnode ptree)]) - left)) - -(module+ test - (check-equal? (siblings-left 'one test-ptree) '("foo" "bar")) - (check-false (siblings-left 'foo test-ptree))) - -;; siblings to the right of target pnode (i.e., follow in tree order) -(define (siblings-right pnode [ptree project-ptree]) - (let-values ([(left right) (siblings-split pnode ptree)]) - right)) - -(module+ test - (check-false (siblings-right 'one test-ptree)) - (check-equal? (siblings-right 'foo test-ptree) '("bar" "one"))) - - -;; get pnode immediately to the left in tree -(define/contract (sibling-previous pnode [ptree project-ptree]) - ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) - (let ([siblings (siblings-left pnode ptree)]) - (and siblings (last siblings)))) - -(module+ test - (check-equal? (sibling-previous 'bar test-ptree) "foo") - (check-false (sibling-previous 'foo test-ptree))) - -;; get pnode immediately to the right in tree -(define/contract (sibling-next pnode [ptree project-ptree]) - ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) - (let ([siblings (siblings-right pnode ptree)]) - (and siblings (first siblings)))) - -(module+ test - (check-equal? (sibling-next 'foo test-ptree) "bar") - (check-false (sibling-next 'one test-ptree))) - - -;; flatten tree to sequence -(define/contract (all-pages [ptree project-ptree]) - (ptree? . -> . (listof string?)) - ; use cdr to get rid of root tag at front - (map ->string (cdr (flatten (remove-parents ptree))))) - -(module+ test - (check-equal? (all-pages test-ptree) '("foo" "bar" "one" "two" "three"))) - -;; helper function for get-previous-pages and get-next-pages -(define/contract (adjacent-pages side pnode [ptree project-ptree]) - ((symbol? pnode?) (ptree?) . ->* . (or/c list? boolean?)) - (let ([result ((if (equal? side 'left) - takef - takef-right) (all-pages ptree) - (λ(y) (not (equal? (->string pnode) (->string y)))))]) - (and (not (empty? result)) result))) - -(module+ test - (check-equal? (adjacent-pages 'left 'one test-ptree) '("foo" "bar")) - (check-equal? (adjacent-pages 'left 'three test-ptree) '("foo" "bar" "one" "two")) - (check-false (adjacent-pages 'left 'foo test-ptree))) - - -;; get sequence of earlier pages -(define/contract (previous-pages pnode [ptree project-ptree]) - ((pnode?) (ptree?) . ->* . (or/c list? boolean?)) - (adjacent-pages 'left pnode ptree)) - -(module+ test - (check-equal? (previous-pages 'one test-ptree) '("foo" "bar")) - (check-equal? (previous-pages 'three test-ptree) '("foo" "bar" "one" "two")) - (check-false (previous-pages 'foo test-ptree))) - - -;; get sequence of next pages -(define (next-pages pnode [ptree project-ptree]) - ((pnode?) (ptree?) . ->* . (or/c list? boolean?)) - (adjacent-pages 'right pnode ptree)) - -(module+ test - (check-equal? (next-pages 'foo test-ptree) '("bar" "one" "two" "three")) - (check-equal? (next-pages 'one test-ptree) '("two" "three")) - (check-false (next-pages 'three test-ptree))) - -;; get page immediately previous -(define/contract (previous-page pnode [ptree project-ptree]) - ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) - (let ([result (previous-pages pnode ptree)]) - (and result (last result)))) - -(module+ test - (check-equal? (previous-page 'one test-ptree) "bar") - (check-equal? (previous-page 'three test-ptree) "two") - (check-false (previous-page 'foo test-ptree))) - -;; get page immediately next -(define (next-page pnode [ptree project-ptree]) - ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) - (let ([result (next-pages pnode ptree)]) - (and result (first result)))) - -(module+ test - (check-equal? (next-page 'foo test-ptree) "bar") - (check-equal? (next-page 'one test-ptree) "two") - (check-false (next-page 'three test-ptree))) - -;; convert path to pnode -;; used for converting "here" values to pnodes -(define/contract (path->pnode x) - (pathish? . -> . pnode?) - (->string (remove-all-ext (last (explode-path (->path x)))))) - -(module+ test - (check-equal? (path->pnode "bar") "bar") - (check-equal? (path->pnode "foo/bar") "bar") - (check-equal? (path->pnode "foo/bar.html") "bar") - (check-equal? (path->pnode "/Users/this/that/foo/bar.html.pp") "bar")) - -(define here->pnode path->pnode) - -(define/contract (pnode->url pnode) - (pnode? . -> . string?) - (define files (directory-list START_DIR)) - (define (source-matches-pnode? x) - ;; todo: consider this test further. - ;; could pnode refer to files without pollen source? - ;; if so, the test is too narrow. - (and (x . starts-with? . pnode) (pollen-source? x))) - (define file-matches (filter source-matches-pnode? files)) - (if ((length file-matches) . > . 1) - (error "Duplicate source files for pnode" pnode) - (->string (->output-path (car file-matches))))) - -;; todo: make tests - - -;; this project setup must follow definitions to prevent undefined errors -(define project-ptree (make-project-ptree)) - +(set-project-ptree (make-project-ptree)) diff --git a/render.rkt b/render.rkt index 3009870..4a49018 100644 --- a/render.rkt +++ b/render.rkt @@ -1,13 +1,11 @@ -#lang racket/base -(require racket/list racket/path racket/port racket/system - racket/file racket/rerequire racket/contract racket/bool) +#lang racket +(require racket/port racket/file racket/rerequire racket/contract) (require "world.rkt" "tools.rkt" "readability.rkt" "template.rkt") (module+ test (require rackunit)) (provide render render-with-session) - ;; for shared use by eval & system (define nowhere-port (open-output-nowhere)) @@ -168,7 +166,7 @@ (mod-date-expired? source-path) ;; 4) source had to be reloaded (some other change) source-reloaded?) - + ;; how we render: import 'text from preproc source file, ;; which is rendered during source parsing, ;; and write that to output path @@ -183,7 +181,7 @@ (display-to-file text output-path #:exists 'replace))) (rendered-message output-path)) - + ;; otherwise, skip file because there's no trigger for render (up-to-date-message output-path))) @@ -244,18 +242,17 @@ ;; Build the possible paths and use the first one ;; that either exists, or has a preproc source that exists. (ormap (λ(p) (if (ormap file-exists? (list p (->preproc-source-path p))) p #f)) - (filter-not false? - (list - ;; path based on template-name - (and template-name (build-path source-dir template-name)) - ;; path based on metas - (let ([source-metas (dynamic-require source-path 'metas)]) - (and (TEMPLATE_META_KEY . in? . source-metas) - (build-path source-dir - (get source-metas TEMPLATE_META_KEY)))) - ;; path using default template name = - ;; "-main" + extension from output path (e.g. foo.xml.p -> -main.xml) - (build-path source-dir (add-ext DEFAULT_TEMPLATE_PREFIX (get-ext (->output-path source-path))))))) + (filter (λ(x) (->boolean x)) ;; if any of the possibilities below are invalid, they return #f + (list + ;; path based on template-name + (and template-name (build-path source-dir template-name)) + ;; path based on metas + (let ([source-metas (dynamic-require source-path 'metas)]) + (and (TEMPLATE_META_KEY . in? . source-metas) + (build-path source-dir (get source-metas TEMPLATE_META_KEY)))) + ;; path using default template name = + ;; "-main" + extension from output path (e.g. foo.xml.p -> -main.xml) + (build-path source-dir (add-ext DEFAULT_TEMPLATE_PREFIX (get-ext (->output-path source-path))))))) ;; if none of these work, make fallback template file (let ([ft-path (build-path source-dir FALLBACK_TEMPLATE_NAME)]) (display-to-file fallback-template-data ft-path #:exists 'replace) @@ -280,7 +277,7 @@ (store-render-in-mod-dates source-path template-path) (message "Rendering source" (->string (file-name-from-path source-path)) "with template" (->string (file-name-from-path template-path))) - (let ([page-result (render-source-with-template source-path template-path)]) + (let ([page-result (time (render-source-with-template source-path template-path))]) (display-to-file page-result output-path #:exists 'replace) (rendered-message output-path))) (up-to-date-message output-path)) @@ -289,6 +286,21 @@ (let ([tp (build-path source-dir FALLBACK_TEMPLATE_NAME)]) (when (file-exists? tp) (delete-file tp)))) +;; cache some modules inside this namespace so they can be shared by namespace for eval +(require web-server/templates + racket/list + xml/path + (planet mb/pollen/debug) + (planet mb/pollen/decode) + (planet mb/pollen/file-tools) + (planet mb/pollen/predicates) + (planet mb/pollen/ptree-nav) + (planet mb/pollen/ptree-decode) + (planet mb/pollen/readability) + (planet mb/pollen/template) + (planet mb/pollen/tools) + (planet mb/pollen/world)) +(define original-ns (current-namespace)) (define/contract (render-source-with-template source-path template-path) (file-exists? file-exists? . -> . string?) @@ -309,6 +321,29 @@ [current-directory source-dir] [current-output-port nowhere-port] [current-error-port nowhere-port]) ; silent evaluation; exceptions still thrown + ;; 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. + (map (λ(mod-name) (namespace-attach-module original-ns mod-name)) + '(racket + web-server/templates + xml/path + racket/port + racket/file + racket/rerequire + racket/contract + racket/list + (planet mb/pollen/debug) + (planet mb/pollen/decode) + (planet mb/pollen/file-tools) + (planet mb/pollen/predicates) + (planet mb/pollen/ptree-nav) + (planet mb/pollen/ptree-decode) + (planet mb/pollen/readability) + (planet mb/pollen/template) + (planet mb/pollen/tools) + (planet mb/pollen/world))) (namespace-require 'racket) ; use namespace-require for FIRST require, then eval after (eval `(begin ;; for include-template (used below) @@ -320,6 +355,7 @@ (include-template #:command-char ,TEMPLATE_FIELD_DELIMITER ,(->string template-name))) (current-namespace)))) + ;; render files listed in a ptree file (define/contract (render-ptree-files ptree #:force [force #f]) ((ptree?) (#:force boolean?) . ->* . void?) diff --git a/template.rkt b/template.rkt index 32cd1e0..5010e04 100644 --- a/template.rkt +++ b/template.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require racket/list racket/contract racket/string xml xml/path racket/bool) -(require "readability.rkt" "debug.rkt" "predicates.rkt" "tools.rkt") +(require racket/contract racket/string xml xml/path racket/bool) +(require "tools.rkt") ;; setup for test cases (module+ test (require rackunit racket/path)) diff --git a/tools.rkt b/tools.rkt index ccf4c79..f3f4c3a 100644 --- a/tools.rkt +++ b/tools.rkt @@ -1,18 +1,16 @@ #lang racket/base -(require racket/contract racket/match) +(require racket/contract racket/match racket/path) (require (only-in racket/format ~a)) -(require racket/list xml) +(require racket/list) (require (only-in racket/string string-join)) (require (only-in xml xexpr? xexpr/c)) (require "readability.rkt" "debug.rkt" "predicates.rkt" "world.rkt") -(provide (all-defined-out) (all-from-out "readability.rkt" "debug.rkt" "predicates.rkt")) +(provide (all-defined-out) (all-from-out "readability.rkt" "debug.rkt" "predicates.rkt" racket/list racket/path)) ;; setup for test cases (module+ test (require rackunit)) - - ;; list of all eligible requires in project require directory (define/contract (get-project-require-files) (-> (or/c (listof complete-path?) boolean?))