From 73c8d8db8b139237347b10bd9948a9cac6e58ee9 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Wed, 19 Feb 2014 19:21:30 -0800
Subject: [PATCH] add splitf-txexpr

---
 main.rkt                 | 15 +++++++++++++++
 scribblings/txexpr.scrbl | 14 ++++++++++++++
 tests.rkt                |  7 ++++++-
 3 files changed, 35 insertions(+), 1 deletion(-)

diff --git a/main.rkt b/main.rkt
index 2015ef4..c3450e0 100644
--- a/main.rkt
+++ b/main.rkt
@@ -192,4 +192,19 @@
   (procedure? txexpr? . -> . txexpr?)
   (map-elements/exclude proc x (λ(x) #f)))
 
+;; function to split tag out of txexpr
+(define+provide/contract (splitf-txexpr tx proc)
+  (txexpr? procedure? . -> . (values (listof txexpr-element?) txexpr?))
+  (define matches empty)
+  (define (do-extraction x)
+    (cond
+      [(proc x) (begin  ; store matched item but return empty value
+                  (set! matches (cons x matches))
+                  empty)]
+      [(txexpr? x) (let-values([(tag attr body) (txexpr->values x)]) 
+                     (make-txexpr tag attr (do-extraction body)))]
+      [(txexpr-elements? x) (filter-not empty? (map do-extraction x))]
+      [else x]))
+  (define tx-extracted (do-extraction tx)) ;; do this first to fill matches
+  (values (reverse matches) tx-extracted)) 
 
diff --git a/scribblings/txexpr.scrbl b/scribblings/txexpr.scrbl
index 190e116..ba18caa 100644
--- a/scribblings/txexpr.scrbl
+++ b/scribblings/txexpr.scrbl
@@ -376,6 +376,20 @@ Be careful with the wider consequences of exclusion tests. When @racket[_exclude
 (map-elements/exclude upcaser tx (λ(x) (equal? (get-tag x) 'div)))
 ]
 
+@defproc[
+(splitf-txexpr
+[tx txexpr?]
+[pred procedure?])
+(values (listof txexpr-element?) txexpr?)]
+Recursively descend through @racket[_txexpr] and extract all elements that match @racket[_pred]. Returns two values: a list of matching elements, and the @racket[_txexpr] with the elements removed. Sort of esoteric, but I've needed it more than once, so here it is.
+
+@examples[#:eval my-eval
+(define tx '(div "Wonderful day" (meta "weather" "good") "for a walk"))
+(define remove? (λ(x) (and (txexpr? x) (equal? 'meta (get-tag x)))))
+(splitf-txexpr tx remove?)
+]
+
+
 @section{License & source code}
 
 This module is licensed under the LGPL.
diff --git a/tests.rkt b/tests.rkt
index 94e2207..3caed00 100644
--- a/tests.rkt
+++ b/tests.rkt
@@ -105,9 +105,14 @@
 
 
 (check-equal? (map-elements (λ(x) (if (string? x) "boing" x))  
-                                  '(p "foo" "bar" (em "square"))) 
+                            '(p "foo" "bar" (em "square"))) 
               '(p "boing" "boing" (em "boing")))
 
 
 
+(define split-this-tx '(root (meta "foo" "bar") "hello" "world" (meta "foo2" "bar2") 
+                  (em "goodnight" "moon" (meta "foo3" "bar3"))))
+(check-equal? (call-with-values (λ() (splitf-txexpr split-this-tx (λ(x) (and (txexpr? x) (equal? 'meta (car x)))))) list) 
+              (list '((meta "foo" "bar") (meta "foo2" "bar2") (meta "foo3" "bar3")) 
+                    '(root "hello" "world" (em "goodnight" "moon"))))