Add xexpr->text procedure.

1 files changed, 50 insertions, 0 deletions

diff --git a/presenters/xexpr-to-text.rkt b/presenters/xexpr-to-text.rkt
new file mode 100644
index 0000000..28fa4bf
--- /dev/null
+++ b/presenters/xexpr-to-text.rkt
@@ -0,0 +1,50 @@
+#lang typed/racket
+
+(provide xexpr->text)
+
+(require typed/xml)
+
+(: xexpr->text (-> XExpr String))
+(define (xexpr->text xexpr)
+  (cond
+    [(string? xexpr) xexpr]
+    [(number? xexpr) (number->string xexpr)]
+    [(symbol? xexpr) (symbol->string xexpr)]
+    [(pair? xexpr)
+     (let* ([fst (car xexpr)]
+            [text (get-text xexpr->text xexpr)]
+            [_attrs (get-attrs xexpr)])
+       (case fst
+         [(br) "\n"]
+         [else text]))]
+    [(cdata? xexpr) (cdata-string xexpr)]
+    [(or (comment? xexpr) (p-i? xexpr)) ""]))
+
+(define-predicate xexpr-attribute? XExpr-Attribute)
+
+(: get-text (-> (-> XExpr String)
+                (U (Pair Symbol (Pair (Listof XExpr-Attribute) (Listof XExpr)))
+                   (Pair Symbol (Listof XExpr)))
+                String))
+(define (get-text f xexpr)
+  (let ([rst (cdr xexpr)])
+    (if (null? rst)
+        (string-append* (map f rst))
+        (let ([attrs (car rst)])
+          (if (and (or (null? attrs) (pair? attrs))
+                   (andmap xexpr-attribute? attrs))
+              (string-append* (map f (cdr rst)))
+              (string-append* (map f rst)))))))
+
+(: get-attrs (-> (U (Pair Symbol (Pair (Listof XExpr-Attribute) (Listof XExpr)))
+                    (Pair Symbol (Listof XExpr)))
+                 (Listof XExpr-Attribute)))
+(define (get-attrs xexpr)
+  (let ([rst (cdr xexpr)])
+    (if (null? rst)
+        '()
+        (let ([attrs (car rst)])
+          (if (and (or (null? attrs) (pair? attrs))
+                   (andmap xexpr-attribute? attrs))
+              attrs
+              '())))))