From 435c6e6f36fd39065ae9d8a00285fda0e4e41fa1 Mon Sep 17 00:00:00 2001 From: Joel Dueck Date: Sun, 21 Feb 2021 13:52:48 -0600 Subject: [PATCH] Improve specificity of errors in validate-txexpr (#15) --- txexpr/base.rkt | 55 +++++++++++++----------- txexpr/scribblings/txexpr.scrbl | 4 +- txexpr/test/tests.rkt | 74 ++++++++++++++++++++++++++++++++- 3 files changed, 107 insertions(+), 26 deletions(-) diff --git a/txexpr/base.rkt b/txexpr/base.rkt index dc1248f..74a91d4 100644 --- a/txexpr/base.rkt +++ b/txexpr/base.rkt @@ -85,34 +85,41 @@ (txexpr-attr? x) (txexpr-attrs? x))) -(define (validate-txexpr-attrs x #:context [txexpr-context #f]) - (match x - [(list (? txexpr-attr? x) ...) x] - [_ (raise-argument-error 'validate-txexpr-attrs - (string-append - (if txexpr-context (format "in ~v, " txexpr-context) "") - (format "list of attributes, each in the form '(symbol \"string\")")) x)])) - - -(define (validate-txexpr-element x #:context [txexpr-context #f]) - (unless (or (string? x) (symbol? x) (valid-char? x) (cdata? x) (txexpr? x)) - (raise-argument-error - 'validate-txexpr-element - (string-append - (if txexpr-context (format "in ~v, " txexpr-context) "") - "valid element (= txexpr, string, symbol, XML char, or cdata)") x)) - x) +(define (validate-txexpr-attrs tx) + (andmap + (lambda (attr) + (unless (and (list? attr) (eq? 2 (length attr))) + (txexpr-error "attribute" "is not a list of the form '(symbol \"string\")" attr tx)) + (unless (symbol? (first attr)) + (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)) + #t) + (second tx))) + +(define (validate-txexpr-elements elems tx) + (andmap + (lambda (e) + (cond + [(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 - [(cons (? txexpr-tag?) _) - (and - (validate-txexpr-attrs (get-attrs x) #:context x) - (andmap (λ (e) (validate-txexpr-element e #:context x)) (get-elements x)) x)] - [_ (raise-argument-error 'validate-txexpr "valid X-expression" x)])) + (unless (list? x) (raise-argument-error 'validate-txexpr "tagged X-expression" x)) + (unless (symbol? (car x)) (txexpr-error "tag" "must be a symbol" (car x) x)) + (match (rest x) + [(list-rest (list (? list?) attrs ...) elems) + (and (validate-txexpr-attrs x) (validate-txexpr-elements elems x) x)] + [(? list? elems) (and (validate-txexpr-elements elems x) x)])) (define (txexpr-unsafe tag attrs elements) (cons tag (match attrs diff --git a/txexpr/scribblings/txexpr.scrbl b/txexpr/scribblings/txexpr.scrbl index d276ba1..6872c98 100644 --- a/txexpr/scribblings/txexpr.scrbl +++ b/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)))) ] diff --git a/txexpr/test/tests.rkt b/txexpr/test/tests.rkt index 37128f8..a7190b1 100644 --- a/txexpr/test/tests.rkt +++ b/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: #\n in: '(root #)") + + ;; (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: #\n in: '(p #)") (check-txexprs-equal? (make-txexpr 'p) '(p)) (check-txexprs-equal? (make-txexpr 'p '((key "value"))) '(p ((key "value"))))