suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

error

Browse Source 
svn: r3941
This commit is contained in:
Jay McCarthy 2006-08-03 16:46:25 +00:00
parent d9409858fd
commit 2fde0eeab7
1 changed files with 20 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
collects/web-server/response.ss
View File

@ -278,10 +278,6 @@
;; Turn an exn:invalid-xexpr into a response.
(define (xexpr-exn->response exn x)
;;; Does it matter what number I use for pretty-print-size-hook?
(pretty-print-size-hook (lambda (v display? op) 20))
(pretty-print-print-hook (pretty-print-hook/web-errors
(exn:invalid-xexpr-code exn)))
(make-response/full
500 "Servlet Error"
(current-seconds)
@ -295,27 +291,22 @@
"<pre>" (exn-message exn) "</pre>"
"<h2>The Full Xexpr Is</h2>"
"<pre>"
(let ((o (open-output-string)))
(pretty-print x o)
(let ([o (open-output-string)])
(parameterize ([current-output-port o])
(pretty-print-invalid-xexpr exn x))
(get-output-string o))
"</pre>"))))
;; Format everything normally, except for the erroneous data.
(define (pretty-print-hook/web-errors err)
(letrec ((f-aux (lambda (v)
(cond
((equal? v err)
(format
(string-append
"<span style='font-weight: bold; "
"color: red; background-color: white;'>"
"~a</span>") v))
((list? v) (string-append "("
(string-join (map f-aux v)
" ")
")"))
(else (format "~a" v))))))
(lambda (v display? op)
((if display? display write) (f-aux v) op))))
)
(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))))