From 8106d318f1b129301423d855104ff4d9c1c38542 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Fri, 13 Mar 2015 16:49:42 -0400
Subject: [PATCH] Fix first-order check for TR's opaque object/c

Closes PR 15003
---
 .../typed-racket/utils/opaque-object.rkt      | 20 +++++++++++++------
 typed-racket-test/gui/succeed/pr15003.rkt     | 14 +++++++++++++
 2 files changed, 28 insertions(+), 6 deletions(-)
 create mode 100644 typed-racket-test/gui/succeed/pr15003.rkt

diff --git a/typed-racket-lib/typed-racket/utils/opaque-object.rkt b/typed-racket-lib/typed-racket/utils/opaque-object.rkt
index 86355b20..8c7e2f42 100644
--- a/typed-racket-lib/typed-racket/utils/opaque-object.rkt
+++ b/typed-racket-lib/typed-racket/utils/opaque-object.rkt
@@ -40,6 +40,7 @@
 (define ((object/c-opaque-proj ctc) blame)
   (λ (obj)
     (match-define (base-object/c-opaque
+                   base-ctc
                    methods method-ctcs
                    fields field-ctcs)
                   ctc)
@@ -67,9 +68,14 @@
     (((contract-projection guard/c) blame) obj)))
 
 (struct base-object/c-opaque
-  (method-names method-ctcs field-names field-ctcs)
+  (obj/c ; keep a copy of the normal object/c for first-order checks
+   method-names method-ctcs field-names field-ctcs)
   #:property prop:contract
   (build-contract-property
+   #:first-order (λ (ctc)
+                   (define obj/c (base-object/c-opaque-obj/c ctc))
+                   (λ (val)
+                     (contract-first-order-passes? obj/c val)))
    #:projection object/c-opaque-proj))
 
 (begin-for-syntax
@@ -90,11 +96,13 @@
   (syntax-parse stx
    [(_ ?clause:object/c-clause ...)
     (syntax/loc stx
-      (base-object/c-opaque
-       (append ?clause.method-names ...)
-       (append ?clause.method-ctcs ...)
-       (append ?clause.field-names ...)
-       (append ?clause.field-ctcs ...)))]))
+      (let ([names  (append ?clause.method-names ...)]
+            [ctcs   (append ?clause.method-ctcs ...)]
+            [fnames (append ?clause.field-names ...)]
+            [fctcs  (append ?clause.field-ctcs ...)])
+        (base-object/c-opaque
+         (dynamic-object/c names ctcs fnames fctcs)
+         names ctcs fnames fctcs)))]))
 
 ;; This contract combinator prevents the method call if the target
 ;; method is typed (assuming that the caller is untyped or the receiving
diff --git a/typed-racket-test/gui/succeed/pr15003.rkt b/typed-racket-test/gui/succeed/pr15003.rkt
new file mode 100644
index 00000000..731ad134
--- /dev/null
+++ b/typed-racket-test/gui/succeed/pr15003.rkt
@@ -0,0 +1,14 @@
+#lang racket/gui
+
+;; make sure the first-order check for opaque object/c
+;; can distinguish Pasteboard% and Text% objects
+
+(module t typed/racket/gui
+  (define snip (make-object string-snip% "foo"))
+  (provide snip))
+
+(require 't)
+
+(define p (new pasteboard%))
+(send p insert snip)
+(send (send snip get-admin) get-editor)