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

performance improvements: cache modules in main render-module namespace and share them with eval namespace used for the rendering

Browse Source
pull/9/head
Matthew Butterick 11 years ago
parent 396290602c
commit 382023f61f
8 changed files with 300 additions and 251 deletions
Show Stats Download Patch File Download Diff File

4
main-preproc.rkt
Unescape Escape View File

@ -1,10 +1,10 @@
#lang racket/base #lang racket
(require (only-in (planet mb/pollen/readability) ->list) (require (only-in (planet mb/pollen/readability) ->list)
(only-in (planet mb/pollen/tools) trim) (only-in (planet mb/pollen/tools) trim)
(only-in (planet mb/pollen/predicates) whitespace?)) (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])) (rename-out [module-begin #%module-begin]))
(require (only-in scribble/text output) (require (only-in scribble/text output)

4
main.rkt
Unescape Escape View File

@ -1,9 +1,9 @@
#lang racket/base #lang racket
(require racket/list) (require racket/list)
(require (planet mb/pollen/tools) (planet mb/pollen/main-helper)) (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/ptree-decode) ptree-source-decode))
(require (only-in (planet mb/pollen/predicates) ptree?)) (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])) (rename-out [module-begin #%module-begin]))
(define-syntax-rule (module-begin expr ...) (define-syntax-rule (module-begin expr ...)

1
ptree-decode.rkt
Unescape Escape View File

@ -7,7 +7,6 @@
(provide (all-defined-out)) (provide (all-defined-out))
;; These functions need to be separated so that they can be accessed by pollen parser (in main.rkt) ;; 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. ;; ptree decoder takes ptree source and returns a full ptree structure.
;; recursively processes tree, converting tree locations & their parents into xexprs of this shape: ;; recursively processes tree, converting tree locations & their parents into xexprs of this shape:

231
ptree-nav.rkt
Unescape Escape View File

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

225
ptree.rkt
Unescape Escape View File

@ -1,10 +1,11 @@
#lang racket/base #lang racket/base
(require xml xml/path racket/list racket/string racket/contract racket/match racket/set racket/path) (require racket/contract)
(require "tools.rkt" "world.rkt" "ptree-decode.rkt" "debug.rkt") (require "tools.rkt" "world.rkt" "ptree-nav.rkt" "ptree-decode.rkt" "debug.rkt")
(module+ test (require rackunit)) (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. ;; function to set up the project-ptree.
;; this is to make life simpler when using tree navigation functions. ;; this is to make life simpler when using tree navigation functions.
@ -29,220 +30,4 @@
(message "Generating ptree from file listing") (message "Generating ptree from file listing")
(ptree-root->ptree (cons POLLEN_TREE_ROOT_NAME (map path->pnode files)))))) (ptree-root->ptree (cons POLLEN_TREE_ROOT_NAME (map path->pnode files))))))
;; remove parents from tree (i.e., just remove attrs) (set-project-ptree (make-project-ptree))
;; 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))

74
render.rkt
Unescape Escape View File

