diff --git a/main.rkt b/main.rkt index a19b140..a49ec7c 100644 --- a/main.rkt +++ b/main.rkt @@ -1,6 +1,6 @@ #lang racket/base (require (for-syntax racket/base)) -(require racket/contract racket/match xml racket/list) +(require racket/contract racket/match xml racket/list sugar/debug) (define-syntax (define+provide/contract stx) (syntax-case stx () @@ -137,14 +137,17 @@ [else x])) -(define+provide/contract (map-elements proc x) - (procedure? tagged-xexpr? . -> . tagged-xexpr?) - (define-values (tag attr elements) (tagged-xexpr->values x)) - (define recursive-proc - (λ(x) - (cond - [(tagged-xexpr? x) (map-elements proc x)] - [else (proc x)]))) - (make-tagged-xexpr tag attr (map recursive-proc elements))) +(define+provide/contract (map-elements proc x [filter-proc (λ(x) #t)]) + ((procedure? tagged-xexpr?) (procedure?) . ->* . tagged-xexpr?) + (cond + [(tagged-xexpr? x) + (if (filter-proc x) + (let-values ([(tag attr elements) (tagged-xexpr->values x)]) + (make-tagged-xexpr tag attr + (map (λ(x)(map-elements proc x filter-proc)) elements))) + x)] + ;; externally the function only accepts tagged-xexpr, + ;; but internally we don't care + [else (proc x)])) diff --git a/tests.rkt b/tests.rkt index 600b086..33be275 100644 --- a/tests.rkt +++ b/tests.rkt @@ -77,3 +77,8 @@ '(p "foo" "bar" (em "square"))) '(p "boing" "boing" (em "boing"))) +(require hyphenate sugar/debug) +(check-equal? (map-elements hyphenate '(p "foobar" (em "snowman")) (λ(tx) (not (equal? (car tx) 'em)))) '(p "foo\u00ADbar" (em "snowman"))) + + +