code updates

main.rkt

@@ -75,9 +75,7 @@
    ;; set up the 'doc export
    (require pollen/decode)
    (define doc (apply (cond
-                        [(equal? parser-mode world:reader-mode-ptree) 
+                        [(equal? parser-mode world:reader-mode-ptree) (λ xs ((dynamic-require 'pollen/ptree 'decode-ptree) xs))]
-                         (λ xs (decode (cons world:ptree-root-node xs)
-                                       #:txexpr-elements-proc (λ(xs) (filter (compose1 not (def/c whitespace?)) 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)

ptree.rkt

@@ -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)))
+  (->boolean (and (symbol? x) (try (not (whitespace/nbsp? (->string x)))
                                    (except [exn:fail? (λ(e) #f)])))))
 
 
-(define+provide/contract (pnode?/error x)
+(define+provide (pnodeish? x)
-  (any/c . -> . boolean?)
+  (try (pnode? (->symbol x))
-  (or (pnode? x) (error "Not a valid pnode:" x)))
+       (except [exn:fail? (λ(e) #f)])))
+
+
+(define/contract+provide (->pnode x)
+  (pnodeish? . -> . pnode?)
+  (->symbol 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) 
+  (try (->boolean (validate-ptree x))
-                  (andmap (λ(i) (or (pnode? i) (ptree? i))) x)
+       (except [exn:fail? (λ(e) #f)])))
-                  (members-unique? (ptree->list x)))))
 
 
 ;; 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)])
+(define+provide/contract (parent p [ptree (current-ptree)])
-  (((or/c false? pnode?)) (ptree?) . ->* . (or/c false? pnode?)) 
+  (((or/c #f pnodeish?)) (ptree?) . ->* . (or/c #f pnode?)) 
-  (and pnode
+  (and ptree p
-       (if (member (->string pnode) (map (λ(x) (->string (if (list? x) (car x) x))) (cdr ptree)))
+       (let ([pnode (->pnode p)])
-           (->string (car ptree))
+         (if (member pnode (map (λ(x) (if (list? x) (car x) x)) (cdr ptree)))
-           (ormap (λ(x) (parent pnode x)) (filter list? ptree)))))
+             (car ptree)
+             (ormap (λ(x) (parent pnode x)) (filter list? ptree))))))
 
 
-(define+provide/contract (children pnode [ptree (current-ptree)])
+(define+provide/contract (children p [ptree (current-ptree)])
-  (((or/c false? pnode?)) (ptree?) . ->* . (or/c false? (listof pnode?)))  
+  (((or/c #f pnodeish?)) (ptree?) . ->* . (or/c #f (listof pnode?)))  
-  (and pnode 
+  (and ptree p 
-       (if (equal? (->string pnode) (->string (car ptree)))
+       (let ([pnode (->pnode p)])
-           (map (λ(x) (->string (if (list? x) (car x) x))) (cdr ptree))
+         (if (equal? pnode (car ptree))
-           (ormap (λ(x) (children pnode x)) (filter list? 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)])
+(define+provide/contract (siblings p [ptree (current-ptree)])
-  (((or/c false? pnode?)) (ptree?) . ->* . (or/c false? (listof string?)))  
+  (((or/c #f pnodeish?)) (ptree?) . ->* . (or/c #f (listof pnode?)))  
-  (children (parent pnode ptree) ptree))
+  (children (parent p ptree) ptree))
 
 
 ;; flatten tree to sequence
-(define+provide/contract (ptree->list [ptree (current-ptree)])
+(define+provide/contract (ptree->list ptree)
-  (ptree? . -> . (listof string?))
+  (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)])
+(define (adjacents side p [ptree (current-ptree)])
-  ((symbol? (or/c false? pnode?)) (ptree?) . ->* . (or/c false? (listof pnode?)))
+  ; ((symbol? (or/c #f pnodeish?)) (ptree?) . ->* . (or/c #f (listof pnode?)))
-  (and pnode
+  (and ptree p
-       (let* ([proc (if (equal? side 'left) takef takef-right)]
+       (let* ([pnode (->pnode p)]
-              [result (proc (ptree->list ptree) (λ(x) (not (equal? (->string pnode) (->string x)))))])
+              [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)]) 
+(define+provide/contract (previous* pnode [ptree (current-ptree)]) 
-  (((or/c false? pnode?)) (ptree?) . ->* . (or/c false? (listof pnode?)))
+  (((or/c #f pnodeish?)) (ptree?) . ->* . (or/c #f (listof pnode?)))
   (adjacents 'left pnode ptree))
 
 
-(define+provide/contract (right-adjacents pnode [ptree (current-ptree)]) 
+(define+provide/contract (next* pnode [ptree (current-ptree)]) 
-  (((or/c false? pnode?)) (ptree?) . ->* . (or/c false? (listof pnode?)))
+  (((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?))
+  (((or/c #f pnodeish?)) (ptree?) . ->* . (or/c #f pnode?))
-  (let ([result (left-adjacents pnode ptree)])
+  (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?))
+  (((or/c #f pnodeish?)) (ptree?) . ->* . (or/c #f pnode?))
-  (let ([result (right-adjacents pnode ptree)])
+  (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)))))

render.rkt

@@ -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-ptree (make-project-ptree (world:current-project-root))])
-                 [current-url-context (world:current-project-root)])
     (for-each (λ(mod-name) (namespace-attach-module cache-ns mod-name)) 
               `(web-server/templates 
                 xml

template.rkt

@@ -14,9 +14,7 @@
 
 (define/contract (puttable-item? x)
   (any/c . -> . boolean?)
-  (or (txexpr? x) 
+  (or (txexpr? x) (has-markup-source? x)))
-      (has-markup-source? x) 
-      (and (pnode? x) (pnode->url x) (has-markup-source? (pnode->url 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? 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)]))
 
 #|(module+ test
   (check-equal? (put '(foo "bar")) '(foo "bar"))

tests/test-ptree.rkt

@@ -3,59 +3,59 @@
 (require "../ptree.rkt" "../world.rkt")
 
 
-(check-true (pnode? "foo-bar"))
+(check-false (pnode? "foo-bar"))
-(check-true (pnode? "Foo_Bar_0123"))
+(check-false (pnode? "Foo_Bar_0123"))
 (check-true (pnode? 'foo-bar))
-(check-true (pnode? "foo-bar.p"))
+(check-false (pnode? "foo-bar.p"))
-(check-true (pnode? "/Users/MB/foo-bar"))
+(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-true (ptree? '(foo (hee (uncle foo)))))
-(check-false (ptree? '(foo (hee 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 'one test-ptree) '(two))
-(check-equal? (children 'two test-ptree) (list "three"))
+(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 'one test-ptree) '(foo bar one))
-(check-equal? (siblings 'foo test-ptree) '("foo" "bar" "one"))
+(check-equal? (siblings 'foo test-ptree) '(foo bar one))
-(check-equal? (siblings 'two test-ptree) '("two"))
+(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? (previous* 'one test-ptree) '(foo bar))
-(check-equal? (left-adjacents 'three test-ptree) '("foo" "bar" "one" "two"))
+(check-equal? (previous* 'three test-ptree) '(foo bar one two))
-(check-false (left-adjacents 'foo test-ptree))
+(check-false (previous* 'foo test-ptree))
 
-(check-equal? (previous 'one test-ptree) "bar")
+(check-equal? (previous 'one test-ptree) 'bar)
-(check-equal? (previous 'three test-ptree) "two")
+(check-equal? (previous 'three test-ptree) 'two)
 (check-false (previous 'foo test-ptree))
 
-(check-equal? (next 'foo test-ptree) "bar")
+(check-equal? (next 'foo test-ptree) 'bar)
-(check-equal? (next 'one test-ptree) "two")
+(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))))