extract-meta refinements

pull/9/head
Matthew Butterick 11 years ago
parent 49611c8053
commit 5d50ff4dc9

@ -94,20 +94,33 @@
(check-true (whitespace? (list "\n" " " "\n" (list "\n" "\n"))))) (check-true (whitespace? (list "\n" " " "\n" (list "\n" "\n")))))
#|
(define (make-meta-hash x)
(define keys (se-path*/list '(meta #:name) x))
(define values (se-path*/list '(meta #:content) x))
(define meta-hash (make-hash))
;todo: convert this to for/list because map does not guarantee ordering
; probably want to keep it in sequence
(map (ƒ(key value) (change meta-hash (as-symbol key) (as-string value))) keys values)
meta-hash)
|# ;; function to strip metas
;; todo: make this more recursive?
(define/contract (extract-tag-from-xexpr tag nx)
(xexpr-name? named-xexpr? . -> . (values named-xexpr? xexpr-content?))
(define matches '())
(define (extract-tag x)
(cond
[(and (named-xexpr? x) (equal? tag (car x)))
; stash matched tag but return empty value
(begin
(set! matches (cons x matches))
empty)]
[(named-xexpr? x) (let-values([(name attr body) (break-named-xexpr x)])
(make-named-xexpr name attr (extract-tag body)))]
[(xexpr-content? x) (filter-not empty? (map extract-tag x))]
[else x]))
(values (extract-tag nx) (reverse matches)))
(module+ test
(define x '(root (meta "foo" "bar") "hello" "world" (meta "foo2" "bar2")
(em "goodnight" "moon" (meta "foo3" "bar3"))))
(check-equal? (values->list (extract-tag-from-xexpr 'meta x))
(list '(root "hello" "world" (em "goodnight" "moon"))
'((meta "foo" "bar") (meta "foo2" "bar2") (meta "foo3" "bar3")))))
;; decoder wireframe ;; decoder wireframe
(define/contract (decode nx (define/contract (decode nx
#:exclude-xexpr-names [excluded-xexpr-names '()] #:exclude-xexpr-names [excluded-xexpr-names '()]
@ -155,30 +168,9 @@
[(string? x) (string-proc x)] [(string? x) (string-proc x)]
[else x])) [else x]))
;; function to strip metas
;; todo: would this be simpler using se-path*/list?
(define (split-metas nx)
(define meta-list '())
(define (&split-metas x)
(cond
[(and (named-xexpr? x) (equal? 'meta (car x)))
(begin
(set! meta-list (cons x meta-list))
empty)]
[(named-xexpr? x) ; handle named-xexpr
(let-values([(name attr body) (break-named-xexpr x)])
(make-named-xexpr name attr (&split-metas body)))]
[(list? x) (filter-not empty? (map &split-metas x))]
[else x]))
(values (&split-metas nx) (reverse meta-list)))
;; put metas back on the end
(define (append-metas nx metas)
(named-xexpr? . -> . named-xexpr?)
(append nx (map meta-proc metas)))
(let-values ([(nx metas) (split-metas nx)]) (let-values ([(nx metas) (extract-tag-from-xexpr 'meta nx)])
(append-metas (&decode nx) metas))) (append (&decode nx) (map meta-proc metas))))
#| #|
;; default content decoder for pollen ;; default content decoder for pollen

@ -191,13 +191,14 @@
[(list? x) (filter-not empty? (map remove-empty x))] [(list? x) (filter-not empty? (map remove-empty x))]
[else x])) [else x]))
(define (filter-tree-inner proc tree) (define (filter-tree-inner proc x)
(cond (cond
[(list? tree) (map (λ(i) (filter-tree-inner proc i)) tree)] [(list? x) (map (λ(i) (filter-tree-inner proc i)) x)]
[else (if (proc tree) tree empty)])) [else (if (proc x) x empty)]))
(remove-empty (filter-tree-inner proc tree))) (remove-empty (filter-tree-inner proc tree)))
(module+ test (module+ test
(check-equal? (filter-tree string? '(p)) empty) (check-equal? (filter-tree string? '(p)) empty)
(check-equal? (filter-tree string? '(p "foo" "bar")) '("foo" "bar")) (check-equal? (filter-tree string? '(p "foo" "bar")) '("foo" "bar"))
@ -212,7 +213,9 @@
(module+ test (module+ test
(check-equal? (filter-not-tree string? '(p)) '(p)) (check-equal? (filter-not-tree string? '(p)) '(p))
(check-equal? (filter-not-tree string? '(p "foo" "bar")) '(p)) (check-equal? (filter-not-tree string? '(p "foo" "bar")) '(p))
(check-equal? (filter-not-tree string? '(p "foo" (p "bar"))) '(p (p)))) (check-equal? (filter-not-tree string? '(p "foo" (p "bar"))) '(p (p)))
;(check-equal? (filter-tree (λ(i) (and (named-xexpr? i) (equal? 'em (car i)))) '(p "foo" (em "bar"))) '(p "foo"))
)
(define/contract (map-tree proc tree) (define/contract (map-tree proc tree)

Loading…
Cancel
Save