From 8e2179a6eb028b3399e0d8fa9676c1dc138429a2 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sat, 19 Dec 2015 10:38:04 -0600
Subject: [PATCH] port struct-type-property/c to late-neg and add some tests
 for it

---
 .../racket/contract/struct-type-property.rkt  | 77 +++++++++++++++++++
 .../racket/contract/private/struct-prop.rkt   | 16 ++--
 2 files changed, 85 insertions(+), 8 deletions(-)
 create mode 100644 pkgs/racket-test/tests/racket/contract/struct-type-property.rkt

diff --git a/pkgs/racket-test/tests/racket/contract/struct-type-property.rkt b/pkgs/racket-test/tests/racket/contract/struct-type-property.rkt
new file mode 100644
index 0000000000..45d8023be1
--- /dev/null
+++ b/pkgs/racket-test/tests/racket/contract/struct-type-property.rkt
@@ -0,0 +1,77 @@
+#lang racket/base
+
+(require "test-util.rkt")
+
+(parameterize ([current-contract-namespace
+                (make-basic-contract-namespace)])
+  (test/spec-passed
+   'struct-type-prop.1
+   '(let ()
+      (define-values (_prop prop? prop-ref) (make-struct-type-property 'prop))
+      (define app-prop (contract (-> prop? integer? boolean?)
+                                 (λ (x v) (((prop-ref x) x) v))
+                                 'pos1 'neg1))
+      (define prop (contract (struct-type-property/c (-> prop? (-> integer? boolean?)))
+                             _prop
+                             'pos2 'neg2))
+      (struct s (f) #:property prop (λ (x) (s-f x)))
+      (define s1 (s even?))
+      (app-prop s1 5)))
+
+  (test/neg-blame
+   'struct-type-prop.2
+   '(let ()
+      (define-values (_prop prop? prop-ref) (make-struct-type-property 'prop))
+      (define app-prop (contract (-> prop? integer? boolean?)
+                                 (λ (x v) (((prop-ref x) x) v))
+                                 'pos1 'neg1))
+      (define prop (contract (struct-type-property/c (-> prop? (-> integer? boolean?)))
+                             _prop
+                             'pos2 'neg2))
+      (struct s (f) #:property prop (λ (x) (s-f x)))
+      (define s1 (s even?))
+      (app-prop s1 'apple)))
+
+  (test/neg-blame
+   'struct-type-prop.3
+   '(let ()
+      (define-values (_prop prop? prop-ref) (make-struct-type-property 'prop))
+      (define app-prop (contract (-> prop? integer? boolean?)
+                                 (λ (x v) (((prop-ref x) x) v))
+                                 'pos1 'neg1))
+      (define prop (contract (struct-type-property/c (-> prop? (-> integer? boolean?)))
+                             _prop
+                             'pos 'neg))
+      (struct s (f) #:property prop (λ (x) (s-f x)))
+      (define s2 (s "not a fun"))
+      (app-prop s2 5)))
+
+  (test/neg-blame
+   'struct-type-prop.4
+   '(let ()
+      (define-values (_prop prop? prop-ref) (make-struct-type-property 'prop))
+      (define app-prop (contract (-> prop? integer? boolean?)
+                                 (λ (x v) (((prop-ref x) x) v))
+                                 'pos1 'neg1))
+      (define prop (contract (struct-type-property/c (-> prop? (-> integer? boolean?)))
+                             _prop
+                             'pos 'neg))
+      (struct s (f) #:property prop (λ (x) (s-f x)))
+      (define s3 (s list))
+      (app-prop s3 5)))
+
+  (test/pos-blame
+   'struct-type-prop.5
+   '(let ()
+      (define-values (_prop prop? prop-ref) (make-struct-type-property 'prop))
+      (define app-prop (contract (-> prop? integer? boolean?)
+                                 (λ (x v) (((prop-ref x) x) v))
+                                 'pos1 'neg1))
+      (define prop (contract (struct-type-property/c (-> prop? (-> integer? boolean?)))
+                             _prop
+                             'pos2 'neg2))
+      (struct s (f) #:property prop (λ (x) (s-f x)))
+      (define s3 (s list?))
+      ((prop-ref s3) 'apple)))
+  
+  )
diff --git a/racket/collects/racket/contract/private/struct-prop.rkt b/racket/collects/racket/contract/private/struct-prop.rkt
index 52ee2345b9..24f096d8c2 100644
--- a/racket/collects/racket/contract/private/struct-prop.rkt
+++ b/racket/collects/racket/contract/private/struct-prop.rkt
@@ -5,23 +5,23 @@
          "misc.rkt")
 (provide (rename-out [struct-type-property/c* struct-type-property/c]))
 
-(define (get-stpc-proj stpc)
-  (define get-val-proj
-    (contract-projection
+(define (get-stpc-late-neg-proj stpc)
+  (define get-late-neg-proj
+    (contract-late-neg-projection
      (struct-type-property/c-value-contract stpc)))
   (λ (input-blame)
     (define blame (blame-add-context input-blame "the struct property value of" #:swap? #t))
-    (define val-proj (get-val-proj blame))
-    (λ (x)
+    (define late-neg-proj (get-late-neg-proj blame))
+    (λ (x neg-party)
       (unless (struct-type-property? x)
-        (raise-blame-error input-blame x
+        (raise-blame-error input-blame x #:neg-party
                            '(expected "struct-type-property" given: "~e")
                            x))
       (define-values (nprop _pred _acc)
         (make-struct-type-property
          (wrap-name x)
          (lambda (val _info)
-           (val-proj val))
+           (late-neg-proj val neg-party))
          (list (cons x values))))
       nprop)))
 
@@ -37,7 +37,7 @@
                         'struct-type-property/c
                         (struct-type-property/c-value-contract c)))
               #:first-order (lambda (c) struct-type-property?)
-              #:projection get-stpc-proj))
+              #:late-neg-projection get-stpc-late-neg-proj))
 
 (define struct-type-property/c*
   (let ([struct-type-property/c