Error messages

svn: r13321

collects/tests/web-server/private/util-test.ss

@@ -19,19 +19,6 @@
     (test-exn "0" exn:fail:contract? (lambda () (contract port-number? 0 'pos 'neg)))
     (test-exn "10000000" exn:fail:contract? (lambda () (contract port-number? 10000000 'pos 'neg))))
    
-   (test-equal? "pretty-print-invalid-xexpr"
-                (let ([os (open-output-string)]
-                      [txe `(html (head (title "Foo"))
-                                  (body (a ([href url]) "Text")))])
-                  (parameterize ([current-output-port os])
-                    (with-handlers ([exn:invalid-xexpr? 
-                                     (lambda (exn)
-                                       (pretty-print-invalid-xexpr exn txe))])
-                      (validate-xexpr txe)
-                      #f))
-                  (get-output-string os))
-                "(html (head (title \"Foo\")) (body (a ((href <font color=\"red\">url</font>)) \"Text\")))\n")
-   
    (test-suite
     "url-replace-path"
     (test-case

collects/web-server/configuration/responders.ss

@@ -3,6 +3,7 @@
          mzlib/list
          net/url)
 (require web-server/http/response-structs
+         web-server/private/xexpr
          web-server/http/request-structs)
 
 (define (format-stack-trace trace)
@@ -29,7 +30,7 @@
           (div ([class "title"]) "Exception")
           (p
            "The application raised an exception with the message:"
-           (pre ,(exn-message exn)))
+           (pre ,(reformat-xexpr-exn (exn-message exn))))
           (p
            "Stack trace:"
            ,(format-stack-trace

collects/web-server/default-web-root/htdocs/error.css

@@ -23,3 +23,8 @@
   padding: 5px;
   border: 1px solid #ff99ff;
 }
+
+.error {
+ color: red;
+ font-size: large;
+}

collects/web-server/private/util.ss

@@ -3,8 +3,6 @@
          mzlib/plt-match
          mzlib/contract
          mzlib/serialize
-         mzlib/pretty
-         xml/xml
          net/url)
 (define path-element?
   (or/c path-string? (symbols 'up 'same)))
@@ -14,7 +12,6 @@
 (provide/contract
  [path-element? contract?]
  [port-number? contract?]
- [pretty-print-invalid-xexpr (exn:invalid-xexpr? any/c . -> . void)]
  [url-replace-path (((listof path/param?) . -> . (listof path/param?)) url? . -> . url?)]
  [explode-path* (path-string? . -> . (listof path-element?))]
  [path-without-base (path-string? path-string? . -> . (listof path-element?))]
@@ -31,20 +28,6 @@
  [read/bytes (bytes? . -> . serializable?)]
  [write/bytes (serializable? . -> . bytes?)])
 
-(define (pretty-print-invalid-xexpr exn xexpr)
-  (define code (exn:invalid-xexpr-code exn))
-  (parameterize ([pretty-print-size-hook (lambda (v display? out)
-                                           (and (equal? v code)
-                                                (string-length (format (if display? "~a" "~v") v))))]
-                 [pretty-print-print-hook (lambda (v display? out)
-                                            (fprintf out
-                                                     (string-append
-                                                      "<font color=\"red\">"
-                                                      (if display? "~a" "~v")
-                                                      "</font>")
-                                                     v))])
-    (pretty-print xexpr)))
-
 (define (read/string str)
   (read (open-input-string str)))
 (define (write/string v)

collects/web-server/private/xexpr.ss

@@ -0,0 +1,117 @@
+#lang scheme
+(require scheme/pretty
+         xml/xml)
+
+(provide/contract
+ [format-xexpr/errors (any/c . -> . string?)]
+ [reformat-xexpr-exn (string? . -> . xexpr/c)])
+
+; Formating Xexprs
+(define (format-xexpr/errors v)
+  (pretty-format (format-xexpr v)))
+
+(define-struct xexpr-error (message content)
+  #:property prop:custom-write
+  (lambda (v port write?)
+    (display "<a title=\"" port)
+    (display (xexpr-error-message v) port)
+    (display "\" class=\"error\">" port)
+    ; XXX Can this be XML escaped?
+    (print (xexpr-error-content v) port)
+    (display "</a>" port)))
+(define mark-error make-xexpr-error)
+
+(define (xexpr-datum? v)
+  (or (string? v)
+      (symbol? v)
+      (exact-nonnegative-integer? v)
+      (comment? v)
+      (pi? v)
+      (cdata? v)))
+
+(define (format-xexpr v)
+  (cond
+    [(pair? v)
+     (cond
+       [(empty? v)
+        (mark-error "Not a valid Xexpr element (No tag; Tag must be a symbol.)" v)]
+       [(symbol? (car v))
+        (list* (car v)
+               (format-elements+attributes (cdr v)))]
+       [else
+        (list* (mark-error "Not a valid Xexpr element tag (Must be a symbol.)" (car v))
+               (format-elements+attributes (cdr v)))])]
+    [(xexpr-datum? v) v]
+    [else
+     (mark-error "Not a valid Xexpr datum (Must be a string, symbol, exact nonnegative integer, comment, PI, or cdata.)" v)]))
+
+(define (format-elements+attributes l)
+  (match l
+    ; ()
+    [(list) empty]
+    ; (datum ...)
+    [(list-rest (? xexpr-datum?) other-elems)
+     (format-elements l)]
+    ; ((p ...) ...)
+    [(list-rest (list-rest (? symbol?) inner-elems) other-elems)
+     (format-elements l)]
+    ; (attrs ...)
+    [(list-rest attrs elems)
+     (list* (format-attributes attrs)
+            (format-elements elems))]
+    [else
+     (mark-error 
+      "Not a valid Xexpr tag content list. (Must be either (1) a list of Xexprs or (2) An attribute list followed by a list of Xexprs.)"
+      l)]))
+
+(define (format-elements l)
+  (map format-xexpr l))
+
+(define (format-attributes l)
+  (match l
+    [(list) empty]
+    [(list-rest attr attrs)
+     (list* (format-attribute attr)
+            (format-attributes attrs))]
+    [else
+     (mark-error 
+      "Not a valid attribute list (Must be list of attributes. An attribute is a list containing a symbol and a string.)"
+      l)]))
+
+(define (format-attribute l)
+  (match l
+    [(list (? symbol? attr) (? string? val))
+     l]
+    [(list (? symbol? attr) val)
+     (list attr (mark-error "Not a valid attribute value (Must be string.)" val))]
+    [(list attr (? string? val))
+     (list (mark-error "Not a valid attribute name (Must be symbol.)" attr) val)]
+    [else
+     (mark-error "Not a valid attribute (Must be a list of a symbol and a string.)" l)]))
+
+; Reformating Xexpr errors
+(define (parse-xexpr-error s)
+  (with-input-from-string 
+   s (lambda ()
+       (define violator (read))
+       (define c:broke (read))
+       (define c:the (read))
+       (define c:contract (read))
+       (define contract-expr (read))
+       (define c:on (read))
+       (define contracted (read))
+       (define c:semi (read-char))
+       (define xml:msg (read-line))
+       (define blank (read-line))
+       (define c:context (read-line))
+       (define not-xexpr (read))
+       (values violator contract-expr contracted xml:msg not-xexpr))))
+
+(define (reformat-xexpr-exn m)
+  (with-handlers (#;[exn? (lambda _ m)])
+    (define-values (violator contract-expr contracted xml:msg not-xexpr)
+      (parse-xexpr-error m))
+    `(span ,(format "~a broke the contract~n~a~non ~a;~a~n~nContext:~n"
+                    violator (pretty-format contract-expr) contracted
+                    xml:msg)
+           ,(make-cdata #f #f (format-xexpr/errors not-xexpr)))))

collects/web-server/scribblings/private.scrbl

@@ -433,13 +433,6 @@ needs. They are provided by @filepath{private/util.ss}.
 
 @subsection{Exceptions}
 
-@defproc[(pretty-print-invalid-xexpr [exn exn:invalid-xexpr?]
-                                     [v any/c])
-         void]{
- Prints @scheme[v] as if it were almost an X-expression highlighting the error
- according to @scheme[exn].
-}
-
 @defproc[(network-error [s symbol?]
                         [fmt string?]
                         [v any/c] ...)

collects/xml/private/xexpr.ss

@@ -84,7 +84,7 @@
                                (cdr x)))
                    (false (make-exn:invalid-xexpr
                            (format
-                            "Expected a symbol as the element name, given ~a"
+                            "Expected a symbol as the element name, given ~s"
                             (car x))
                            (current-continuation-marks)
                            x)))))
@@ -92,7 +92,7 @@
                  (make-exn:invalid-xexpr
                   (format (string-append
                            "Expected a string, symbol, number, comment, "
-                           "processing instruction, or list, given ~a")
+                           "processing instruction, or list, given ~s")
                           x)
                   (current-continuation-marks)
                   x)))))