benign refactorings

txexpr/base.rkt

@@ -148,24 +148,27 @@
     [else (error 'validate-txexpr (format "~v: not an X-expression" x))]))
 
 
-(define+provide+safe (txexpr tag [attrs null] [elements null])
+(define (txexpr-base func-name tag attrs elements)
-  ((symbol?) (txexpr-attrs? txexpr-elements?) . ->* . txexpr?)
   (unless (txexpr-tag? tag)
-    (raise-argument-error 'txexpr "txexpr-tag?" tag))
+    (raise-argument-error func-name "txexpr-tag?" tag))
   (unless (txexpr-attrs? attrs)
-    (raise-argument-error 'txexpr "txexpr-attrs?" attrs))
+    (raise-argument-error func-name "txexpr-attrs?" attrs))
   (unless (txexpr-elements? elements)
-    (raise-argument-error 'txexpr "txexpr-elements?" elements))
+    (raise-argument-error func-name "txexpr-elements?" elements))
+  
+  (cons tag (append (if (empty? attrs)
+                        empty
+                        (list attrs)) elements)))
+
 
-  (define result (cons tag (append (if (empty? attrs) empty (list attrs)) elements)))
+(define+provide+safe (txexpr tag [attrs null] [elements null])
-  (unless (txexpr? result)
+  ((txexpr-tag?) (txexpr-attrs? txexpr-elements?) . ->* . txexpr?)
-    (error 'txexpr "not a txexpr"))
+  (txexpr-base 'txexpr tag attrs elements))
-  result)
 
 
 (define+provide+safe (txexpr* tag [attrs null] . elements)
-  ((symbol?) (txexpr-attrs?) #:rest txexpr-elements? . ->* . txexpr?)
+  ((txexpr-tag?) (txexpr-attrs?) #:rest txexpr-elements? . ->* . txexpr?)
-  (txexpr tag attrs elements))
+  (txexpr-base 'txexpr* tag attrs elements))
 
 
 (define make-txexpr txexpr) ; for backward compatability
@@ -173,7 +176,7 @@
 
 
 (define+provide+safe (txexpr->values x)
-  (txexpr? . -> . (values symbol? txexpr-attrs? txexpr-elements?))
+  (txexpr? . -> . (values txexpr-tag? txexpr-attrs? txexpr-elements?))
   (if (txexpr-short? x)
       (values (car x) '() (cdr x))
       (values (car x) (cadr x) (cddr x))))
@@ -181,8 +184,8 @@
 
 (define+provide+safe (txexpr->list x)
   (txexpr? . -> . list?)
-  (define-values (tag attrs content) (txexpr->values x))
+  (define-values (tag attrs elements) (txexpr->values x))
-  (list tag attrs content))
+  (list tag attrs elements))
 
 
 ;; convenience functions to retrieve only one part of txexpr
@@ -193,7 +196,7 @@
 
 (define+provide+safe (get-attrs x)
   (txexpr? . -> . txexpr-attrs?)
-  (define-values (tag attrs content) (txexpr->values x))
+  (define-values (tag attrs elements) (txexpr->values x))
   attrs)
 
 
@@ -249,6 +252,7 @@
   (txexpr? can-be-txexpr-attr-key? can-be-txexpr-attr-value? . -> . txexpr?)
   (attr-set* tx key value))
 
+
 (define+provide+safe (attr-set* tx . kvs)
   ((txexpr?) #:rest (listof (or/c can-be-txexpr-attr-key? can-be-txexpr-attr-value?)) . ->* . txexpr?)
   ;; unlike others, this uses hash operations to guarantee that your attr-set
@@ -261,8 +265,7 @@
             (append-map (λ(sublist)
                           (list (->txexpr-attr-key (first sublist))
                                 (->txexpr-attr-value (second sublist)))) (slice-at kvs 2)))))
-  (txexpr (get-tag tx) new-attrs (get-elements tx)))
+  (txexpr-base 'attr-set* (get-tag tx) new-attrs (get-elements tx)))
-
 
 
 (define+provide+safe (attr-join tx key value)
@@ -273,7 +276,6 @@
   (attr-set tx key (string-join `(,@starting-values ,value) " ")))      
 
 
-
 (define+provide+safe (attr-ref tx key [failure-result (λ _ (raise (make-exn:fail:contract (format "attr-ref: no value found for key ~v" key) (current-continuation-marks))))])
   ((txexpr? can-be-txexpr-attr-key?) (any/c) . ->* . any)
   (define result (assq (->txexpr-attr-key key) (get-attrs tx)))
@@ -284,22 +286,20 @@
           failure-result)))
 
 
-
 (define+provide+safe (remove-attrs x)
   (txexpr? . -> . txexpr?)
   (let loop ([x x])
     (if (txexpr? x)
-        (let-values ([(tag attr elements) (txexpr->values x)])
+        (let-values ([(tag attrs elements) (txexpr->values x)])
-          (txexpr tag null (map loop elements)))
+          (cons tag (map loop elements)))
         x)))
 
 
-
 (define+provide+safe (map-elements proc x)
   (procedure? txexpr? . -> . txexpr?)
   (proc (if (txexpr? x) 
-            (let-values ([(tag attr elements) (txexpr->values x)])
+            (let-values ([(tag attrs elements) (txexpr->values x)])
-              (txexpr tag attr (map (λ(e)(map-elements proc e)) elements)))
+              (txexpr tag attrs (map (λ(e)(map-elements proc e)) elements)))
             x)))
 
 
@@ -307,19 +307,19 @@
 (define deleted-signal (gensym))
 (define+provide+safe (splitf-txexpr tx pred [proc (λ(x) deleted-signal)])
   ((txexpr? procedure?) (procedure?) . ->* . (values txexpr? txexpr-elements?))
+  (unless (txexpr? tx)
+    (raise-argument-error 'splitf-txexpr "txexpr?" tx))
   (define matches null)
   (define (do-extraction x)
     (cond
-      [(pred x) (begin  ; store matched item and return processed value
+      [(pred x) ;; store matched item and return processed value
        (set! matches (cons x matches))
-                  (proc x))]
+       (proc x)]
-      [(txexpr? x) (let-values([(tag attr elements) (txexpr->values x)]) 
+      [(txexpr? x) (let-values([(tag attrs elements) (txexpr->values x)]) 
-                     (txexpr tag attr (filter (λ(e) (not (equal? e deleted-signal)))
+                     (txexpr tag attrs (filter (λ(e) (not (eq? e deleted-signal)))
                                                (map do-extraction elements))))]
       [else x]))
   (define tx-extracted (do-extraction tx)) ;; do this first to fill matches
-  (unless (txexpr? tx-extracted)
-    (error 'splitf-txexpr "Bad input"))
   (values tx-extracted (reverse matches)))
 
 
@@ -335,20 +335,22 @@
   (and matches (car matches)))
 
 
-(define+provide+safe (xexpr->html x)
+;; don't use "![CDATA[...]]" wrapper in HTML, it's not consistent with the spec
-  (xexpr? . -> . string?)
 (define (->cdata x)
-    (cond
+  (if (string? x)
-      [(cdata? x) x]
+      (cdata #f #f x)
-      ; don't use "![CDATA[...]]" wrapper in HTML, it's not consistent with the spec
+      x))
-      [(string? x) (cdata #f #f x)] 
-      [else x]))
-  (xexpr->string (let loop ([x x])
-                   (cond
-                     [(txexpr? x) (if (member (get-tag x) '(script style))
-                                      (txexpr (get-tag x) (get-attrs x)
-                                              (map ->cdata (get-elements x)))
-                                      (txexpr (get-tag x) (get-attrs x)
-                                              (map loop (get-elements x))))]
-                     [else x]))))
 
+
+(define+provide+safe (xexpr->html x)
+  (xexpr? . -> . string?)
+  (xexpr->string
+   (let loop ([x x])
+     (if (txexpr? x)
+         (let*-values ([(tag attrs elements) (txexpr->values x)]
+                       [(proc) (if (memq tag '(script style))
+                                   ->cdata
+                                   loop)])
+           ;; a little faster than `txexpr` since we know the pieces are valid
+           (cons tag (append attrs (map proc elements))))
+         x))))

txexpr/tests.rkt

@@ -4,23 +4,22 @@
 ;; use a separate test file to avoid cycle in loading
 (define-syntax (test-safe-and-unsafe stx)
   (syntax-case stx ()
-    [(_ exprs ...)
+    [(_ . exprs)
      (with-syntax ([module-without-contracts (generate-temporary)]
                    [module-with-contracts (generate-temporary)]) 
-       (replace-context stx #'(begin
+       (replace-context stx
+                        #'(begin
                             (module module-without-contracts racket
                               (require rackunit "main.rkt")
-                                  (define-syntax (values->list stx)
+                              (define-syntax-rule (values->list values-expr)
-                                    (syntax-case stx ()
+                                (call-with-values (λ () values-expr) list))
-                                      [(_ values-expr) #'(call-with-values (λ () values-expr) list)]))
+                              . exprs)
-                                  exprs ...)
                             (require 'module-without-contracts)
                             (module module-with-contracts racket
                               (require rackunit (submod "main.rkt" safe))
-                                  (define-syntax (values->list stx)
+                              (define-syntax-rule (values->list values-expr)
-                                    (syntax-case stx ()
+                                (call-with-values (λ () values-expr) list))
-                                      [(_ values-expr) #'(call-with-values (λ () values-expr) list)]))
+                              . exprs)
-                                  exprs ...)
                             (require 'module-with-contracts))))]))
 
 (test-safe-and-unsafe