From 6f4ad1de254d836b16d5ecfa116e2de5eb71afc1 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Tue, 24 Apr 2012 14:44:48 -0400 Subject: [PATCH] Add contracts to interface syntax & structures --- collects/racket/private/class-internal.rkt | 49 +++++++++++++--------- collects/scribblings/reference/class.scrbl | 17 +++++--- collects/tests/racket/contract-test.rktl | 41 ++++++++++++++++++ 3 files changed, 83 insertions(+), 24 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index a638f1796a..b09cc4f5e0 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -1,5 +1,4 @@ #lang racket/base - (require (for-syntax racket/base) mzlib/etc racket/contract/base @@ -2129,7 +2128,7 @@ [method-names (append (reverse public-names) super-method-ids)] [field-names (append public-field-names super-field-ids)] [super-interfaces (cons (class-self-interface super) interfaces)] - [i (interface-make name super-interfaces #f method-names #f null)] + [i (interface-make name super-interfaces #f method-names (make-immutable-hash) #f null)] [methods (if no-method-changes? (class-methods super) (make-vector method-width))] @@ -3339,16 +3338,19 @@ (lambda (stx m-stx) (syntax-case m-stx () [((interface-expr ...) ([prop prop-val] ...) var ...) - (let ([vars (syntax->list (syntax (var ...)))] - [name (syntax-local-infer-name stx)]) - (for-each - (lambda (v) - (unless (identifier? v) - (raise-syntax-error #f - "not an identifier" - stx - v))) - vars) + (let ([name (syntax-local-infer-name stx)]) + (define-values (vars ctcs) + (for/fold ([vars '()] [ctcs '()]) + ([v (syntax->list #'(var ...))]) + (syntax-case v () + [id + (identifier? #'id) + (values (cons #'id vars) (cons #f ctcs))] + [(id ctc) + (identifier? #'id) + (values (cons #'id vars) (cons #'ctc ctcs))] + [_ (raise-syntax-error #f "not an identifier or identifier-contract pair" + stx v)]))) (let ([dup (check-duplicate-identifier vars)]) (when dup (raise-syntax-error #f @@ -3356,13 +3358,15 @@ stx dup))) (with-syntax ([name (datum->syntax #f name #f)] - [(var ...) (map localize vars)]) + [(var ...) (map localize vars)] + [((v c) ...) (filter (λ (p) (cadr p)) (map list vars ctcs))]) (syntax/loc stx (compose-interface 'name (list interface-expr ...) `(var ...) + (make-immutable-hash (list (cons 'v c) ...)) (list prop ...) (list prop-val ...)))))]))) @@ -3396,12 +3400,13 @@ [all-implemented ; hash-table: interface -> #t #:mutable] public-ids ; (listof symbol) (in any order?!?) + contracts ; (hashof symbol? contract?) [class ; (union #f class) -- means that anything implementing #:mutable] ; this interface must be derived from this class properties) ; (listof (vector gensym prop val)) #:inspector insp) -(define (compose-interface name supers vars props vals) +(define (compose-interface name supers vars ctcs props vals) (for-each (lambda (intf) (unless (interface? intf) @@ -3428,7 +3433,8 @@ (lambda (super) (for-each (lambda (var) - (when (hash-ref ht var #f) + (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) @@ -3438,7 +3444,12 @@ ""))))) (interface-public-ids super))) supers) - ;; Merge properties: + ;; Check that ctcs are contracts + (for ([(k v) (in-hash ctcs)]) + (unless (contract? v) + (obj-error 'interface "contract expression for ~a not a contract: ~a" + k v))) + ;; merge properties: (let ([prop-ht (make-hash)]) ;; Hash on gensym to avoid providing the same property multiple ;; times when it originated from a single interface. @@ -3466,8 +3477,8 @@ (interface-public-ids super))) supers) ;; Done - (let ([i (interface-make name supers #f (hash-map ht (lambda (k v) k)) class - (hash-map prop-ht (lambda (k v) v)))]) + (let ([i (interface-make name supers #f (hash-map ht (lambda (k v) k)) + ctcs class (hash-map prop-ht (lambda (k v) v)))]) (setup-all-implemented! i) i))))) @@ -3513,7 +3524,7 @@ make-)) (define object<%> ((make-naming-constructor struct:interface 'interface:object%) - 'object% null #f null #f null)) + 'object% null #f null (make-immutable-hash) #f null)) (setup-all-implemented! object<%>) (define object% ((make-naming-constructor struct:class 'class:object%) 'object% diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index d9aea7a821..9c1bed8b2f 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -159,7 +159,10 @@ interface is not an object (i.e., there are no ``meta-classes'' or @guideintro["classes"]{classes, objects, and interfaces} -@defform[(interface (super-interface-expr ...) id ...)]{ +@defform/subs[(interface (super-interface-expr ...) name-clause ...) + ([name-clause + id + (id contract-expr)])]{ Produces an interface. The @racket[id]s must be mutually distinct. @@ -177,7 +180,8 @@ includes all of the specified @racket[id]s, plus all identifiers from the superinterfaces. Duplicate identifier names among the superinterfaces are ignored, but if a superinterface contains one of the @racket[id]s in the @racket[interface] expression, the -@exnraise[exn:fail:object]. +@exnraise[exn:fail:object]. A given @racket[id] may be paired with +a corresponding @racket[contract-expr]. If no @racket[super-interface-expr]s are provided, then the derivation requirement of the resulting interface is trivial: any class that @@ -195,9 +199,12 @@ superinterfaces specify inconsistent derivation requirements, the (interface (file-interface) file-list parent-directory)) ]} -@defform[(interface* (super-interface-expr ...) - ([property-expr val-expr] ...) - id ...)]{ +@defform/subs[(interface* (super-interface-expr ...) + ([property-expr val-expr] ...) + name-clause ...) + ([name-clause + id + (id contract-expr)])]{ Like @racket[interface], but also associates to the interface the structure-type properties produced by the @racket[property-expr]s with diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 694db4927c..6b778dbd9e 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -8437,6 +8437,47 @@ (regexp-match #rx"additional info" (exn-message x)) (regexp-match #rx"blaming: neg" (exn-message x))))) +;; interface contracts + + (test/spec-passed + 'interface-1 + '(interface () [x number?])) + + (test/spec-passed + 'interface-2 + '(interface () [x number?] [y number?])) + + (test/spec-passed + 'interface-3 + '(interface () [get-x (-> integer?)])) + + (contract-syntax-error-test + 'interface-4 + '(interface () [x number?] [x symbol?])) + + (contract-error-test + 'interface-5 + '(interface () [x (λ (x y) x)]) + exn:fail?) + + (contract-error-test + 'interface-6 + '(interface ((interface () x)) x) + exn:fail?) + + (test/spec-passed + 'interface-7 + '(interface ((interface () x)) [x integer?])) + + (test/spec-passed + 'interface-8 + '(interface ((interface () [x number?])) [x integer?])) + + (contract-error-test + 'interface-9 + '(interface ((interface () [x number?])) x) + exn:fail?) + ; ; ;