From 937bb7a7c493f39e60ccab96d1a98910ae5da303 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Tue, 20 Nov 2018 13:20:31 +0000
Subject: [PATCH] Identify, expose, and repair bug (using the new
 `opaque-placeholder`)

---
 syndicate/term.rkt                          |  7 +-
 syndicate/test/core/nesting-confusion-2.rkt | 79 +++++++++++++++++++++
 2 files changed, 85 insertions(+), 1 deletion(-)
 create mode 100644 syndicate/test/core/nesting-confusion-2.rkt

diff --git a/syndicate/term.rkt b/syndicate/term.rkt
index 54c3e4f..2dd2644 100644
--- a/syndicate/term.rkt
+++ b/syndicate/term.rkt
@@ -74,6 +74,11 @@
   (apply (struct-type-make-constructor (struct->struct-type t))
          (map f (struct-fields t))))
 
+(struct opaque-placeholder ())
+;; ^ not transparent or prefab -- used to frustrate
+;; otherwise-potentially-matching constant positions in instantiated
+;; terms
+
 (define (instantiate-term->value t actuals)
   (define (pop-actual!)
     (define v (car actuals))
@@ -101,7 +106,7 @@
        (begin0 (pop-actual!)
          (pop-captures! detail))] ;; to consume nested bindings
       [(discard)
-       (discard)]
+       (opaque-placeholder)]
       [(? non-object-struct?)
        (struct-map walk t)]
       [(? list?)
diff --git a/syndicate/test/core/nesting-confusion-2.rkt b/syndicate/test/core/nesting-confusion-2.rkt
new file mode 100644
index 0000000..7d94b0d
--- /dev/null
+++ b/syndicate/test/core/nesting-confusion-2.rkt
@@ -0,0 +1,79 @@
+#lang imperative-syndicate/test-implementation
+;; 2018-11-20 Prior to the commit that introduced this test case (and
+;; fixed the bug it exposed), matching a constant/literal `(discard)`
+;; in an `inbound` pattern would match a visibility-restricted term,
+;; so long as the captures were in the right places. After the fix,
+;; `instantiate-term->value` replaces `(discard)` in the term with an
+;; opaque value that cannot match any other value, meaning that only
+;; patterns which completely ignore `discard`ed positions will match.
+;;
+;; Previously, the test-case marked (B) below yielded the correct
+;; output, but (A) yielded the following incorrect output:
+;;
+;;     Added discarded topic: Computering
+;;     Added discarded topic: Bicycling
+;;     Added discarded topic: Evil
+;;     Added discarded topic: Cryptography
+;;     Added topic: Computering
+;;     Added topic: Bicycling
+;;     Added topic: Evil
+;;     Added topic: Cryptography
+;;
+;; Now both yield the same output.
+
+(require (only-in imperative-syndicate/pattern discard capture))
+
+(assertion-struct researcher (name topic))
+
+(define-syntax-rule (correct-topics)
+  (expected-output (set "Added topic: Bicycling"
+                        "Added topic: Computering"
+                        "Added topic: Cryptography"
+                        "Added topic: Evil")))
+
+(test-case ;; (A)
+    [(spawn #:name 'tony
+            (assert (researcher "Tony" "Computering"))
+            (assert (researcher "Tony" "Bicycling")))
+     (spawn #:name 'alice
+            (assert (researcher "Alice" "Cryptography"))
+            (assert (researcher "Alice" "Bicycling")))
+     (spawn #:name 'eve
+            (assert (researcher "Eve" "Cryptography"))
+            (assert (researcher "Eve" "Computering"))
+            (assert (researcher "Eve" "Evil")))
+
+     (dataspace #:name 'inner-dataspace
+                (spawn #:name 'all-topics
+                       (during (inbound (researcher _ $topic))
+                         (on-start (printf "Added topic: ~a\n" topic))
+                         (on-stop (printf "Removed topic: ~a\n" topic))))
+                (spawn #:name 'all-researchers
+                       (during (inbound (researcher (discard) $topic))
+                         (on-start (printf "Added discarded topic: ~a\n" topic))
+                         (on-stop (printf "Removed discarded topic: ~a\n" topic)))))]
+  no-crashes
+  (correct-topics))
+
+(test-case ;; (B)
+    [(spawn #:name 'tony
+            (assert (researcher "Tony" "Computering"))
+            (assert (researcher "Tony" "Bicycling")))
+     (spawn #:name 'alice
+            (assert (researcher "Alice" "Cryptography"))
+            (assert (researcher "Alice" "Bicycling")))
+     (spawn #:name 'eve
+            (assert (researcher "Eve" "Cryptography"))
+            (assert (researcher "Eve" "Computering"))
+            (assert (researcher "Eve" "Evil")))
+
+     (spawn #:name 'all-topics
+            (during (researcher _ $topic)
+              (on-start (printf "Added topic: ~a\n" topic))
+              (on-stop (printf "Removed topic: ~a\n" topic))))
+     (spawn #:name 'all-researchers
+            (during (researcher (discard) $topic)
+              (on-start (printf "Added discarded topic: ~a\n" topic))
+              (on-stop (printf "Removed discarded topic: ~a\n" topic))))]
+  no-crashes
+  (correct-topics))