racket/generics: add contract combinator

The generics library now generates a `name/c` macro
for a generic interface `name`. The combinator can be
used to contract instances (or constructors) of a
generic interface across standard contract boundaries.

collects/racket/private/generic.rkt

@@ -1,5 +1,7 @@
 #lang racket/base
 (require racket/local
+         racket/contract/base
+         racket/contract/combinator
          (for-syntax racket/base
                      racket/local
                      racket/syntax)
@@ -135,6 +137,10 @@
                (for/hash ([name (in-list '(#,@(map syntax->datum generics)))]
                           [gen (in-vector (get-generics this))])
                  (values name (not (not gen)))))
+             ;; Define the contract that goes with this generic interface
+             (define-generics-contract header name? get-generics
+               (generic generic-idx) ...)
+             ;; Define generic functions
              (define generic
                (generic-arity-coerce
                 (make-keyword-procedure
@@ -156,3 +162,115 @@
                              (error 'generic "not implemented for ~e" this)))
                        (raise-argument-error 'generic name-str this))))))
              ...)))]))
+
+;; generate a contract combinator for instances of a generic interface
+(define-syntax (define-generics-contract stx)
+  (syntax-case stx ()
+    [(_ name name? accessor (generic generic-idx) ...)
+     (with-syntax ([name/c (format-id #'name "~a/c" #'name)])
+       #'(define-syntax (name/c stx)
+           (syntax-case stx ()
+             [(_ [method-id ctc] (... ...))
+              (andmap (λ (id) (and (identifier? id)
+                                   ;; make sure the ids are all
+                                   ;; in the interface
+                                   (member (syntax-e id) (list 'generic ...))))
+                      (syntax->list #'(method-id  (... ...))))
+              #'(make-generic-instance/c
+                 name?
+                 accessor
+                 (list 'method-id (... ...))
+                 (list ctc (... ...))
+                 (make-immutable-hash
+                  (list (cons 'generic generic-idx) ...)))])))]))
+
+;; make a generic instance contract
+(define (make-generic-instance/c name? accessor ids ctc-args method-map)
+  (define ctcs (coerce-contracts 'generic-instance/c ctc-args))
+  ;; map method table indices to ids & projections
+  (define id+ctc-map
+    (for/hash ([id ids] [ctc ctcs])
+      (values (hash-ref method-map id)
+              (cons id (contract-projection ctc)))))
+  (cond [(andmap chaperone-contract? ctcs)
+         (chaperone-generic-instance/c
+          name? ids ctcs accessor id+ctc-map method-map)]
+        [else
+         (impersonator-generic-instance/c
+          name? ids ctcs accessor id+ctc-map method-map)]))
+
+(define (generic-instance/c-name ctc)
+  (define method-names
+    (map (λ (id ctc) (build-compound-type-name id ctc))
+         (base-generic-instance/c-ids ctc)
+         (base-generic-instance/c-ctcs ctc)))
+  (apply build-compound-type-name
+         (cons 'generic-instance/c method-names)))
+
+;; redirect for use with chaperone-vector
+(define ((method-table-redirect ctc blame) vec idx val)
+  (define id+ctc-map (base-generic-instance/c-id+ctc-map ctc))
+  (define maybe-id+ctc (hash-ref id+ctc-map idx #f))
+  (cond [maybe-id+ctc
+         (define id (car maybe-id+ctc))
+         (define proj (cdr maybe-id+ctc))
+         (define blame-string (format "the ~a method of" id))
+         ((proj (blame-add-context blame blame-string)) val)]
+        [else val]))
+
+;; projection for generic methods
+(define ((generic-instance/c-proj proxy-struct) ctc)
+  (λ (blame)
+    ;; for redirecting the method table accessor
+    (define (redirect struct v)
+      (chaperone-vector
+       v
+       (method-table-redirect ctc blame)
+       (λ (vec i v) v)))
+    (λ (val)
+      (unless (contract-first-order-passes? ctc val)
+        (raise-blame-error
+         blame val
+         '(expected: "~s," given: "~e")
+         (contract-name ctc)
+         val))
+      (define accessor (base-generic-instance/c-accessor ctc))
+      (proxy-struct val accessor redirect))))
+
+;; recognizes instances of this generic interface
+(define ((generic-instance/c-first-order ctc) v)
+  (cond [((base-generic-instance/c-name? ctc) v)
+         (define accessor (base-generic-instance/c-accessor ctc))
+         (define method-table (accessor v))
+         (define ids (base-generic-instance/c-ids ctc))
+         (define ctcs (base-generic-instance/c-ctcs ctc))
+         (define method-map (base-generic-instance/c-method-map ctc))
+         ;; do sub-contract first-order checks
+         (for/and ([id ids] [ctc ctcs])
+           (contract-first-order-passes?
+            ctc
+            (vector-ref method-table (hash-ref method-map id))))]
+        [else #f]))
+
+;; name?       - for first-order checks
+;; ids         - for method names (used to build the ctc name)
+;; ctcs        - for the contract name
+;; accessor    - for chaperoning the struct type property
+;; id+ctc-map  - for chaperoning the method table vector
+;; method-map  - for first-order checks
+(struct base-generic-instance/c
+  (name? ids ctcs accessor id+ctc-map method-map))
+
+(struct chaperone-generic-instance/c base-generic-instance/c ()
+  #:property prop:chaperone-contract
+  (build-chaperone-contract-property
+   #:projection (generic-instance/c-proj chaperone-struct)
+   #:first-order generic-instance/c-first-order
+   #:name generic-instance/c-name))
+
+(struct impersonator-generic-instance/c base-generic-instance/c ()
+  #:property prop:contract
+  (build-contract-property
+   #:projection (generic-instance/c-proj impersonate-struct)
+   #:first-order generic-instance/c-first-order
+   #:name generic-instance/c-name))

collects/scribblings/reference/generic.scrbl

@@ -40,6 +40,12 @@ Defines
        corresponding method on values where
        @racket[id]@racketidfont{?} is true.}
 
+ @item{@racket[id]@racketidfont{/c} as a contract combinator that
+       recognizes instances of structure types which implement the
+       @racketidfont{gen:}@racket[id] generic interface. The combinator
+       takes pairs of @racket[method-id]s and contracts. The contracts
+       will be applied to each of the corresponding method implementations.}
+
 ]
 
 Each @racket[method-id]'s @racket[kw-formals*] must include a required
@@ -55,6 +61,9 @@ implemented by the instance. This table is intended for use by
 higher-level APIs to adapt their behavior depending on method
 availability.}
 
+The @racket[id]@racketidfont{/c} combinator is intended to be used to
+contract the range of a constructor procedure for a struct type that
+implements the generic interface.
 
 @defform[(define/generic local-id method-id)
          #:contracts
@@ -77,6 +86,7 @@ syntax error.}
 @(define (new-evaluator)
    (let* ([e (make-base-eval)])
      (e '(require (for-syntax racket/base)
+                  racket/contract
                   racket/generic))
      e))
 
@@ -121,6 +131,19 @@ syntax error.}
 (gen-print y)
 (gen-port-print (current-output-port) y)
 (gen-print* y #:width 100 #:height 90)
+
+(define/contract make-num-contracted
+  (-> number?
+      (printable/c
+        [gen-print (->* (printable?) (output-port?) void?)]
+        [gen-port-print (-> output-port? printable? void?)]
+        [gen-print* (->* (printable? #:width exact-nonnegative-integer?)
+                         (output-port? #:height exact-nonnegative-integer?)
+                         void?)]))
+   make-num)
+
+(define z (make-num-contracted 10))
+(gen-print* z #:width "not a number" #:height 5)
 ]
 
 @close-eval[evaluator]

collects/tests/generic/contract.rkt

@@ -0,0 +1,53 @@
+#lang racket/load
+
+(module a racket/base
+  (require racket/generic)
+
+  (define-generics simple-dict
+    (dict-ref    simple-dict key [default])
+    (dict-set    simple-dict key val)
+    (dict-remove simple-dict key))
+
+  (provide dict-ref
+           dict-set
+           dict-remove
+           gen:simple-dict
+           simple-dict?
+           simple-dict/c))
+
+(module b racket/base
+  (require 'a racket/contract)
+
+  ;; same as in "alist.rkt"
+  (define-struct alist (v)
+    #:methods gen:simple-dict
+    [(define (dict-ref dict key
+                       [default (lambda () (error "key not found" key))])
+       (cond [(assoc key (alist-v dict)) => cdr]
+             [else (if (procedure? default) (default) default)]))
+     (define (dict-set dict key val)
+       (alist (cons (cons key val) (alist-v dict))))
+     (define (dict-remove dict key)
+       (define al (alist-v dict))
+       (remove* (assoc key al) al))])
+
+  (provide/contract
+   [make-alist
+    (-> list?
+        (simple-dict/c
+         [dict-ref (->* (simple-dict? symbol?) (any/c) integer?)]
+         [dict-set (-> simple-dict? symbol? integer? simple-dict?)]
+         [dict-remove (-> simple-dict? symbol? simple-dict?)]))]))
+
+(module c racket/base
+  (require 'a 'b rackunit)
+
+  (define dict (make-alist '((a . 5) (b . 10))))
+  (check-equal? (dict-ref dict 'a) 5)
+  (check-equal? (dict-ref dict 'b) 10)
+  (check-exn exn:fail:contract?
+             (λ () (dict-set dict 'a "bad")))
+  (check-exn exn:fail:contract?
+             (λ () (dict-set dict "bad" 5))))
+
+(require 'c)

collects/tests/generic/tests.rkt

@@ -8,4 +8,5 @@
          (submod "struct-form.rkt" test)
          (submod "equal+hash.rkt" test)
          (submod "custom-write.rkt" test)
+         "contract.rkt"
          "from-unstable.rkt")