mbutterick
/
pollen
3
3
Fork 0
Code Issues 1 Pull Requests Projects Releases Wiki Activity

added make-xexpr-attr function

Browse Source
pull/9/head
Matthew Butterick 12 years ago
parent ef4ed84ade
commit a46f2357ae
2 changed files with 148 additions and 116 deletions
Show Stats Download Patch File Download Diff File

232
template.rkt
Unescape Escape View File

@ -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])
((pmap-tree?) (xexpr-tag? xexpr-tag?) . ->* . pmap-tree?)
(define/contract (add-parents x [parent empty])
((pmap-tree?) (xexpr-tag?) . ->* . pmap-tree?)
; disallow main as parent tag
(when (equal? parent 'map-main) (set! parent empty))
(cond
[(list? x)
(let ([new-parent (car x)])
; xexpr with topic as name, parent as attr, children as elements
`(,@(add-parents new-parent parent) ,@(map (λ(i) (add-parents i new-parent)) (cdr x))))]
[else `(,(->symbol x) ((parent ,(->string parent))))]))
(match x
[(list (? xexpr-tag? tag) elements ...) ; next level in hierarchy
(let-values ([(tag attr _) (break-tagged-xexpr (add-parents tag parent))])
;; xexpr with tag as name, parent as attr, children as elements with tag as next parent
(make-tagged-xexpr tag attr (map (λ(e) (add-parents e tag)) elements)))]
;; 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")))
(check-equal? (add-parents stt) '(map-main
((parent ""))
(foo ((parent "")))
(one ((parent "")) (two ((parent "one")))))))
(define (remove-parents x)
(cond
[(list? x) `(,(car x) ,@(map remove-parents (cddr x)))]
[else x]))
(define (main->tree main)
(add-parents main))
(define tree (main->tree map-main))
(define (get-parent x [xexpr tree])
(if (empty? x)
empty
(let ([result (se-path* `(,(->symbol x) #:parent) xexpr)])
(if (not result) ; se-path* returns #f if nothing found
empty ; but don't pass #f up through the chain.
(->string result)))))
; algorithm to find children
(define (get-children x [xexpr tree])
(if (empty? x)
empty
; find contents of node.
(let ([node-contents (se-path*/list `(,(->symbol x)) xexpr)])
; If there are sublists, just take first element
(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
(define (get-all-siblings x [xexpr tree])
(get-children (get-parent x xexpr) xexpr))
(define (get-adjacent-siblings x [xexpr tree])
(define-values (left right)
(splitf-at (get-all-siblings x xexpr) (λ(y) (not (equal? (->string x) (->string y))))))
; use cdr because right piece includes x itself at front
(values left (if (empty? right)
empty
(cdr right))))
(define (get-left-siblings x [xexpr tree])
(define-values (left right) (get-adjacent-siblings x xexpr))
left)
(define (get-right-siblings x [xexpr tree])
(define-values (left right) (get-adjacent-siblings x xexpr))
right)
(define (get-left x [xexpr tree])
(if (empty? (get-left-siblings x xexpr))
empty
(last (get-left-siblings x xexpr))))
(define (get-right x [xexpr tree])
(if (empty? (get-right-siblings x xexpr))
empty
(first (get-right-siblings x xexpr))))
(define (make-page-sequence [xexpr tree])
; use cdr to get rid of body tag at front
; todo: calculate exclusions?
(map ->string (cdr (flatten (remove-parents xexpr)))))
(define (get-adjacent-pages x [xexpr tree])
(define-values (left right)
(splitf-at (make-page-sequence xexpr) (λ(y) (not (equal? (->string x) (->string y))))))
; use cdr because right piece includes x itself at front
(values left (if (empty? right)
empty
(cdr right))))
(define (get-previous-pages x [xexpr tree])
(define-values (left right) (get-adjacent-pages x xexpr))
left)
(define (get-next-pages x [xexpr tree])
(define-values (left right) (get-adjacent-pages x xexpr))
right)
(define (get-previous x [xexpr tree])
(if (empty? (get-previous-pages x xexpr))
empty
(last (get-previous-pages x xexpr))))
(define (get-next x [xexpr tree])
(if (empty? (get-next-pages x xexpr))
empty
(first (get-next-pages x xexpr))))
(provide (all-defined-out) (all-from-out web-server/templates))
(define stt `(map-main "foo" ,(map-topic "one" (map-topic "two" "three"))))
(check-equal? (add-parents stt)
'(map-main ((parent "")) (foo ((parent ""))) (one ((parent ""))
(two ((parent "one")) (three ((parent "two"))))))))
(define (remove-parents x)
(cond
[(list? x) `(,(car x) ,@(map remove-parents (cddr x)))]
[else x]))
(define (main->tree main)
(add-parents main))
(define tree (main->tree map-main))
(define (get-parent x [xexpr tree])
(if (empty? x)
empty
(let ([result (se-path* `(,(->symbol x) #:parent) xexpr)])
(if (not result) ; se-path* returns #f if nothing found
empty ; but don't pass #f up through the chain.
(->string result)))))
; algorithm to find children
(define (get-children x [xexpr tree])
(if (empty? x)
empty
; find contents of node.
(let ([node-contents (se-path*/list `(,(->symbol x)) xexpr)])
; If there are sublists, just take first element
(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
(define (get-all-siblings x [xexpr tree])
(get-children (get-parent x xexpr) xexpr))
(define (get-adjacent-siblings x [xexpr tree])
(define-values (left right)
(splitf-at (get-all-siblings x xexpr) (λ(y) (not (equal? (->string x) (->string y))))))
; use cdr because right piece includes x itself at front
(values left (if (empty? right)
empty
(cdr right))))
(define (get-left-siblings x [xexpr tree])
(define-values (left right) (get-adjacent-siblings x xexpr))
left)
(define (get-right-siblings x [xexpr tree])
(define-values (left right) (get-adjacent-siblings x xexpr))
right)
(define (get-left x [xexpr tree])
(if (empty? (get-left-siblings x xexpr))
empty
(last (get-left-siblings x xexpr))))
(define (get-right x [xexpr tree])
(if (empty? (get-right-siblings x xexpr))
empty
(first (get-right-siblings x xexpr))))
(define (make-page-sequence [xexpr tree])
; use cdr to get rid of body tag at front
; todo: calculate exclusions?
(map ->string (cdr (flatten (remove-parents xexpr)))))
(define (get-adjacent-pages x [xexpr tree])
(define-values (left right)
(splitf-at (make-page-sequence xexpr) (λ(y) (not (equal? (->string x) (->string y))))))
; use cdr because right piece includes x itself at front
(values left (if (empty? right)
empty
(cdr right))))
(define (get-previous-pages x [xexpr tree])
(define-values (left right) (get-adjacent-pages x xexpr))
left)
(define (get-next-pages x [xexpr tree])
(define-values (left right) (get-adjacent-pages x xexpr))
right)
(define (get-previous x [xexpr tree])
(if (empty? (get-previous-pages x xexpr))
empty
(last (get-previous-pages x xexpr))))
(define (get-next x [xexpr tree])
(if (empty? (get-next-pages x xexpr))
empty
(first (get-next-pages x xexpr))))
(provide (all-defined-out) (all-from-out web-server/templates))

32
tools.rkt
Unescape Escape View File

@ -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?)

Write Preview
Loading…
Cancel
Save