updates

main-helper.rkt

@@ -37,7 +37,7 @@
 ;; We want to make this identifier behave as a runtime function
 ;; This requires two steps.
 ;; First, define the underlying function as syntax-rule
-(define-syntax (get-here stx)
+(define-syntax (get-here-path stx)
   (datum->syntax stx 
                  '(begin 
                     ;; Even though begin permits defines,
@@ -45,7 +45,7 @@
                     ;; whereupon define would cause an error.
                     ;; Therefore, best to use let.
                     (let* ([ccr (current-contract-region)] ; trick for getting current module name
-                           [here-path (cond
+                           [hp (cond
                                         ;; if contract-region is called from within submodule,
                                         ;; you get a list
                                         ;; in which case, just grab the path from the front
@@ -59,7 +59,7 @@
                       ;; so raises possibility of inconsistent values.
                       ;; Whereas the complete path is unambiguous,
                       ;; and can be made relative by the caller (or otherwise altered).
-                      (->string here-path)))))
+                      (->string hp)))))
 
 ;; todo: update tests
 ;(module+ test
@@ -68,7 +68,7 @@
 ; Second step: apply a separate syntax transform to the identifier itself
 ; We can't do this in one step, because if the macro goes from identifier to function definition,
 ; The macro processor will evaluate the body at compile-time, not at runtime.
-(define-syntax here (λ(stx) (datum->syntax stx '(get-here))))
+(define-syntax here-path (λ(stx) (datum->syntax stx '(get-here-path))))
 
 ;; todo: update test
 ;(module+ test

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)
+         (only-in (planet mb/pollen/ptree) ptree-source-decode path->name)
          (only-in (planet mb/pollen/predicates) ptree?))
 
 (provide (all-from-out racket/list

main.rkt

@@ -42,23 +42,26 @@
      
      ;; set up a hook for identifier 'here'
      ;; (but under a different name to avoid macrofication)
-     (define inner-here here)  
+     (define inner-here-path here-path)  
      (provide (all-defined-out))
      (provide (all-from-out ; pollen file should bring its requires
                (planet mb/pollen/tools)))) 
    
    (require 'pollen-inner) ; provides doc & #%top, among other things
    
-   ;; prepare the elements, and append inner-here as meta.
-   (define all-elements (cons 
-                         ;; append inner-here as meta
+   (define here (path->name 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
-                         `(meta "here" ,inner-here)
+   (define all-elements (cons `(meta "here-path" ,inner-here-path)
+                              (cons `(meta "here" ,here)                         
                                     (cond
                                       ;; doc is probably a list, but might be a single string
                                       [(string? doc) (list doc)] 
-                           [(tagged-xexpr? doc) (list doc)] ; if it's a single nx, just leave it
-                           [(list? doc) doc]))) ; if it's nx content, splice it in
+                                      ;; if it's a single nx, just leave it
+                                      [(tagged-xexpr? doc) (list doc)]
+                                      ;; if it's nx content, splice it in
+                                      [(list? doc) doc])))) 
    
    
    ;; split out the metas now (in raw form)
@@ -78,7 +81,7 @@
    ;; Because if it's overridden to something other than *.ptree, 
    ;; ptree processing will fail.
    ;; This defeats rule that ptree file suffix triggers ptree decoding.
-   (define here-is-ptree? (ptree-source? (->path inner-here)))
+   (define here-is-ptree? (ptree-source? (->path inner-here-path)))
    
    (define main (apply (if here-is-ptree?
                            ;; ptree source files will go this way,
@@ -89,9 +92,10 @@
                            ;; it just hits #%top and becomes a tagged-xexpr.
                            root) (tagged-xexpr-elements main-raw)))
    
-   (provide main metas
-            (except-out (all-from-out 'pollen-inner) inner-here) ; everything from user 
-            (rename-out (inner-here here))) ; change identifier back (now safe from macrofication)
+   
+   (provide main metas here
+            (except-out (all-from-out 'pollen-inner) inner-here-path) ; everything from user 
+            (rename-out (inner-here-path here-path))) ; change identifier back (now safe from macrofication)
    
    (module+ main
      (displayln ";-------------------------")

predicates.rkt

@@ -161,7 +161,7 @@
 
 
 ;; certain ptree requirements are enforced at compile-time.
-;; (such as pnodes must be valid strings, and unique.)
+;; (such as names must be valid strings, and unique.)
 ;; 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.
@@ -170,7 +170,7 @@
   (and (match x
          ;; a tagged-xexpr with one attr ('parent)
          ;; whose subelements recursively meet the same test.
-         [(list (? pnode? tag) (? ptree-attr? attr) elements ...) 
+         [(list (? ptree-name? tag) (? ptree-attr? attr) elements ...) 
           (andmap ptree? elements)]
          [else #f])))
 
@@ -196,7 +196,7 @@
 
 
 ;; ptree location must represent a possible valid filename
-(define/contract (pnode? x #:loud [loud #f])
+(define/contract (ptree-name? x #:loud [loud #f])
   ((any/c) (#:loud boolean?) . ->* . boolean?)
   ;; todo: how to express the fact that the ptree-location must be 
   ;; a valid base name for a file?
@@ -205,21 +205,21 @@
   (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 name?
+              ;; todo: should test be same as valid module ptree-name?
               (->boolean (regexp-match #px"^[-_A-Za-z0-9]+$" (->string x))))))
   (if (and (not result) loud)
       (error "Not a valid ptree key:" x)
       result))
 
 (module+ test
-  (check-true (pnode? #f))
-  (check-true (pnode? "foo-bar"))
-  (check-true (pnode? "Foo_Bar_0123"))
-  (check-true (pnode? 'foo-bar))
-  (check-false (pnode? "foo-bar.p"))
-  (check-false (pnode? "/Users/MB/foo-bar"))
-  (check-false (pnode? ""))
-  (check-false (pnode? " ")))
+  (check-true (ptree-name? #f))
+  (check-true (ptree-name? "foo-bar"))
+  (check-true (ptree-name? "Foo_Bar_0123"))
+  (check-true (ptree-name? 'foo-bar))
+  (check-false (ptree-name? "foo-bar.p"))
+  (check-false (ptree-name? "/Users/MB/foo-bar"))
+  (check-false (ptree-name? ""))
+  (check-false (ptree-name? " ")))
 
 
 ;; recursive whitespace test

ptree.rkt

@@ -19,7 +19,7 @@
   (directory-pathish? . -> . ptree?)
   (let ([files (map remove-ext (filter (λ(x) (has-ext? x POLLEN_SOURCE_EXT)) (directory-list dir)))])
     (message "Generating ptree from file listing")
-    (ptree-root->ptree (cons POLLEN_TREE_ROOT_NAME (map path->pnode files)))))
+    (ptree-root->ptree (cons POLLEN_TREE_ROOT_NAME (map path->name files)))))
 
 
 ;; Try loading from ptree file, or failing that, synthesize ptree.
@@ -50,12 +50,14 @@
 
 
 ;; return the parent of a given name
-(define/contract (parent pnode [ptree current-ptree])
-  ((pnode?) (ptree?) . ->* . (or/c string? boolean?)) 
-  (and pnode (let ([result (se-path* `(,(->symbol pnode) #:parent) ptree)])
+(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
 
 
+(define ptree-parent parent)
+
 (module+ test
   (define test-ptree-main `(ptree-main "foo" "bar" (one (two "three"))))
   (define test-ptree (ptree-root->ptree test-ptree-main))
@@ -65,12 +67,12 @@
 
 
 
-; get children of a particular pnode
-(define/contract (children pnode [ptree current-ptree])
-  ((pnode?) (ptree?) . ->* . (or/c list? boolean?))  
+; 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 pnode  (let ([children (se-path*/list `(,(->symbol pnode)) ptree)])
-                ; If there are sublists, just take first pnode
+  (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)))))
 
 (module+ test
@@ -81,11 +83,11 @@
 
 
 ;; find all siblings on current level: go up to parent and ask for children
-(define/contract (siblings pnode [ptree current-ptree])
-  ;; this never returns false: pnode is always a sibling of itself.
-  ;; todo: how to use input value in contract? e.g., to check that pnode is part of output list
-  ((pnode?) (ptree?) . ->* . (or/c list? boolean?))  
-  (children (parent pnode ptree) ptree))
+(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?))  
+  (children (parent name ptree) ptree))
 
 (module+ test
   (check-equal? (siblings 'one test-ptree) '("foo" "bar" "one"))
@@ -95,11 +97,11 @@
 
 
 
-(define/contract (siblings-split pnode [ptree current-ptree])
-  ((pnode?) (ptree?) . ->* . (values (or/c (listof pnode?) boolean?) 
-                                     (or/c (listof pnode?) boolean?)))
-  (let-values ([(left right) (splitf-at (siblings pnode ptree) 
-                                        (λ(e) (not (equal? (->string e) (->string pnode)))))])
+(define/contract (siblings-split name [ptree current-ptree])
+  ((ptree-name?) (ptree?) . ->* . (values (or/c (listof ptree-name?) boolean?) 
+                                     (or/c (listof ptree-name?) boolean?)))
+  (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)))))
 
 (module+ test
@@ -107,18 +109,18 @@
   (check-equal? (values->list (siblings-split 'bar test-ptree)) (list '("foo") '("one"))))
 
 
-;; siblings to the left of target pnode (i.e., precede in tree order)
-(define (siblings-left pnode [ptree current-ptree])
-  (let-values ([(left right) (siblings-split pnode ptree)])
+;; siblings to the left of target name (i.e., precede in tree order)
+(define (siblings-left name [ptree current-ptree])
+  (let-values ([(left right) (siblings-split name ptree)])
     left))
 
 (module+ test
   (check-equal? (siblings-left 'one test-ptree) '("foo" "bar"))
   (check-false (siblings-left 'foo test-ptree)))
 
-;; siblings to the right of target pnode (i.e., follow in tree order)
-(define (siblings-right pnode [ptree current-ptree])
-  (let-values ([(left right) (siblings-split pnode ptree)])
+;; siblings to the right of target name (i.e., follow in tree order)
+(define (siblings-right name [ptree current-ptree])
+  (let-values ([(left right) (siblings-split name ptree)])
     right))
 
 (module+ test
@@ -126,20 +128,20 @@
   (check-equal? (siblings-right 'foo test-ptree) '("bar" "one")))
 
 
-;; get pnode immediately to the left in tree
-(define/contract (sibling-previous pnode [ptree current-ptree])
-  ((pnode?) (ptree?) . ->* . (or/c string? boolean?))
-  (let ([siblings (siblings-left pnode ptree)])
+;; get name immediately to the left in tree
+(define/contract (sibling-previous name [ptree current-ptree])
+  ((ptree-name?) (ptree?) . ->* . (or/c string? boolean?))
+  (let ([siblings (siblings-left name ptree)])
     (and siblings (last siblings))))
 
 (module+ test
   (check-equal? (sibling-previous 'bar test-ptree) "foo")
   (check-false (sibling-previous 'foo test-ptree)))
 
-;; get pnode immediately to the right in tree
-(define/contract (sibling-next pnode [ptree current-ptree])
-  ((pnode?) (ptree?) . ->* . (or/c string? boolean?))
-  (let ([siblings (siblings-right pnode ptree)])
+;; get name immediately to the right in tree
+(define/contract (sibling-next name [ptree current-ptree])
+  ((ptree-name?) (ptree?) . ->* . (or/c string? boolean?))
+  (let ([siblings (siblings-right name ptree)])
     (and siblings (first siblings))))
 
 (module+ test
@@ -148,106 +150,108 @@
 
 
 ;; flatten tree to sequence
-(define/contract (all-pnodes [ptree current-ptree])
+(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))))) 
 
 (module+ test
-  (check-equal? (all-pnodes test-ptree) '("foo" "bar" "one" "two" "three")))
+  (check-equal? (all-names test-ptree) '("foo" "bar" "one" "two" "three")))
 
-;; helper function for get-previous-pnodes and get-next-pnodes
-(define/contract (adjacent-pnodes side pnode [ptree current-ptree])
-  ((symbol? pnode?) (ptree?) . ->* . (or/c list? boolean?))
+;; 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?))
   (let ([result ((if (equal? side 'left) 
                      takef 
-                     takef-right) (all-pnodes ptree) 
-                                  (λ(y) (not (equal? (->string pnode) (->string y)))))])
+                     takef-right) (all-names ptree) 
+                                  (λ(y) (not (equal? (->string name) (->string y)))))])
     (and (not (empty? result)) result)))
 
 (module+ test
-  (check-equal? (adjacent-pnodes 'left 'one test-ptree) '("foo" "bar"))
-  (check-equal? (adjacent-pnodes 'left 'three test-ptree) '("foo" "bar" "one" "two"))
-  (check-false (adjacent-pnodes 'left 'foo test-ptree)))
+  (check-equal? (adjacent-names 'left 'one test-ptree) '("foo" "bar"))
+  (check-equal? (adjacent-names 'left 'three test-ptree) '("foo" "bar" "one" "two"))
+  (check-false (adjacent-names 'left 'foo test-ptree)))
 
 
-;; get sequence of earlier pnodes
-(define/contract (previous-pnodes pnode [ptree current-ptree])
-  ((pnode?) (ptree?) . ->* . (or/c list? boolean?))
-  (adjacent-pnodes 'left pnode ptree))
+;; get sequence of earlier names
+(define/contract (ptree-previous* name [ptree current-ptree])
+  ((ptree-name?) (ptree?) . ->* . (or/c list? boolean?))
+  (adjacent-names 'left name ptree))
 
 (module+ test
-  (check-equal? (previous-pnodes 'one test-ptree) '("foo" "bar"))
-  (check-equal? (previous-pnodes 'three test-ptree) '("foo" "bar" "one" "two"))
-  (check-false (previous-pnodes 'foo test-ptree)))
+  (check-equal? (ptree-previous* 'one test-ptree) '("foo" "bar"))
+  (check-equal? (ptree-previous* 'three test-ptree) '("foo" "bar" "one" "two"))
+  (check-false (ptree-previous* 'foo test-ptree)))
 
 
-;; get sequence of next pnodes
-(define (next-pnodes pnode [ptree current-ptree])
-  ((pnode?) (ptree?) . ->* . (or/c list? boolean?))
-  (adjacent-pnodes 'right pnode ptree))
+;; get sequence of next names
+(define (ptree-next* name [ptree current-ptree])
+  ((ptree-name?) (ptree?) . ->* . (or/c list? boolean?))
+  (adjacent-names 'right name ptree))
 
 (module+ test
-  (check-equal? (next-pnodes 'foo test-ptree) '("bar" "one" "two" "three"))
-  (check-equal? (next-pnodes 'one test-ptree) '("two" "three"))
-  (check-false (next-pnodes 'three test-ptree)))
-
-;; get pnode immediately previous
-(define/contract (previous-pnode pnode [ptree current-ptree])
-  ((pnode?) (ptree?) . ->* . (or/c string? boolean?))
-  (let ([result (previous-pnodes pnode ptree)])
+  (check-equal? (ptree-next* 'foo test-ptree) '("bar" "one" "two" "three"))
+  (check-equal? (ptree-next* 'one test-ptree) '("two" "three"))
+  (check-false (ptree-next* 'three test-ptree)))
+
+;; get name immediately previous
+(define/contract (ptree-previous name [ptree current-ptree])
+  ((ptree-name?) (ptree?) . ->* . (or/c string? boolean?))
+  (let ([result (ptree-previous* name ptree)])
     (and result (last result))))
 
 (module+ test
-  (check-equal? (previous-pnode 'one test-ptree) "bar")
-  (check-equal? (previous-pnode 'three test-ptree) "two")
-  (check-false (previous-pnode 'foo test-ptree)))
-
-;; get pnode immediately next
-(define (next-pnode pnode [ptree current-ptree])
-  ((pnode?) (ptree?) . ->* . (or/c string? boolean?))
-  (let ([result (next-pnodes pnode ptree)])
+  (check-equal? (ptree-previous 'one test-ptree) "bar")
+  (check-equal? (ptree-previous 'three test-ptree) "two")
+  (check-false (ptree-previous 'foo test-ptree)))
+
+;; get name immediately next
+(define (ptree-next name [ptree current-ptree])
+  ((ptree-name?) (ptree?) . ->* . (or/c string? boolean?))
+  (let ([result (ptree-next* name ptree)])
     (and result (first result))))
 
 (module+ test
-  (check-equal? (next-pnode 'foo test-ptree) "bar")
-  (check-equal? (next-pnode 'one test-ptree) "two")
-  (check-false (next-pnode 'three test-ptree)))
-
-;; convert path to pnode
-;; used for converting "here" values to pnodes
-(define/contract (path->pnode x)
-  (pathish? . -> . pnode?)
+  (check-equal? (ptree-next 'foo test-ptree) "bar")
+  (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->pnode "bar") "bar")
-  (check-equal? (path->pnode "foo/bar") "bar")
-  (check-equal? (path->pnode "foo/bar.html") "bar")
-  (check-equal? (path->pnode "/Users/this/that/foo/bar.html.pp") "bar"))
+  (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->pnode path->pnode)
+(define here->name path->name)
 
-(define/contract (pnode->url pnode [files current-url-context])
-  ((pnode?) ((listof pathish?)) . ->* . (or/c string? boolean?))
+(define/contract (name->url name [files current-url-context])
+  ((ptree-name?) ((listof pathish?)) . ->* . (or/c string? boolean?))
   ;; 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 pnode
-  (define matching-paths (filter (λ(x) (equal? (path->pnode x) (->string pnode))) output-paths))
+  ;; find ones that match name
+  (define matching-paths (filter (λ(x) (equal? (path->name x) (->string name))) output-paths))
   
   (cond
     [((len matching-paths) . = . 1) (->string (car matching-paths))]
-    [((len matching-paths) . > . 1) (error "More than one matching URL for" pnode)]
+    [((len matching-paths) . > . 1) (error "More than one matching URL for" name)]
     [else #f] ))
 
+(define ptree-name->url name->url)
+
 
 (module+ test
   (define files '("foo.html" "bar.html" "bar.html.p" "zap.html" "zap.xml"))
-  (check-equal? (pnode->url 'foo files) "foo.html")
-  (check-equal? (pnode->url 'bar files) "bar.html")
-  ;;  (check-equal? (pnode->url 'zap files) 'error) ;; todo: how to test error?
-  (check-false (pnode->url 'hee files)))
+  (check-equal? (name->url 'foo files) "foo.html")
+  (check-equal? (name->url 'bar 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:
@@ -280,19 +284,19 @@
 
 
 ;; contract for ptree-source-decode
-(define/contract (valid-pnodes? x)
+(define/contract (valid-names? x)
   (any/c . -> . boolean?)
-  (andmap (λ(x) (pnode? #:loud #t x)) (filter-not whitespace? (flatten x))))
+  (andmap (λ(x) (ptree-name? #:loud #t x)) (filter-not whitespace? (flatten x))))
 
 ;; contract for ptree-source-decode
-(define/contract (unique-pnodes? x)
+(define/contract (unique-names? x)
   (any/c . -> . boolean?)
   ;; use map ->string to make keys comparable
   (elements-unique? #:loud #t (map ->string (filter-not whitespace? (flatten x)))))
 
 
 (define/contract (ptree-source-decode . elements)
-  (() #:rest (and/c valid-pnodes? unique-pnodes?) . ->* . ptree?)
+  (() #:rest (and/c valid-names? unique-names?) . ->* . ptree?)
   (ptree-root->ptree (decode (cons POLLEN_TREE_ROOT_NAME elements)
                              #:xexpr-elements-proc (λ(xs) (filter-not whitespace? xs)))))
 
@@ -322,4 +326,4 @@
   (displayln "Running module main")
   (set-current-ptree (make-project-ptree (->path "/Users/MB/git/bpt/")))
   (set-current-url-context "/Users/MB/git/bpt/")
-  (pnode->url (previous-pnode (previous-pnode 'what-is-typography))))
+  (name->url (ptree-previous (ptree-previous 'what-is-typography))))

template.rkt

@@ -1,6 +1,6 @@
 #lang racket/base
 (require racket/contract racket/string xml xml/path racket/bool)
-(require "tools.rkt")
+(require "tools.rkt" "ptree.rkt")
 
 ;; setup for test cases
 (module+ test (require rackunit racket/path))
@@ -15,7 +15,9 @@
 
 (define/contract (puttable-item? x)
   (any/c . -> . boolean?)
-  (or (tagged-xexpr? x) (has-pollen-source? x)))
+  (or (tagged-xexpr? x) 
+      (has-pollen-source? x) 
+      (has-pollen-source? (name->url x))))
 
 (define/contract (query-key? x)
   (any/c . -> . boolean?)
@@ -26,7 +28,8 @@
   (cond
     ;; Using put has no effect on tagged-xexprs. It's here to make the idiom smooth.
     [(tagged-xexpr? x) x] 
-    [(has-pollen-source? x) (dynamic-require (->pollen-source-path x) 'main)]))
+    [(has-pollen-source? x) (dynamic-require (->pollen-source-path x) 'main)]
+    [(has-pollen-source? (name->url x)) (dynamic-require (->pollen-source-path (name->url x)) 'main)]))
 
 (module+ test
   (check-equal? (put '(foo "bar")) '(foo "bar"))
@@ -58,7 +61,7 @@
     (let* ([metas (dynamic-require (->pollen-source-path 'put) 'metas)]
            [here (find-in-metas 'put 'here)]
            [here-relative (list (->string (find-relative-path (current-directory) (car here))))])     
-      (check-equal? here-relative (list "put.p")))))
+      (check-equal? here-relative (list "put")))))
 
 
 (define/contract (find-in-main px query)