Improve specificity of errors in validate-txexpr #15

Merged
otherjoel merged 2 commits from recursive-validate into master 4 years ago

@ -85,34 +85,41 @@
(txexpr-attr? x) (txexpr-attr? x)
(txexpr-attrs? 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? ;; 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) (define+provide+safe (validate-txexpr x)
(any/c . -> . txexpr?) (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) (define (txexpr-unsafe tag attrs elements)
(cons tag (match attrs (cons tag (match attrs

@ -195,7 +195,7 @@ Predicate for functions that handle @racket[_txexpr-attrs]. Covers values that a
(validate-txexpr (validate-txexpr
[possible-txexpr any/c]) [possible-txexpr any/c])
txexpr?] 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 @examples[#:eval my-eval
(validate-txexpr 'root) (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"))))
(validate-txexpr '(root ((id "top")(class "42")) ("hi"))) (validate-txexpr '(root ((id "top")(class "42")) ("hi")))
(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))))
] ]

@ -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" ((key "value")))))) ; malformed
(check-exn exn:fail? (λ _ (validate-txexpr '("p" "foo" "bar")))) ; no name (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 ((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) '(p))
(check-txexprs-equal? (make-txexpr 'p '((key "value"))) '(p ((key "value")))) (check-txexprs-equal? (make-txexpr 'p '((key "value"))) '(p ((key "value"))))

Loading…
Cancel
Save