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

updates

Browse Source
pull/9/head
Matthew Butterick 11 years ago
parent 8faace5b8e
commit 7caab48bba
13 changed files with 161 additions and 175 deletions
Show Stats Download Patch File Download Diff File

14
command.rkt
Unescape Escape View File

@ -10,11 +10,11 @@
[arg (if (> (len args) 0) (get args 0) "")]) [arg (if (> (len args) 0) (get args 0) "")])
(case arg (case arg
[("start") `(require "server.rkt")] [("start") `(require "server.rkt")]
[("regenerate") `(begin [("render") `(begin
;; todo: take extensions off the comand line ;; todo: take extensions off the comand line
(displayln "Regenerate preproc & ptree files ...") (displayln "Render preproc & ptree files ...")
(require "regenerate.rkt" "pollen-file-tools.rkt" "world.rkt") (require "render.rkt" "file-tools.rkt" "world.rkt")
(apply regenerate-with-session (append-map project-files-with-ext (list POLLEN_PREPROC_EXT POLLEN_TREE_EXT))))] (apply render-with-session (append-map project-files-with-ext (list POLLEN_PREPROC_EXT POLLEN_TREE_EXT))))]
[("clone") (let ([target-path [("clone") (let ([target-path
(if (> (len args) 1) (if (> (len args) 1)
(->path (get args 1)) (->path (get args 1))
@ -49,12 +49,12 @@
(displayln (format "Completed to ~a" ,target-path)) (displayln (format "Completed to ~a" ,target-path))
)))] )))]
[("") `(displayln "No command given")] [("") `(displayln "No command given")]
;; treat other input as a possible file name for regeneration ;; treat other input as a possible file name for rendering
[else (let ([possible-file (->path arg)]) [else (let ([possible-file (->path arg)])
(if (file-exists? possible-file) (if (file-exists? possible-file)
`(begin `(begin
(require (planet mb/pollen/regenerate)) (require (planet mb/pollen/render))
(regenerate ,possible-file)) (render ,possible-file))
`(displayln (format "No command defined for ~a" ,arg))))])))) `(displayln (format "No command defined for ~a" ,arg))))]))))
(handle-pollen-command) (handle-pollen-command)

128
pollen-file-tools.rkt → file-tools.rkt
Unescape Escape View File

