From b2ad19e32728f476850eba2a9d37776328a7216c Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 1 Sep 2013 22:47:18 -0700 Subject: [PATCH] tidied pmap --- pmap-decode.rkt | 41 +++++++++++++++-------------- pmap.rkt | 68 +++++++++++++++++++++++++++---------------------- world.rkt | 1 + 3 files changed, 60 insertions(+), 50 deletions(-) diff --git a/pmap-decode.rkt b/pmap-decode.rkt index 5124138..e9d82c8 100644 --- a/pmap-decode.rkt +++ b/pmap-decode.rkt @@ -24,33 +24,36 @@ ;; single map entry: convert to xexpr with parent [else (make-tagged-xexpr (->symbol x) (make-xexpr-attr POLLEN_MAP_PARENT_KEY (->string parent)))])) + +;; this sets default input for following functions +(define/contract (pmap-root->pmap tx) + ;; (not/c pmap) prevents pmaps from being accepted as input + ((and/c tagged-xexpr? (not/c pmap?)) . -> . pmap?) + (add-parents tx)) + + (module+ test (define test-pmap-main `(pmap-main "foo" "bar" (one (two "three")))) (check-equal? (pmap-root->pmap test-pmap-main) `(pmap-main ((,POLLEN_MAP_PARENT_KEY "")) (foo ((,POLLEN_MAP_PARENT_KEY "pmap-main"))) (bar ((,POLLEN_MAP_PARENT_KEY "pmap-main"))) (one ((,POLLEN_MAP_PARENT_KEY "pmap-main")) (two ((,POLLEN_MAP_PARENT_KEY "one")) (three ((,POLLEN_MAP_PARENT_KEY "two")))))))) -;; this sets default input for following functions -(define/contract (pmap-root->pmap tx) - (tagged-xexpr? . -> . pmap?) - (add-parents tx)) + +;; contract for pmap-source-decode +(define/contract (valid-pmap-keys? x) + (any/c . -> . boolean?) + (andmap (λ(x) (pmap-key? #:loud #t x)) (filter-not whitespace? (flatten x)))) + +;; contract for pmap-source-decode +(define/contract (unique-pmap-keys? x) + (any/c . -> . boolean?) + ;; use map ->string to make keys comparable + (elements-unique? #:loud #t (map ->string (filter-not whitespace? (flatten x))))) (define/contract (pmap-source-decode . elements) - (() #:rest (and/c - ;; todo: how to put these contracts under a let? - ;; all elements must be valid pmap keys - (flat-named-contract 'valid-pmap-keys - (λ(e) (andmap (λ(x) (pmap-key? #:loud #t x)) - (filter-not whitespace? (flatten e))))) - ;; 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))))))) - . ->* . pmap?) - (pmap-root->pmap (decode (cons 'pmap-root elements) - #:xexpr-elements-proc (λ(xs) (filter-not whitespace? xs)) - ))) + (() #:rest (and/c valid-pmap-keys? unique-pmap-keys?) . ->* . pmap?) + (pmap-root->pmap (decode (cons POLLEN_MAP_ROOT_NAME elements) + #:xexpr-elements-proc (λ(xs) (filter-not whitespace? xs))))) diff --git a/pmap.rkt b/pmap.rkt index c14bc33..573622f 100644 --- a/pmap.rkt +++ b/pmap.rkt @@ -6,20 +6,27 @@ (provide (all-defined-out)) -;; get the values out of the file, or make them up -(define pmap - (let ([pmap-source (build-path START_DIR DEFAULT_POLLEN_MAP)]) - (if (file-exists? pmap-source) - ;; Load it from default path. - ;; dynamic require of a pmap source file gets you a full pmap. - (dynamic-require pmap-source POLLEN_ROOT) - ;; ... or else synthesize it - ;; get list of all files - (let* ([files (directory-list START_DIR)] - ;; filter it to those with pollen extensions - [files (map remove-ext (filter (λ(x) (has-ext? x POLLEN_SOURCE_EXT)) files))]) - ;; make a 'pmap-root structure and convert it to a full pmap - (pmap-root->pmap (make-tagged-xexpr 'pmap-root empty (map path->string files))))))) +;; function to set up the project-pmap. +;; this is to make life simpler when using map navigation functions. +;; the current main.pmap of the project is used as the default input. +;; without this, you'd have to pass it over and over. +;; which is sort of the functional lifestyle, +;; but in templates, gets tiresome and error-prone. +(define/contract (make-project-pmap) + (-> pmap?) + (define pmap-source (build-path START_DIR DEFAULT_POLLEN_MAP)) + (if (file-exists? pmap-source) + ;; Load it from default path. + ;; dynamic require of a pmap source file gets you a full pmap. + (dynamic-require pmap-source POLLEN_ROOT) + ;; ... or else synthesize it + (let* ([files (directory-list START_DIR)] + ;; restrict files to those with pollen extensions + [files (map remove-ext (filter (λ(x) (has-ext? x POLLEN_SOURCE_EXT)) files))]) + ;; make a POLLEN_MAP_ROOT_NAME structure and convert it to a full pmap + (pmap-root->pmap (cons POLLEN_MAP_ROOT_NAME (map path->string files)))))) + +(define project-pmap (make-project-pmap)) ;; remove parents from map (i.e., just remove attrs) @@ -35,15 +42,14 @@ (module+ test - (let ([sample-main `(pmap-root "foo" "bar" (one (two "three")))]) + (let ([sample-main `(POLLEN_MAP_ROOT_NAME "foo" "bar" (one (two "three")))]) (check-equal? (pmap-root->pmap sample-main) - `(pmap-root ((,POLLEN_MAP_PARENT_KEY "")) (foo ((,POLLEN_MAP_PARENT_KEY "pmap-root"))) (bar ((,POLLEN_MAP_PARENT_KEY "pmap-root"))) (one ((,POLLEN_MAP_PARENT_KEY "pmap-root")) (two ((,POLLEN_MAP_PARENT_KEY "one")) (three ((,POLLEN_MAP_PARENT_KEY "two"))))))))) - + `(POLLEN_MAP_ROOT_NAME ((,POLLEN_MAP_PARENT_KEY "")) (foo ((,POLLEN_MAP_PARENT_KEY "POLLEN_MAP_ROOT_NAME"))) (bar ((,POLLEN_MAP_PARENT_KEY "POLLEN_MAP_ROOT_NAME"))) (one ((,POLLEN_MAP_PARENT_KEY "POLLEN_MAP_ROOT_NAME")) (two ((,POLLEN_MAP_PARENT_KEY "one")) (three ((,POLLEN_MAP_PARENT_KEY "two"))))))))) ;; return the parent of a given name -(define/contract (parent element [pmap pmap]) +(define/contract (parent element [pmap project-pmap]) ((pmap-key?) (pmap?) . ->* . (or/c string? boolean?)) (and element (let ([result (se-path* `(,(->symbol element) #:parent) pmap)]) (and result (->string result))))) ; se-path* returns #f if nothing found @@ -59,7 +65,7 @@ ; get children of a particular element -(define/contract (children element [pmap pmap]) +(define/contract (children element [pmap project-pmap]) ((pmap-key?) (pmap?) . ->* . (or/c list? boolean?)) ;; se-path*/list returns '() if nothing found (and element (let ([children (se-path*/list `(,(->symbol element)) pmap)]) @@ -74,7 +80,7 @@ ;; find all siblings on current level: go up to parent and ask for children -(define/contract (siblings element [pmap pmap]) +(define/contract (siblings element [pmap project-pmap]) ;; this never returns false: element is always a sibling of itself. ;; todo: how to use input value in contract? e.g., to check that element is part of output list ((pmap-key?) (pmap?) . ->* . (or/c list? boolean?)) @@ -88,7 +94,7 @@ -(define/contract (siblings-split element [pmap pmap]) +(define/contract (siblings-split element [pmap project-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) @@ -101,7 +107,7 @@ ;; siblings to the left of target element (i.e., precede in map order) -(define (siblings-left element [pmap pmap]) +(define (siblings-left element [pmap project-pmap]) (let-values ([(left right) (siblings-split element pmap)]) left)) @@ -110,7 +116,7 @@ (check-false (siblings-left 'foo test-pmap))) ;; siblings to the right of target element (i.e., follow in map order) -(define (siblings-right element [pmap pmap]) +(define (siblings-right element [pmap project-pmap]) (let-values ([(left right) (siblings-split element pmap)]) right)) @@ -120,7 +126,7 @@ ;; get element immediately to the left in map -(define/contract (sibling-previous element [pmap pmap]) +(define/contract (sibling-previous element [pmap project-pmap]) ((pmap-key?) (pmap?) . ->* . (or/c string? boolean?)) (let ([siblings (siblings-left element pmap)]) (and siblings (last siblings)))) @@ -130,7 +136,7 @@ (check-false (sibling-previous 'foo test-pmap))) ;; get element immediately to the right in map -(define/contract (sibling-next element [pmap pmap]) +(define/contract (sibling-next element [pmap project-pmap]) ((pmap-key?) (pmap?) . ->* . (or/c string? boolean?)) (let ([siblings (siblings-right element pmap)]) (and siblings (first siblings)))) @@ -141,7 +147,7 @@ ;; flatten map to sequence -(define/contract (all-pages [pmap pmap]) +(define/contract (all-pages [pmap project-pmap]) (pmap? . -> . (listof string?)) ; use cdr to get rid of main-map tag at front (map ->string (cdr (flatten (remove-parents pmap))))) @@ -150,7 +156,7 @@ (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]) +(define/contract (adjacent-pages side element [pmap project-pmap]) ((symbol? pmap-key?) (pmap?) . ->* . (or/c list? boolean?)) (let ([result ((if (equal? side 'left) takef @@ -165,7 +171,7 @@ ;; get sequence of earlier pages -(define/contract (previous-pages element [pmap pmap]) +(define/contract (previous-pages element [pmap project-pmap]) ((pmap-key?) (pmap?) . ->* . (or/c list? boolean?)) (adjacent-pages 'left element pmap)) @@ -176,7 +182,7 @@ ;; get sequence of next pages -(define (next-pages element [pmap pmap]) +(define (next-pages element [pmap project-pmap]) ((pmap-key?) (pmap?) . ->* . (or/c list? boolean?)) (adjacent-pages 'right element pmap)) @@ -186,7 +192,7 @@ (check-false (next-pages 'three test-pmap))) ;; get page immediately previous -(define/contract (previous-page element [pmap pmap]) +(define/contract (previous-page element [pmap project-pmap]) ((pmap-key?) (pmap?) . ->* . (or/c string? boolean?)) (let ([result (previous-pages element pmap)]) (and result (last result)))) @@ -197,7 +203,7 @@ (check-false (previous-page 'foo test-pmap))) ;; get page immediately next -(define (next-page element [pmap pmap]) +(define (next-page element [pmap project-pmap]) ((pmap-key?) (pmap?) . ->* . (or/c string? boolean?)) (let ([result (next-pages element pmap)]) (and result (first result)))) diff --git a/world.rkt b/world.rkt index 782cc40..6f4fba4 100644 --- a/world.rkt +++ b/world.rkt @@ -13,6 +13,7 @@ (define POLLEN_MAP_EXT 'pmap) (define DEFAULT_POLLEN_MAP "main.pmap") (define POLLEN_MAP_PARENT_KEY 'parent) +(define POLLEN_MAP_ROOT_NAME 'pmap-root) (define MAIN_POLLEN_EXPORT 'main) ;(define META_POLLEN_TAG 'metas)