code updates

pull/9/head
Matthew Butterick 10 years ago
parent c5073b36cd
commit 14369f6c0f

@ -75,9 +75,7 @@
;; set up the 'doc export
(require pollen/decode)
(define doc (apply (cond
[(equal? parser-mode world:reader-mode-ptree)
(λ xs (decode (cons world:ptree-root-node xs)
#:txexpr-elements-proc (λ(xs) (filter (compose1 not (def/c whitespace?)) xs))))]
[(equal? parser-mode world:reader-mode-ptree) (λ xs ((dynamic-require 'pollen/ptree 'decode-ptree) xs))]
;; 'root is the hook for the decoder function.
;; If it's not a defined identifier, it just hits #%top and becomes `(root ,@body ...)
[(or (equal? parser-mode world:reader-mode-markup)

@ -1,22 +1,45 @@
#lang racket/base
(require racket/path racket/bool xml)
(require "tools.rkt" "world.rkt" "decode.rkt" sugar txexpr "cache.rkt")
(define+provide current-ptree (make-parameter #f))
(define+provide (pnode? x)
(->boolean (and (xexpr? x) (try (not (whitespace/nbsp? (->string x)))
(except [exn:fail? (λ(e) #f)])))))
(->boolean (and (symbol? x) (try (not (whitespace/nbsp? (->string x)))
(except [exn:fail? (λ(e) #f)])))))
(define+provide (pnodeish? x)
(try (pnode? (->symbol x))
(except [exn:fail? (λ(e) #f)])))
(define/contract+provide (->pnode x)
(pnodeish? . -> . pnode?)
(->symbol x))
(define+provide/contract (pnode?/error x)
(any/c . -> . boolean?)
(or (pnode? x) (error "Not a valid pnode:" x)))
(define+provide/contract (decode-ptree xs)
(txexpr-elements? . -> . any/c) ; because ptree is being explicitly validated
(validate-ptree
(decode (cons world:ptree-root-node xs)
#:txexpr-elements-proc (λ(xs) (filter (compose1 not whitespace?) xs))
#:string-proc string->symbol))) ; because faster than ->pnode
(define+provide (validate-ptree x)
(let ([pnodes (ptree->list x)])
(and
(andmap (λ(p) (or (pnode? p) (error (format "validate-ptree: \"~a\" is not a valid pnode" p)))) pnodes)
(try (members-unique?/error pnodes)
(except [exn:fail? (λ(e) (error (format "validate-ptree: ~a" (exn-message e))))]))
x)))
(define+provide (ptree? x)
(->boolean (and (txexpr? x)
(andmap (λ(i) (or (pnode? i) (ptree? i))) x)
(members-unique? (ptree->list x)))))
(try (->boolean (validate-ptree x))
(except [exn:fail? (λ(e) #f)])))
;; Try loading from ptree file, or failing that, synthesize ptree.
@ -26,107 +49,64 @@
(cached-require ptree-source world:main-pollen-export))
(define+provide/contract (parent pnode [ptree (current-ptree)])
(((or/c false? pnode?)) (ptree?) . ->* . (or/c false? pnode?))
(and pnode
(if (member (->string pnode) (map (λ(x) (->string (if (list? x) (car x) x))) (cdr ptree)))
(->string (car ptree))
(ormap (λ(x) (parent pnode x)) (filter list? ptree)))))
(define+provide/contract (parent p [ptree (current-ptree)])
(((or/c #f pnodeish?)) (ptree?) . ->* . (or/c #f pnode?))
(and ptree p
(let ([pnode (->pnode p)])
(if (member pnode (map (λ(x) (if (list? x) (car x) x)) (cdr ptree)))
(car ptree)
(ormap (λ(x) (parent pnode x)) (filter list? ptree))))))
(define+provide/contract (children pnode [ptree (current-ptree)])
(((or/c false? pnode?)) (ptree?) . ->* . (or/c false? (listof pnode?)))
(and pnode
(if (equal? (->string pnode) (->string (car ptree)))
(map (λ(x) (->string (if (list? x) (car x) x))) (cdr ptree))
(ormap (λ(x) (children pnode x)) (filter list? ptree)))))
(define+provide/contract (children p [ptree (current-ptree)])
(((or/c #f pnodeish?)) (ptree?) . ->* . (or/c #f (listof pnode?)))
(and ptree p
(let ([pnode (->pnode p)])
(if (equal? pnode (car ptree))
(map (λ(x) (if (list? x) (car x) x)) (cdr ptree))
(ormap (λ(x) (children pnode x)) (filter list? ptree))))))
(define+provide/contract (siblings pnode [ptree (current-ptree)])
(((or/c false? pnode?)) (ptree?) . ->* . (or/c false? (listof string?)))
(children (parent pnode ptree) ptree))
(define+provide/contract (siblings p [ptree (current-ptree)])
(((or/c #f pnodeish?)) (ptree?) . ->* . (or/c #f (listof pnode?)))
(children (parent p ptree) ptree))
;; flatten tree to sequence
(define+provide/contract (ptree->list [ptree (current-ptree)])
(ptree? . -> . (listof string?))
(define+provide/contract (ptree->list ptree)
(ptree? . -> . (listof pnode?))
; use cdr to get rid of root tag at front
(map ->string (cdr (flatten ptree))))
(cdr (flatten ptree)))
(define+provide/contract (adjacents side pnode [ptree (current-ptree)])
((symbol? (or/c false? pnode?)) (ptree?) . ->* . (or/c false? (listof pnode?)))
(and pnode
(let* ([proc (if (equal? side 'left) takef takef-right)]
[result (proc (ptree->list ptree) (λ(x) (not (equal? (->string pnode) (->string x)))))])
(define (adjacents side p [ptree (current-ptree)])
; ((symbol? (or/c #f pnodeish?)) (ptree?) . ->* . (or/c #f (listof pnode?)))
(and ptree p
(let* ([pnode (->pnode p)]
[proc (if (equal? side 'left) takef takef-right)]
[result (proc (ptree->list ptree) (λ(x) (not (equal? pnode x))))])
(and (not (empty? result)) result))))
(define+provide/contract (left-adjacents pnode [ptree (current-ptree)])
(((or/c false? pnode?)) (ptree?) . ->* . (or/c false? (listof pnode?)))
(define+provide/contract (previous* pnode [ptree (current-ptree)])
(((or/c #f pnodeish?)) (ptree?) . ->* . (or/c #f (listof pnode?)))
(adjacents 'left pnode ptree))
(define+provide/contract (right-adjacents pnode [ptree (current-ptree)])
(((or/c false? pnode?)) (ptree?) . ->* . (or/c false? (listof pnode?)))
(define+provide/contract (next* pnode [ptree (current-ptree)])
(((or/c #f pnodeish?)) (ptree?) . ->* . (or/c #f (listof pnode?)))
(adjacents 'right pnode ptree))
(define+provide/contract (previous pnode [ptree (current-ptree)])
(((or/c false? pnode?)) (ptree?) . ->* . (or/c false? pnode?))
(let ([result (left-adjacents pnode ptree)])
(((or/c #f pnodeish?)) (ptree?) . ->* . (or/c #f pnode?))
(let ([result (previous* pnode ptree)])
(and result (last result))))
(define+provide/contract (next pnode [ptree (current-ptree)])
(((or/c false? pnode?)) (ptree?) . ->* . (or/c false? pnode?))
(let ([result (right-adjacents pnode ptree)])
(((or/c #f pnodeish?)) (ptree?) . ->* . (or/c #f pnode?))
(let ([result (next* pnode ptree)])
(and result (first result))))
;; this is a helper function to permit unit tests
(define+provide (pnode->url/paths pnode url-list)
;; check for duplicates because some sources might have already been rendered
(define output-paths (remove-duplicates (map ->output-path url-list) equal?))
(define matching-paths (filter (λ(x) (equal? (->string x) (->string pnode))) output-paths))
(cond
[((len matching-paths) . = . 1) (->string (car matching-paths))]
[((len matching-paths) . > . 1) (error "More than one matching URL for" pnode)]
[else #f]))
(define+provide/contract (pnode->url pnode [url-context (current-url-context)])
((pnode?) (pathish?) . ->* . (or/c false? pnode?))
(parameterize ([current-url-context url-context])
(pnode->url/paths pnode (directory-list (current-url-context)))))
;; this sets default input for following functions
(define+provide/contract (ptree-root->ptree tx)
;; (not/c ptree) prevents ptrees from being accepted as input
((and/c txexpr?) . -> . ptree?)
tx)
(define+provide/contract (pnodes-unique?/error x)
(any/c . -> . boolean?)
(define members (filter-not whitespace? (flatten x)))
(and (andmap pnode?/error members)
(members-unique?/error (map ->string members))))
(define+provide/contract (ptree-source-decode . elements)
(() #:rest pnodes-unique?/error . ->* . ptree?)
(ptree-root->ptree (decode (cons world:ptree-root-node elements)
#:txexpr-elements-proc (λ(xs) (filter-not whitespace? xs)))))
(define current-ptree (make-parameter #f))
(define current-url-context (make-parameter (world:current-project-root)))
(provide current-ptree current-url-context)
;; used to convert here-path into here
(define+provide/contract (path->pnode path)
(pathish? . -> . pnode?)
(->string (->output-path (find-relative-path (world:current-project-root) (->path path)))))

@ -245,8 +245,7 @@
(list? . -> . bytes?)
(parameterize ([current-namespace (make-base-namespace)]
[current-output-port (current-error-port)]
[current-ptree (make-project-ptree (world:current-project-root))]
[current-url-context (world:current-project-root)])
[current-ptree (make-project-ptree (world:current-project-root))])
(for-each (λ(mod-name) (namespace-attach-module cache-ns mod-name))
`(web-server/templates
xml

@ -14,9 +14,7 @@
(define/contract (puttable-item? x)
(any/c . -> . boolean?)
(or (txexpr? x)
(has-markup-source? x)
(and (pnode? x) (pnode->url x) (has-markup-source? (pnode->url x)))))
(or (txexpr? x) (has-markup-source? x)))
(module+ test
(check-false (puttable-item? #t))
@ -31,8 +29,7 @@
(cond
;; Using put has no effect on txexprs. It's here to make the idiom smooth.
[(txexpr? x) x]
[(has-markup-source? x) (cached-require (->markup-source-path x) world:main-pollen-export)]
[(has-markup-source? (pnode->url x)) (cached-require (->markup-source-path (pnode->url x)) world:main-pollen-export)]))
[(has-markup-source? x) (cached-require (->markup-source-path x) world:main-pollen-export)]))
#|(module+ test
(check-equal? (put '(foo "bar")) '(foo "bar"))

@ -3,59 +3,59 @@
(require "../ptree.rkt" "../world.rkt")
(check-true (pnode? "foo-bar"))
(check-true (pnode? "Foo_Bar_0123"))
(check-false (pnode? "foo-bar"))
(check-false (pnode? "Foo_Bar_0123"))
(check-true (pnode? 'foo-bar))
(check-true (pnode? "foo-bar.p"))
(check-true (pnode? "/Users/MB/foo-bar"))
(check-false (pnode? "foo-bar.p"))
(check-false (pnode? "/Users/MB/foo-bar"))
(check-false (pnode? #f))
(check-false (pnode? ""))
(check-false (pnode? " "))
(check-true (ptree? '(foo)))
(check-true (ptree? '(foo (hee))))
(check-true (ptree? '(foo (hee (uncle "foo")))))
(check-false (ptree? '(foo (hee hee (uncle "foo")))))
(check-true (ptree? '(foo (hee (uncle foo)))))
(check-false (ptree? '(foo (hee hee (uncle foo)))))
(define test-ptree-main `(ptree-main "foo" "bar" (one (two "three"))))
(define test-ptree-main `(ptree-main foo bar (one (two three))))
(define test-ptree (ptree-root->ptree test-ptree-main))
(check-equal? (parent 'three test-ptree) "two")
(check-equal? (parent "three" test-ptree) "two")
(check-equal? (parent 'three test-ptree) 'two)
(check-equal? (parent "three" test-ptree) 'two)
(check-false (parent #f test-ptree))
(check-false (parent 'nonexistent-name test-ptree))
(check-equal? (children 'one test-ptree) (list "two"))
(check-equal? (children 'two test-ptree) (list "three"))
(check-equal? (children 'one test-ptree) '(two))
(check-equal? (children 'two test-ptree) '(three))
(check-false (children 'three test-ptree))
(check-false (children #f test-ptree))
(check-false (children 'fooburger test-ptree))
(check-equal? (siblings 'one test-ptree) '("foo" "bar" "one"))
(check-equal? (siblings 'foo test-ptree) '("foo" "bar" "one"))
(check-equal? (siblings 'two test-ptree) '("two"))
(check-equal? (siblings 'one test-ptree) '(foo bar one))
(check-equal? (siblings 'foo test-ptree) '(foo bar one))
(check-equal? (siblings 'two test-ptree) '(two))
(check-false (siblings #f test-ptree))
(check-false (siblings 'invalid-key test-ptree))
(check-equal? (left-adjacents 'one test-ptree) '("foo" "bar"))
(check-equal? (left-adjacents 'three test-ptree) '("foo" "bar" "one" "two"))
(check-false (left-adjacents 'foo test-ptree))
(check-equal? (previous* 'one test-ptree) '(foo bar))
(check-equal? (previous* 'three test-ptree) '(foo bar one two))
(check-false (previous* 'foo test-ptree))
(check-equal? (previous 'one test-ptree) "bar")
(check-equal? (previous 'three test-ptree) "two")
(check-equal? (previous 'one test-ptree) 'bar)
(check-equal? (previous 'three test-ptree) 'two)
(check-false (previous 'foo test-ptree))
(check-equal? (next 'foo test-ptree) "bar")
(check-equal? (next 'one test-ptree) "two")
(check-equal? (next 'foo test-ptree) 'bar)
(check-equal? (next 'one test-ptree) 'two)
(check-false (next 'three test-ptree))
(check-equal? (ptree->list test-ptree) '("foo" "bar" "one" "two" "three"))
(check-equal? (ptree->list test-ptree) '(foo bar one two three))
(let ([sample-main `(world:pollen-tree-root-name "foo" "bar" (one (two "three")))])
(let ([sample-main `(world:pollen-tree-root-name foo bar (one (two three)))])
(check-equal? (ptree-root->ptree sample-main)
`(world:pollen-tree-root-name "foo" "bar" (one (two "three")))))
`(world:pollen-tree-root-name foo bar (one (two three)))))
(define files '("foo.html" "bar.html" "bar.html.p" "zap.html" "zap.xml"))
(check-equal? (pnode->url/paths 'foo.html files) "foo.html")
@ -64,6 +64,6 @@
(check-false (pnode->url/paths 'hee files))
(set! test-ptree-main `(,world:ptree-root-node "foo" "bar" (one (two "three"))))
(set! test-ptree-main `(,world:ptree-root-node foo bar (one (two three))))
(check-equal? (ptree-root->ptree test-ptree-main)
`(,world:ptree-root-node "foo" "bar" (one (two "three"))))
`(,world:ptree-root-node foo bar (one (two three))))
Loading…
Cancel
Save