From 552d6de95368eadd25c27f3fab1090fa9f035043 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Fri, 22 Jun 2012 16:20:42 -0400 Subject: [PATCH] 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 | 118 +++++++++++++++++++ collects/scribblings/reference/generic.scrbl | 23 ++++ collects/tests/generic/contract.rkt | 53 +++++++++ collects/tests/generic/tests.rkt | 1 + 4 files changed, 195 insertions(+) create mode 100644 collects/tests/generic/contract.rkt diff --git a/collects/racket/private/generic.rkt b/collects/racket/private/generic.rkt index f85cfc856c..1432cb46be 100644 --- a/collects/racket/private/generic.rkt +++ b/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)) diff --git a/collects/scribblings/reference/generic.scrbl b/collects/scribblings/reference/generic.scrbl index a9cc47f211..6c94941c07 100644 --- a/collects/scribblings/reference/generic.scrbl +++ b/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] diff --git a/collects/tests/generic/contract.rkt b/collects/tests/generic/contract.rkt new file mode 100644 index 0000000000..3a7ca9cccc --- /dev/null +++ b/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) diff --git a/collects/tests/generic/tests.rkt b/collects/tests/generic/tests.rkt index 2dc252deea..1270fa31c6 100644 --- a/collects/tests/generic/tests.rkt +++ b/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")