128 lines
3.8 KiB
Racket
128 lines
3.8 KiB
Racket
#lang racket/base
|
|
(require racket/contract
|
|
racket/match
|
|
racket/list
|
|
racket/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?)]
|
|
[pretty-xexpr/c contract?])
|
|
|
|
(define pretty-xexpr/c
|
|
(make-contract
|
|
#:name 'pretty-xexpr/c
|
|
#:projection
|
|
(lambda (blame)
|
|
(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)) "\n"
|
|
,(make-cdata #f #f (format-xexpr/errors val))))))])
|
|
(((contract-projection xexpr/c) blame) val))))))
|
|
|
|
(define (drop-after delim str)
|
|
(match (regexp-match-positions (regexp-quote delim) str)
|
|
[(list-rest (list-rest start end) _rst)
|
|
(substring str 0 end)]
|
|
[_
|
|
str]))
|
|
|
|
; Formating Xexprs
|
|
(define (format-xexpr/errors v)
|
|
(pretty-format (format-xexpr v) 80))
|
|
|
|
(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)
|
|
(p-i? v)
|
|
(pcdata? 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, pcdata, 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)
|
|
(if (list? l)
|
|
(map format-xexpr l)
|
|
(mark-error
|
|
"Expected a list of elements"
|
|
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)]))
|