simply ptree & related tests

pull/9/head
Matthew Butterick 11 years ago
parent db873cdc7c
commit eed20de71b

@ -8,7 +8,7 @@
(require racket/list
(planet mb/pollen/tools)
(planet mb/pollen/main-helper)
(only-in (planet mb/pollen/ptree) ptree-source-decode path->name)
(only-in (planet mb/pollen/ptree) ptree-source-decode)
(only-in (planet mb/pollen/predicates) ptree?))
(provide (all-from-out racket/list

@ -49,7 +49,7 @@
(require 'pollen-inner) ; provides doc & #%top, among other things
(define here (path->name inner-here-path))
(define here 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

@ -165,34 +165,16 @@
;; otherwise this becomes a rather expensive contract
;; because every function in ptree.rkt uses it.
;; note that a ptree is just a bunch of recursively nested ptrees.
(define/contract (ptree? x)
(define/contract (ptree? xs)
(any/c . -> . boolean?)
(and (match x
;; a tagged-xexpr with one attr ('parent)
;; whose subelements recursively meet the same test.
[(list (? ptree-name? tag) (? ptree-attr? attr) elements ...)
(andmap ptree? elements)]
[else #f])))
(and (list? xs) (andmap (λ(x) (or (ptree-name? x) (ptree? x))) xs)))
(module+ test
(check-true (ptree? '(foo ((parent "bar")))))
(check-false (ptree? '(foo)))
(check-false (ptree? '(foo ((parent "bar")(hee "haw")))))
(check-true (ptree? '(foo ((parent "bar")) (hee ((parent "foo"))))))
(check-false (ptree? '(foo ((parent "bar")) (hee ((uncle "foo")))))))
;; ptree attr must be ((parent "value"))
(define/contract (ptree-attr? x)
(any/c . -> . boolean?)
(match x
;; todo: how can I use POLLEN_MAP_PARENT_KEY
[`((parent ,(? string?))) #t]
[else #f]))
(check-true (ptree? '(foo)))
(check-true (ptree? '(foo (hee))))
(check-true (ptree? '(foo (hee ((uncle "foo")))))))
(module+ test
(check-true (ptree-attr? '((parent "bar"))))
(check-false (ptree-attr? '((parent "bar") '(foo "bar"))))
(check-false (ptree-attr? '())))
;; ptree location must represent a possible valid filename
@ -203,10 +185,8 @@
;; however, don't restrict it to existing files
;; (author may want to use ptree as wireframe)
(define result
(or (eq? x #f) ; OK for map-key to be #f
(and (or (symbol? x) (string? x))
;; todo: should test be same as valid module ptree-name?
(->boolean (regexp-match #px"^[-_A-Za-z0-9.]+$" (->string x))))))
(or (eq? x #f) ; OK for map-key to be #f
(and (not (list? x)) (not (whitespace? (->string x))))))
(if (and (not result) loud)
(error "Not a valid ptree key:" x)
result))
@ -217,7 +197,7 @@
(check-true (ptree-name? "Foo_Bar_0123"))
(check-true (ptree-name? 'foo-bar))
(check-true (ptree-name? "foo-bar.p"))
(check-false (ptree-name? "/Users/MB/foo-bar"))
(check-true (ptree-name? "/Users/MB/foo-bar"))
(check-false (ptree-name? ""))
(check-false (ptree-name? " ")))
@ -227,6 +207,7 @@
(any/c . -> . boolean?)
(cond
[(or (vector? x) (list? x) (set? x)) (andmap whitespace? (->list x))]
[(equal? "" x) #t] ; empty string is deemed whitespace
[(or (symbol? x) (string? x)) (->boolean (regexp-match #px"^\\s+$" (->string x)))]
[else #f]))

@ -1,5 +1,5 @@
#lang racket/base
(require racket/contract racket/match xml/path)
(require racket/contract racket/match xml/path racket/bool)
(require "tools.rkt" "world.rkt" "debug.rkt" "decode.rkt")
(module+ test (require rackunit))
@ -19,7 +19,7 @@
(directory-pathish? . -> . ptree?)
(let ([files (map remove-ext (filter (λ(x) (has-ext? x POLLEN_DECODER_EXT)) (directory-list dir)))])
(message "Generating ptree from file listing")
(ptree-root->ptree (cons POLLEN_TREE_ROOT_NAME (map path->name files)))))
(ptree-root->ptree (cons POLLEN_TREE_ROOT_NAME files))))
;; Try loading from ptree file, or failing that, synthesize ptree.
@ -30,33 +30,22 @@
(ptree-source->ptree ptree-source)
(directory->ptree project-dir)))
;; remove parents from tree (i.e., just remove attrs)
;; is not the inverse of add-parents, i.e., you do not get back your original input.
(define/contract (remove-parents mt)
(ptree? . -> . tagged-xexpr?)
(remove-attrs mt))
(module+ test
(check-equal? (remove-parents
`(ptree-main ((,POLLEN_TREE_PARENT_NAME "")) (foo ((,POLLEN_TREE_PARENT_NAME ""))) (bar ((,POLLEN_TREE_PARENT_NAME ""))) (one ((,POLLEN_TREE_PARENT_NAME "")) (two ((,POLLEN_TREE_PARENT_NAME "one")) (three ((,POLLEN_TREE_PARENT_NAME "two")))))))
'(ptree-main (foo) (bar) (one (two (three))))))
(module+ test
(let ([sample-main `(POLLEN_TREE_ROOT_NAME "foo" "bar" (one (two "three")))])
(check-equal? (ptree-root->ptree sample-main)
`(POLLEN_TREE_ROOT_NAME ((,POLLEN_TREE_PARENT_NAME "")) (foo ((,POLLEN_TREE_PARENT_NAME "POLLEN_TREE_ROOT_NAME"))) (bar ((,POLLEN_TREE_PARENT_NAME "POLLEN_TREE_ROOT_NAME"))) (one ((,POLLEN_TREE_PARENT_NAME "POLLEN_TREE_ROOT_NAME")) (two ((,POLLEN_TREE_PARENT_NAME "one")) (three ((,POLLEN_TREE_PARENT_NAME "two")))))))))
`(POLLEN_TREE_ROOT_NAME "foo" "bar" (one (two "three"))))))
;; return the parent of a given name
(define/contract (parent name [ptree current-ptree])
((ptree-name?) (ptree?) . ->* . (or/c string? boolean?))
(and name (let ([result (se-path* `(,(->symbol name) #:parent) ptree)])
(and result (->string result))))) ; se-path* returns #f if nothing found
((ptree-name?) (ptree?) . ->* . (or/c ptree-name? false?))
(and name
(if (member (->string name) (map (λ(x) (->string (if (list? x) (car x) x))) (cdr ptree)))
(->string (car ptree))
(ormap (λ(x) (parent name x)) (filter list? ptree)))))
(define ptree-parent parent)
(module+ test
(define test-ptree-main `(ptree-main "foo" "bar" (one (two "three"))))
@ -66,14 +55,13 @@
(check-false (parent 'nonexistent-name test-ptree)))
; get children of a particular name
(define/contract (children name [ptree current-ptree])
((ptree-name?) (ptree?) . ->* . (or/c list? boolean?))
;; se-path*/list returns '() if nothing found
(and name (let ([children (se-path*/list `(,(->symbol name)) ptree)])
; If there are sublists, just take first name
(and (not (empty? children)) (map (λ(i) (->string (if (list? i) (car i) i))) children)))))
((ptree-name?) (ptree?) . ->* . (or/c (listof ptree-name?) false?))
(and name
(if (equal? (->string name) (->string (car ptree)))
(map (λ(x) (->string (if (list? x) (car x) x))) (cdr ptree))
(ormap (λ(x) (children name x)) (filter list? ptree)))))
(module+ test
(check-equal? (children 'one test-ptree) (list "two"))
@ -86,9 +74,10 @@
(define/contract (siblings name [ptree current-ptree])
;; this never returns false: name is always a sibling of itself.
;; todo: how to use input value in contract? e.g., to check that name is part of output list
((ptree-name?) (ptree?) . ->* . (or/c list? boolean?))
((ptree-name?) (ptree?) . ->* . (or/c (listof string?) false?))
(children (parent name ptree) ptree))
(module+ test
(check-equal? (siblings 'one test-ptree) '("foo" "bar" "one"))
(check-equal? (siblings 'foo test-ptree) '("foo" "bar" "one"))
@ -98,8 +87,8 @@
(define/contract (siblings-split name [ptree current-ptree])
((ptree-name?) (ptree?) . ->* . (values (or/c (listof ptree-name?) boolean?)
(or/c (listof ptree-name?) boolean?)))
((ptree-name?) (ptree?) . ->* . (values (or/c (listof ptree-name?) false?)
(or/c (listof ptree-name?) false?)))
(let-values ([(left right) (splitf-at (siblings name ptree)
(λ(e) (not (equal? (->string e) (->string name)))))])
(values (if (empty? left) #f left) (if (empty? (cdr right)) #f (cdr right)))))
@ -128,9 +117,10 @@
(check-equal? (siblings-right 'foo test-ptree) '("bar" "one")))
;; get name immediately to the left in tree
(define/contract (sibling-previous name [ptree current-ptree])
((ptree-name?) (ptree?) . ->* . (or/c string? boolean?))
((ptree-name?) (ptree?) . ->* . (or/c ptree-name? false?))
(let ([siblings (siblings-left name ptree)])
(and siblings (last siblings))))
@ -140,7 +130,7 @@
;; get name immediately to the right in tree
(define/contract (sibling-next name [ptree current-ptree])
((ptree-name?) (ptree?) . ->* . (or/c string? boolean?))
((ptree-name?) (ptree?) . ->* . (or/c ptree-name? false?))
(let ([siblings (siblings-right name ptree)])
(and siblings (first siblings))))
@ -153,14 +143,16 @@
(define/contract (all-names [ptree current-ptree])
(ptree? . -> . (listof string?))
; use cdr to get rid of root tag at front
(map ->string (cdr (flatten (remove-parents ptree)))))
(map ->string (cdr (flatten ptree))))
(module+ test
(check-equal? (all-names test-ptree) '("foo" "bar" "one" "two" "three")))
;; helper function for get-previous-names and get-next-names
(define/contract (adjacent-names side name [ptree current-ptree])
((symbol? ptree-name?) (ptree?) . ->* . (or/c list? boolean?))
((symbol? ptree-name?) (ptree?) . ->* . (or/c (listof ptree-name?) false?))
(let ([result ((if (equal? side 'left)
takef
takef-right) (all-names ptree)
@ -175,7 +167,7 @@
;; get sequence of earlier names
(define/contract (ptree-previous* name [ptree current-ptree])
((ptree-name?) (ptree?) . ->* . (or/c list? boolean?))
((ptree-name?) (ptree?) . ->* . (or/c (listof ptree-name?) false?))
(adjacent-names 'left name ptree))
(module+ test
@ -184,9 +176,11 @@
(check-false (ptree-previous* 'foo test-ptree)))
;; get sequence of next names
(define (ptree-next* name [ptree current-ptree])
((ptree-name?) (ptree?) . ->* . (or/c list? boolean?))
((ptree-name?) (ptree?) . ->* . (or/c (listof ptree-name?) false?))
(adjacent-names 'right name ptree))
(module+ test
@ -196,7 +190,7 @@
;; get name immediately previous
(define/contract (ptree-previous name [ptree current-ptree])
((ptree-name?) (ptree?) . ->* . (or/c string? boolean?))
((ptree-name?) (ptree?) . ->* . (or/c ptree-name? false?))
(let ([result (ptree-previous* name ptree)])
(and result (last result))))
@ -207,7 +201,7 @@
;; get name immediately next
(define (ptree-next name [ptree current-ptree])
((ptree-name?) (ptree?) . ->* . (or/c string? boolean?))
((ptree-name?) (ptree?) . ->* . (or/c ptree-name? false?))
(let ([result (ptree-next* name ptree)])
(and result (first result))))
@ -216,27 +210,17 @@
(check-equal? (ptree-next 'one test-ptree) "two")
(check-false (ptree-next 'three test-ptree)))
;; convert path to name
;; used for converting "here" values to names
(define/contract (path->name x)
(pathish? . -> . ptree-name?)
(->string (remove-all-ext (last (explode-path (->path x))))))
(module+ test
(check-equal? (path->name "bar") "bar")
(check-equal? (path->name "foo/bar") "bar")
(check-equal? (path->name "foo/bar.html") "bar")
(check-equal? (path->name "/Users/this/that/foo/bar.html.pp") "bar"))
(define here->name path->name)
(define/contract (name->url name [files current-url-context])
((ptree-name?) ((listof pathish?)) . ->* . (or/c string? boolean?))
((ptree-name?) ((listof pathish?)) . ->* . (or/c ptree-name? false?))
;; upconvert all files to their output path
;; then remove duplicates because some sources might have already been rendered
(define output-paths (remove-duplicates (map ->output-path files) equal?))
;; find ones that match name
(define matching-paths (filter (λ(x) (equal? (path->name x) (->string name))) output-paths))
(define matching-paths (filter (λ(x) (equal? (->string x) (->string name))) output-paths))
(cond
[((len matching-paths) . = . 1) (->string (car matching-paths))]
@ -248,38 +232,25 @@
(module+ test
(define files '("foo.html" "bar.html" "bar.html.p" "zap.html" "zap.xml"))
(check-equal? (name->url 'foo files) "foo.html")
(check-equal? (name->url 'bar files) "bar.html")
(check-equal? (name->url 'foo.html files) "foo.html")
(check-equal? (name->url 'bar.html files) "bar.html")
;; (check-equal? (name->url 'zap files) 'error) ;; todo: how to test error?
(check-false (name->url 'hee files)))
;; recursively processes tree, converting tree locations & their parents into xexprs of this shape:
;; '(location ((parent "parent")))
(define/contract (add-parents x [parent empty])
((tagged-xexpr?) (xexpr-tag?) . ->* . ptree?)
(match x
;; this pattern signifies next level in hierarchy
;; where first element is new parent, and rest are children.
[(list (? xexpr-tag? next-parent) children ...)
(let-values ([(tag attr _) (break-tagged-xexpr (add-parents next-parent parent))])
;; xexpr with tag as name, parent as attr, children as elements with tag as next parent
(make-tagged-xexpr tag attr (map (λ(c) (add-parents c tag)) children)))]
;; single map entry: convert to xexpr with parent
[else (make-tagged-xexpr (->symbol x) (make-xexpr-attr POLLEN_TREE_PARENT_NAME (->string parent)))]))
;; this sets default input for following functions
(define/contract (ptree-root->ptree tx)
;; (not/c ptree) prevents ptrees from being accepted as input
((and/c tagged-xexpr? (not/c ptree?)) . -> . ptree?)
(add-parents tx))
((and/c tagged-xexpr?) . -> . ptree?)
tx)
(module+ test
(set! test-ptree-main `(ptree-main "foo" "bar" (one (two "three"))))
(check-equal? (ptree-root->ptree test-ptree-main)
`(ptree-main ((,POLLEN_TREE_PARENT_NAME "")) (foo ((,POLLEN_TREE_PARENT_NAME "ptree-main"))) (bar ((,POLLEN_TREE_PARENT_NAME "ptree-main"))) (one ((,POLLEN_TREE_PARENT_NAME "ptree-main")) (two ((,POLLEN_TREE_PARENT_NAME "one")) (three ((,POLLEN_TREE_PARENT_NAME "two"))))))))
`(ptree-main "foo" "bar" (one (two "three")))))
@ -322,8 +293,11 @@
;; set the state variable using the setter
(set-current-url-context PROJECT_ROOT)
#|
(module+ main
(displayln "Running module main")
(set-current-ptree (make-project-ptree (->path "/Users/MB/git/bpt/")))
(set-current-url-context "/Users/MB/git/bpt/")
(name->url (ptree-previous (ptree-previous 'what-is-typography))))
(ptree-previous (ptree-previous 'what-is-typography.html))
(name->url "how-to-pay-for-this-book.html"))
|#
Loading…
Cancel
Save