simply ptree & related tests

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

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

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

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"))
+|#