From 8ab87a9fcc30b002372dc87e467fc6ee8d2ddde0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 26 May 2012 21:04:55 -0600 Subject: [PATCH] racket/class: new error message convention --- collects/racket/private/class-internal.rkt | 386 ++++++++++++--------- collects/scribblings/reference/class.scrbl | 2 +- collects/tests/racket/object.rktl | 17 +- 3 files changed, 235 insertions(+), 170 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index 54023eeb40..a2ae2b1063 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -262,9 +262,9 @@ (define (validate-local-member orig s) (if (symbol? s) s - (error 'local-member-name - "used before its definition: ~a" - orig))) + (obj-error 'local-member-name + "used before its definition" + "name" (as-write orig)))) ;;-------------------------------------------------------------------- ;; field info creation/access @@ -1422,7 +1422,7 @@ ;; store a dummy method body that should never be called for abstracts [(abstract-method ...) (map (lambda (abs) #'(lambda (this . rest) - (obj-error 'class "Cannot call abstract method"))) + (obj-error 'class "cannot call abstract method"))) (map car abstracts))] [mappings mappings] @@ -1847,7 +1847,10 @@ (define (check-member-key id v) (unless (member-name-key? v) - (error 'define-local-member-name "not a member key for ~a: ~e" id v)) + (obj-error 'define-local-member-name + "value is not a member key" + "value" v + "local name" (as-write id))) (member-key-id v)) (define-syntax (member-name-key stx) @@ -1991,9 +1994,9 @@ ;; -- Check superclass -- (unless (class? super) - (obj-error 'class* "superclass expression ~e returned a non-class: ~a" - super - (for-class name))) + (obj-error 'class* "superclass expression result is not a class" + "result" super + #:class-name name)) (when any-localized? (check-still-unique name @@ -2039,17 +2042,17 @@ (for-each (lambda (intf) (unless (interface? intf) - (obj-error 'class* "interface expression returned a non-interface: ~a~a" - intf - (for-class name)))) + (obj-error 'class* "interface expression result is not an interface" + "result" intf + #:class-name name))) interfaces) ;; -- Check inspectors --- (when inspector (unless (inspector? inspector) - (obj-error 'class* "inspect class result is not an inspector or #f: ~a~a" - inspector - (for-class name)))) + (obj-error 'class* "class `inspect' result is not an inspector or #f" + "result" inspector + #:class-name name))) ;; -- Match method and field names to indices -- (let ([method-ht (if no-new-methods? @@ -2069,28 +2072,28 @@ (for ([id (in-list public-names)] [p (in-naturals (class-method-width super))]) (when (hash-ref method-ht id #f) - (obj-error 'class* "superclass ~e already contains method: ~a~a" - super - id - (for-class name))) + (obj-error 'class* "superclass already contains method" + "superclass" super + "method name" (as-write id) + #:class-name name)) (hash-set! method-ht id p))) ;; Keep check here for early failure, will add to hashtable later in this function. (unless no-new-fields? (for ([id (in-list public-field-names)]) (when (hash-ref field-ht id #f) - (obj-error 'class* "superclass ~e already contains field: ~a~a" - super - id - (for-class name))))) + (obj-error 'class* "superclass already contains field" + "superclass" super + "field name" (as-write id) + #:class-name name)))) ;; Check that superclass has expected fields (for-each (lambda (id) (unless (hash-ref field-ht id #f) - (obj-error 'class* "superclass ~e does not provide field: ~a~a" - super - id - (for-class name)))) + (obj-error 'class* "superclass does not provide field" + "superclass" super + "field name" (as-write id) + (and name "class") name))) inherit-field-names) ;; Check that superclass has expected methods, and get indices @@ -2102,11 +2105,11 @@ method-ht id (lambda () (obj-error 'class* - "~a does not provide an expected method for ~a: ~a~a" - (if (eq? method-ht super-method-ht) "superclass" "class") - what - id - (for-class name))))) + (format "~a does not provide an expected method for ~a" + (if (eq? method-ht super-method-ht) "superclass" "class") + what) + (format "~a name" what) (as-write id) + #:class-name name)))) ids))] [method-width (+ (class-method-width super) (length public-names))] [field-width (+ (class-field-width super) num-fields)] @@ -2132,29 +2135,26 @@ (lambda (var) (unless (hash-ref method-ht var #f) (obj-error 'class* - "interface-required method missing: ~a~a~a" - var - (for-class name) - (for-intf (interface-name intf))))) + "missing interface-required method" + "method name" (as-write var) + (and name "class name") (as-write name) + (and (interface-name intf) "interface name") (as-write (interface-name intf))))) (interface-public-ids intf))) interfaces) - (let ([c (get-implement-requirement interfaces 'class* (for-class name))]) + (let ([c (get-implement-requirement interfaces 'class* #:class-name name)]) (when (and c (not (subclass? super c))) (obj-error 'class* - "interface-required implementation not satisfied~a~a" - (for-class name) - (let ([r (class-name c)]) - (if r - (format " required class: ~a" r) - ""))))) + "interface-required implementation not satisfied" + (and name "class name") (as-write name) + (and (class-name c) "required class name") (as-write (class-name c))))) ;; -- For serialization, check that the superclass is compatible -- (when deserialize-id (unless (class-serializer super) (obj-error 'class* - "superclass is not serialiazable, not transparent, and does not implement externalizable<%>: ~e~a" - super - (for-class name)))) + "superclass is not serialiazable, not transparent, and does not implement externalizable<%>" + "superclass" super + #:class-name name))) ;; ---- Make the class and its interface ---- (let* ([class-make (if name @@ -2299,11 +2299,11 @@ (not (vector-ref vec (sub1 (vector-length vec))))) (obj-error 'class* (string-append - "superclass ~e method for override, overment, inherit/super, " - "or rename-super is not overrideable: ~a~a") - super - mname - (for-class name)))) + "superclass method for override, overment, inherit/super, " + "or rename-super is not overrideable") + "superclass" super + "method name" (as-write mname) + #:class-name name))) (vector-ref (class-super-methods super) index)) rename-super-indices rename-super-names)] @@ -2332,11 +2332,11 @@ (unless aug-ok? (obj-error 'class* (string-append - "superclass ~e method for augride, augment, inherit/inner, " - "or rename-inner method is not augmentable: ~a~a") - super - mname - (for-class name))))))]) + "superclass method for augride, augment, inherit/inner, " + "or rename-inner method is not augmentable") + "superclass" super + "method name" (as-write mname) + #:class-name name)))))]) (for-each (check-aug #f) augride-normal-names (get-indices method-ht "augride" augride-normal-names)) @@ -2420,9 +2420,9 @@ (for-each (lambda (index method id) (when (eq? 'final (vector-ref meth-flags index)) (obj-error 'class* - "cannot override or augment final method: ~a~a" - id - (for-class name))) + "cannot override or augment final method" + "method name" (as-write id) + #:class-name name)) (let ([v (vector-ref beta-methods index)]) (if (zero? (vector-length v)) ;; Normal mode - set vtable entry @@ -2548,8 +2548,9 @@ o))) (if (interface-extension? i externalizable<%>) (lambda () - (error 'deserialize "cannot deserialize instance with cycles~a" - (for-class name))) + (obj-error 'deserialize + "cannot deserialize instance with cycles" + #:class-name name)) (lambda () (let ([o (object-make)]) (values o @@ -2654,9 +2655,9 @@ An example (lambda () (hash-set! ht s #t) #f)) - (obj-error 'class* "external ~a mapped to overlapping keys~a" - what - (for-class name)))) + (obj-error 'class* (format "external ~a mapped to overlapping keys" + what) + #:class-name name))) syms))) (define (get-properties intfs) @@ -3591,17 +3592,17 @@ An example (lambda (intf) (unless (interface? intf) (obj-error 'interface - "superinterface expression returned a non-interface: ~e~a" - intf - (for-intf name)))) + "superinterface expression result is not an interface" + "result" intf + #:intf-name name))) supers) (for-each (lambda (p) (unless (struct-type-property? p) (obj-error 'interface - "property expression returned a non-property: ~e~a" - p - (for-intf name)))) + "property expression result is not a property" + "result" p + #:intf-name name))) props) (let ([ht (make-hasheq)]) (for-each @@ -3615,13 +3616,10 @@ An example (lambda (var) (when (and (hash-ref ht var #f) (not (hash-ref ctcs var #f))) - (obj-error 'interface "variable already in superinterface: ~a~a~a" - var - (for-intf name) - (let ([r (interface-name super)]) - (if r - (format " already in: ~a" r) - ""))))) + (obj-error 'interface "variable already in superinterface" + "variable name" (as-write var) + (and (interface-name super) "already in") (as-write (interface-name super)) + #:intf-name name))) (interface-public-ids super))) supers) ;; merge properties: @@ -3638,7 +3636,7 @@ An example (hash-set! prop-ht g (vector g p v)))) props vals) ;; Check for [conflicting] implementation requirements - (let ([class (get-implement-requirement supers 'interface (for-intf name))] + (let ([class (get-implement-requirement supers 'interface #:intf-name name)] [interface-make (if name (make-naming-constructor struct:interface @@ -3672,7 +3670,9 @@ An example (interface-supers i)) (set-interface-all-implemented! i ht))) -(define (get-implement-requirement interfaces where for) +(define (get-implement-requirement interfaces where + #:class-name [class-name #f] + #:intf-name [intf-name #f]) (let loop ([class #f] [supers interfaces]) (if (null? supers) @@ -3687,8 +3687,9 @@ An example [else (obj-error where - "conflicting class implementation requirements in superinterfaces~a" - for)]) + "conflicting class implementation requirements in superinterfaces" + #:class-name class-name + #:intf-name intf-name)]) (cdr supers)))))) ;;-------------------------------------------------------------------- @@ -3943,9 +3944,9 @@ An example ;; make sure the class isn't abstract (unless (null? (class-abstract-ids class)) (obj-error 'instantiate - "cannot instantiate class ~a with abstract methods ~a" - class - (class-abstract-ids class))) + "cannot instantiate class with abstract methods" + "class" class + "abstract methods" (as-write-list (class-abstract-ids class)))) ;; Generate correct class by concretizing methods w/interface ctcs (let* ([class (fetch-concrete-class class blame)] [o ((class-make-object class))]) @@ -3974,9 +3975,9 @@ An example (if explict-named-args? (obj-error 'instantiate - "class has only by-position initializers, but given by-name arguments:~a~a" - (make-named-arg-string named-args) - (for-class (class-name c))) + "class has only by-position initializers, but given by-name arguments" + "arguments" (as-lines (make-named-arg-string named-args)) + #:class-name (class-name c)) ;; If args were implicit from subclass, should report as unused: (unused-args-error o named-args)))) ;; Merge by-pos into named args: @@ -4003,13 +4004,15 @@ An example c inited? leftovers ; merely passed through to continue-make-super named-args) (unless (unbox inited?) - (obj-error 'instantiate "superclass initialization not invoked by initialization~a" - (for-class (class-name c)))))))))) + (obj-error 'instantiate + "superclass initialization not invoked by initialization" + #:class-name (class-name c))))))))) (define (continue-make-super o c inited? leftovers by-pos-args new-named-args) (when (unbox inited?) - (obj-error 'instantiate "superclass already initialized by class initialization~a" - (for-class (class-name c)))) + (obj-error 'instantiate + "superclass already initialized by class initialization" + #:class-name (class-name c))) (set-box! inited? #t) (let ([named-args (if (eq? 'list (class-init-mode c)) ;; all old args must have been used up @@ -4049,9 +4052,9 @@ An example named-args))] [else (obj-error 'instantiate - "too many initialization arguments:~a~a" - (make-pos-arg-string by-pos-args) - (for-class (class-name c)))]))] + "too many initialization arguments" + "arguments" (as-lines (make-pos-arg-string by-pos-args)) + #:class-name (class-name c))]))] [else (cons (cons (car nl) (car al)) (do-merge (cdr al) (cdr nl) ic named-args by-pos-args c))])) @@ -4090,26 +4093,31 @@ An example args)))) (define (make-named-arg-string args) - (let loop ([args args][count 0]) - (cond - [(null? args) ""] - [(= count 3) " ..."] + (apply + string-append + (let loop ([args args][count 0]) + (cond + [(null? args) null] + [(= count 3) '("\n ...")] [else (let ([rest (loop (cdr args) (add1 count))]) - (format " (~a ~e)~a" - (caar args) - (cdar args) - rest))]))) + (cons (format "\n [~a ~e]" + (caar args) + (cdar args)) + rest))])))) (define (unused-args-error this args) (let ([arg-string (make-named-arg-string args)]) - (obj-error 'instantiate "unused initialization arguments:~a~a" - arg-string - (for-class/which "instantiated" (class-name (object-ref this)))))) + (obj-error 'instantiate "unused initialization arguments" + "unused arguments" (as-lines arg-string) + #:class-name (class-name (object-ref this)) + #:which-class "instantiated "))) (define (missing-argument-error class-name name) - (obj-error 'instantiate "no argument for required init variable: ~a~a" - name - (if class-name (format " in class: ~a" class-name) ""))) + (obj-error 'instantiate + "no argument for required init variable" + "init variable name" (as-write name) + #:class-name class-name + #:which-class "instantiated ")) ;;-------------------------------------------------------------------- ;; methods and fields @@ -4214,11 +4222,13 @@ An example (let ([pos (hash-ref (class-method-ht cls) name #f)]) (if pos (vector-ref (class-methods cls) pos) - (obj-error who "no such method: ~a~a" - name - (for-class (class-name cls))))) - (obj-error who "target is not an object: ~e for method: ~a" - in-object name)))) + (obj-error who + "no such method" + "method name" (as-write name) + #:class-name (class-name cls)))) + (obj-error who "target is not an object" + "target" in-object + "method name" (as-write name))))) (define-values (make-class-field-accessor make-class-field-mutator) (let ([check-and-get-index @@ -4229,9 +4239,9 @@ An example (raise-argument-error who "symbol?" name)) (hash-ref (class-field-ht class) name (lambda () - (obj-error who "no such field: ~a~a" - name - (for-class (class-name class))))))]) + (obj-error who "no such field" + "field-name" (as-write name) + #:class-name (class-name class)))))]) (values (λ (class name) (let* ([fi (check-and-get-index 'class-field-accessor class name)] [ref (field-info-external-ref fi)]) @@ -4262,9 +4272,9 @@ An example (if (interface? class) (let ([intf class]) (unless (method-in-interface? name intf) - (obj-error 'make-generic "no such method: ~a~a" - name - (for-intf (interface-name intf)))) + (obj-error 'make-generic "no such method" + "method name" (as-write name) + #:intf-name (interface-name intf))) (lambda (obj) (unless (is-a? obj intf) (raise-type-error @@ -4274,9 +4284,9 @@ An example (find-method/who 'make-generic obj name))) (let* ([pos (hash-ref (class-method-ht class) name (lambda () - (obj-error 'make-generic "no such method: ~a~a" - name - (for-class (class-name class)))))] + (obj-error 'make-generic "no such method" + "method name" (as-write name) + #:class-name (class-name class))))] [instance? (class-object? class)] [dynamic-generic (lambda (obj) @@ -4356,19 +4366,18 @@ An example (define (set-field!/proc id obj val) (unless (object? obj) - (raise-mismatch-error - 'set-field! - "expected an object, got " - obj)) + (raise-argument-error 'set-field! + "object?" + obj)) (let* ([cls (object-ref obj)] [field-ht (class-field-ht cls)] [fi (hash-ref field-ht id #f)]) (if fi ((field-info-external-set! fi) obj val) - (raise-mismatch-error - 'get-field - (format "expected an object that has a field named ~s, got " id) - obj)))) + (obj-error 'get-field + "given object does not have the requested field" + "field name" (as-write id) + "object" obj)))) (define-syntax (get-field stx) (syntax-case stx () @@ -4383,19 +4392,18 @@ An example (define (get-field/proc id obj) (unless (object? obj) - (raise-mismatch-error - 'get-field - "expected an object, got " - obj)) + (raise-argument-error 'get-field + "object?" + obj)) (let* ([cls (object-ref obj)] [field-ht (class-field-ht cls)] [fi (hash-ref field-ht id #f)]) (if fi ((field-info-external-ref fi) obj) - (raise-mismatch-error - 'get-field - (format "expected an object that has a field named ~s, got " id) - obj)))) + (obj-error 'get-field + "given object does not have the requested field" + "field name" (as-write id) + "object" obj)))) (define-syntax (field-bound? stx) (syntax-case stx () @@ -4410,10 +4418,9 @@ An example (define (field-bound?/proc id obj) (unless (object? obj) - (raise-mismatch-error - 'field-bound? - "expected an object, got " - obj)) + (raise-argument-error 'field-bound? + "object?" + obj)) (let loop ([obj obj]) (let* ([cls (object-ref obj)] [field-ht (class-field-ht cls)]) @@ -4422,10 +4429,9 @@ An example (define (field-names obj) (unless (object? obj) - (raise-mismatch-error - 'field-names - "expected an object, got " - obj)) + (raise-argument-error 'field-names + "object?" + obj)) (let loop ([obj obj]) (let* ([cls (object-ref obj)] [field-ht (class-field-ht cls)] @@ -4611,7 +4617,8 @@ An example (if (zero? (class-pos next)) (loop #f #t) (loop (vector-ref (class-supers next) (sub1 (class-pos next))) #t))))) - (raise-mismatch-error 'class-info "current inspector cannot inspect class: " c))) + (raise-arguments-error 'class-info "current inspector cannot inspect class" + "class" c))) (define object->vector (opt-lambda (in-o [opaque-v '...]) @@ -4876,9 +4883,60 @@ An example (define-struct (exn:fail:object exn:fail) () #:inspector insp) -(define (obj-error where . msg) +(struct as-write (content)) +(struct as-write-list (content)) +(struct as-value-list (content)) +(struct as-lines (content)) + +(define (obj-error where + msg + #:class-name [class-name #f] + #:intf-name [intf-name #f] + #:which-class [which-class ""] + . fields) + (define all-fields + (append fields + (if class-name + (list (string-append which-class "class name") + (as-write class-name)) + null) + (if intf-name + (list "interface name" + (as-write intf-name)) + null))) (raise (make-exn:fail:object - (string-append (format "~a: " where) (apply format msg)) + (format "~a: ~a~a" where msg + (apply + string-append + (let loop ([fields all-fields]) + (cond + [(null? fields) null] + [else + (define field (car fields)) + (define val (cadr fields)) + (list* + "\n " + field + (if (or (as-write-list? val) + (as-lines? val)) + ":" + ": ") + (cond + [(or (as-write-list? val) + (as-value-list? val)) + (apply string-append + (for/list ([v (in-list (as-write-list-content val))]) + (format (if (as-write-list? val) + "\n ~s" + "\n ~e") + v)))] + [(as-write? val) + (format "~s" (as-write-content val))] + [(as-lines? val) + (as-lines-content val)] + [else + (format "~e" val)]) + (loop (cddr fields)))])))) (current-continuation-marks)))) (define (for-class name) @@ -4896,28 +4954,33 @@ An example (define (check-mixin-super mixin-name super% from-ids) (let ([mixin-name (or mixin-name 'mixin)]) (unless (class? super%) - (error mixin-name "argument is not a class: ~e" super%)) + (obj-error mixin-name + "argument is not a class" + "argument" super%)) (for-each (lambda (from-id) (unless (implementation? super% from-id) - (error mixin-name "argument does not implement ~e: ~e" from-id super%))) + (obj-error mixin-name + "argument class does not implement method" + "argument" super% + "method name" (as-write from-id)))) from-ids))) (define (check-mixin-from-interfaces all-from) (for-each (lambda (from-id) (unless (interface? from-id) - (error 'mixin - "expected from-interface, got: ~e; others ~e" - from-id - all-from))) + (obj-error 'mixin + "given value for from-interface is not an interface" + "given" from-id + "all given" (as-value-list all-from)))) all-from)) (define (check-mixin-to-interfaces all-to) (for-each (lambda (to-id) (unless (interface? to-id) - (error 'mixin - "expected to-interface, got: ~e; others ~e" - to-id - all-to))) + (obj-error 'mixin + "given values for from-interface is not an interface" + "given" to-id + "all given" (as-value-list all-to)))) all-to)) @@ -4925,9 +4988,10 @@ An example (for-each (lambda (x) (unless (ormap (lambda (i) (method-in-interface? x i)) from-ids) - (error 'mixin - "method `~a' was referenced in definition, but is not in any of the from-interfaces: ~e" - x from-ids))) + (obj-error 'mixin + "method was referenced in definition, but is not in any of the from-interfaces" + "method name" (as-write x) + "from-interfaces" (as-write-list from-ids)))) xs)) (define-syntax (mixin stx) diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index ae6cbcf0a3..2ce27f6550 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -1196,7 +1196,7 @@ Extracts the field with (external) name @racket[id] from the value of @racket[obj-expr]. If @racket[obj-expr] does not produce an object, the -@exnraise[exn:fail:contract]. If the object has no @racket[id] method, +@exnraise[exn:fail:contract]. If the object has no @racket[id] field, the @exnraise[exn:fail:object].} @defform[(set-field! id obj-expr expr)]{ diff --git a/collects/tests/racket/object.rktl b/collects/tests/racket/object.rktl index 34f30d059b..933b410a9c 100644 --- a/collects/tests/racket/object.rktl +++ b/collects/tests/racket/object.rktl @@ -1232,17 +1232,17 @@ (syntax-test #'(get-field 1 b)) (syntax-test #'(get-field a b c)) -(error-test #'(get-field x 1) exn:application:mismatch?) -(error-test #'(get-field x (new object%)) exn:application:mismatch?) +(error-test #'(get-field x 1) exn:fail:contract?) +(error-test #'(get-field x (new object%)) exn:fail:object?) (error-test #'(get-field x (new (class object% (define x 1) (super-new)))) - exn:application:mismatch?) + exn:fail:object?) (error-test #'(let ([o (let () (define-local-member-name f) (new (class object% (field [f 0]) (super-new))))]) (get-field f o)) - exn:application:mismatch?) + exn:fail:object?) (test 0 'get-field1 (get-field x (new (class object% (field [x 0]) (super-new))))) (test 0 'get-field2 (let () (define-local-member-name f) @@ -1259,16 +1259,17 @@ (syntax-test #'(set-field! 1 b c)) (syntax-test #'(set-field! a b c d)) -(error-test #'(set-field! x 1 2) exn:application:mismatch?) -(error-test #'(set-field! x (new object%) 2) exn:application:mismatch?) +(error-test #'(set-field! x 1 2)) +(error-test #'(set-field! x (new object%) 2) exn:fail:object?) (error-test #'(set-field! x (new (class object% (define x 1) (super-new))) 2) - exn:application:mismatch?) + exn:fail:object?) (error-test #'(let ([o (let () (define-local-member-name f) (new (class object% (field [f 0]) (super-new))))]) - (set-field! f o 2))) + (set-field! f o 2)) + exn:fail:object?) (test 1 'set-field!1 (let ([o (new (class object% (field [x 0]) (super-new)))]) (set-field! x o 1) (get-field x o)))