Fixing xexpr pretty printing

svn: r13875

collects/web-server/configuration/responders.ss

@@ -1,8 +1,8 @@
 #lang scheme
 (require scheme/runtime-path
          net/url
-         web-server/http/response-structs
          web-server/private/xexpr
+         web-server/http/response-structs
          web-server/http/request-structs)
 
 (define (format-stack-trace trace)
@@ -33,7 +33,9 @@
           (div ([class "title"]) "Exception")
           (p
            "The application raised an exception with the message:"
-           (pre ,(reformat-xexpr-exn (exn-message exn))))
+           (pre ,(if (exn:pretty? exn)
+                     (exn:pretty-xexpr exn)
+                     (exn-message exn))))
           (p
            "Stack trace:"
            ,(format-stack-trace

collects/web-server/default-web-root/htdocs/servlets/examples/bad-xexpr.ss

@@ -0,0 +1,5 @@
+#lang web-server/insta
+(define (start initial-request)
+  `(html (head (title "Foo"))
+         (body (a ([href #f])
+                  "Zog"))))

collects/web-server/formlets/input.ss

@@ -1,6 +1,6 @@
 #lang scheme
 (require web-server/http
-         xml
+         web-server/private/xexpr
          (only-in "lib.ss"
                   formlet/c
                   pure
@@ -31,7 +31,7 @@
          default))))
 
 (provide/contract
- [make-input ((string? . -> . xexpr/c) . -> . (formlet/c (or/c false/c binding?)))]
+ [make-input ((string? . -> . pretty-xexpr/c) . -> . (formlet/c (or/c false/c binding?)))]
  #;[binding:form-required (formlet/c (binding? . -> . bytes?))]
  #;[binding:form/default (bytes? . -> . (formlet/c (binding? . -> . bytes?)))])
 

collects/web-server/formlets/lib.ss

@@ -1,6 +1,6 @@
 #lang scheme
 (require web-server/http
-         xml)
+         web-server/private/xexpr)
 
 ; Combinators
 (define (const x) (lambda _ x))
@@ -68,7 +68,7 @@
 
 ; Contracts
 (define xexpr-forest/c
-  (listof xexpr/c))
+  (listof pretty-xexpr/c))
 
 (define (formlet/c c)
   (integer? . -> . 
@@ -91,7 +91,7 @@
           () #:rest (listof (formlet/c alpha))
           . ->* . (formlet/c beta))]
  [xml-forest (xexpr-forest/c . -> . (formlet/c procedure?))]
- [xml (xexpr/c . -> . (formlet/c procedure?))] 
+ [xml (pretty-xexpr/c . -> . (formlet/c procedure?))] 
  [text (string? . -> . (formlet/c procedure?))]
  [tag-xexpr (symbol? (listof (list/c symbol? string?)) (formlet/c alpha) . -> . (formlet/c alpha))]
  [formlet-display ((formlet/c alpha) . -> . xexpr-forest/c)]

collects/web-server/formlets/servlet.ss

@@ -1,11 +1,11 @@
 #lang scheme
 (require web-server/servlet
-         xml
+         web-server/private/xexpr
          "lib.ss")
 
 (provide/contract
  [send/formlet (((formlet/c any/c))
-                (#:wrap (xexpr/c . -> . response/c))                 
+                (#:wrap (pretty-xexpr/c . -> . response/c))                 
                 . ->* . any/c)])
 
 (define (send/formlet f
@@ -23,7 +23,7 @@
               ,@(formlet-display f)))))))
 
 (provide/contract
- [embed-formlet (embed/url/c (formlet/c any/c) . -> . xexpr/c)])
+ [embed-formlet (embed/url/c (formlet/c any/c) . -> . pretty-xexpr/c)])
 
 (define (embed-formlet embed/url f)
   `(form ([action ,(embed/url

collects/web-server/http/cookie.ss

@@ -3,6 +3,7 @@
          web-server/http/request-structs
          web-server/http/response-structs
          xml
+         web-server/private/xexpr
          scheme/contract)
 
 (provide/contract 
@@ -13,7 +14,7 @@
                                             #:secure? (or/c false/c boolean?))
                                  . ->* . cookie?)]
  [cookie->header (cookie? . -> . header?)]
- [xexpr-response/cookies ((listof cookie?) xexpr/c . -> . response/full?)])
+ [xexpr-response/cookies ((listof cookie?) pretty-xexpr/c . -> . response/full?)])
 
 (define (set-when-true fn val)
   (if val

collects/web-server/http/response-structs.ss

@@ -1,7 +1,8 @@
 #lang scheme/base
 (require mzlib/contract
          scheme/list
-         xml/xml
+         xml
+         web-server/private/xexpr
          web-server/http/request-structs)
 
 (define TEXT/HTML-MIME-TYPE #"text/html; charset=utf-8")
@@ -13,7 +14,7 @@
 (define response/c
   (or/c response/basic?
         (cons/c bytes? (listof (or/c string? bytes?)))
-        xexpr/c))
+        pretty-xexpr/c))
 
 ;; response/full->size: response/full -> number
 (define (response/full->size resp)

collects/web-server/private/xexpr.ss

@@ -2,13 +2,38 @@
 (require scheme/pretty
          xml)
 
+(define-struct (exn:pretty exn) (xexpr))
+
 (provide/contract
+ [struct (exn:pretty exn) ([message string?]
+                           [continuation-marks continuation-mark-set?]
+                           [xexpr xexpr/c])]
  [format-xexpr/errors (any/c . -> . string?)]
- [reformat-xexpr-exn (string? . -> . xexpr/c)])
+ [pretty-xexpr/c contract?])
+
+(define pretty-xexpr/c
+  (make-proj-contract
+   'pretty-xexpr/c
+   (lambda (pos neg src-info name)
+     (lambda (val)
+       (define marks (current-continuation-marks))
+       (with-handlers ([exn:fail:contract?
+                        (lambda (exn)
+                          (raise
+                           (make-exn:pretty
+                            (exn-message exn)
+                            marks
+                            `(span ,(drop-after "Context:\n" (exn-message exn))
+                                   ,(make-cdata #f #f (format-xexpr/errors val))))))])
+         (contract xexpr/c val pos neg src-info))))
+   (lambda (v) #t)))
+
+(define (drop-after delim str)
+  (substring str 0 (cdr (first (regexp-match-positions (regexp-quote delim) str)))))
 
 ; Formating Xexprs
 (define (format-xexpr/errors v)
-  (pretty-format (format-xexpr v)))
+  (pretty-format (format-xexpr v) 80))
 
 (define-struct xexpr-error (message content)
   #:property prop:custom-write
@@ -27,6 +52,7 @@
       (exact-nonnegative-integer? v)
       (comment? v)
       (p-i? v)
+      (pcdata? v)
       (cdata? v)))
 
 (define (format-xexpr v)
@@ -43,7 +69,7 @@
                (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)]))
+     (mark-error "Not a valid Xexpr datum (Must be a string, symbol, exact nonnegative integer, comment, PI, pcdata, or cdata.)" v)]))
 
 (define (format-elements+attributes l)
   (match l
@@ -87,39 +113,4 @@
     [(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)]))
+     (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))
-       (when 
-           (or (ormap eof-object? 
-                    (list violator c:broke c:the c:contract contract-expr
-                          c:on contracted c:semi xml:msg blank c:context not-xexpr))
-               (not (andmap symbol=?
-                            (list 'broke 'the 'contract 'on '|;| 'Context:)
-                            (list c:broke c:the c:contract c:on c:semi c:context))))
-         (error 'parse-xexpr-error "Not Xexpr error"))
-       (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/xml/private/xexpr.ss

@@ -21,6 +21,17 @@
 
 (define xexpr-drop-empty-attributes (make-parameter #f))
 
+(define xexpr-datum/c
+  (or/c string? symbol? exact-nonnegative-integer?
+        comment? p-i? cdata? pcdata?))
+
+#;(define xexpr/c
+  (flat-rec-contract xexpr
+    xexpr-datum/c
+    (cons/c symbol?
+            (or/c (cons/c (listof (list/c symbol? string?)) (listof xexpr))
+                  (listof xexpr)))))
+
 (define xexpr/c 
   (make-proj-contract
    'xexpr?