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

made class/c use the name from the context for the name of the contract, when available

Browse Source
This commit is contained in:
Robby Findler 2012-04-06 16:17:24 -05:00
parent 483dde9ea8
commit 1a9ab0b018
2 changed files with 76 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

131
collects/racket/private/class-internal.rkt
View File

@ -2966,54 +2966,55 @@
inherits inherit-contracts inherit-fields inherit-field-contracts inherits inherit-contracts inherit-fields inherit-field-contracts
supers super-contracts inners inner-contracts supers super-contracts inners inner-contracts
overrides override-contracts augments augment-contracts overrides override-contracts augments augment-contracts
augrides augride-contracts absents absent-fields opaque?) augrides augride-contracts absents absent-fields opaque? name)
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:projection class/c-proj #:projection class/c-proj
#:name #:name
(λ (ctc) (λ (ctc)
(let* ([pair-ids-ctcs (or (class/c-name ctc)
(λ (is ctcs) (let* ([pair-ids-ctcs
(for/list ([i (in-list is)] (λ (is ctcs)
[ctc (in-list ctcs)]) (for/list ([i (in-list is)]
(if (not ctc) [ctc (in-list ctcs)])
i (if (not ctc)
(build-compound-type-name i ctc))))] i
[handle-optional (build-compound-type-name i ctc))))]
(λ (name is ctcs) [handle-optional
(if (null? is) (λ (name is ctcs)
null (if (null? is)
(list (cons name (pair-ids-ctcs is ctcs)))))] null
[handle-absents (list (cons name (pair-ids-ctcs is ctcs)))))]
(λ (meths fields) [handle-absents
(cond (λ (meths fields)
[(and (null? meths) (null? fields)) (cond
null] [(and (null? meths) (null? fields))
[(null? fields) null]
(list (cons 'absent meths))] [(null? fields)
[else (list (cons 'absent meths))]
(list (list* 'absent (cons 'field fields) meths))]))] [else
[handled-methods (list (list* 'absent (cons 'field fields) meths))]))]
(for/list ([i (in-list (class/c-methods ctc))] [handled-methods
[ctc (in-list (class/c-method-contracts ctc))]) (for/list ([i (in-list (class/c-methods ctc))]
(cond [ctc (in-list (class/c-method-contracts ctc))])
[ctc (build-compound-type-name i ctc)] (cond
[else i]))]) [ctc (build-compound-type-name i ctc)]
(apply build-compound-type-name [else i]))])
'class/c (apply build-compound-type-name
(append 'class/c
handled-methods (append
(handle-optional 'init (class/c-inits ctc) (class/c-init-contracts ctc)) handled-methods
(handle-optional 'field (class/c-fields ctc) (class/c-field-contracts ctc)) (handle-optional 'init (class/c-inits ctc) (class/c-init-contracts ctc))
(handle-optional 'inherit (class/c-inherits ctc) (class/c-inherit-contracts ctc)) (handle-optional 'field (class/c-fields ctc) (class/c-field-contracts ctc))
(handle-optional 'inherit-field (class/c-inherit-fields ctc) (class/c-inherit-field-contracts ctc)) (handle-optional 'inherit (class/c-inherits ctc) (class/c-inherit-contracts ctc))
(handle-optional 'super (class/c-supers ctc) (class/c-super-contracts ctc)) (handle-optional 'inherit-field (class/c-inherit-fields ctc) (class/c-inherit-field-contracts ctc))
(handle-optional 'inner (class/c-inners ctc) (class/c-inner-contracts ctc)) (handle-optional 'super (class/c-supers ctc) (class/c-super-contracts ctc))
(handle-optional 'override (class/c-overrides ctc) (class/c-override-contracts ctc)) (handle-optional 'inner (class/c-inners ctc) (class/c-inner-contracts ctc))
(handle-optional 'augment (class/c-augments ctc) (class/c-augment-contracts ctc)) (handle-optional 'override (class/c-overrides ctc) (class/c-override-contracts ctc))
(handle-optional 'augride (class/c-augrides ctc) (class/c-augride-contracts ctc)) (handle-optional 'augment (class/c-augments ctc) (class/c-augment-contracts ctc))
(handle-absents (class/c-absents ctc) (class/c-absent-fields ctc)))))) (handle-optional 'augride (class/c-augrides ctc) (class/c-augride-contracts ctc))
(handle-absents (class/c-absents ctc) (class/c-absent-fields ctc)))))))
#:first-order #:first-order
(λ (ctc) (λ (ctc)
(λ (cls) (λ (cls)
@ -3201,23 +3202,35 @@
[augride-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augride-contracts null)))] [augride-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augride-contracts null)))]
[absents #`(list #,@(reverse (hash-ref parsed-forms 'absents null)))] [absents #`(list #,@(reverse (hash-ref parsed-forms 'absents null)))]
[absent-fields #`(list #,@(reverse (hash-ref parsed-forms 'absent-fields null)))]) [absent-fields #`(list #,@(reverse (hash-ref parsed-forms 'absent-fields null)))])
(syntax/loc stx (with-syntax ([name
(let* ([inits+contracts (sort (list (cons i i-c) ...) ;; same as syntax-local-infer-name, except doesn't
(lambda (s1 s2) ;; make a name up from the src loc; in that case,
(string<? (symbol->string s1) (symbol->string s2))) ;; we just use the big ole (class/c ...)-based name
#:key car)]) (or (let loop ([prop (syntax-property stx 'inferred-name)])
(make-class/c methods method-ctcs (cond
fields field-ctcs [(symbol? prop) prop]
(map car inits+contracts) (map cdr inits+contracts) [(pair? prop) (or (loop (car prop))
inherits inherit-ctcs (loop (cdr prop)))]
inherit-fields inherit-field-ctcs [else #f]))
supers super-ctcs (syntax-local-name))])
inners inner-ctcs (syntax/loc stx
overrides override-ctcs (let* ([inits+contracts (sort (list (cons i i-c) ...)
augments augment-ctcs (lambda (s1 s2)
augrides augride-ctcs (string<? (symbol->string s1) (symbol->string s2)))
absents absent-fields #:key car)])
opaque?)))))])) (make-class/c methods method-ctcs
fields field-ctcs
(map car inits+contracts) (map cdr inits+contracts)
inherits inherit-ctcs
inherit-fields inherit-field-ctcs
supers super-ctcs
inners inner-ctcs
overrides override-ctcs
augments augment-ctcs
augrides augride-ctcs
absents absent-fields
opaque?
'name))))))]))
(define (check-object-contract obj methods fields fail) (define (check-object-contract obj methods fields fail)
(unless (object? obj) (unless (object? obj)

4
collects/tests/racket/contract-test.rktl
View File

@ -10256,6 +10256,10 @@ so that propagation occurs.
(test-name '(set/c (set/c char?) #:cmp 'eqv) (set/c (set/c char? #:cmp 'dont-care) #:cmp 'eqv)) (test-name '(set/c (set/c char?) #:cmp 'eqv) (set/c (set/c char? #:cmp 'dont-care) #:cmp 'eqv))
(test-name '(set/c (-> char? char?) #:cmp 'equal) (set/c (-> char? char?) #:cmp 'equal)) (test-name '(set/c (-> char? char?) #:cmp 'equal) (set/c (-> char? char?) #:cmp 'equal))
(test-name '(class/c [m (->m integer? integer?)]) (class/c [m (->m integer? integer?)]))
(test-name 'c%/c (let ([c%/c (class/c [m (->m integer? integer?)])])
c%/c))
;; NOT YET RELEASED ;; NOT YET RELEASED
#; #;
(test-name '(pr/dc [x integer?] (test-name '(pr/dc [x integer?]