From d7095c9995a702977468a4955172a1ffab6145c9 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Fri, 23 Oct 2015 19:49:30 -0400
Subject: [PATCH] quit-world action

---
 prospect/core.rkt                        |  6 +++-
 prospect/examples/example-quit-world.rkt | 36 ++++++++++++++++++++++++
 prospect/trace/stderr.rkt                |  5 +++-
 3 files changed, 45 insertions(+), 2 deletions(-)
 create mode 100644 prospect/examples/example-quit-world.rkt

diff --git a/prospect/core.rkt b/prospect/core.rkt
index 2924c1c..6f06626 100644
--- a/prospect/core.rkt
+++ b/prospect/core.rkt
@@ -3,6 +3,7 @@
 
 (provide (struct-out message)
          (except-out (struct-out quit) quit)
+         (struct-out quit-world)
          (rename-out [quit <quit>])
          (except-out (struct-out spawn) spawn)
          (rename-out [spawn <spawn>])
@@ -73,6 +74,7 @@
 
 ;; Actions ⊃ Events
 (struct spawn (boot) #:prefab)
+(struct quit-world () #:prefab) ;; NB. An action. Compare (quit), a Transition.
 
 ;; A Behavior is a ((Option Event) Any -> Transition): a function
 ;; mapping an Event (or, in the #f case, a poll signal) and a
@@ -115,7 +117,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define (event? x) (or (patch? x) (message? x)))
-(define (action? x) (or (event? x) (spawn? x)))
+(define (action? x) (or (event? x) (spawn? x) (quit-world? x)))
 
 (define (prepend-at-meta pattern level)
   (if (zero? level)
@@ -333,6 +335,8 @@
                       ;; ^ behavior & state already removed by disable-process
                       patches
                       meta-action)]
+    [(quit-world)
+     (make-quit)]
     [(? patch? delta-orig)
      (define-values (new-mux _label patches meta-action)
        (mux-update-stream (world-mux w) label delta-orig))
diff --git a/prospect/examples/example-quit-world.rkt b/prospect/examples/example-quit-world.rkt
new file mode 100644
index 0000000..d7c7008
--- /dev/null
+++ b/prospect/examples/example-quit-world.rkt
@@ -0,0 +1,36 @@
+#lang prospect
+;; Demonstrates quit-world.
+
+(require (only-in racket/port read-bytes-line-evt))
+
+(define (spawn-command-listener)
+  (spawn (lambda (e s)
+           (match e
+             [(message (at-meta (at-meta (external-event _ (list #"quit")))))
+              (printf "Quitting just the leaf actor.\n")
+              (quit)]
+             [(message (at-meta (at-meta (external-event _ (list #"quit-world")))))
+              (printf "Terminating the whole network.\n")
+              (transition s (quit-world))]
+             [_ #f]))
+         (void)
+         (sub (external-event (read-bytes-line-evt (current-input-port) 'any) ?)
+              #:meta-level 2)))
+
+(define (spawn-ticker)
+  (define (sub-to-alarm)
+    (sub (external-event (alarm-evt (+ (current-inexact-milliseconds) 1000)) ?) #:meta-level 2))
+  (spawn (lambda (e s)
+           (match e
+             [(message (at-meta (at-meta (external-event _ _))))
+              (printf "Tick!\n")
+              (transition s
+                          (list (retract ?)
+                                (sub-to-alarm)))]
+             [_ #f]))
+         (void)
+         (sub-to-alarm)))
+
+(printf "Type 'quit' or 'quit-world'.\n")
+(spawn-world (spawn-command-listener)
+             (spawn-ticker))
diff --git a/prospect/trace/stderr.rkt b/prospect/trace/stderr.rkt
index 1b9e256..de4745c 100644
--- a/prospect/trace/stderr.rkt
+++ b/prospect/trace/stderr.rkt
@@ -171,6 +171,9 @@
               (unless (matcher-empty? interests)
                 (output "~a's final interests:\n" pidstr)
                 (pretty-print-matcher interests (current-error-port))))]
+           [(quit-world)
+            (with-color BRIGHT-RED
+              (output "Process ~a performed a quit-world.\n" pidstr))]
            [(? patch? p)
             (when (or show-actions? show-patch-actions?)
               (output "~a performing a patch:\n" pidstr)
@@ -180,7 +183,7 @@
               (output "~a sending a message:\n" pidstr)
               (pretty-write body (current-error-port)))])]
         [('internal-action-result (list pids a old-w t))
-         (when t
+         (when (transition? t)
            (define new-w (transition-state t))
            (define pidstr (format-pids pids))
            (define newcount (hash-count (world-behaviors new-w)))