Improve specificity of errors in validate-txexpr (#15)

txexpr/base.rkt

@@ -85,34 +85,41 @@
       (txexpr-attr? x)
       (txexpr-attrs? x)))
 
-(define (validate-txexpr-attrs x #:context [txexpr-context #f])
+(define (validate-txexpr-attrs tx)
-  (match x
+  (andmap
-    [(list (? txexpr-attr? x) ...) x]
+   (lambda (attr)
-    [_ (raise-argument-error 'validate-txexpr-attrs
+     (unless (and (list? attr) (eq? 2 (length attr)))
-                             (string-append 
+       (txexpr-error "attribute" "is not a list of the form '(symbol \"string\")" attr tx))
-                              (if txexpr-context (format "in ~v, " txexpr-context) "")
+     (unless (symbol? (first attr))
-                              (format "list of attributes, each in the form '(symbol \"string\")")) x)]))
+       (txexpr-error "attribute key" "is not a symbol" (first attr) tx))
-
+     (unless (string? (second attr))
-
+       (txexpr-error "attribute value" "is not a string" (second attr) tx))
-(define (validate-txexpr-element x #:context [txexpr-context #f])
+     #t)
-  (unless (or (string? x) (symbol? x) (valid-char? x) (cdata? x) (txexpr? x))
+   (second tx)))
-    (raise-argument-error
+
-     'validate-txexpr-element
+(define (validate-txexpr-elements elems tx)
-     (string-append
+  (andmap
-      (if txexpr-context (format "in ~v, " txexpr-context) "")
+   (lambda (e)
-      "valid element (= txexpr, string, symbol, XML char, or cdata)") x))
+     (cond
-  x)
+       [(or (string? e) (symbol? e) (my-valid-char? e) (cdata? e)) #t]
+       [(and (list? e) (symbol? (first e)))
+        (validate-txexpr e)]
+       [else (txexpr-error "element" "not a valid element (= txexpr, string, symbol, XML char, or cdata)" e tx)]))
+   elems))
+  
+(define (txexpr-error noun has-problem bad tx)
+  (raise-arguments-error 'validate-txexpr (format "~a ~a" noun has-problem) noun bad "in" tx))
 
 ;; is it a named x-expression?
-;; todo: rewrite this recursively so errors can be pinpointed (for debugging)
+;; Restricting to primitive predicates allows for more specific (helpful) errors
 (define+provide+safe (validate-txexpr x)
   (any/c . -> . txexpr?)
-  (match x
+  (unless (list? x) (raise-argument-error 'validate-txexpr "tagged X-expression" x))
-    [(cons (? txexpr-tag?) _)
+  (unless (symbol? (car x)) (txexpr-error "tag" "must be a symbol" (car x) x))
-     (and
+  (match (rest x)
-      (validate-txexpr-attrs (get-attrs x) #:context x)
+    [(list-rest (list (? list?) attrs ...) elems)
-      (andmap (λ (e) (validate-txexpr-element e #:context x)) (get-elements x)) x)]
+     (and (validate-txexpr-attrs x) (validate-txexpr-elements elems x) x)]
-    [_ (raise-argument-error 'validate-txexpr "valid X-expression" x)]))
+    [(? list? elems) (and (validate-txexpr-elements elems x) x)]))
 
 (define (txexpr-unsafe tag attrs elements)
   (cons tag (match attrs

txexpr/scribblings/txexpr.scrbl

@@ -195,7 +195,7 @@ Predicate for functions that handle @racket[_txexpr-attrs]. Covers values that a
 (validate-txexpr
 [possible-txexpr any/c])
 txexpr?]
-Like @racket[txexpr?], but raise a descriptive error if @racket[_possible-txexpr] is invalid, and otherwise return @racket[_possible-txexpr] itself.
+Like @racket[txexpr?], but raise a descriptive error pinpointing the first problem encountered if @racket[_possible-txexpr] is invalid, and otherwise return @racket[_possible-txexpr] itself.
 
 @examples[#:eval my-eval
 (validate-txexpr 'root)
@@ -204,6 +204,8 @@ Like @racket[txexpr?], but raise a descriptive error if @racket[_possible-txexpr
 (validate-txexpr '(root ((id "top")(class "42"))))
 (validate-txexpr '(root ((id "top")(class "42")) ("hi")))
 (validate-txexpr '(root ((id "top")(class "42")) "hi"))
+(validate-txexpr '(root (p "Hello " (span [[class "inner"]] (1 2 3)))))
+(validate-txexpr `(root (p "Look out" (span ,(void)) (1 2 3))))
 ]
 
 

txexpr/test/tests.rkt

@@ -71,7 +71,79 @@
  (check-exn exn:fail? (λ _ (validate-txexpr '(p "foo" "bar" ((key "value")))))) ; malformed
  (check-exn exn:fail? (λ _ (validate-txexpr '("p" "foo" "bar")))) ; no name
  (check-exn exn:fail? (λ _ (validate-txexpr '(root ((id "top")(class 42)))))) ; malformed attrs
+ (check-exn exn:fail? (λ _ (validate-txexpr `(root  ,(void))))) ; invalid element type
 
+ (define-syntax (check-validate-exn-msg stx)
+   (syntax-case stx ()
+     [(_ tx) (syntax/loc stx (check-validate-exn-msg tx ""))]
+     [(_ tx msg) 
+      (syntax/loc stx
+        (check-equal? (with-handlers ([exn:fail:contract? (λ (e) (exn-message e))])
+                                      (validate-txexpr tx)) msg))]))
+ ;; Root element not a list
+ (check-validate-exn-msg
+  "foo"
+  "validate-txexpr: contract violation\n  expected: tagged X-expression\n  given: \"foo\"")
+
+ ;; No name
+ (check-validate-exn-msg
+  '("p" "foo" "bar")
+  "validate-txexpr: tag must be a symbol\n  tag: \"p\"\n  in: '(\"p\" \"foo\" \"bar\")")
+
+ ;; Invalid element
+ (check-validate-exn-msg
+  '(p "foo" "bar" ((key "value")))
+  "validate-txexpr: element not a valid element (= txexpr, string, symbol, XML char, or cdata)\n  element: '((key \"value\"))\n  in: '(p \"foo\" \"bar\" ((key \"value\")))")
+
+ ;; Malformed attribute list
+ (check-validate-exn-msg
+  '(p ((key "val") "foo" "bar") "hi")
+  "validate-txexpr: attribute is not a list of the form '(symbol \"string\")\n  attribute: \"foo\"\n  in: '(p ((key \"val\") \"foo\" \"bar\") \"hi\")")
+ 
+ ;; Invalid attribute key
+ (check-validate-exn-msg
+  '(root ((id "top") (class 42)))
+  "validate-txexpr: attribute value is not a string\n  attribute value: 42\n  in: '(root ((id \"top\") (class 42)))")
+
+ ;; Invalid attribute value
+ (check-validate-exn-msg
+  '(root ((id "top") ("class" 42)))
+  "validate-txexpr: attribute key is not a symbol\n  attribute key: \"class\"\n  in: '(root ((id \"top\") (\"class\" 42)))")
+
+ ;; Invalid element type
+ (check-validate-exn-msg
+  `(root ,(void))
+  "validate-txexpr: element not a valid element (= txexpr, string, symbol, XML char, or cdata)\n  element: #<void>\n  in: '(root #<void>)")
+
+ ;; (Deeply nested) No name: error should pinpoint element in 'div txexpr 
+ (check-validate-exn-msg
+  '(fine-outer [[type "valid"]] (div (br) ("p" "foo" "bar")))
+  "validate-txexpr: element not a valid element (= txexpr, string, symbol, XML char, or cdata)\n  element: '(\"p\" \"foo\" \"bar\")\n  in: '(div (br) (\"p\" \"foo\" \"bar\"))")
+
+ ;; (Deeply nested) Invalid element: error should pinpoint element in 'p txexpr
+ (check-validate-exn-msg
+  '(fine-outer [[type "valid"]] (div (br) (p "foo" "bar" ((key "value")))))
+  "validate-txexpr: element not a valid element (= txexpr, string, symbol, XML char, or cdata)\n  element: '((key \"value\"))\n  in: '(p \"foo\" \"bar\" ((key \"value\")))")
+
+ ;; (Deeply nested) Malformed attribute list: error should pinpoint attr in 'p txexpr
+ (check-validate-exn-msg
+  '(fine-outer [[type "valid"]] (div (br) (p ((key "val") "foo" "bar") "hi")))
+  "validate-txexpr: attribute is not a list of the form '(symbol \"string\")\n  attribute: \"foo\"\n  in: '(p ((key \"val\") \"foo\" \"bar\") \"hi\")")
+ 
+ ;; (Deeply nested) Invalid attribute key: error should pinpoint attr key in 'p txexpr
+ (check-validate-exn-msg
+  '(fine-outer [[type "valid"]] (div (br) (p ((id "top") (class 42)))))
+  "validate-txexpr: attribute value is not a string\n  attribute value: 42\n  in: '(p ((id \"top\") (class 42)))")
+
+ ;; (Deeply nested) Invalid attribute value: error should pinpoint attr val in 'p txexpr
+ (check-validate-exn-msg
+  '(fine-outer [[type "valid"]] (div (br) (p ((id "top") ("class" 42)))))
+  "validate-txexpr: attribute key is not a symbol\n  attribute key: \"class\"\n  in: '(p ((id \"top\") (\"class\" 42)))")
+
+ ;; (Deeply nested) Invalid element type: error should pinpoint element in 'p txexpr
+ (check-validate-exn-msg
+  `(fine-outer [[type "valid"]] (div (br) (p ,(void))))
+  "validate-txexpr: element not a valid element (= txexpr, string, symbol, XML char, or cdata)\n  element: #<void>\n  in: '(p #<void>)")
  
  (check-txexprs-equal? (make-txexpr 'p) '(p))
  (check-txexprs-equal? (make-txexpr 'p '((key "value"))) '(p ((key "value"))))