pmap improvements

pmap.rkt

@@ -18,13 +18,13 @@
     ; ... synthesize it
     (let ([files (directory-list START_DIR)])
       (set! files (map remove-ext (filter (λ(x) (has-ext? x POLLEN_SOURCE_EXT)) files)))
-      (set! pmap-main (make-tagged-xexpr 'map-main empty (map path->string files)))))
+      (set! pmap-main (make-tagged-xexpr 'pmap-root empty (map path->string files)))))
 
 
 ;; recursively processes map, converting map locations & their parents into xexprs of this shape:
 ;; '(location ((parent "parent")))
 (define/contract (add-parents x [parent empty])
-  ((pmap?) (xexpr-tag?) . ->* . pmap?)
+  ((tagged-xexpr?) (xexpr-tag?) . ->* . pmap?)
   ; disallow map-main as parent tag
   ;  (when (equal? parent 'map-main) (set! parent empty)) 
   (match x
@@ -57,7 +57,7 @@
 ;; remove parents from map (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) 
-  (pmap? . -> . pmap?)
+  (pmap? . -> . tagged-xexpr?)
   (remove-attrs mt))
 
 (module+ test
@@ -68,9 +68,9 @@
 
 
 (module+ test
-  (define sample-main `(pmap-root "foo" "bar" (one (two "three"))))
-  (check-equal? (main->pmap sample-main) 
-                '(pmap-root ((parent "")) (foo ((parent "pmap-root"))) (bar ((parent "pmap-root"))) (one ((parent "pmap-root")) (two ((parent "one")) (three ((parent "two"))))))))
+  (let ([sample-main `(pmap-root "foo" "bar" (one (two "three")))])
+    (check-equal? (main->pmap sample-main) 
+                  '(pmap-root ((parent "")) (foo ((parent "pmap-root"))) (bar ((parent "pmap-root"))) (one ((parent "pmap-root")) (two ((parent "one")) (three ((parent "two")))))))))
 
 
 
@@ -118,78 +118,77 @@
   (check-equal? (siblings 'two test-pmap) '("two"))
   (check-false (siblings 'invalid-key test-pmap)))
 
-;; helper function
-(define/contract (side-siblings side element [pmap pmap]) 
-  ((symbol? pmap-key?) (pmap?) . ->* . (or/c list? boolean?))
-  (define result ((if (equal? side 'left) takef takef-right) 
-                  (siblings element pmap) 
-                  (λ(i) (not (equal? (->string element) (->string i))))))
-  (and (not (empty? result)) result))
 
 
-(define/contract (pmap-split element elements)
-  (pmap-key? (listof pmap-key?) . -> . (values (listof pmap-key?) (listof pmap-key?)))
-  (define-values (left right) (splitf-at elements 
-                                         (λ(e) (not (equal? (->string e) (->string element))))))
-  (values left (cdr right)))
+(define/contract (siblings-split element [pmap pmap])
+  ((pmap-key?) (pmap?) . ->* . (values (or/c (listof pmap-key?) boolean?) 
+                                       (or/c (listof pmap-key?) boolean?)))
+  (let-values ([(left right) (splitf-at (siblings element pmap) 
+                                        (λ(e) (not (equal? (->string e) (->string element)))))])
+    (values (if (empty? left) #f left) (if (empty? (cdr right)) #f (cdr right)))))
 
 (module+ test
-  (check-equal? (values->list (pmap-split 'bar (siblings 'bar test-pmap))) (list '("foo") '("one"))))
+  (check-equal? (values->list (siblings-split 'one test-pmap)) '(("foo" "bar") #f))
+  (check-equal? (values->list (siblings-split 'bar test-pmap)) (list '("foo") '("one"))))
 
 
 ;; siblings to the left of target element (i.e., precede in map order)
-(define (left-siblings element [pmap pmap])
-  (side-siblings 'left element pmap))
+(define (siblings-left element [pmap pmap])
+  (let-values ([(left right) (siblings-split element pmap)])
+    left))
 
 (module+ test
-  (check-equal? (left-siblings 'one test-pmap) '("foo" "bar"))
-  (check-false (left-siblings 'foo test-pmap)))
+  (check-equal? (siblings-left 'one test-pmap) '("foo" "bar"))
+  (check-false (siblings-left 'foo test-pmap)))
 
 ;; siblings to the right of target element (i.e., follow in map order)
-(define (right-siblings element [pmap pmap])
-  (side-siblings 'right element pmap))
+(define (siblings-right element [pmap pmap])
+  (let-values ([(left right) (siblings-split element pmap)])
+    right))
 
 (module+ test
-  (check-false (right-siblings 'one test-pmap))
-  (check-equal? (right-siblings 'foo test-pmap) '("bar" "one")))
+  (check-false (siblings-right 'one test-pmap))
+  (check-equal? (siblings-right 'foo test-pmap) '("bar" "one")))
 
 
 ;; get element immediately to the left in map
-(define/contract (left-sibling element [pmap pmap])
+(define/contract (sibling-previous element [pmap pmap])
   ((pmap-key?) (pmap?) . ->* . (or/c string? boolean?))
-  (define siblings (left-siblings element pmap))
-  (and siblings (last siblings)))
+  (let ([siblings (siblings-left element pmap)])
+    (and siblings (last siblings))))
 
 (module+ test
-  (check-equal? (left-sibling 'bar test-pmap) "foo")
-  (check-false (left-sibling 'foo test-pmap)))
+  (check-equal? (sibling-previous 'bar test-pmap) "foo")
+  (check-false (sibling-previous 'foo test-pmap)))
 
 ;; get element immediately to the right in map
-(define/contract (right-sibling element [pmap pmap])
+(define/contract (sibling-next element [pmap pmap])
   ((pmap-key?) (pmap?) . ->* . (or/c string? boolean?))
-  (define siblings (right-siblings element pmap))
-  (and siblings (first siblings)))
+  (let ([siblings (siblings-right element pmap)])
+    (and siblings (first siblings))))
 
 (module+ test
-  (check-equal? (right-sibling 'foo test-pmap) "bar")
-  (check-false (right-sibling 'one test-pmap)))
+  (check-equal? (sibling-next 'foo test-pmap) "bar")
+  (check-false (sibling-next 'one test-pmap)))
 
 
 ;; flatten map to sequence
-(define/contract (make-page-sequence [pmap pmap])
+(define/contract (all-pages [pmap pmap])
   (pmap? . -> . (listof string?))
   ; use cdr to get rid of main-map tag at front
   (map ->string (cdr (flatten (remove-parents pmap))))) 
 
 (module+ test
-  (check-equal? (make-page-sequence test-pmap) '("foo" "bar" "one" "two" "three")))
+  (check-equal? (all-pages test-pmap) '("foo" "bar" "one" "two" "three")))
 
 ;; helper function for get-previous-pages and get-next-pages
 (define/contract (adjacent-pages side element [pmap pmap])
   ((symbol? pmap-key?) (pmap?) . ->* . (or/c list? boolean?))
-  (define result ((if (equal? side 'left) takef takef-right)
-                  (make-page-sequence pmap) (λ(y) (not (equal? (->string element) (->string y))))))
-  (and (not (empty? result)) result))
+  (let ([result ((if (equal? side 'left) 
+                     takef 
+                     takef-right) (all-pages pmap) 
+                                  (λ(y) (not (equal? (->string element) (->string y)))))])
+    (and (not (empty? result)) result)))
 
 (module+ test
   (check-equal? (adjacent-pages 'left 'one test-pmap) '("foo" "bar"))
@@ -221,8 +220,8 @@
 ;; get page immediately previous
 (define/contract (previous-page element [pmap pmap])
   ((pmap-key?) (pmap?) . ->* . (or/c string? boolean?))
-  (define result (previous-pages element pmap))
-  (and result (last result)))
+  (let ([result (previous-pages element pmap)])
+    (and result (last result))))
 
 (module+ test
   (check-equal? (previous-page 'one test-pmap) "bar")
@@ -232,21 +231,14 @@
 ;; get page immediately next
 (define (next-page element [pmap pmap])
   ((pmap-key?) (pmap?) . ->* . (or/c string? boolean?))
-  (define result (next-pages element pmap))
-  (and result (first result)))
+  (let ([result (next-pages element pmap)])
+    (and result (first result))))
 
 (module+ test
   (check-equal? (next-page 'foo test-pmap) "bar")
   (check-equal? (next-page 'one test-pmap) "two")
   (check-false (next-page 'three test-pmap)))
 
-#|(module+ test
-  ;; need to parameterize current-directory
-  ;; because pollen main depends on it to find the include functions
-  (define pm (parameterize ([current-directory "./tests/"])
-               (main->pmap (dynamic-require "test.pmap" 'main))))
-  (check-equal? (previous-page (parent 'printers-and-paper pm) pm) "ligatures"))
-|#
 
 
 (define/contract (pmap-decode . elements)
@@ -259,14 +251,14 @@
               ;; they must also be unique
               (flat-named-contract 'unique-pmap-keys
                                    (λ(e) (elements-unique? #:loud #t 
-                                          (map ->string ; to make keys comparable
-                                               (filter-not whitespace? (flatten e)))))))
+                                                           (map ->string ; to make keys comparable
+                                                                (filter-not whitespace? (flatten e)))))))
       . ->* . pmap?)
   (main->pmap (decode (cons 'pmap-root elements)
-          ;          #:exclude-xexpr-tags 'em
-          ;          #:xexpr-tag-proc [xexpr-tag-proc (λ(x)x)]
-          ;          #:xexpr-attr-proc [xexpr-attr-proc (λ(x)x)]
-          #:xexpr-elements-proc (λ(xs) (filter-not whitespace? xs))
-          ; #:block-xexpr-proc block-xexpr-proc
-          ;          #:inline-xexpr-proc [inline-xexpr-proc (λ(x)x)]
-          )))
+                      ;          #:exclude-xexpr-tags 'em
+                      ;          #:xexpr-tag-proc [xexpr-tag-proc (λ(x)x)]
+                      ;          #:xexpr-attr-proc [xexpr-attr-proc (λ(x)x)]
+                      #:xexpr-elements-proc (λ(xs) (filter-not whitespace? xs))
+                      ; #:block-xexpr-proc block-xexpr-proc
+                      ;          #:inline-xexpr-proc [inline-xexpr-proc (λ(x)x)]
+                      )))

predicates.rkt

@@ -115,6 +115,8 @@
 
 ;; count incidence of elements in a list
 ;; returns hash where key is element, value is incidence
+;; todo: move this? Ideally it would be in tools,
+;; but that would create a circular dependency.
 (define/contract (count-incidence x)
   (list? . -> . hash?)
   (define counter (make-hash))
@@ -136,11 +138,11 @@
       [(string? x) (elements-unique? (string->list x))]
       [else #t]))
   (if (and (not result) loud)
-      ;; using dynamic-require to avoid circular dependency
-      ;; todo: better way of handling this?
       (let* ([duplicate-keys (filter-not empty? (hash-map (count-incidence x) 
                                                           (λ(k v) (if (> v 1) k '()))))])
-        (error (string-append (if (> (len duplicate-keys) 1) "Keys aren’t" "Key isn’t") " unique:") duplicate-keys))
+        (error (string-append (if (= (len duplicate-keys) 1) 
+                                  "Item isn’t"
+                                  "Items aren’t") " unique:") duplicate-keys))
       result))
 
 (module+ test
@@ -152,16 +154,39 @@
   (check-false (elements-unique? "foo")))
 
 
-;; todo: how to restrict this test?
-;; pmap requirements are enforced at compile-time.
-;; (such as pmap-keys must be unique).
-;; (and every element must have a parent attr).
+;; certain pmap requirements are enforced at compile-time.
+;; (such as pmap-keys must be valid strings, and unique.)
 ;; otherwise this becomes a rather expensive contract
-;; because every function in pmap.rkt uses it
+;; because every function in pmap.rkt uses it.
+;; note that a pmap is just a bunch of recursively nested pmaps.
 (define/contract (pmap? x)
   (any/c . -> . boolean?)
-  (tagged-xexpr? x))
+  (and (match x
+         ;; a tagged-xexpr with one attr ('parent)
+         ;; whose subelements recursively meet the same test.
+         [(list (? pmap-key? tag) (? pmap-attr? attr) elements ...) 
+          (andmap pmap? elements)]
+         [else #f])))
 
+(module+ test
+  (check-true (pmap? '(foo ((parent "bar")))))
+  (check-false (pmap? '(foo)))
+  (check-false (pmap? '(foo ((parent "bar")(hee "haw")))))
+  (check-true (pmap? '(foo ((parent "bar")) (hee ((parent "foo"))))))
+  (check-false (pmap? '(foo ((parent "bar")) (hee ((uncle "foo")))))))
+
+;; pmap attr must be ((parent "value"))
+(define/contract (pmap-attr? x)
+  (any/c . -> . boolean?)
+  (match x
+    [(list `(parent ,(? string?))) #t]
+    [else #f]))
+
+(module+ test
+  (check-true (pmap-attr? '((parent "bar"))))
+  (check-false (pmap-attr? '((parent "bar")(foo "bar"))))
+  (check-false (pmap-attr? '())))
+  
 
 ;; pmap location must represent a possible valid filename
 (define/contract (pmap-key? x #:loud [loud #f])

regenerate.rkt

@@ -90,7 +90,7 @@
   (pmap-source? . -> . void?)
   (message "Regenerating pages from pollen map: " (filename-of pmap))
   (for-each regenerate-path/message 
-            (make-page-sequence (main->pmap (dynamic-require pmap 'main)))))
+            (all-pages (dynamic-require pmap 'main))))
 
 (define (get-pollen-files-with-ext ext)
   (filter (λ(f) (has-ext? f ext)) (directory-list pollen-file-root)))

tests/test.pmap

@@ -24,4 +24,3 @@ how-to-pay-for-this-book
                bibliography
                charter
                mb-lectures-and-articles}
-