diff --git a/pmap.rkt b/pmap.rkt index 39dc01c..e868315 100644 --- a/pmap.rkt +++ b/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)] + ))) diff --git a/predicates.rkt b/predicates.rkt index ffb3d2c..e1b6e5d 100644 --- a/predicates.rkt +++ b/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]) diff --git a/regenerate.rkt b/regenerate.rkt index b1a8207..8c40f71 100644 --- a/regenerate.rkt +++ b/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))) diff --git a/tests/test.pmap b/tests/test.pmap index b85c901..823e99e 100644 --- a/tests/test.pmap +++ b/tests/test.pmap @@ -24,4 +24,3 @@ how-to-pay-for-this-book bibliography charter mb-lectures-and-articles} -