diff --git a/main-imports.rkt b/main-imports.rkt index ba9f7ab..72fa72d 100644 --- a/main-imports.rkt +++ b/main-imports.rkt @@ -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 diff --git a/main.rkt b/main.rkt index 3e90f3e..c6c300f 100644 --- a/main.rkt +++ b/main.rkt @@ -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 diff --git a/predicates.rkt b/predicates.rkt index 7fba50e..4a6c735 100644 --- a/predicates.rkt +++ b/predicates.rkt @@ -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])) diff --git a/ptree.rkt b/ptree.rkt index 28dbc78..51a4d6a 100644 --- a/ptree.rkt +++ b/ptree.rkt @@ -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")) +|# \ No newline at end of file