From a5d10076963ff93a2d3c7bc5c13825f0a12f4cd2 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Tue, 21 Aug 2012 12:04:16 -0400
Subject: [PATCH] racket/generic: allow impersonator contracts

This enables the use of polymorphic contracts with generic
interfaces and their instances.
---
 collects/racket/private/generic.rkt       | 11 +++--
 collects/tests/generic/poly-contracts.rkt | 59 +++++++++++++++++++++++
 collects/tests/generic/tests.rkt          |  3 +-
 3 files changed, 67 insertions(+), 6 deletions(-)
 create mode 100644 collects/tests/generic/poly-contracts.rkt

diff --git a/collects/racket/private/generic.rkt b/collects/racket/private/generic.rkt
index 8cfbffaadd..ffbc284110 100644
--- a/collects/racket/private/generic.rkt
+++ b/collects/racket/private/generic.rkt
@@ -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))
diff --git a/collects/tests/generic/poly-contracts.rkt b/collects/tests/generic/poly-contracts.rkt
new file mode 100644
index 0000000000..1c59b03ffa
--- /dev/null
+++ b/collects/tests/generic/poly-contracts.rkt
@@ -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)
diff --git a/collects/tests/generic/tests.rkt b/collects/tests/generic/tests.rkt
index 1b168632b6..f40763cfe9 100644
--- a/collects/tests/generic/tests.rkt
+++ b/collects/tests/generic/tests.rkt
@@ -10,4 +10,5 @@
          (submod "custom-write.rkt" test)
          "base-interfaces.rkt"
          "contract.rkt"
-         "from-unstable.rkt")
+         "from-unstable.rkt"
+         "poly-contracts.rkt")