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

Fixing xexpr pretty printing

Browse Source 
svn: r13875
This commit is contained in:
Jay McCarthy 2009-02-27 21:11:01 +00:00
parent 5fda17741b
commit 12dcbfdc88
9 changed files with 63 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/web-server/configuration/responders.ss
View File

@ -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

5
collects/web-server/default-web-root/htdocs/servlets/examples/bad-xexpr.ss Normal file
View File

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

4
collects/web-server/formlets/input.ss
View File

@ -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?)))])

6
collects/web-server/formlets/lib.ss
View File

@ -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)]

6
collects/web-server/formlets/servlet.ss
View File

@ -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

3
collects/web-server/http/cookie.ss
View File

@ -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

5
collects/web-server/http/response-structs.ss
View File

@ -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)

69
collects/web-server/private/xexpr.ss
View File

@ -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)]))
; 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)))))
(mark-error "Not a valid attribute (Must be a list of a symbol and a string.)" l)]))

11
collects/xml/private/xexpr.ss
View File

@ -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?