114 lines
4.6 KiB
Racket
114 lines
4.6 KiB
Racket
#lang racket/base
|
|
(require racket/contract/base)
|
|
|
|
#|
|
|
TODO
|
|
- more options
|
|
- 'pretty : pretty-print, then use multi-line format as necessary
|
|
- need no-contracts version?
|
|
- document or remove #:details arg
|
|
|#
|
|
|
|
;; A DetailsTable is (listof (cons Field any))
|
|
;; A Field is one of
|
|
;; - string
|
|
;; - (cons string (listof FieldOption))
|
|
;; A FieldOption is one of
|
|
;; - 'multi
|
|
;; - 'value
|
|
;; - 'maybe
|
|
|
|
(define field-option/c (or/c 'multi 'value 'maybe))
|
|
(define field/c (or/c string? (cons/c string? (listof field-option/c))))
|
|
|
|
(define details-list/c
|
|
(recursive-contract
|
|
(or/c '() (cons/c field/c (cons/c any/c details-list/c)))))
|
|
|
|
(provide/contract
|
|
[raise-misc-error
|
|
(->* (symbol? string?)
|
|
(#:continued (or/c string? (listof string))
|
|
#:constructor (-> string? continuation-mark-set? exn?))
|
|
#:rest details-list/c
|
|
any)]
|
|
[compose-error-message
|
|
(->* (symbol? string?)
|
|
(#:continued (or/c string? (listof string)))
|
|
#:rest details-list/c
|
|
string?)])
|
|
|
|
;; ----
|
|
|
|
(define (raise-misc-error who message
|
|
#:details [detail-table null]
|
|
#:continued [continued-message null]
|
|
#:constructor [constructor exn:fail]
|
|
. field+detail-list)
|
|
(raise
|
|
(constructor
|
|
(compose* who message
|
|
continued-message
|
|
(field+detail-list->table 'raise-misc-error field+detail-list detail-table))
|
|
(current-continuation-marks))))
|
|
|
|
(define (compose-error-message who message
|
|
#:details [detail-table null]
|
|
#:continued [continued-message null]
|
|
. field+detail-list)
|
|
(let ([details
|
|
(field+detail-list->table 'compose-error-message field+detail-list detail-table)])
|
|
(compose* who message continued-message details)))
|
|
|
|
(define (compose* who message continued-message details)
|
|
(let* ([parts (let loop ([details details])
|
|
(cond [(null? details) null]
|
|
[else
|
|
(let* ([field+opts (car (car details))]
|
|
[options (if (pair? field+opts) (cdr field+opts) '())]
|
|
[value? (memq 'value options)]
|
|
[multi? (memq 'multi options)]
|
|
[maybe? (memq 'maybe options)]
|
|
[convert-value
|
|
(cond [value?
|
|
(lambda (v) ((error-value->string-handler) v (error-print-width)))]
|
|
[else
|
|
(lambda (v) (format "~a" v))])]
|
|
[field (if (pair? field+opts) (car field+opts) field+opts)]
|
|
[value (cdr (car details))])
|
|
(cond [(and (or maybe? multi? (not value?))
|
|
(not value))
|
|
(loop (cdr details))]
|
|
[multi?
|
|
(list* "\n " field ": "
|
|
(let value-loop ([value value])
|
|
(cond [(pair? value)
|
|
(list* "\n "
|
|
(convert-value (car value))
|
|
(value-loop (cdr value)))]
|
|
[(null? value)
|
|
(loop (cdr details))])))]
|
|
[else
|
|
(list* "\n " field ": "
|
|
(convert-value value)
|
|
(loop (cdr details)))]))]))]
|
|
[parts (let loop ([continued continued-message])
|
|
(cond [(pair? continued) (list* "\n " (car continued) (loop (cdr continued)))]
|
|
[(string? continued) (loop (list continued))]
|
|
[(null? continued) parts]))]
|
|
[parts (list* message (if (null? continued-message) "" ";") parts)]
|
|
[parts (if who
|
|
(list* (symbol->string who) ": " parts)
|
|
parts)])
|
|
(apply string-append parts)))
|
|
|
|
;; ----
|
|
|
|
(define (field+detail-list->table who lst onto)
|
|
(cond [(null? lst) onto]
|
|
[else
|
|
(let ([field (car lst)]
|
|
[value (cadr lst)])
|
|
(cons (cons field value)
|
|
(field+detail-list->table who (cddr lst) onto)))]))
|