From bd65204760da41f15999fb3cca560b16b6321874 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonyg@leastfixedpoint.com>
Date: Thu, 10 Jun 2021 13:29:19 +0200
Subject: [PATCH] entity/stop-on-retract

---
 syndicate/driver-support.rkt |  4 ++--
 syndicate/drivers/tcp.rkt    |  3 ---
 syndicate/drivers/timer.rkt  |  1 -
 syndicate/syntax.rkt         | 11 +++++++----
 4 files changed, 9 insertions(+), 10 deletions(-)

diff --git a/syndicate/driver-support.rkt b/syndicate/driver-support.rkt
index be407fa..800a598 100644
--- a/syndicate/driver-support.rkt
+++ b/syndicate/driver-support.rkt
@@ -9,9 +9,9 @@
 
 (define-logger syndicate/driver-support)
 
-(define (linked-thread peer
-                       thread-proc
+(define (linked-thread thread-proc
                        #:name [name (gensym 'linked-thread)]
+                       #:peer [peer (ref (entity/stop-on-retract #:name (list name 'monitor)))]
                        #:custodian [c (make-custodian)])
   (define handle #f)
   (define armed? #t)
diff --git a/syndicate/drivers/tcp.rkt b/syndicate/drivers/tcp.rkt
index e0d91f0..873cb75 100644
--- a/syndicate/drivers/tcp.rkt
+++ b/syndicate/drivers/tcp.rkt
@@ -38,7 +38,6 @@
   (on-stop  (log-syndicate/drivers/tcp-info "-listener on ~v ~v" host port))
   (linked-thread
    #:name (list (TcpInbound host port) 'thread)
-   (ref (entity #:name 'listen-monitor #:retract (lambda (_handle) (stop-current-facet))))
    (lambda (facet)
      (define listener (tcp-listen port 512 #t host))
      (let loop ()
@@ -103,8 +102,6 @@
   (linked-thread
    #:name (list name 'input-thread)
    #:custodian custodian
-   (ref (entity #:name (list name 'socket-monitor)
-                #:retract (lambda (_handle) (stop-current-facet))))
    (lambda (facet)
      (let loop ()
        (define bs (read-bytes-avail i))
diff --git a/syndicate/drivers/timer.rkt b/syndicate/drivers/timer.rkt
index d999851..25a5bb8 100644
--- a/syndicate/drivers/timer.rkt
+++ b/syndicate/drivers/timer.rkt
@@ -24,7 +24,6 @@
 
     (linked-thread
      #:name 'timer-driver-thread
-     (ref (entity #:name 'timer-monitor #:retract (lambda (_handle) (stop-current-facet))))
      (lambda (facet)
        (struct pending-timer (deadline label) #:transparent)
 
diff --git a/syndicate/syntax.rkt b/syndicate/syntax.rkt
index 3b5b7f5..3128932 100644
--- a/syndicate/syntax.rkt
+++ b/syndicate/syntax.rkt
@@ -24,6 +24,7 @@
          begin/dataflow
          define/dataflow
          stop-when-true
+         entity/stop-on-retract
 
          this-target
          at
@@ -123,6 +124,9 @@
     (when test
       (stop-current-facet expr ...))))
 
+(define (entity/stop-on-retract #:name [name 'stop-on-retract] [k void])
+  (entity #:name name #:retract (lambda (_handle) (stop-current-facet (k)))))
+
 ;;---------------------------------------------------------------------------
 
 (define-for-syntax orig-insp
@@ -217,15 +221,14 @@
                            (match-define (list #,@(analyse-pattern-bindings #'pat)) bindings)
                            (define name name-stx.N)
                            (define monitor
-                             (ref (entity #:name (list name 'monitor-in-parent)
-                                          #:retract (lambda (_handle) (stop-current-facet)))))
+                             (ref (entity/stop-on-retract #:name (list name 'monitor-in-parent))))
                            (define monitor-handle (turn-assert! this-turn monitor 'alive))
                            (turn-spawn! this-turn
                                         #:name name
                                         #:daemon? daemon.D
                                         #:link
-                                        (entity #:name (list name 'monitor-in-child)
-                                                #:retract (lambda (_handle) (stop-current-facet)))
+                                        (entity/stop-on-retract #:name
+                                                                (list name 'monitor-in-child))
                                         (lambda () expr ...)
                                         (hasheq monitor-handle #t)))))))])))