added make-xexpr-attr function

template.rkt

@@ -1,9 +1,11 @@
 #lang racket/base
-(require xml xml/path racket/list racket/string racket/contract)
+(require xml xml/path racket/list racket/string racket/contract racket/match)
 (require (except-in web-server/templates in))
 (require "tools.rkt" "world.rkt")
 
-(module+ test (require rackunit)
+(module+ test (require rackunit))
+
+(module+ test
   (define tt (main->tree (dynamic-require "tests/test.pmap" POLLEN_ROOT))))
 
 ; get the values out of the file, or make them up
@@ -17,7 +19,7 @@
     ; ... synthesize it
     (let ([files (directory-list START_DIR)])
       (set! files (map remove-ext (filter (λ(x) (has-ext? x POLLEN_SOURCE_EXT)) files)))
-      (set! map-main `(map-main ,@(map path->string files)))))
+      (set! map-main (make-tagged-xexpr 'map-main empty (map path->string files)))))
 
 ;; todo: restrict this test
 (define/contract (pmap-tree? x)
@@ -25,119 +27,119 @@
   (tagged-xexpr? x))
 
 ;; insert parents into pmap tree as attrs
-(define/contract (add-parents x [parent null] [previous null])
+(define/contract (add-parents x [parent empty])
-  ((pmap-tree?) (xexpr-tag? xexpr-tag?) . ->* . pmap-tree?)
+  ((pmap-tree?) (xexpr-tag?) . ->* . pmap-tree?)
   ; disallow main as parent tag
   (when (equal? parent 'map-main) (set! parent empty)) 
-  (cond
+  (match x
-    [(list? x) 
+    [(list (? xexpr-tag? tag) elements ...) ; next level in hierarchy 
-     (let ([new-parent (car x)])
+     (let-values ([(tag attr _) (break-tagged-xexpr (add-parents tag parent))])
-       ; xexpr with topic as name, parent as attr, children as elements
+       ;; xexpr with tag as name, parent as attr, children as elements with tag as next parent
-       `(,@(add-parents new-parent parent) ,@(map (λ(i) (add-parents i new-parent)) (cdr x))))]
+       (make-tagged-xexpr tag attr (map (λ(e) (add-parents e tag)) elements)))]
-    [else `(,(->symbol x) ((parent ,(->string parent))))]))
+    ;; single map entry: convert to xexpr with parent
+    [else (make-tagged-xexpr (->symbol x) (make-xexpr-attr 'parent (->string parent)))]))
 
 (module+ test
-  (define stt `(map-main "foo" ,(map-topic "one" "two")))
+  (define stt `(map-main "foo" ,(map-topic "one" (map-topic "two" "three"))))
-  (check-equal? (add-parents stt) '(map-main
+  (check-equal? (add-parents stt) 
-                                    ((parent ""))
+                '(map-main ((parent "")) (foo ((parent ""))) (one ((parent "")) 
-                                    (foo ((parent "")))
+                                                                  (two ((parent "one")) (three ((parent "two"))))))))
-                                    (one ((parent "")) (two ((parent "one")))))))
+
-  
+(define (remove-parents x)  
-  (define (remove-parents x)  
+  (cond
-    (cond
+    [(list? x) `(,(car x) ,@(map remove-parents (cddr x)))]
-      [(list? x) `(,(car x) ,@(map remove-parents (cddr x)))]
+    [else x]))
-      [else x]))
+
-  
+
-  
+(define (main->tree main)
-  (define (main->tree main)
+  (add-parents main))
-    (add-parents main))
+
-  
+
-  
+
-  
+
-  
+(define tree (main->tree map-main))
-  (define tree (main->tree map-main))
+
-  
+(define (get-parent x [xexpr tree])
-  (define (get-parent x [xexpr tree])
+  (if (empty? x)
-    (if (empty? x)
+      empty
-        empty
+      (let ([result (se-path* `(,(->symbol x) #:parent) xexpr)])
-        (let ([result (se-path* `(,(->symbol x) #:parent) xexpr)])
+        (if (not result) ; se-path* returns #f if nothing found
-          (if (not result) ; se-path* returns #f if nothing found
+            empty ; but don't pass #f up through the chain.
-              empty ; but don't pass #f up through the chain.
+            (->string result)))))
-              (->string result)))))
+
-  
+; algorithm to find children
-  ; algorithm to find children
+(define (get-children x [xexpr tree])
-  (define (get-children x [xexpr tree])
+  (if (empty? x)
-    (if (empty? x)
+      empty
-        empty
+      ; find contents of node. 
-        ; find contents of node. 
+      (let ([node-contents (se-path*/list `(,(->symbol x)) xexpr)])
-        (let ([node-contents (se-path*/list `(,(->symbol x)) xexpr)])
+        ; If there are sublists, just take first element
-          ; If there are sublists, just take first element
+        (map (λ(i) (->string (if (list? i) (car i) i))) node-contents))))
-          (map (λ(i) (->string (if (list? i) (car i) i))) node-contents))))
+
-  
+; find all siblings on current level: go up to parent and ask for children
-  ; find all siblings on current level: go up to parent and ask for children
+(define (get-all-siblings x [xexpr tree])
-  (define (get-all-siblings x [xexpr tree])
+  (get-children (get-parent x xexpr) xexpr))
-    (get-children (get-parent x xexpr) xexpr))
+
-  
+(define (get-adjacent-siblings x [xexpr tree])
-  (define (get-adjacent-siblings x [xexpr tree])
+  (define-values (left right)
-    (define-values (left right)
+    (splitf-at (get-all-siblings x xexpr) (λ(y) (not (equal? (->string x) (->string y))))))
-      (splitf-at (get-all-siblings x xexpr) (λ(y) (not (equal? (->string x) (->string y))))))
+  ; use cdr because right piece includes x itself at front
-    ; use cdr because right piece includes x itself at front
+  (values left (if (empty? right)
-    (values left (if (empty? right)
+                   empty
-                     empty
+                   (cdr right))))
-                     (cdr right))))
+
-  
+(define (get-left-siblings x [xexpr tree])
-  (define (get-left-siblings x [xexpr tree])
+  (define-values (left right) (get-adjacent-siblings x xexpr))
-    (define-values (left right) (get-adjacent-siblings x xexpr))
+  left)
-    left)
+
-  
+(define (get-right-siblings x [xexpr tree])
-  (define (get-right-siblings x [xexpr tree])
+  (define-values (left right) (get-adjacent-siblings x xexpr))
-    (define-values (left right) (get-adjacent-siblings x xexpr))
+  right)
-    right)
+
-  
+(define (get-left x [xexpr tree])
-  (define (get-left x [xexpr tree])
+  (if (empty? (get-left-siblings x xexpr))
-    (if (empty? (get-left-siblings x xexpr))
+      empty
-        empty
+      (last (get-left-siblings x xexpr))))
-        (last (get-left-siblings x xexpr))))
+
-  
+(define (get-right x [xexpr tree])
-  (define (get-right x [xexpr tree])
+  (if (empty? (get-right-siblings x xexpr))
-    (if (empty? (get-right-siblings x xexpr))
+      empty
-        empty
+      (first (get-right-siblings x xexpr))))
-        (first (get-right-siblings x xexpr))))
+
-  
+
-  
+(define (make-page-sequence [xexpr tree])
-  (define (make-page-sequence [xexpr tree])
+  ; use cdr to get rid of body tag at front
-    ; use cdr to get rid of body tag at front
+  ; todo: calculate exclusions?
-    ; todo: calculate exclusions?
+  (map ->string (cdr (flatten (remove-parents xexpr))))) 
-    (map ->string (cdr (flatten (remove-parents xexpr))))) 
+
-  
+(define (get-adjacent-pages x [xexpr tree])
-  (define (get-adjacent-pages x [xexpr tree])
+  (define-values (left right)
-    (define-values (left right)
+    (splitf-at (make-page-sequence xexpr) (λ(y) (not (equal? (->string x) (->string y))))))
-      (splitf-at (make-page-sequence xexpr) (λ(y) (not (equal? (->string x) (->string y))))))
+  ; use cdr because right piece includes x itself at front
-    ; use cdr because right piece includes x itself at front
+  (values left (if (empty? right)
-    (values left (if (empty? right)
+                   empty
-                     empty
+                   (cdr right))))
-                     (cdr right))))
+
-  
+(define (get-previous-pages x [xexpr tree])
-  (define (get-previous-pages x [xexpr tree])
+  (define-values (left right) (get-adjacent-pages x xexpr))
-    (define-values (left right) (get-adjacent-pages x xexpr))
+  left)
-    left)
+
-  
+(define (get-next-pages x [xexpr tree])
-  (define (get-next-pages x [xexpr tree])
+  (define-values (left right) (get-adjacent-pages x xexpr))
-    (define-values (left right) (get-adjacent-pages x xexpr))
+  right)
-    right)
+
-  
+(define (get-previous x [xexpr tree])
-  (define (get-previous x [xexpr tree])
+  (if (empty? (get-previous-pages x xexpr))
-    (if (empty? (get-previous-pages x xexpr))
+      empty
-        empty
+      (last (get-previous-pages x xexpr))))
-        (last (get-previous-pages x xexpr))))
+
-  
+(define (get-next x [xexpr tree])
-  (define (get-next x [xexpr tree])
+  (if (empty? (get-next-pages x xexpr))
-    (if (empty? (get-next-pages x xexpr))
+      empty
-        empty
+      (first (get-next-pages x xexpr))))
-        (first (get-next-pages x xexpr))))
+
-  
+
-  
+
-  
+
-  
+
-  
+(provide (all-defined-out) (all-from-out web-server/templates))
-  (provide (all-defined-out) (all-from-out web-server/templates))

tools.rkt

@@ -2,7 +2,7 @@
 (require racket/contract racket/match)
 (require (only-in racket/path filename-extension))
 (require (only-in racket/format ~a))
-(require (only-in racket/list empty empty? second filter-not splitf-at takef dropf dropf-right))
+(require racket/list)
 (require (only-in racket/string string-join))
 (require (only-in xml xexpr? xexpr/c))
 (require (prefix-in scribble: (only-in scribble/decode whitespace?)))
@@ -139,6 +139,36 @@
   (call-with-values (λ() vs) list))
 
 
+;; convert list of alternating keys & values to attr
+;; todo: make contract. Which is somewhat complicated:
+;; list of items, made of xexpr-attr or even numbers of symbol/string pairs
+;; use splitf*-at with xexpr-attr? as test, then check lengths of resulting lists
+(define/contract (make-xexpr-attr . items)
+  (() #:rest (listof (λ(i) (or (xexpr-attr? i) (symbol? i) (string? i)))) . ->* . xexpr-attr?)
+  
+  ;; need this function to make sure that 'foo and "foo" are treated as the same hash key
+  (define (make-attr-list items)
+    (if (empty? items)
+        empty
+        (let ([key (->symbol (first items))]
+              [value (->string (second items))]
+              [rest (drop items 2)])
+          (append (list key value) (make-attr-list rest)))))
+  
+  ;; use flatten to splice xexpr-attrs into list
+  (define attr-hash (apply hash (make-attr-list (flatten items))))
+  `(,@(map (λ(k v) (list k v)) (hash-keys attr-hash) (hash-values attr-hash))))
+
+(module+ test
+  (check-equal? (make-xexpr-attr 'foo "bar") '((foo "bar")))
+  (check-equal? (make-xexpr-attr "foo" 'bar) '((foo "bar")))
+  (check-equal? (make-xexpr-attr "foo" "bar" "goo" "gar") '((foo "bar")(goo "gar")))
+  (check-equal? (make-xexpr-attr '((foo "bar")(goo "gar")) "hee" "haw") 
+                '((foo "bar")(goo "gar")(hee "haw")))
+  (check-equal? (make-xexpr-attr '((foo "bar")(goo "gar")) "foo" "haw") '((foo "haw")(goo "gar")))
+)
+
+
 ;; create tagged-xexpr from parts (opposite of break-tagged-xexpr)
 (define/contract (make-tagged-xexpr name [attr empty] [content empty])
   ((symbol?) (xexpr-attr? xexpr-elements?) . ->* . tagged-xexpr?)