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

even faster

Browse Source
pull/9/head
Matthew Butterick 11 years ago
parent acc990b094
commit 925aeadfb1
7 changed files with 195 additions and 197 deletions
Show Stats Download Patch File Download Diff File

20
lang/reader.rkt
Unescape Escape View File

@ -1,24 +1,28 @@
#lang racket/base #lang racket/base
(require (only-in scribble/reader make-at-reader)) (require (only-in scribble/reader make-at-reader))
(provide (rename-out [mb-read read] [mb-read-syntax read-syntax]) read-inner) (provide (rename-out [pollen-read read] [pollen-read-syntax read-syntax]) read-inner)
(define read-inner (define read-inner
(make-at-reader #:command-char #\◊ (make-at-reader #:command-char #\◊
#:syntax? #t #:syntax? #t
#:inside? #t)) #:inside? #t))
(define (mb-read p) (define (pollen-read p)
(syntax->datum (syntax->datum
(mb-read-syntax (object-name p) p))) (pollen-read-syntax (object-name p) p)))
(define (make-output-datum i) (define (make-output-datum i)
`(module pollen-lang-module pollen `(module pollen-lang-module pollen
,@i)) ,@i))
(define (mb-read-syntax path-string p) (define (pollen-read-syntax path-string p)
(define i (read-inner path-string p)) (define file-contents (read-inner path-string p))
(datum->syntax i (define file-ext (car (regexp-match #px"\\w+$" (path->string path-string))))
`(module pollen-lang-module pollen/main-preproc ,@i) (datum->syntax file-contents
i)) `(module pollen-lang-module ,(if (member file-ext (list "pd" "ptree"))
'pollen/main
'pollen/main-preproc)
,@file-contents)
file-contents))

106
main-current.rkt
Unescape Escape View File

@ -0,0 +1,106 @@
#lang racket/base
(require "main-imports.rkt")
(provide (except-out (all-from-out racket/base) #%module-begin)
(rename-out [module-begin #%module-begin]))
(define-syntax-rule (module-begin expr ...)
(#%module-begin
;; this is here only so that dynamic-rerequire of a pollen module
;; transitively reloads the extras also.
;; if this isn't here, then dynamic-rerequire can't see them
;; and thus they are not tracked for changes.
(require-extras)
;; We want our module language to support require & provide
;; which are only supported at the module level, so ...
;; create a submodule to contain the input
;; and export as needed
;; doclang2_raw is a clone of scribble/doclang2 with decode disabled
;; helpful because it collects & exports content via 'doc
(module pollen-inner pollen/lang/doclang2_raw
;; use same requires as top of main.rkt
;; (can't import them from surrounding module due to submodule rules)
;; todo: how to keep these two lists in sync?
;; and why doesn't this work:
;; (require pollen/main-imports)
;; (provide (all-from-out pollen/main-imports))
(require pollen/tools pollen/main-helper pollen/top pollen/ptree sugar txexpr)
(require-and-provide-extras) ; brings in the project require files
expr ... ; body of module
;; set up a hook for identifier 'here'
;; (but under a different name to avoid macrofication)
(define inner-here-path here-path)
(provide (all-defined-out))
(provide (all-from-out ; pollen file should bring its requires
pollen/tools)))
(require 'pollen-inner) ; provides doc & #%top, among other things
(define here ((bound/c path->pnode) inner-here-path))
;; prepare the elements, and append inner-here-path as meta.
;; put it first so it can be overridden by custom meta later on
(define all-elements (cons `(meta "here-path" ,inner-here-path)
(cons `(meta "here" ,here)
(cond
;; doc is probably a list, but might be a single string
[(string? doc) (list doc)]
;; if it's a single nx, just leave it
[(txexpr? doc) (list doc)]
;; if it's nx content, splice it in
[(list? doc) doc]))))
;; split out the metas now (in raw form)
(define-values (metas-raw main-raw)
((bound/c split-tag-from-xexpr) 'meta (make-txexpr 'irrelevant-tag empty all-elements)))
(define metas (make-meta-hash metas-raw))
;; Policy: here in the core lang, do as little to main as possible.
;; The point is just to set it up for further processing.
;; Unlike Scribble, which insists on decoding,
;; Pollen just passes through the minimally processed data.
;; one exception: if file extension marks it as ptree, send it to the ptree decoder instead.
;; this tests inner-here (which is always the file name)
;; rather than (get metas 'here) which might have been overridden.
;; Because if it's overridden to something other than *.ptree,
;; ptree processing will fail.
;; This defeats rule that ptree file suffix triggers ptree decoding.
(define here-is-ptree? ((bound/c ptree-source?) ((bound/c ->path) inner-here-path)))
(define main (apply (if here-is-ptree?
;; ptree source files will go this way,
(bound/c ptree-source-decode)
;; ... but other files, including pollen, will go this way.
;; Root is treated as a function.
;; If it's not defined elsewhere,
;; it just hits #%top and becomes a txexpr.
root) ((bound/c get-elements) main-raw)))
(provide main metas here
(except-out (all-from-out 'pollen-inner) inner-here-path) ; everything from user
(rename-out (inner-here-path here-path))) ; change identifier back (now safe from macrofication)
(module+ main
(displayln ";-------------------------")
(displayln (string-append "; pollen decoded 'main" (if here-is-ptree? " (as ptree)" "")))
(displayln ";-------------------------")
main
(displayln "")
(if here-is-ptree?
(displayln (format "(ptree? main) ~a" (ptree? main)))
(displayln (format "(txexpr? main) ~a" (txexpr? main))))
(displayln "")
(displayln ";-------------------------")
(displayln "; pollen 'metas")
(displayln ";-------------------------")
metas
)))

25
main-helper.rkt
Unescape Escape View File

@ -26,39 +26,22 @@
(define-syntax (require-project-require-files stx) (define-syntax (require-project-require-files stx)
(do-project-require-file-syntax stx)) (do-project-require-file-syntax stx))
;; here = path of this file, relative to current directory.
;; We want to make this identifier behave as a runtime function
;; This requires two steps.
;; First, define the underlying function as syntax-rule
(define-syntax (get-here-path stx) (define-syntax (get-here-path stx)
(datum->syntax stx (datum->syntax stx
'(begin '(begin
;; Even though begin permits defines,
;; This macro might be used in an expression context, ;; This macro might be used in an expression context,
;; whereupon define would cause an error. Therefore, use let. ;; so we use let, not define.
(let* ([ccr (current-contract-region)] ; trick for getting current module name (let* ([ccr (current-contract-region)] ; trick for getting current module name
[hp (cond [here-path (cond
;; if contract-region is called from within submodule, ;; if contract-region is called from within submodule,
;; you get a list ;; you get a list
;; in which case, just grab the path from the front ;; in which case, just grab the path from the front
[(list? ccr) (car ccr)] [(list? ccr) (car ccr)]
;; file isn't yet saved in drracket ;; file isn't yet saved in drracket
;; 'pollen-lang-module name is applied by reader
[(equal? 'pollen-lang-module ccr) 'nowhere] [(equal? 'pollen-lang-module ccr) 'nowhere]
[else ccr])]) [else ccr])])
;; pass complete path back as here value (as string) (path->string here-path)))))
;; Why not relative to current-directory?
;; Because current-directory can't be parameterized
;; so raises possibility of inconsistent values.
;; Whereas the complete path is unambiguous,
;; and can be made relative by the caller (or otherwise altered).
((bound/c ->string) hp)))))
; Second step: apply a separate syntax transform to the identifier itself
; We can't do this in one step, because if the macro goes from identifier to function definition,
; The macro processor will evaluate the body at compile-time, not at runtime.
(define-syntax here-path (λ(stx) (datum->syntax stx '(get-here-path))))

9
main-preproc.rkt
Unescape Escape View File

@ -1,12 +1,12 @@
#lang racket/base #lang racket/base
(provide (except-out (all-from-out racket/base) #%module-begin) (provide (except-out (all-from-out racket/base) #%module-begin)
(rename-out [replacement-module-begin #%module-begin])) (rename-out [new-module-begin #%module-begin]))
(define-syntax-rule (replacement-module-begin body ...) (define-syntax-rule (new-module-begin body ...)
(#%module-begin (#%module-begin
(module inner pollen/lang/doclang_raw (module inner pollen/lang/doclang_raw
main main-raw
(λ(x) (apply string-append (cdr x))) ;; chop first linebreak with cdr (λ(x) (apply string-append (cdr x))) ;; chop first linebreak with cdr
() ()
(require pollen/main-helper) (require pollen/main-helper)
@ -16,7 +16,8 @@
body ...) body ...)
(require 'inner) (require 'inner)
(provide (all-from-out 'inner)) (define main main-raw)
(provide (all-from-out 'inner) main)
(module+ main (module+ main
(display main)))) (display main))))

130
main.rkt
Unescape Escape View File

@ -1,106 +1,56 @@
#lang racket/base #lang racket/base
(require "main-imports.rkt")
(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 [new-module-begin #%module-begin]))
(define-syntax-rule (module-begin expr ...) (define-syntax-rule (new-module-begin body-exprs ...)
(#%module-begin (#%module-begin
;; first three lines are positional arguments
;; this is here only so that dynamic-rerequire of a pollen module (module inner pollen/lang/doclang_raw
;; transitively reloads the extras also. main-raw
;; if this isn't here, then dynamic-rerequire can't see them (λ(x) (cdr x)) ;; chop first linebreak with cdr
;; and thus they are not tracked for changes. ()
(require-extras) (require pollen/main-helper pollen/top )
(require-project-require-files)
;; We want our module language to support require & provide
;; which are only supported at the module level, so ...
;; create a submodule to contain the input
;; and export as needed
;; doclang2_raw is a clone of scribble/doclang2 with decode disabled
;; helpful because it collects & exports content via 'doc
(module pollen-inner pollen/lang/doclang2_raw
;; use same requires as top of main.rkt
;; (can't import them from surrounding module due to submodule rules)
;; todo: how to keep these two lists in sync?
;; and why doesn't this work:
;; (require pollen/main-imports)
;; (provide (all-from-out pollen/main-imports))
(require pollen/tools pollen/main-helper pollen/top pollen/ptree sugar txexpr)
(require-and-provide-extras) ; brings in the project require files
expr ... ; body of module
;; set up a hook for identifier 'here'
;; (but under a different name to avoid macrofication)
(define inner-here-path here-path)
(provide (all-defined-out)) (provide (all-defined-out))
(provide (all-from-out ; pollen file should bring its requires
pollen/tools)))
(require 'pollen-inner) ; provides doc & #%top, among other things ;; Build 'here
(define here-path (get-here-path))
(require (only-in xml xexpr->string))
(require (only-in racket/path find-relative-path))
(require (only-in pollen/file-tools ->output-path))
(require (only-in pollen/world PROJECT_ROOT))
(define (path->pnode path)
(path->string (->output-path (find-relative-path PROJECT_ROOT path))))
(define here (path->pnode here-path))
(define here ((bound/c path->pnode) inner-here-path)) body-exprs ...)
;; prepare the elements, and append inner-here-path as meta. (require 'inner)
;; put it first so it can be overridden by custom meta later on
(define all-elements (cons `(meta "here-path" ,inner-here-path)
(cons `(meta "here" ,here)
(cond
;; doc is probably a list, but might be a single string
[(string? doc) (list doc)]
;; if it's a single nx, just leave it
[(txexpr? doc) (list doc)]
;; if it's nx content, splice it in
[(list? doc) doc]))))
;; split out the metas now (in raw form)
(define-values (metas-raw main-raw)
((bound/c split-tag-from-xexpr) 'meta (make-txexpr 'irrelevant-tag empty all-elements)))
(define metas (make-meta-hash metas-raw)) ;; function to split tag out of txexpr
(require txexpr)
;; Policy: here in the core lang, do as little to main as possible. ;; split out the metas. Might include user-defined metas.
;; The point is just to set it up for further processing. ;; But first, append here-path and here as meta.
;; Unlike Scribble, which insists on decoding, ;; so they can be overridden by custom meta later
;; Pollen just passes through the minimally processed data. ;; 'root is the hook for the decoder function.
;; one exception: if file extension marks it as ptree, send it to the ptree decoder instead. ;; If it's not defined elsewhere, it just hits #%top and becomes a txexpr.
;; this tests inner-here (which is always the file name) (define one-with-everything `(root
;; rather than (get metas 'here) which might have been overridden. ,@(cons `(meta "here-path" ,here-path)
;; Because if it's overridden to something other than *.ptree, (cons `(meta "here" ,here)
;; ptree processing will fail. main-raw))))
;; This defeats rule that ptree file suffix triggers ptree decoding.
(define here-is-ptree? ((bound/c ptree-source?) ((bound/c ->path) inner-here-path)))
(define main (apply (if here-is-ptree? (define is-meta-element? (λ(x) (and (txexpr? x) (equal? 'meta (get-tag x)))))
;; ptree source files will go this way, (define-values (metas-raw main-without-metas)
(bound/c ptree-source-decode) (splitf-txexpr one-with-everything is-meta-element?))
;; ... but other files, including pollen, will go this way.
;; Root is treated as a function.
;; If it's not defined elsewhere,
;; it just hits #%top and becomes a txexpr.
root) ((bound/c get-elements) main-raw)))
(define meta-element-to-pair (λ(x) (cons (cadr x) (caddr x))))
(define metas (make-hash (map meta-element-to-pair metas-raw)))
(define main main-without-metas)
(provide main metas here (provide (all-from-out 'inner) metas main)
(except-out (all-from-out 'pollen-inner) inner-here-path) ; everything from user
(rename-out (inner-here-path here-path))) ; change identifier back (now safe from macrofication)
(module+ main (module+ main
(displayln ";-------------------------") (print main))))
(displayln (string-append "; pollen decoded 'main" (if here-is-ptree? " (as ptree)" "")))
(displayln ";-------------------------")
main
(displayln "")
(if here-is-ptree?
(displayln (format "(ptree? main) ~a" (ptree? main)))
(displayln (format "(txexpr? main) ~a" (txexpr? main))))
(displayln "")
(displayln ";-------------------------")
(displayln "; pollen 'metas")
(displayln ";-------------------------")
metas
)))

6
render.rkt
Unescape Escape View File

@ -220,8 +220,6 @@
;; todo: this won't work with source files nested down one level ;; todo: this won't work with source files nested down one level
(define-values (source-dir ignored also-ignored) (split-path source-path)) (define-values (source-dir ignored also-ignored) (split-path source-path))
;; find out whether source had to be reloaded
(define source-reloaded? (handle-source-rerequire source-path))
;; Then the rest: ;; Then the rest:
;; set the template, render the source file with template, and catch the output. ;; set the template, render the source file with template, and catch the output.
@ -262,7 +260,8 @@
;; c) mod-dates indicates render is needed ;; c) mod-dates indicates render is needed
(mod-date-expired? source-path template-path) (mod-date-expired? source-path template-path)
;; d) dynamic-rerequire indicates the source had to be reloaded ;; d) dynamic-rerequire indicates the source had to be reloaded
source-reloaded?) (let ([source-reloaded? (handle-source-rerequire source-path)])
source-reloaded?))
(begin (begin
(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)))
@ -344,7 +343,6 @@
;; for include-template (used below) ;; for include-template (used below)
(require web-server/templates) (require web-server/templates)
;; for ptree navigation functions, and template commands ;; for ptree navigation functions, and template commands
;; todo: main-helper is here for #%top and bound/c — should they go elsewhere?
(require pollen/debug pollen/ptree pollen/template pollen/top) (require pollen/debug pollen/ptree pollen/template pollen/top)
;; import source into eval space. This sets up main & metas ;; import source into eval space. This sets up main & metas
(require ,(->string source-name)) (require ,(->string source-name))

48
tools.rkt
Unescape Escape View File

@ -1,49 +1,5 @@
#lang racket/base #lang racket/base
(require racket/contract racket/list) (require racket/list "debug.rkt" "predicates.rkt")
(require txexpr sugar "debug.rkt" "predicates.rkt" "world.rkt") (provide (all-from-out racket/list "debug.rkt" "predicates.rkt"))
(provide (all-from-out "debug.rkt" "predicates.rkt" racket/list))
;; setup for test cases
(module+ test (require rackunit))
;; convert list of meta tags to a hash for export from pollen document.
;; every meta is form (meta "key" "value") (enforced by contract)
;; later metas with the same name will override earlier ones.
(define+provide/contract (make-meta-hash mxs)
((listof meta-xexpr?) . -> . hash?)
(apply hash (append-map get-elements mxs)))
(module+ test
(check-equal? (make-meta-hash '((meta "foo" "bar")(meta "hee" "haw")))
(hash "foo" "bar" "hee" "haw"))
(check-equal? (make-meta-hash '((meta "foo" "bar")(meta "foo" "haw")))
(hash "foo" "haw")))
;; function to split tag out of txexpr
(define+provide/contract (split-tag-from-xexpr tag tx)
(txexpr-tag? txexpr? . -> . (values (listof txexpr-element?) txexpr? ))
(define matches '())
(define (extract-tag x)
(cond
[(and (txexpr? x) (equal? tag (car x)))
; stash matched tag but return empty value
(begin
(set! matches (cons x matches))
empty)]
[(txexpr? x) (let-values([(tag attr body) (txexpr->values x)])
(make-txexpr tag attr (extract-tag body)))]
[(txexpr-elements? x) (filter-not empty? (map extract-tag x))]
[else x]))
(define tx-extracted (extract-tag tx)) ;; do this first to fill matches
(values (reverse matches) tx-extracted))
(module+ test
(define xx '(root (meta "foo" "bar") "hello" "world" (meta "foo2" "bar2")
(em "goodnight" "moon" (meta "foo3" "bar3"))))
(check-equal? (call-with-values (λ() (split-tag-from-xexpr 'meta xx)) list)
(list '((meta "foo" "bar") (meta "foo2" "bar2") (meta "foo3" "bar3"))
'(root "hello" "world" (em "goodnight" "moon")))))
Write Preview
Loading…
Cancel
Save