@ -9,12 +9,21 @@
; helper functions for regenerate functions ; helper functions for regenerate functions
(define pollen-file-root (current-directory)) (define pollen-project-directory (current-directory))
;; this is for regenerate module.
;; when we want to be friendly with inputs for functions that require a path.
;; Strings & symbols often result from xexpr parsing
;; and are trivially converted to paths.
;; so let's say close enough.
(define/contract (pathish? x)
(any/c . -> . boolean?)
(->boolean (or path? string? symbol?)))
;; does path have a certain extension ;; does path have a certain extension
(define/contract (has-ext? path ext) (define/contract (has-ext? x ext)
(path? symbol? . -> . boolean?) (pathish? stringish? . -> . boolean?)
(define ext-of-path (filename-extension path)) (define ext-of-path (filename-extension (->path x)))
(and ext-of-path (equal? (bytes->string/utf-8 ext-of-path) (->string ext)))) (and ext-of-path (equal? (bytes->string/utf-8 ext-of-path) (->string ext))))
(module+ test (module+ test
@ -23,20 +32,20 @@
(apply values (map string->path foo-path-strings))) (apply values (map string->path foo-path-strings)))
;; test the sample paths before using them for other tests ;; test the sample paths before using them for other tests
(define foo-paths (list foo-path foo.txt-path foo.bar-path foo.bar.txt-path)) (define foo-paths (list foo-path foo.txt-path foo.bar-path foo.bar.txt-path))
(for-each check-equal? (map path->string foo-paths) foo-path-strings)) (for-each check-equal? (map ->string foo-paths) foo-path-strings))
(module+ test (module+ test
(check-false (has-ext? foo-path 'txt)) (check-false (has-ext? foo-path 'txt))
(check-true (has-ext? foo.txt-path 'txt)) (check-true (foo.txt-path . has-ext? . 'txt))
(check-true (has-ext? foo.bar.txt-path 'txt)) (check-true (has-ext? foo.bar.txt-path 'txt))
(check-false (has-ext? foo.bar.txt-path 'doc))) ; wrong extension (check-false (foo.bar.txt-path . has-ext? . 'doc))) ; wrong extension
;; get file extension as a string ;; get file extension as a string
(define/contract (get-ext path) (define/contract (get-ext x)
(path? . -> . string?) (pathish? . -> . string?)
(bytes->string/utf-8 (filename-extension path))) (bytes->string/utf-8 (filename-extension (->path x))))
(module+ test (module+ test
(check-equal? (get-ext (->path "foo.txt")) "txt") (check-equal? (get-ext (->path "foo.txt")) "txt")
@ -46,17 +55,17 @@
;; put extension on path ;; put extension on path
(define/contract (add-ext path ext) (define/contract (add-ext x ext)
(path? (or/c symbol? string?) . -> . path?) (pathish? stringish? . -> . path?)
(string->path (string-append (->string path) "." (->string ext)))) (->path (string-append (->string x) "." (->string ext))))
(module+ test (module+ test
(check-equal? (add-ext (string->path "foo") "txt") (string->path "foo.txt"))) (check-equal? (add-ext (string->path "foo") "txt") (string->path "foo.txt")))
;; take one extension off path ;; take one extension off path
(define/contract (remove-ext path) (define/contract (remove-ext x)
(path? . -> . path?) (pathish? . -> . path?)
(path-replace-suffix path "")) (path-replace-suffix (->path x) ""))
(module+ test (module+ test
(check-equal? (remove-ext foo-path) foo-path) (check-equal? (remove-ext foo-path) foo-path)
@ -66,8 +75,9 @@
;; take all extensions off path ;; take all extensions off path
(define/contract (remove-all-ext path) (define/contract (remove-all-ext x)
(path? . -> . path?) (pathish? . -> . path?)
(define path (->path x))
(define path-with-removed-ext (remove-ext path)) (define path-with-removed-ext (remove-ext path))
(if (equal? path path-with-removed-ext) (if (equal? path path-with-removed-ext)
path path
@ -79,16 +89,6 @@
(check-not-equal? (remove-all-ext foo.bar.txt-path) foo.bar-path) ; removes more than one ext (check-not-equal? (remove-all-ext foo.bar.txt-path) foo.bar-path) ; removes more than one ext
(check-equal? (remove-all-ext foo.bar.txt-path) foo-path)) (check-equal? (remove-all-ext foo.bar.txt-path) foo-path))
;; superfluous: use file-name-from-path in racket/path
#|(define/contract (filename-of path)
(complete-path? . -> . path?)
(define-values (dir filename ignored) (split-path path))
filename)
(module+ test
(check-equal? (filename-of (build-path (current-directory) "pollen-file-tools.rkt")) (->path "pollen-file-tools.rkt")))|#
;; todo: tests for these predicates ;; todo: tests for these predicates
@ -102,11 +102,11 @@
(define/contract (has-preproc-source? x) (define/contract (has-preproc-source? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(file-exists? (make-preproc-source-path (->path x)))) (file-exists? (->preproc-source-path (->path x))))
(define/contract (has-pollen-source? x) (define/contract (has-pollen-source? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(file-exists? (make-pollen-source-path (->path x)))) (file-exists? (->pollen-source-path (->path x))))
(define/contract (needs-preproc? x) (define/contract (needs-preproc? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
@ -121,7 +121,7 @@
(define/contract (ptree-source? x) (define/contract (ptree-source? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(has-ext? (->path x) POLLEN_TREE_EXT)) (has-ext? x POLLEN_TREE_EXT))
(module+ test (module+ test
(check-true (ptree-source? "foo.ptree")) (check-true (ptree-source? "foo.ptree"))
@ -130,7 +130,7 @@
(define/contract (pollen-source? x) (define/contract (pollen-source? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(has-ext? (->path x) POLLEN_SOURCE_EXT)) (has-ext? x POLLEN_SOURCE_EXT))
(module+ test (module+ test
(check-true (pollen-source? "foo.p")) (check-true (pollen-source? "foo.p"))
@ -152,7 +152,7 @@
;; todo: extend this beyond just racket files? ;; todo: extend this beyond just racket files?
(define/contract (project-require-file? x) (define/contract (project-require-file? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(has-ext? (->path x) 'rkt)) (has-ext? x 'rkt))
(module+ test (module+ test
(check-true (project-require-file? "foo.rkt")) (check-true (project-require-file? "foo.rkt"))
@ -160,55 +160,53 @@
;; this is for regenerate module.
;; when we want to be friendly with inputs for functions that require a path.
;; Strings & symbols often result from xexpr parsing
;; and are trivially converted to paths.
;; so let's say close enough.
(define/contract (pathish? x)
(any/c . -> . boolean?)
(->boolean (or path? string? symbol?)))
;; todo: tighten these input contracts ;; todo: tighten these input contracts
;; so that, say, a source-path cannot be input for make-preproc-source-path ;; so that, say, a source-path cannot be input for make-preproc-source-path
(define/contract (make-preproc-source-path path) (define/contract (->preproc-source-path x)
(path? . -> . path?) (pathish? . -> . path?)
(add-ext path POLLEN_PREPROC_EXT)) (->path (if (preproc-source? x)
x
(add-ext x POLLEN_PREPROC_EXT))))
(define/contract (make-preproc-output-path path) (module+ test
(path? . -> . path?) (check-equal? (->preproc-source-path (->path "foo.pp")) (->path "foo.pp"))
(remove-ext path)) (check-equal? (->preproc-source-path (->path "foo.html")) (->path "foo.html.pp"))
(check-equal? (->preproc-source-path "foo") (->path "foo.pp"))
(check-equal? (->preproc-source-path 'foo) (->path "foo.pp")))
(define/contract (make-pollen-output-path thing) (define/contract (->output-path x)
(pathish? . -> . path?) (pathish? . -> . path?)
(remove-ext (->path thing))) (->path
(if (or (pollen-source? x) (preproc-source? x))
(remove-ext x)
x)))
(module+ test (module+ test
(check-equal? (make-pollen-output-path (->path "foo.html.p")) (->path "foo.html")) (check-equal? (->output-path (->path "foo.ptree")) (->path "foo.ptree"))
(check-equal? (make-pollen-output-path (->path "/Users/mb/git/foo.html.p")) (->path "/Users/mb/git/foo.html")) (check-equal? (->output-path "foo.html") (->path "foo.html"))
(check-equal? (make-pollen-output-path "foo.xml.p") (->path "foo.xml")) (check-equal? (->output-path 'foo.html.p) (->path "foo.html"))
(check-equal? (make-pollen-output-path 'foo.barml.p) (->path "foo.barml"))) (check-equal? (->output-path (->path "/Users/mb/git/foo.html.p")) (->path "/Users/mb/git/foo.html"))
(check-equal? (->output-path "foo.xml.p") (->path "foo.xml"))
(check-equal? (->output-path 'foo.barml.p) (->path "foo.barml")))
;; turns input into corresponding pollen source path ;; turns input into corresponding pollen source path
;; does not, however, validate that new path exists ;; does not, however, validate that new path exists
;; todo: should it? I don't think so, sometimes handy to make the name for later use ;; todo: should it? I don't think so, sometimes handy to make the name for later use
;; OK to use pollen source as input (comes out the same way) ;; OK to use pollen source as input (comes out the same way)
(define/contract (make-pollen-source-path thing) (define/contract (->pollen-source-path x)
(pathish? . -> . path?) (pathish? . -> . path?)
(define path (->path thing)) (->path (if (pollen-source? x)
(if (pollen-source? path) x
path (add-ext x POLLEN_SOURCE_EXT))))
(add-ext path POLLEN_SOURCE_EXT)))
(module+ test (module+ test
(check-equal? (make-pollen-source-path (->path "foo.p")) (->path "foo.p")) (check-equal? (->pollen-source-path (->path "foo.p")) (->path "foo.p"))
(check-equal? (make-pollen-source-path (->path "foo.html")) (->path "foo.html.p")) (check-equal? (->pollen-source-path (->path "foo.html")) (->path "foo.html.p"))
(check-equal? (make-pollen-source-path "foo") (->path "foo.p")) (check-equal? (->pollen-source-path "foo") (->path "foo.p"))
(check-equal? (make-pollen-source-path 'foo) (->path "foo.p"))) (check-equal? (->pollen-source-path 'foo) (->path "foo.p")))
(define/contract (project-files-with-ext ext) (define/contract (project-files-with-ext ext)
(symbol? . -> . (listof complete-path?)) (symbol? . -> . (listof complete-path?))
(map ->complete-path (filter (λ(i) (has-ext? i ext)) (directory-list pollen-file-root)))) (map ->complete-path (filter (λ(i) (has-ext? i ext)) (directory-list pollen-project-directory))))
;; todo: write tests for project-files-with-ext ;; todo: write tests for project-files-with-ext

2
lang/reader.rkt
Unescape Escape View File

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(require (only-in scribble/reader make-at-reader) (require (only-in scribble/reader make-at-reader)
(only-in "../world.rkt" POLLEN_EXPRESSION_DELIMITER) (only-in "../world.rkt" POLLEN_EXPRESSION_DELIMITER)
(only-in "../pollen-file-tools.rkt" preproc-source?)) (only-in "../file-tools.rkt" preproc-source?))
(provide (rename-out [mb-read read] (provide (rename-out [mb-read read]
[mb-read-syntax read-syntax]) [mb-read-syntax read-syntax])

3
main.rkt
Unescape Escape View File

@ -3,7 +3,7 @@
(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?))
(require (only-in (planet mb/pollen/pollen-file-tools) has-ext?)) (require (only-in (planet mb/pollen/file-tools) has-ext?))
(require (only-in (planet mb/pollen/world) POLLEN_TREE_EXT)) (require (only-in (planet mb/pollen/world) POLLEN_TREE_EXT))
(provide (except-out (all-from-out racket/base) #%module-begin) (provide (except-out (all-from-out racket/base) #%module-begin)
(rename-out [module-begin #%module-begin])) (rename-out [module-begin #%module-begin]))
@ -40,6 +40,7 @@
;; but it makes debugging tricky, because an undefined (symbol item ...) ;; but it makes debugging tricky, because an undefined (symbol item ...)
;; is just treated as a valid tagged-xexpr, not an undefined function. ;; is just treated as a valid tagged-xexpr, not an undefined function.
(define-syntax-rule (#%top . id) (define-syntax-rule (#%top . id)
;; todo: can #%top emit a debug message when a function hits it?
(λ x `(id ,@x))) (λ x `(id ,@x)))
expr ... ; body of module expr ... ; body of module

4
predicates.rkt
Unescape Escape View File

@ -1,13 +1,13 @@
#lang racket/base #lang racket/base
(require racket/contract racket/match racket/list xml racket/set) (require racket/contract racket/match racket/list xml racket/set)
(require (prefix-in html: "library/html.rkt")) (require (prefix-in html: "library/html.rkt"))
(require "world.rkt" "readability.rkt" "pollen-file-tools.rkt") (require "world.rkt" "readability.rkt" "file-tools.rkt")
(module+ test (require rackunit)) (module+ test (require rackunit))
(provide (all-defined-out) (provide (all-defined-out)
(all-from-out "pollen-file-tools.rkt")) (all-from-out "file-tools.rkt"))
;; add a block tag to the list ;; add a block tag to the list

6
ptree.rkt
Unescape Escape View File

@ -1,5 +1,5 @@
#lang racket/base #lang racket/base
(require xml xml/path racket/list racket/string racket/contract racket/match racket/set) (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 "tools.rkt" "world.rkt" "ptree-decode.rkt" "debug.rkt")
(module+ test (require rackunit)) (module+ test (require rackunit))
@ -19,7 +19,7 @@
;; Load it from default path. ;; Load it from default path.
;; dynamic require of a ptree source file gets you a full ptree. ;; dynamic require of a ptree source file gets you a full ptree.
(begin (begin
(message "Loading ptree file" (->string ptree-source)) (message "Using ptree file" (->string (file-name-from-path ptree-source)))
(dynamic-require ptree-source POLLEN_ROOT)) (dynamic-require ptree-source POLLEN_ROOT))
;; ... or else synthesize it ;; ... or else synthesize it
(let* ([files (directory-list START_DIR)] (let* ([files (directory-list START_DIR)]
@ -238,7 +238,7 @@
(define file-matches (filter source-matches-pnode? files)) (define file-matches (filter source-matches-pnode? files))
(if ((length file-matches) . > . 1) (if ((length file-matches) . > . 1)
(error "Duplicate source files for pnode" pnode) (error "Duplicate source files for pnode" pnode)
(->string (make-pollen-output-path (car file-matches))))) (->string (->output-path (car file-matches)))))
;; todo: make tests ;; todo: make tests

129
regenerate.rkt → render.rkt
Unescape Escape View File

@ -1,11 +1,11 @@
#lang racket/base #lang racket/base
(require racket/list racket/path racket/port racket/system (require racket/list racket/path racket/port racket/system
racket/file racket/rerequire racket/contract racket/bool) racket/file racket/rerequire racket/contract racket/bool)
(require "world.rkt" "tools.rkt" "ptree.rkt" "readability.rkt" "template.rkt") (require "world.rkt" "tools.rkt" "readability.rkt" "template.rkt")
(module+ test (require rackunit)) (module+ test (require rackunit))
(provide regenerate regenerate-with-session) (provide render render-with-session)
;; mod-dates is a hash that takes lists of paths as keys, ;; mod-dates is a hash that takes lists of paths as keys,
;; and lists of modification times as values. ;; and lists of modification times as values.
@ -31,7 +31,7 @@
(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 "regenerate.rkt")))))) (check-true (exact-integer? (path->mod-date-value (build-path (current-directory) (->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)
@ -53,20 +53,20 @@
(module+ test (module+ test
(reset-mod-dates) (reset-mod-dates)
(store-refresh-in-mod-dates (build-path (current-directory) (->path "regenerate.rkt"))) (store-refresh-in-mod-dates (build-path (current-directory) (->path "render.rkt")))
(check-true (= (len mod-dates) 1)) (check-true (= (len mod-dates) 1))
(reset-mod-dates)) (reset-mod-dates))
;; when you want to generate everything fresh, ;; when you want to generate everything fresh,
;; but without having to #:force everything. ;; but without having to #:force everything.
;; Regenerate functions will always go when no mod-date is found. ;; render functions will always go when no mod-date is found.
(define/contract (reset-mod-dates) (define/contract (reset-mod-dates)
(-> void?) (-> void?)
(set! mod-dates (make-hash))) (set! mod-dates (make-hash)))
(module+ test (module+ test
(reset-mod-dates) (reset-mod-dates)
(store-refresh-in-mod-dates (build-path (current-directory) (->path "regenerate.rkt"))) (store-refresh-in-mod-dates (build-path (current-directory) (->path "render.rkt")))
(reset-mod-dates) (reset-mod-dates)
(check-true (= (len mod-dates) 0))) (check-true (= (len mod-dates) 0)))
@ -80,7 +80,7 @@
(module+ test (module+ test
(reset-mod-dates) (reset-mod-dates)
(let ([path (build-path (current-directory) (->path "regenerate.rkt"))]) (let ([path (build-path (current-directory) (->path "render.rkt"))])
(store-refresh-in-mod-dates path) (store-refresh-in-mod-dates path)
(check-false (mod-date-expired? path)) (check-false (mod-date-expired? path))
(reset-mod-dates) (reset-mod-dates)
@ -88,80 +88,65 @@
;; convenience function for external modules to use ;; convenience function for external modules to use
(define/contract (regenerate-with-session . xs) (define/contract (render-with-session . xs)
(() #:rest (listof pathish?) . ->* . void?) (() #:rest (listof pathish?) . ->* . void?)
;; This will trigger regeneration of all files. ;; This will trigger rendering of all files.
;; Why not pass #:force #t through with regenerate? ;; Why not pass #:force #t through with render?
;; Because certain files will pass through multiple times (e.g., templates) ;; Because certain files will pass through multiple times (e.g., templates)
;; And with #:force, they would be regenerated repeatedly. ;; And with #:force, they would be rendered repeatedly.
;; Using reset-mod-dates is sort of like session control: ;; Using reset-mod-dates is sort of like session control:
;; setting a state that persists through the whole operation. ;; setting a state that persists through the whole operation.
(reset-mod-dates) (reset-mod-dates)
(for-each regenerate xs)) (for-each render xs))
;; dispatches path to the right regeneration function ;; dispatches path to the right rendering function
;; use #:force to refresh regardless of cached state ;; use #:force to refresh regardless of cached state
(define/contract (regenerate #:force [force #f] . xs) (define/contract (render #:force [force #f] . xs)
(() (#:force boolean?) #:rest (listof pathish?) . ->* . void?) (() (#:force boolean?) #:rest (listof pathish?) . ->* . void?)
(define (&regenerate x) (define (&render x)
(let ([path (->complete-path (->path x))]) (let ([path (->complete-path (->path x))])
; (message "Regenerating" (->string path))
(cond (cond
;; this will catch pp (preprocessor) files ;; this will catch preprocessor files
[(needs-preproc? path) (regenerate-with-preproc path #:force force)] [(needs-preproc? path) (render-with-preproc path #:force force)]
;; this will catch p files, ;; this will catch pollen source files,
;; and files without extension that correspond to p files ;; and files without extension that correspond to p files
[(needs-template? path) (regenerate-with-template path #:force force)] [(needs-template? path) (render-with-template path #:force force)]
;; this will catch ptree files ;; this will catch ptree files
[(ptree-source? path) (let ([ptree (dynamic-require path 'main)]) [(ptree-source? path) (let ([ptree (dynamic-require path 'main)])
(regenerate-with-ptree ptree #:force force))] (render-ptree-files ptree #:force force))]
[(equal? FALLBACK_TEMPLATE_NAME (->string (file-name-from-path path))) [(equal? FALLBACK_TEMPLATE_NAME (->string (file-name-from-path path)))
(message "Regenerate: using fallback template")] (message "Render: using fallback template")]
[(file-exists? path) 'pass-through] [(file-exists? path) 'pass-through]
[else (error "Regenerate couldn't find" (->string (file-name-from-path path)))]))) [else (error "Render couldn't find" (->string (file-name-from-path path)))])))
(for-each &regenerate xs)) (for-each &render xs))
;; todo: write tests ;; todo: write tests
(define/contract (regenerating-message path) (define/contract (rendering-message path)
(any/c . -> . void?) (any/c . -> . void?)
;; you can actually stuff whatever string you want into path — ;; you can actually stuff whatever string you want into path —
;; if it's not really a path, file-name-from-path won't choke ;; if it's not really a path, file-name-from-path won't choke
(message "Regenerating:" (->string (file-name-from-path path)))) (message "Rendering" (->string (file-name-from-path path))))
(define/contract (regenerated-message path) (define/contract (rendered-message path)
(any/c . -> . void?) (any/c . -> . void?)
(message "Regenerated:" (->string (file-name-from-path path)))) (message "Rendered" (->string (file-name-from-path path))))
(define/contract (up-to-date-message path)
(define/contract (complete-preproc-source-path x) (any/c . -> . void?)
(pathish? . -> . complete-path?) (message "File is up to date:" (->string (file-name-from-path path))))
(let ([path (->path x)])
(->complete-path (if (preproc-source? path)
path
(make-preproc-source-path path)))))
;; todo: tests
(define/contract (complete-preproc-output-path x)
(pathish? . -> . complete-path?)
(let ([path (->path x)])
(->complete-path (if (preproc-source? path)
(make-preproc-output-path path)
path))))
;; todo: tests
(define/contract (regenerate-with-preproc x #:force [force #f]) (define/contract (render-with-preproc x #:force [force #f])
(((and/c pathish? (((and/c pathish?
(flat-named-contract 'file-exists (flat-named-contract 'file-exists
(λ(x) (file-exists? (complete-preproc-source-path x)))))) (#:force boolean?) . ->* . void?) (λ(x) (file-exists? (->complete-path (->preproc-source-path x))))))) (#:force boolean?) . ->* . void?)
;; x might be either a preproc-source path or preproc-output path ;; x might be either a preproc-source path or preproc-output path
(define source-path (complete-preproc-source-path x)) (define source-path (->complete-path (->preproc-source-path x)))
(define-values (source-dir source-name _) (split-path source-path)) (define-values (source-dir source-name _) (split-path source-path))
(define output-path (complete-preproc-output-path x)) (define output-path (->complete-path (->output-path x)))
;; Three conditions under which we refresh: ;; Three conditions under which we refresh:
(if (or (if (or
@ -175,7 +160,7 @@
(mod-date-expired? source-path)) (mod-date-expired? source-path))
;; use single quotes to escape spaces in pathnames ;; use single quotes to escape spaces in pathnames
(let ([command (format "~a '~a' > '~a'" RACKET_PATH source-path output-path)]) (let ([command (format "~a '~a' > '~a'" RACKET_PATH source-path output-path)])
(regenerating-message (format "~a from ~a" (rendering-message (format "~a from ~a"
(file-name-from-path output-path) (file-name-from-path output-path)
(file-name-from-path source-path))) (file-name-from-path source-path)))
(store-refresh-in-mod-dates source-path) (store-refresh-in-mod-dates source-path)
@ -183,14 +168,14 @@
(parameterize ([current-directory source-dir] (parameterize ([current-directory source-dir]
[current-output-port (open-output-nowhere)]) [current-output-port (open-output-nowhere)])
(system command)) (system command))
(regenerated-message output-path)) (rendered-message output-path))
;; otherwise, skip file because there's no trigger for refresh ;; otherwise, skip file because there's no trigger for refresh
(message "File is up to date:" (->string (file-name-from-path output-path))))) (up-to-date-message output-path)))
;; todo: write tests ;; todo: write tests
;; utility function for regenerate-with-template ;; utility function for render-with-template
(define/contract (handle-source-rerequire source-path) (define/contract (handle-source-rerequire source-path)
((and/c path? file-exists?) . -> . boolean?) ((and/c path? file-exists?) . -> . boolean?)
@ -219,10 +204,10 @@
(->boolean (> (len (get-output-string port-for-catching-file-info)) 0))) (->boolean (> (len (get-output-string port-for-catching-file-info)) 0)))
(define (complete-pollen-source-path x) (define (complete-pollen-source-path x)
(->complete-path (make-pollen-source-path (->path x)))) (->complete-path (->pollen-source-path (->path x))))
;; apply template ;; apply template
(define/contract (regenerate-with-template x [template-name #f] #:force [force #f]) (define/contract (render-with-template x [template-name #f] #:force [force #f])
(((and/c pathish? (((and/c pathish?
(flat-named-contract 'file-exists (flat-named-contract 'file-exists
(λ(x) (file-exists? (complete-pollen-source-path x)))))) (λ(x) (file-exists? (complete-pollen-source-path x))))))
@ -237,13 +222,13 @@
(define source-reloaded? (handle-source-rerequire source-path)) (define source-reloaded? (handle-source-rerequire source-path))
;; Then the rest: ;; Then the rest:
;; set the template, regenerate the source file with template, and catch the output. ;; set the template, render the source file with template, and catch the output.
;; 1) Set the template. ;; 1) Set the template.
(define template-path (define template-path
(or (or
;; 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 (make-preproc-source-path p))) p #f)) (ormap (λ(p) (if (ormap file-exists? (list p (->preproc-source-path p))) p #f))
(filter-not false? (filter-not false?
(list (list
;; path based on template-name ;; path based on template-name
@ -253,22 +238,23 @@
(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 =
(build-path source-dir DEFAULT_TEMPLATE)))) ;; "-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 temporary template file ;; if none of these work, make temporary template file
(let ([tp (build-path source-dir FALLBACK_TEMPLATE_NAME)]) (let ([tp (build-path source-dir FALLBACK_TEMPLATE_NAME)])
(display-to-file #:exists 'replace fallback-template-data tp) (display-to-file #:exists 'replace fallback-template-data tp)
tp))) tp)))
;; refresh template (it might have its own preprocessor file) ;; refresh template (it might have its own preprocessor file)
(regenerate template-path #:force force) (render template-path #:force force)
;; calculate new path for generated file ;; calculate new path for generated file
(define output-path (make-pollen-output-path source-path)) (define output-path (->output-path source-path))
;; 2) Regenerate the source file with template, if needed. ;; 2) render the source file with template, if needed.
;; Regenerate is expensive, so we avoid it when we can. ;; render is expensive, so we avoid it when we can.
;; Four conditions where we regenerate: ;; Four conditions where we render:
(if (or force ; a) it's explicitly demanded (if (or force ; a) it's explicitly demanded
(not (file-exists? output-path)) ; b) output file does not exist (not (file-exists? output-path)) ; b) output file does not exist
;; c) mod-dates indicates refresh is needed ;; c) mod-dates indicates refresh is needed
@ -277,12 +263,11 @@
source-reloaded?) source-reloaded?)
(begin (begin
(store-refresh-in-mod-dates source-path template-path) (store-refresh-in-mod-dates source-path template-path)
(message "Rendering source" (->string source-path) (message "Rendering source" (->string (file-name-from-path source-path)) "with template" (->string (file-name-from-path template-path)))
"with template" (->string template-path))
(let ([page-result (render-source-with-template source-path template-path)]) (let ([page-result (render-source-with-template source-path template-path)])
(display-to-file #:exists 'replace page-result output-path) (display-to-file #:exists 'replace page-result output-path)
(regenerated-message (file-name-from-path output-path)))) (rendered-message output-path)))
(message "Regenerate with template: file is up to date:" (->string (file-name-from-path output-path)))) (up-to-date-message output-path))
;; delete fallback template if needed ;; delete fallback template if needed
(let ([tp (build-path source-dir FALLBACK_TEMPLATE_NAME)]) (let ([tp (build-path source-dir FALLBACK_TEMPLATE_NAME)])
@ -316,11 +301,13 @@
(eval `(require ,(path->string source-name)) (current-namespace)) (eval `(require ,(path->string source-name)) (current-namespace))
(eval `(include-template #:command-char ,TEMPLATE_FIELD_DELIMITER ,(->string template-name)) (current-namespace)))) (eval `(include-template #:command-char ,TEMPLATE_FIELD_DELIMITER ,(->string template-name)) (current-namespace))))
;; regenerate files listed in a ptree file ;; render files listed in a ptree file
(define/contract (regenerate-with-ptree ptree #:force [force #f]) (define/contract (render-ptree-files ptree #:force [force #f])
((ptree?) (#:force boolean?) . ->* . void?) ((ptree?) (#:force boolean?) . ->* . void?)
;; pass force parameter through ;; pass force parameter through
(for-each (λ(i) (regenerate i #:force force)) (all-pages ptree))) (for-each (λ(i) (render i #:force force))
;; use dynamic-require to avoid requiring ptree.rkt every time render.rkt is required
((dynamic-require "ptree.rkt" 'all-pages) ptree)))

34
server-routes.rkt
Unescape Escape View File

@ -2,7 +2,7 @@
(require racket/list racket/contract racket/rerequire racket/file racket/format xml) (require racket/list racket/contract racket/rerequire racket/file racket/format xml)
(require (only-in net/url url-query url->path url->string)) (require (only-in net/url url-query url->path url->string))
(require (only-in web-server/http/request-structs request-uri request-client-ip)) (require (only-in web-server/http/request-structs request-uri request-client-ip))
(require "world.rkt" "regenerate.rkt" "readability.rkt" "predicates.rkt" "debug.rkt") (require "world.rkt" "render.rkt" "readability.rkt" "predicates.rkt" "debug.rkt")
(module+ test (require rackunit)) (module+ test (require rackunit))
@ -13,24 +13,24 @@
(provide (all-defined-out)) (provide (all-defined-out))
;; extract main xexpr from a path ;; extract main xexpr from a path
(define/contract (file->xexpr path #:regen [regen #t]) (define/contract (file->xexpr path #:render [wants-render #t])
((complete-path?) (#:regen boolean?) . ->* . tagged-xexpr?) ((complete-path?) (#:render boolean?) . ->* . tagged-xexpr?)
(when regen (regenerate path)) ; refresh path (when wants-render (render path))
(dynamic-rerequire path) ; stores module mod date; reloads if it's changed (dynamic-rerequire path) ; stores module mod date; reloads if it's changed
(dynamic-require path 'main)) (dynamic-require path 'main))
(module+ test (module+ test
(check-equal? (file->xexpr (build-path (current-directory) "tests/server-routes/foo.p") #:regen #f) '(root "\n" "foo"))) (check-equal? (file->xexpr (build-path (current-directory) "tests/server-routes/foo.p") #:render #f) '(root "\n" "foo")))
;; read contents of file to string ;; read contents of file to string
;; just file->string with a regenerate option ;; just file->string with a render option
(define/contract (slurp path #:regen [regen #t]) (define/contract (slurp path #:render [wants-render #t])
((complete-path?) (#:regen boolean?) . ->* . string?) ((complete-path?) (#:render boolean?) . ->* . string?)
(when regen (regenerate path)) (when wants-render (render path))
(file->string path)) (file->string path))
(module+ test (module+ test
(check-equal? (slurp (build-path (current-directory) "tests/server-routes/bar.html") #:regen #f) "<html><body><p>bar</p></body></html>")) (check-equal? (slurp (build-path (current-directory) "tests/server-routes/bar.html") #:render #f) "<html><body><p>bar</p></body></html>"))
;; add a wrapper to tagged-xexpr that displays it as monospaced text ;; add a wrapper to tagged-xexpr that displays it as monospaced text
@ -56,7 +56,7 @@
;; for viewing source without using "view source" ;; for viewing source without using "view source"
(define/contract (route-raw-html path) (define/contract (route-raw-html path)
(complete-path? . -> . xexpr?) (complete-path? . -> . xexpr?)
(format-as-code (slurp path #:regen #f))) (format-as-code (slurp path #:render #f)))
;; todo: consolidate with function above, they're the same. ;; todo: consolidate with function above, they're the same.
;; server route that shows contents of file on disk ;; server route that shows contents of file on disk
@ -80,14 +80,14 @@
;; get lists of files by mapping a filter function for each file type ;; get lists of files by mapping a filter function for each file type
(define-values (pollen-files preproc-files ptree-files template-files) (define-values (pollen-files preproc-files ptree-files template-files)
(let ([all-files-in-project-directory (directory-list pollen-file-root)]) (let ([all-files-in-project-directory (directory-list pollen-project-directory)])
(apply values (apply values
(map (λ(test) (filter test all-files-in-project-directory)) (map (λ(test) (filter test all-files-in-project-directory))
(list pollen-source? preproc-source? ptree-source? template-source?))))) (list pollen-source? preproc-source? ptree-source? template-source?)))))
;; The actual post-preproc files may not have been generated yet ;; The actual post-preproc files may not have been generated yet
;; so calculate their names (rather than rely on directory list) ;; so calculate their names (rather than rely on directory list)
(define post-preproc-files (map make-preproc-output-path preproc-files)) (define post-preproc-files (map ->output-path preproc-files))
;; Make a combined list of preproc files and post-preproc file, in alphabetical order ;; Make a combined list of preproc files and post-preproc file, in alphabetical order
(define all-preproc-files (sort (append preproc-files post-preproc-files) (define all-preproc-files (sort (append preproc-files post-preproc-files)
@ -98,7 +98,7 @@
;; not necessarily true (it will assume the extension of its template.) ;; not necessarily true (it will assume the extension of its template.)
;; But pulling out all the template extensions requires parsing all the files, ;; But pulling out all the template extensions requires parsing all the files,
;; which is slow and superfluous, since we're trying to be lazy about rendering. ;; which is slow and superfluous, since we're trying to be lazy about rendering.
(define post-pollen-files (map make-pollen-output-path pollen-files)) (define post-pollen-files (map ->output-path pollen-files))
;; Make a combined list of pollen files and post-pollen files, in alphabetical order ;; Make a combined list of pollen files and post-pollen files, in alphabetical order
(define all-pollen-files (sort (append pollen-files post-pollen-files) #:key path->string string<?)) (define all-pollen-files (sort (append pollen-files post-pollen-files) #:key path->string string<?))
@ -149,7 +149,7 @@
; default route ; default route
(define (route-default req) (define (route-default req)
(define request-url (request-uri req)) (define request-url (request-uri req))
(define path (reroot-path (url->path request-url) pollen-file-root)) (define path (reroot-path (url->path request-url) pollen-project-directory))
(define force (equal? (get-query-value request-url 'force) "true")) (define force (equal? (get-query-value request-url 'force) "true"))
(with-handlers ([exn:fail? (λ(e) (message "Regenerate is skipping" (url->string request-url) "because of error\n" (exn-message e)))]) (with-handlers ([exn:fail? (λ(e) (message "Render is skipping" (url->string request-url) "because of error\n" (exn-message e)))])
(regenerate path #:force force))) (render path #:force force)))

6
server.rkt
Unescape Escape View File

@ -1,5 +1,5 @@
#lang web-server #lang web-server
(require "start.rkt") (require "startup.rkt")
(require web-server/servlet-env) (require web-server/servlet-env)
(require web-server/dispatch web-server/dispatchers/dispatch) (require web-server/dispatch web-server/dispatchers/dispatch)
(require xml) (require xml)
@ -18,7 +18,7 @@
(λ(req string-arg) (λ(req string-arg)
(logger req) (logger req)
(define filename string-arg) (define filename string-arg)
(response/xexpr (route-proc (build-path pollen-file-root filename))))) (response/xexpr (route-proc (build-path pollen-project-directory filename)))))
(define-values (start url) (define-values (start url)
(dispatch-rules (dispatch-rules
@ -42,4 +42,4 @@
#:listen-ip #f #:listen-ip #f
#:servlet-regexp #rx"" ; respond to top level #:servlet-regexp #rx"" ; respond to top level
#:command-line? #t #:command-line? #t
#:extra-files-paths (list (build-path pollen-file-root))) #:extra-files-paths (list (build-path pollen-project-directory)))

0
start.rkt → startup.rkt
Unescape Escape View File

6
template.rkt
Unescape Escape View File

@ -26,7 +26,7 @@
(cond (cond
;; Using put has no effect on tagged-xexprs. It's here to make the idiom smooth. ;; Using put has no effect on tagged-xexprs. It's here to make the idiom smooth.
[(tagged-xexpr? x) x] [(tagged-xexpr? x) x]
[(has-pollen-source? x) (dynamic-require (make-pollen-source-path x) 'main)])) [(has-pollen-source? x) (dynamic-require (->pollen-source-path x) 'main)]))
(module+ test (module+ test
(check-equal? (put '(foo "bar")) '(foo "bar")) (check-equal? (put '(foo "bar")) '(foo "bar"))
@ -48,14 +48,14 @@
(define/contract (find-in-metas px key) (define/contract (find-in-metas px key)
(puttable-item? query-key? . -> . (or/c xexpr-elements? false?)) (puttable-item? query-key? . -> . (or/c xexpr-elements? false?))
(and (has-pollen-source? px) (and (has-pollen-source? px)
(let ([metas (dynamic-require (make-pollen-source-path px) 'metas)] (let ([metas (dynamic-require (->pollen-source-path px) 'metas)]
[key (->string key)]) [key (->string key)])
(and (key . in? . metas ) (->list (get metas key)))))) (and (key . in? . metas ) (->list (get metas key))))))
(module+ test (module+ test
(parameterize ([current-directory "tests/template"]) (parameterize ([current-directory "tests/template"])
(check-equal? (find-in-metas "put" "foo") (list "bar")) (check-equal? (find-in-metas "put" "foo") (list "bar"))
(let* ([metas (dynamic-require (make-pollen-source-path 'put) 'metas)] (let* ([metas (dynamic-require (->pollen-source-path 'put) 'metas)]
[here (find-in-metas 'put 'here)] [here (find-in-metas 'put 'here)]
[here-relative (list (->string (find-relative-path (current-directory) (car here))))]) [here-relative (list (->string (find-relative-path (current-directory) (car here))))])
(check-equal? here-relative (list "put.p"))))) (check-equal? here-relative (list "put.p")))))

2
tools.rkt
Unescape Escape View File

@ -16,7 +16,7 @@
;; 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?))
(define extras-directory (build-path pollen-file-root EXTRAS_DIR)) (define extras-directory (build-path pollen-project-directory EXTRAS_DIR))
(and (directory-exists? extras-directory) (and (directory-exists? extras-directory)
;; #:build? option returns complete paths (instead of just file names) ;; #:build? option returns complete paths (instead of just file names)
(let ([files (filter project-require-file? (directory-list extras-directory #:build? #t))]) (let ([files (filter project-require-file? (directory-list extras-directory #:build? #t))])

2
world.rkt
Unescape Escape View File

@ -8,7 +8,7 @@
(define POLLEN_EXPRESSION_DELIMITER #\◊) (define POLLEN_EXPRESSION_DELIMITER #\◊)
(define TEMPLATE_FIELD_DELIMITER POLLEN_EXPRESSION_DELIMITER) (define TEMPLATE_FIELD_DELIMITER POLLEN_EXPRESSION_DELIMITER)
(define DEFAULT_TEMPLATE "-main.html") (define DEFAULT_TEMPLATE_PREFIX "-main")
(define FALLBACK_TEMPLATE_NAME "-temp-fallback-template.html") (define FALLBACK_TEMPLATE_NAME "-temp-fallback-template.html")
(define TEMPLATE_META_KEY "template") (define TEMPLATE_META_KEY "template")

Write Preview
Loading…
Cancel
Save