From a46f2357ae262d6478ee7f83d2a6e8835c4d8db8 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 12 Aug 2013 16:27:41 -0700 Subject: [PATCH] added make-xexpr-attr function --- template.rkt | 232 ++++++++++++++++++++++++++------------------------- tools.rkt | 32 ++++++- 2 files changed, 148 insertions(+), 116 deletions(-) diff --git a/template.rkt b/template.rkt index 48b3e51..3a976ed 100644 --- a/template.rkt +++ b/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]) - ((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)) \ No newline at end of file + (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)) \ No newline at end of file diff --git a/tools.rkt b/tools.rkt index b7e075a..5fb6264 100644 --- a/tools.rkt +++ b/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?)