@ -1,13 +1,11 @@
#lang racket/base #lang racket
(require racket/list racket/path racket/port racket/system (require racket/port racket/file racket/rerequire racket/contract)
racket/file racket/rerequire racket/contract racket/bool)
(require "world.rkt" "tools.rkt" "readability.rkt" "template.rkt") (require "world.rkt" "tools.rkt" "readability.rkt" "template.rkt")
(module+ test (require rackunit)) (module+ test (require rackunit))
(provide render render-with-session) (provide render render-with-session)
;; for shared use by eval & system ;; for shared use by eval & system
(define nowhere-port (open-output-nowhere)) (define nowhere-port (open-output-nowhere))
@ -168,7 +166,7 @@
(mod-date-expired? source-path) (mod-date-expired? source-path)
;; 4) source had to be reloaded (some other change) ;; 4) source had to be reloaded (some other change)
source-reloaded?) source-reloaded?)
;; how we render: import 'text from preproc source file, ;; how we render: import 'text from preproc source file,
;; which is rendered during source parsing, ;; which is rendered during source parsing,
;; and write that to output path ;; and write that to output path
@ -183,7 +181,7 @@
(display-to-file text output-path #:exists 'replace))) (display-to-file text output-path #:exists 'replace)))
(rendered-message output-path)) (rendered-message output-path))
;; otherwise, skip file because there's no trigger for render ;; otherwise, skip file because there's no trigger for render
(up-to-date-message output-path))) (up-to-date-message output-path)))
@ -244,18 +242,17 @@
;; Build the possible paths and use the first one ;; Build the possible paths and use the first one
;; that either exists, or has a preproc source that exists. ;; that either exists, or has a preproc source that exists.
(ormap (λ(p) (if (ormap file-exists? (list p (->preproc-source-path p))) p #f)) (ormap (λ(p) (if (ormap file-exists? (list p (->preproc-source-path p))) p #f))
(filter-not false? (filter (λ(x) (->boolean x)) ;; if any of the possibilities below are invalid, they return #f
(list (list
;; path based on template-name ;; path based on template-name
(and template-name (build-path source-dir template-name)) (and template-name (build-path source-dir template-name))
;; path based on metas ;; path based on metas
(let ([source-metas (dynamic-require source-path 'metas)]) (let ([source-metas (dynamic-require source-path 'metas)])
(and (TEMPLATE_META_KEY . in? . source-metas) (and (TEMPLATE_META_KEY . in? . source-metas)
(build-path source-dir (build-path source-dir (get source-metas TEMPLATE_META_KEY))))
(get source-metas TEMPLATE_META_KEY)))) ;; path using default template name =
;; path using default template name = ;; "-main" + extension from output path (e.g. foo.xml.p -> -main.xml)
;; "-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)))))))
(build-path source-dir (add-ext DEFAULT_TEMPLATE_PREFIX (get-ext (->output-path source-path)))))))
;; if none of these work, make fallback template file ;; if none of these work, make fallback template file
(let ([ft-path (build-path source-dir FALLBACK_TEMPLATE_NAME)]) (let ([ft-path (build-path source-dir FALLBACK_TEMPLATE_NAME)])
(display-to-file fallback-template-data ft-path #:exists 'replace) (display-to-file fallback-template-data ft-path #:exists 'replace)
@ -280,7 +277,7 @@
(store-render-in-mod-dates source-path template-path) (store-render-in-mod-dates source-path template-path)
(message "Rendering source" (->string (file-name-from-path source-path)) (message "Rendering source" (->string (file-name-from-path source-path))
"with template" (->string (file-name-from-path template-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) (display-to-file page-result output-path #:exists 'replace)
(rendered-message output-path))) (rendered-message output-path)))
(up-to-date-message output-path)) (up-to-date-message output-path))
@ -289,6 +286,21 @@
(let ([tp (build-path source-dir FALLBACK_TEMPLATE_NAME)]) (let ([tp (build-path source-dir FALLBACK_TEMPLATE_NAME)])
(when (file-exists? tp) (delete-file tp)))) (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) (define/contract (render-source-with-template source-path template-path)
(file-exists? file-exists? . -> . string?) (file-exists? file-exists? . -> . string?)
@ -309,6 +321,29 @@
[current-directory source-dir] [current-directory source-dir]
[current-output-port nowhere-port] [current-output-port nowhere-port]
[current-error-port nowhere-port]) ; silent evaluation; exceptions still thrown [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 (namespace-require 'racket) ; use namespace-require for FIRST require, then eval after
(eval `(begin (eval `(begin
;; for include-template (used below) ;; for include-template (used below)
@ -320,6 +355,7 @@
(include-template #:command-char ,TEMPLATE_FIELD_DELIMITER ,(->string template-name))) (include-template #:command-char ,TEMPLATE_FIELD_DELIMITER ,(->string template-name)))
(current-namespace)))) (current-namespace))))
;; render files listed in a ptree file ;; render files listed in a ptree file
(define/contract (render-ptree-files ptree #:force [force #f]) (define/contract (render-ptree-files ptree #:force [force #f])
((ptree?) (#:force boolean?) . ->* . void?) ((ptree?) (#:force boolean?) . ->* . void?)

4
template.rkt
Unescape Escape View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require racket/list racket/contract racket/string xml xml/path racket/bool) (require racket/contract racket/string xml xml/path racket/bool)
(require "readability.rkt" "debug.rkt" "predicates.rkt" "tools.rkt") (require "tools.rkt")
;; setup for test cases ;; setup for test cases
(module+ test (require rackunit racket/path)) (module+ test (require rackunit racket/path))

8
tools.rkt
Unescape Escape View File

@ -1,18 +1,16 @@
#lang racket/base #lang racket/base
(require racket/contract racket/match) (require racket/contract racket/match racket/path)
(require (only-in racket/format ~a)) (require (only-in racket/format ~a))
(require racket/list xml) (require racket/list)
(require (only-in racket/string string-join)) (require (only-in racket/string string-join))
(require (only-in xml xexpr? xexpr/c)) (require (only-in xml xexpr? xexpr/c))
(require "readability.rkt" "debug.rkt" "predicates.rkt" "world.rkt") (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 ;; setup for test cases
(module+ test (require rackunit)) (module+ test (require rackunit))
;; list of all eligible requires in project require directory ;; list of all eligible requires in project require directory
(define/contract (get-project-require-files) (define/contract (get-project-require-files)
(-> (or/c (listof complete-path?) boolean?)) (-> (or/c (listof complete-path?) boolean?))

Write Preview
Loading…
Cancel
Save