Add contracts to interface syntax & structures

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 ...)))]
+       (let ([name (syntax-local-infer-name stx)])
-             [name (syntax-local-infer-name stx)])
+         (define-values (vars ctcs)
-         (for-each
+           (for/fold ([vars '()] [ctcs '()])
-          (lambda (v)
+                     ([v (syntax->list #'(var ...))])
-            (unless (identifier? v)
+             (syntax-case v ()
-              (raise-syntax-error #f
+               [id
-                                  "not an identifier"
+                (identifier? #'id)
-                                  stx
+                (values (cons #'id vars) (cons #f ctcs))]
-                                  v)))
+               [(id ctc)
-          vars)
+                (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 
+        (let ([i (interface-make name supers #f (hash-map ht (lambda (k v) k))
-                                 (hash-map prop-ht (lambda (k v) v)))])
+                                 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%

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 ...) 
+@defform/subs[(interface* (super-interface-expr ...)
-                     ([property-expr val-expr] ...)
+                          ([property-expr val-expr] ...)
-           id ...)]{
+                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

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?)
+    
 ;                                                                                    
 ;                                                                                    
 ;