pull/9/head
Matthew Butterick 11 years ago
parent 8faace5b8e
commit 7caab48bba

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

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

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

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

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

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

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

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

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

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

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

Loading…
Cancel
Save