diff --git a/collects/unstable/error.rkt b/collects/unstable/error.rkt new file mode 100644 index 0000000000..cf0ea97c16 --- /dev/null +++ b/collects/unstable/error.rkt @@ -0,0 +1,113 @@ +#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)))])) diff --git a/collects/unstable/scribblings/error.scrbl b/collects/unstable/scribblings/error.scrbl new file mode 100644 index 0000000000..975b5faa4d --- /dev/null +++ b/collects/unstable/scribblings/error.scrbl @@ -0,0 +1,81 @@ +#lang scribble/manual +@(require scribble/eval "utils.rkt" + (for-label racket/base racket/contract unstable/error)) + +@(define the-eval (make-base-eval)) +@(the-eval '(require unstable/error)) + +@title[#:tag "error"]{Errors} +@unstable[@author+email["Ryan Culpepper" "ryanc@racket-lang.org"]] + +@defmodule[unstable/error] + +@defproc[(raise-misc-error [name symbol?] + [message string?] + [field (let ([option/c (or/c 'value 'multi 'maybe)]) + (or/c string? (cons/c string? (listof option/c))))] + [value any/c] ... ... + [#:continued continued-message (or/c string? (listof string?)) null] + [#:constructor constructor + (-> string? continuation-mark-set? exn?) + exn:fail]) + any]{ + +Raises an exception with a message composed according to the Racket +@tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{error +message convention}. The exception is created with +@racket[constructor], which is @racket[exn:fail] by default. + +The composed error message includes details consisting of the +alternating @racket[field] and @racket[value] arguments. By default, +@racket[value] is formatted as if by @racket[display] unless it is +@racket[#f], in which case the detail line is omitted. The following +options affect the formatting of the detail line: + +@itemlist[ + +@item{@racket['multi] formats each element in the corresponding value, +which must be a list, as a separate line} + +@item{@racket['value] formats the value using +@racket[error-value->string-handler]; the detail line is not omittable +unless @racket['maybe] or @racket['multi] is also provided} + +] + +@examples[#:eval the-eval + +(raise-misc-error 'mcbean "too many stars upon thars" + '("given" value) 'star-bellied-sneetch + '("stars" value) 3) + +(raise-misc-error 'hal "unable to open pod bay doors" + #:continued + "this mission is too important to let you jeopardize it" + "threat" "David Bowman" + "detection" "lip reading") + +(raise-misc-error 'car "missing car keys" + '("searched" multi) + (list "dresser" "desk" "kitchen table" "under sofa" + "behind microwave" "in washing machine") + "last seen" + #f) +] +} + +@defproc[(compose-error-message + [name symbol?] + [message string?] + [field (let ([option/c (or/c 'value 'multi 'maybe)]) + (or/c string? (cons/c string? (listof option/c))))] + [value any/c] ... ... + [#:continued continued-message (or/c string? (listof string?)) null]) + string?]{ + +Like @racket[raise-misc-error], but produces a string conforming to +the Racket @tech[#:doc '(lib +"scribblings/reference/reference.scrbl")]{error message convention}. +} + +@(close-eval the-eval) diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl index 205de9df13..0212152c72 100644 --- a/collects/unstable/scribblings/unstable.scrbl +++ b/collects/unstable/scribblings/unstable.scrbl @@ -81,6 +81,7 @@ Keep documentation and tests up to date. @include-section["wrapc.scrbl"] @include-section["debug.scrbl"] @include-section["define.scrbl"] +@include-section["error.scrbl"] @include-section["file.scrbl"] @include-section["find.scrbl"] @include-section["flonum.scrbl"]