racket/generic: allow impersonator contracts

This enables the use of polymorphic contracts with generic
interfaces and their instances.
This commit is contained in:
Asumu Takikawa 2012-08-21 12:04:16 -04:00
parent 71e81f9fff
commit a5d1007696
3 changed files with 67 additions and 6 deletions

View File

@ -128,7 +128,8 @@
(vector (let ([mthd-generic (vector-ref generic-vector generic-idx)])
(and mthd-generic
(generic-arity-coerce mthd-generic)))
...))))))
...))
null #t))))
;; Hash table mapping method name symbols to
;; whether the given method is implemented
(define (defined-table this)
@ -220,11 +221,11 @@
[else val]))
;; projection for generic methods
(define ((generic-instance/c-proj proxy-struct) ctc)
(define ((generic-instance/c-proj proxy-struct proxy-vector) ctc)
(λ (blame)
;; for redirecting the method table accessor
(define (redirect struct v)
(chaperone-vector
(proxy-vector
v
(method-table-redirect ctc blame)
(λ (vec i v) v)))
@ -266,13 +267,13 @@
(struct chaperone-generic-instance/c base-generic-instance/c ()
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:projection (generic-instance/c-proj chaperone-struct)
#:projection (generic-instance/c-proj chaperone-struct chaperone-vector)
#: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)
#:projection (generic-instance/c-proj impersonate-struct impersonate-vector)
#:first-order generic-instance/c-first-order
#:name generic-instance/c-name))

View File

@ -0,0 +1,59 @@
#lang racket
;; generics with parametric contracts
(require rackunit)
(module stack racket
(require racket/generic)
(define-generics stack
(stack-push stack elem)
(stack-pop stack)
(stack-peek stack))
(define (make-stack/c elem/c)
(define rec-stack/c (recursive-contract (make-stack/c elem/c)))
(stack/c
[stack-push (-> rec-stack/c elem/c rec-stack/c)]
[stack-pop (-> rec-stack/c rec-stack/c)]
[stack-peek (-> rec-stack/c elem/c)]))
(define elem/c (new-∀/c 'elem))
(provide gen:stack
stack?
make-stack/c
;; generic functions have polymorphic contracts
(contract-out
[stack-push (-> (make-stack/c elem/c) elem/c (make-stack/c elem/c))]
[stack-pop (-> (make-stack/c elem/c) (make-stack/c elem/c))]
[stack-peek (-> (make-stack/c elem/c) elem/c)])))
(module instance racket
(require (submod ".." stack))
(define-struct list-stack (l)
#:methods gen:stack
[(define (stack-push stack elem)
(list-stack (cons elem (list-stack-l stack))))
(define (stack-pop stack)
(define lst (list-stack-l stack))
(if (empty? lst)
stack
(list-stack (cdr lst))))
(define (stack-peek stack)
(car (list-stack-l stack)))])
(provide
(contract-out
;; specific instantiation of contract
[list-stack (-> (listof symbol?) (make-stack/c symbol?))])))
(require 'stack 'instance)
(define stack (list-stack '(a b c)))
(check-true (stack? (stack-pop stack)))
(check-equal? (stack-peek stack) 'a)
(check-equal? (stack-peek (stack-push stack 'e)) 'e)

View File

@ -10,4 +10,5 @@
(submod "custom-write.rkt" test)
"base-interfaces.rkt"
"contract.rkt"
"from-unstable.rkt")
"from-unstable.rkt"
"poly-contracts.rkt")