From b6a8c7577efb07fb6f00809b069d52077a33e1ae Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Tue, 13 Aug 2013 22:17:02 -0700 Subject: [PATCH] finished adding contracts & tests to map.rkt (formerly template.rkt) --- template.rkt => map.rkt | 151 ++++++++++++++++++++++++++-------------- regenerate.rkt | 4 +- server.rkt | 2 +- 3 files changed, 100 insertions(+), 57 deletions(-) rename template.rkt => map.rkt (52%) diff --git a/template.rkt b/map.rkt similarity index 52% rename from template.rkt rename to map.rkt index 8b5caa7..d69c8d5 100644 --- a/template.rkt +++ b/map.rkt @@ -1,5 +1,6 @@ #lang racket/base (require xml xml/path racket/list racket/string racket/contract racket/match) +;; todo: why is this require here? (require (except-in web-server/templates in)) (require "tools.rkt" "world.rkt") @@ -44,10 +45,9 @@ [else (make-tagged-xexpr (->symbol x) (make-xexpr-attr 'parent (->string parent)))])) (module+ test - (define test-map `(map-main "foo" ,(map-topic "one" (map-topic "two" "three")))) + (define test-map `(map-main "foo" "bar" ,(map-topic "one" (map-topic "two" "three")))) (check-equal? (add-parents test-map) - '(map-main ((parent "")) (foo ((parent "map-main"))) (one ((parent "map-main")) - (two ((parent "one")) (three ((parent "two")))))))) + '(map-main ((parent "")) (foo ((parent "map-main"))) (bar ((parent "map-main"))) (one ((parent "map-main")) (two ((parent "one")) (three ((parent "two")))))))) ;; remove parents from tree (i.e., just remove attrs) ;; is not the inverse of add-parents, i.e., you do not get back your original input. @@ -61,9 +61,9 @@ (module+ test (check-equal? (remove-parents - '(map-main ((parent "")) (foo ((parent ""))) + '(map-main ((parent "")) (foo ((parent ""))) (bar ((parent ""))) (one ((parent "")) (two ((parent "one")) (three ((parent "two"))))))) - '(map-main (foo) (one (two (three)))))) + '(map-main (foo) (bar) (one (two (three)))))) ;; todo: what is this for? (define (main->tree main) @@ -89,7 +89,7 @@ (define test-tree (main->tree test-map)) (check-equal? (get-parent 'three test-tree) "two") (check-equal? (get-parent "three" test-tree) "two") - (check-false (get-parent 'fooburger test-tree))) + (check-false (get-parent 'nonexistent-name test-tree))) @@ -101,7 +101,6 @@ ; If there are sublists, just take first element (and (not (empty? children)) (map (λ(i) (->string (if (list? i) (car i) i))) children))))) - (module+ test (check-equal? (get-children 'one test-tree) (list "two")) (check-equal? (get-children 'two test-tree) (list "three")) @@ -109,7 +108,6 @@ (check-false (get-children 'fooburger test-tree))) - ;; find all siblings on current level: go up to parent and ask for children (define/contract (get-all-siblings element [tree tree]) ;; this never returns false: element is always a sibling of itself. @@ -118,75 +116,122 @@ (get-children (get-parent element tree) tree)) (module+ test - (check-equal? (get-all-siblings 'one test-tree) '("foo" "one")) - (check-equal? (get-all-siblings 'foo test-tree) '("foo" "one")) + (check-equal? (get-all-siblings 'one test-tree) '("foo" "bar" "one")) + (check-equal? (get-all-siblings 'foo test-tree) '("foo" "bar" "one")) (check-equal? (get-all-siblings 'two test-tree) '("two")) (check-false (get-all-siblings 'invalid-key test-tree))) +;; helper function +(define/contract (get-side-siblings side element [tree tree]) + ((symbol? map-key?) (pmap-tree?) . ->* . (or/c list? boolean?)) + (define result ((if (equal? side 'left) takef takef-right) + (get-all-siblings element tree) + (λ(i) (not (equal? (->string element) (->string i)))))) + (and (not (empty? result)) result)) + ;; siblings to the left of target element (i.e., precede in map order) -(define/contract (get-left-siblings element [tree tree]) - ((map-key?) (pmap-tree?) . ->* . (or/c list? boolean?)) - (takef (get-all-siblings element tree) (λ(i) (not (equal? (->string element) (->string i)))))) +(define (get-left-siblings element [tree tree]) + (get-side-siblings 'left element tree)) (module+ test - (check-equal? (get-left-siblings 'one test-tree) '("foo")) - (check-equal? (get-left-siblings 'foo test-tree) '())) + (check-equal? (get-left-siblings 'one test-tree) '("foo" "bar")) + (check-false (get-left-siblings 'foo test-tree))) ;; siblings to the right of target element (i.e., follow in map order) -(define/contract (get-right-siblings element [tree tree]) - ((map-key?) (pmap-tree?) . ->* . (or/c list? boolean?)) - (takef-right (get-all-siblings element tree) (λ(i) (not (equal? (->string element) (->string i)))))) +(define (get-right-siblings element [tree tree]) + (get-side-siblings 'right element tree)) (module+ test - (check-equal? (get-right-siblings 'one test-tree) '()) - (check-equal? (get-right-siblings 'foo test-tree) '("one"))) + (check-false (get-right-siblings 'one test-tree)) + (check-equal? (get-right-siblings 'foo test-tree) '("bar" "one"))) + -;;;;;;;;;;;;;;;;;;; -;; todo next +;; get element immediately to the left in map +(define/contract (get-left element [tree tree]) + ((map-key?) (pmap-tree?) . ->* . (or/c string? boolean?)) + (define siblings (get-left-siblings element tree)) + (and siblings (last siblings))) -(define (get-left element [tree tree]) - (if (empty? (get-left-siblings element tree)) - empty - (last (get-left-siblings element tree)))) +(module+ test + (check-equal? (get-left 'bar test-tree) "foo") + (check-false (get-left 'foo test-tree))) + +;; get element immediately to the right in map +(define/contract (get-right element [tree tree]) + ((map-key?) (pmap-tree?) . ->* . (or/c string? boolean?)) + (define siblings (get-right-siblings element tree)) + (and siblings (first siblings))) -(define (get-right element [tree tree]) - (if (empty? (get-right-siblings element tree)) - empty - (first (get-right-siblings element tree)))) +(module+ test + (check-equal? (get-right 'foo test-tree) "bar") + (check-false (get-right 'one test-tree))) -(define (make-page-sequence [tree tree]) - ; use cdr to get rid of body tag at front - ; todo: calculate exclusions? +;; flatten tree to sequence +(define/contract (make-page-sequence [tree tree]) + (pmap-tree? . -> . (listof string?)) + ; use cdr to get rid of main-map tag at front (map ->string (cdr (flatten (remove-parents tree))))) -(define (get-adjacent-pages element [tree tree]) - (define-values (left right) - (splitf-at (make-page-sequence tree) (λ(y) (not (equal? (->string element) (->string y)))))) - ; use cdr because right piece includes x itself at front - (values left (if (empty? right) - empty - (cdr right)))) +(module+ test + (check-equal? (make-page-sequence test-tree) '("foo" "bar" "one" "two" "three"))) + +;; helper function for get-previous-pages and get-next-pages +(define/contract (get-adjacent-pages side element [tree tree]) + ((map-key? symbol?) (pmap-tree?) . ->* . (or/c list? boolean?)) + (define result ((if (equal? side 'left) takef takef-right) + (make-page-sequence tree) (λ(y) (not (equal? (->string element) (->string y)))))) + (and (not (empty? result)) result)) + +(module+ test + (check-equal? (get-adjacent-pages 'left 'one test-tree) '("foo" "bar")) + (check-equal? (get-adjacent-pages 'left 'three test-tree) '("foo" "bar" "one" "two")) + (check-false (get-adjacent-pages 'left 'foo test-tree))) + + +;; get sequence of earlier pages +(define/contract (get-previous-pages element [tree tree]) + ((map-key?) (pmap-tree?) . ->* . (or/c list? boolean?)) + (get-adjacent-pages 'left element tree)) + +(module+ test + (check-equal? (get-previous-pages 'one test-tree) '("foo" "bar")) + (check-equal? (get-previous-pages 'three test-tree) '("foo" "bar" "one" "two")) + (check-false (get-previous-pages 'foo test-tree))) -(define (get-previous-pages element [tree tree]) - (define-values (left right) (get-adjacent-pages element tree)) - left) +;; get sequence of next pages (define (get-next-pages element [tree tree]) - (define-values (left right) (get-adjacent-pages element tree)) - right) + ((map-key?) (pmap-tree?) . ->* . (or/c list? boolean?)) + (get-adjacent-pages 'right element tree)) -(define (get-previous element [tree tree]) - (if (empty? (get-previous-pages element tree)) - empty - (last (get-previous-pages element tree)))) +(module+ test + (check-equal? (get-next-pages 'foo test-tree) '("bar" "one" "two" "three")) + (check-equal? (get-next-pages 'one test-tree) '("two" "three")) + (check-false (get-next-pages 'three test-tree))) -(define (get-next element [tree tree]) - (if (empty? (get-next-pages element tree)) - empty - (first (get-next-pages element tree)))) +;; get page immediately previous +(define/contract (get-previous element [tree tree]) + ((map-key?) (pmap-tree?) . ->* . (or/c string? boolean?)) + (define result (get-previous-pages element tree)) + (and result (last result))) + +(module+ test + (check-equal? (get-previous 'one test-tree) "bar") + (check-equal? (get-previous 'three test-tree) "two") + (check-false (get-previous 'foo test-tree))) +;; get page immediately next +(define (get-next element [tree tree]) + ((map-key?) (pmap-tree?) . ->* . (or/c string? boolean?)) + (define result (get-next-pages element tree)) + (and result (first result))) +(module+ test + (check-equal? (get-next 'foo test-tree) "bar") + (check-equal? (get-next 'one test-tree) "two") + (check-false (get-next 'three test-tree))) +;; todo: why is this re-exporting web-server/templates? (provide (all-defined-out) (all-from-out web-server/templates)) \ No newline at end of file diff --git a/regenerate.rkt b/regenerate.rkt index 68da4af..3e008aa 100644 --- a/regenerate.rkt +++ b/regenerate.rkt @@ -1,8 +1,6 @@ #lang racket (require xml/path) -(require (planet mb/pollen/world)) -(require (planet mb/pollen/tools)) -(require (planet mb/pollen/template)) +(require "world.rkt" "tools.rkt" "map.rkt") (require racket/rerequire) ; hash of mod-dates takes lists of paths as keys, diff --git a/server.rkt b/server.rkt index 4e33e88..b6747b2 100755 --- a/server.rkt +++ b/server.rkt @@ -5,7 +5,7 @@ (require racket/rerequire) (require xml) (require xml/path) -(require "tools.rkt" "world.rkt" "regenerate.rkt" "template.rkt") +(require "tools.rkt" "world.rkt" "regenerate.rkt" "map.rkt") (displayln "Pollen server starting...")