shored up pmap-decode

pull/9/head
Matthew Butterick 11 years ago
parent 5ba9b92c77
commit 4dee701062

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(require racket/list) (require racket/list)
(require (planet mb/pollen/tools) (planet mb/pollen/main-helper)) (require (planet mb/pollen/tools) (planet mb/pollen/main-helper))
(require (only-in (planet mb/pollen/pmap) pmap-decode)) (require (only-in (planet mb/pollen/pmap-decode) pmap-source-decode))
(require (only-in (planet mb/pollen/predicates) pmap?)) (require (only-in (planet mb/pollen/predicates) pmap?))
(require (only-in (planet mb/pollen/pollen-file-tools) has-ext?)) (require (only-in (planet mb/pollen/pollen-file-tools) has-ext?))
(require (only-in (planet mb/pollen/world) POLLEN_MAP_EXT)) (require (only-in (planet mb/pollen/world) POLLEN_MAP_EXT))
@ -76,16 +76,17 @@
;; Unlike Scribble, which insists on decoding, ;; Unlike Scribble, which insists on decoding,
;; Pollen just passes through the minimally processed data. ;; Pollen just passes through the minimally processed data.
;; one exception: if file extension marks it as pmap, send it to the pmap decoder instead. ;; one exception: if file extension marks it as pmap, send it to the pmap decoder instead.
(define source-is-pmap? (define pmap-source?
;; this tests inner-here (which is always the file name) ;; this tests inner-here (which is always the file name)
;; rather than (get metas 'here) which might have been overridden. ;; rather than (get metas 'here) which might have been overridden.
;; Because if it's overridden to something other than *.pmap, ;; Because if it's overridden to something other than *.pmap,
;; pmap processing will fail. ;; pmap processing will fail.
;; This defeats rule that pmap file suffix triggers pmap decoding. ;; This defeats rule that pmap file suffix triggers pmap decoding.
((->path inner-here) . has-ext? . POLLEN_MAP_EXT)) ((->path inner-here) . has-ext? . POLLEN_MAP_EXT))
(define main (apply (if source-is-pmap? (define main (apply (if pmap-source?
pmap-decode ;; pmap source files will go this way,
;; most files will go this way. pmap-source-decode
;; ... but other files, including pollen, will go this way.
;; Root is treated as a function. ;; Root is treated as a function.
;; If it's not defined elsewhere, ;; If it's not defined elsewhere,
;; it just hits #%top and becomes a tagged-xexpr. ;; it just hits #%top and becomes a tagged-xexpr.

@ -0,0 +1,56 @@
#lang racket/base
(require racket/list racket/string racket/contract racket/match racket/set)
(require "tools.rkt" "world.rkt" "decode.rkt")
(module+ test (require rackunit))
(provide (all-defined-out))
;; These functions need to be separated so that they can be accessed by pollen parser (in main.rkt)
;; Other pmap functions are in pmap.rkt.
;; pmap decoder takes pmap source and returns a full pmap structure.
;; recursively processes map, converting map locations & their parents into xexprs of this shape:
;; '(location ((parent "parent")))
(define/contract (add-parents x [parent empty])
((tagged-xexpr?) (xexpr-tag?) . ->* . pmap?)
(match x
;; this pattern signifies next level in hierarchy
;; where first element is new parent, and rest are children.
[(list (? xexpr-tag? next-parent) children ...)
(let-values ([(tag attr _) (break-tagged-xexpr (add-parents next-parent parent))])
;; xexpr with tag as name, parent as attr, children as elements with tag as next parent
(make-tagged-xexpr tag attr (map (λ(c) (add-parents c tag)) children)))]
;; single map entry: convert to xexpr with parent
[else (make-tagged-xexpr (->symbol x) (make-xexpr-attr POLLEN_MAP_PARENT_KEY (->string parent)))]))
(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))
(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))
)))

@ -1,63 +1,25 @@
#lang racket/base #lang racket/base
(require xml xml/path racket/list racket/string racket/contract racket/match racket/set) (require xml xml/path racket/list racket/string racket/contract racket/match racket/set)
(require "tools.rkt" "world.rkt" "decode.rkt") (require "tools.rkt" "world.rkt" "pmap-decode.rkt")
(module+ test (require rackunit)) (module+ test (require rackunit))
(provide (all-defined-out)) (provide (all-defined-out))
;; get the values out of the file, or make them up ;; get the values out of the file, or make them up
(define pmap-file (build-path START_DIR DEFAULT_POLLEN_MAP)) (define pmap
(define pmap-main empty) (let ([pmap-source (build-path START_DIR DEFAULT_POLLEN_MAP)])
(if (file-exists? pmap-source)
;; todo next: why doesn't this line work? ;; Load it from default path.
(report (dynamic-require pmap-file 'main)) ;; dynamic require of a pmap source file gets you a full pmap.
(dynamic-require pmap-source POLLEN_ROOT)
(error 'stop) ;; ... or else synthesize it
;; get list of all files
(let* ([files (directory-list START_DIR)]
;; todo: this ain't a function ;; filter it to those with pollen extensions
(if (file-exists? pmap-file) [files (map remove-ext (filter (λ(x) (has-ext? x POLLEN_SOURCE_EXT)) files))])
; load it .... ;; make a 'pmap-root structure and convert it to a full pmap
(set! pmap-main (dynamic-require pmap-file POLLEN_ROOT)) (pmap-root->pmap (make-tagged-xexpr 'pmap-root empty (map path->string files)))))))
; ... or else 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 '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])
((tagged-xexpr?) (xexpr-tag?) . ->* . pmap?)
; disallow map-main as parent tag
; (when (equal? parent 'map-main) (set! parent empty))
(match x
;; this pattern signifies next level in hierarchy
;; where first element is new parent, and rest are children.
[(list (? xexpr-tag? next-parent) children ...)
(let-values ([(tag attr _) (break-tagged-xexpr (add-parents next-parent parent))])
;; xexpr with tag as name, parent as attr, children as elements with tag as next parent
(make-tagged-xexpr tag attr (map (λ(c) (add-parents c tag)) children)))]
;; single map entry: convert to xexpr with parent
[else (make-tagged-xexpr (->symbol x) (make-xexpr-attr POLLEN_MAP_PARENT_KEY (->string parent)))]))
(module+ test
(define test-pmap-main `(pmap-main "foo" "bar" (one (two "three"))))
(check-equal? (main->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 (main->pmap tx)
(tagged-xexpr? . -> . pmap?)
(add-parents tx))
(define pmap (main->pmap pmap-main))
;; remove parents from map (i.e., just remove attrs) ;; remove parents from map (i.e., just remove attrs)
@ -74,7 +36,7 @@
(module+ test (module+ test
(let ([sample-main `(pmap-root "foo" "bar" (one (two "three")))]) (let ([sample-main `(pmap-root "foo" "bar" (one (two "three")))])
(check-equal? (main->pmap sample-main) (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"))))))))) `(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")))))))))
@ -88,7 +50,8 @@
(module+ test (module+ test
(define test-pmap (main->pmap test-pmap-main)) (define test-pmap-main `(pmap-main "foo" "bar" (one (two "three"))))
(define test-pmap (pmap-root->pmap test-pmap-main))
(check-equal? (parent 'three test-pmap) "two") (check-equal? (parent 'three test-pmap) "two")
(check-equal? (parent "three" test-pmap) "two") (check-equal? (parent "three" test-pmap) "two")
(check-false (parent 'nonexistent-name test-pmap))) (check-false (parent 'nonexistent-name test-pmap)))
@ -246,24 +209,4 @@
(define/contract (pmap-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?)
(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)]
)))

Loading…
Cancel
Save