Compare commits
1 Commits
Author | SHA1 | Date |
---|---|---|
Sam Tobin-Hochstadt | 111c202c20 |
17
README.md
17
README.md
|
@ -47,19 +47,6 @@ This repository contains
|
|||
- a sketch of a Haskell implementation of the core routing structures
|
||||
of Syndicate in `hs/`
|
||||
|
||||
## Copyright and License
|
||||
## Copyright
|
||||
|
||||
Copyright © Tony Garnock-Jones 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018.
|
||||
|
||||
This program is free software: you can redistribute it and/or modify
|
||||
it under the terms of the GNU Lesser General Public License as published by
|
||||
the Free Software Foundation, either version 3 of the License, or
|
||||
(at your option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public License
|
||||
along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
Copyright © Tony Garnock-Jones 2010, 2011, 2012, 2013, 2014, 2015, 2016.
|
||||
|
|
|
@ -64,7 +64,7 @@
|
|||
(define (parse-command prefix line)
|
||||
(match-define (pregexp #px"^([^ ]+)( +([^:]+)?(:(.*))?)?$" (list _ command _ params _ rest)) line)
|
||||
(irc-message prefix
|
||||
(string-upcase command)
|
||||
command
|
||||
(string-split (or params ""))
|
||||
rest))
|
||||
|
||||
|
|
|
@ -154,15 +154,6 @@
|
|||
(irc-privmsg (irc-source-nick (nick) (user)) T Text))))]
|
||||
[_ (void)]))])))
|
||||
|
||||
(spawn #:name 'ison-responder
|
||||
(stop-when-reloaded)
|
||||
(define/query-set nicks (ircd-connection-info _ $N _) N)
|
||||
(on (message (ircd-action $conn (irc-message _ "ISON" $SomeNicks $MoreNicks)))
|
||||
(define Nicks (append SomeNicks (string-split (or MoreNicks ""))))
|
||||
(define (on? N) (set-member? (nicks) N))
|
||||
(define Present (string-join (filter on? Nicks) " "))
|
||||
(send! (ircd-event conn (irc-message server-prefix 303 '("*") Present)))))
|
||||
|
||||
(spawn #:name 'session-listener-factory
|
||||
(stop-when-reloaded)
|
||||
(during/spawn (ircd-listener $port)
|
||||
|
|
|
@ -176,22 +176,20 @@
|
|||
(when (and (not (equal? (ip-packet-source-interface p) interface-name))
|
||||
(ip-address-in-subnet? destination network netmask))
|
||||
(define timer-id (gensym 'ippkt))
|
||||
;; v Use `spawn` instead of `react` to avoid gratuitous packet
|
||||
;; reordering.
|
||||
(spawn (on-start (send! (set-timer timer-id 5000 'relative)))
|
||||
(react (on-start (send! (set-timer timer-id 5000 'relative)))
|
||||
(stop-when (message (timer-expired timer-id _))
|
||||
(log-warning "ARP lookup of ~a failed, packet dropped"
|
||||
(ip-address->hostname destination)))
|
||||
(log-warning "ARP lookup of ~a failed, packet dropped"
|
||||
(ip-address->hostname destination)))
|
||||
(stop-when (asserted (arp-query IPv4-ethertype
|
||||
destination
|
||||
($ interface (ethernet-interface interface-name _))
|
||||
$destination-hwaddr))
|
||||
(send! (ethernet-packet interface
|
||||
#f
|
||||
(ethernet-interface-hwaddr interface)
|
||||
destination-hwaddr
|
||||
IPv4-ethertype
|
||||
(format-ip-packet p))))))))
|
||||
(send! (ethernet-packet interface
|
||||
#f
|
||||
(ethernet-interface-hwaddr interface)
|
||||
destination-hwaddr
|
||||
IPv4-ethertype
|
||||
(format-ip-packet p))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
|
@ -75,9 +75,7 @@
|
|||
(define response
|
||||
(string->bytes/utf-8
|
||||
(format (string-append
|
||||
"HTTP/1.0 200 OK\r\n"
|
||||
"Content-Type: text/html\r\n"
|
||||
"\r\n"
|
||||
"HTTP/1.0 200 OK\r\n\r\n"
|
||||
"<h1>Hello world from syndicate-netstack!</h1>\n"
|
||||
"<p>This is running on syndicate's own\n"
|
||||
"<a href='https://github.com/tonyg/syndicate/'>\n"
|
||||
|
@ -85,7 +83,4 @@
|
|||
"<p>There have been ~a requests prior to this one.</p>\n")
|
||||
counter)))
|
||||
(send! (outbound (tcp-channel us them response)))
|
||||
(for [(i 4)]
|
||||
(define buf (make-bytes 1024 (+ #x30 i)))
|
||||
(send! (outbound (tcp-channel us them buf))))
|
||||
(stop-facet (current-facet-id)))))))
|
||||
|
|
|
@ -13,14 +13,10 @@
|
|||
(require "dump-bytes.rkt")
|
||||
(require "checksum.rkt")
|
||||
|
||||
(require/activate syndicate/drivers/timestate)
|
||||
(require/activate syndicate/drivers/timer)
|
||||
(require "ip.rkt")
|
||||
(require "port-allocator.rkt")
|
||||
|
||||
(module+ test (require rackunit))
|
||||
|
||||
(define-logger netstack/tcp)
|
||||
|
||||
;; tcp-address/tcp-address : "kernel" tcp connection state machines
|
||||
;; tcp-handle/tcp-address : "user" outbound connections
|
||||
;; tcp-listener/tcp-address : "user" inbound connections
|
||||
|
@ -50,19 +46,6 @@
|
|||
;; (tcp-port-allocation Number (U TcpHandle TcpListener))
|
||||
(struct tcp-port-allocation (port handle) #:prefab)
|
||||
|
||||
(define (summarize-tcp-packet packet)
|
||||
(format "(~a) ~a:~a -> ~a:~a (seq ~a, ack ~a, flags ~a, window ~a, payload ~a)"
|
||||
(if (tcp-packet-from-wire? packet) "I" "O")
|
||||
(ip-address->hostname (tcp-packet-source-ip packet))
|
||||
(tcp-packet-source-port packet)
|
||||
(ip-address->hostname (tcp-packet-destination-ip packet))
|
||||
(tcp-packet-destination-port packet)
|
||||
(tcp-packet-sequence-number packet)
|
||||
(tcp-packet-ack-number packet)
|
||||
(tcp-packet-flags packet)
|
||||
(tcp-packet-window-size packet)
|
||||
(bit-string-byte-count (tcp-packet-data packet))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; User-accessible driver startup
|
||||
|
||||
|
@ -117,9 +100,10 @@
|
|||
(field [local-peer-present? #f]
|
||||
[remote-peer-present? #f])
|
||||
|
||||
(on-timeout relay-peer-wait-time-msec
|
||||
(when (not (and (local-peer-present?) (remote-peer-present?)))
|
||||
(error 'spawn-relay "TCP relay process timed out waiting for peer")))
|
||||
(on-start (send! (set-timer timer-name relay-peer-wait-time-msec 'relative)))
|
||||
(on (message (timer-expired timer-name _))
|
||||
(when (not (and (local-peer-present?) (remote-peer-present?)))
|
||||
(error 'spawn-relay "TCP relay process timed out waiting for peer")))
|
||||
|
||||
(on (asserted (observe (tcp-channel remote-addr local-user-addr _)))
|
||||
(local-peer-present? #t))
|
||||
|
@ -181,6 +165,16 @@
|
|||
(define-syntax-rule (set-flags! v ...)
|
||||
(begin (unless (zero? v) (set! flags (set-add flags 'v))) ...))
|
||||
(set-flags! ns cwr ece urg ack psh rst syn fin)
|
||||
(log-info "TCP ~a:~a -> ~a:~a (seq ~a, ack ~a, flags ~a, window ~a)"
|
||||
(ip-address->hostname src-ip)
|
||||
src-port
|
||||
(ip-address->hostname dst-ip)
|
||||
dst-port
|
||||
sequence-number
|
||||
ack-number
|
||||
flags
|
||||
window-size)
|
||||
(when spawn-needed? (log-info " - spawn needed!"))
|
||||
(bit-string-case rest
|
||||
([ (opts :: binary bytes (- (* data-offset 4) 20))
|
||||
(data :: binary) ]
|
||||
|
@ -195,9 +189,7 @@
|
|||
window-size
|
||||
(bit-string->bytes opts)
|
||||
(bit-string->bytes data))))
|
||||
(log-netstack/tcp-debug "TCP ~a" (summarize-tcp-packet packet))
|
||||
(when spawn-needed?
|
||||
(log-netstack/tcp-debug " - spawn needed!")
|
||||
(active-state-vectors (set-add (active-state-vectors) statevec))
|
||||
(spawn-state-vector src-ip src-port dst-ip dst-port))
|
||||
(send! packet)))
|
||||
|
@ -205,9 +197,9 @@
|
|||
(else #f)))
|
||||
|
||||
(begin/dataflow
|
||||
(log-netstack/tcp-debug "SCN yielded statevecs ~v and local-ips ~v"
|
||||
(active-state-vectors)
|
||||
(local-ips)))
|
||||
(log-info "SCN yielded statevecs ~v and local-ips ~v"
|
||||
(active-state-vectors)
|
||||
(local-ips)))
|
||||
|
||||
(define (deliver-outbound-packet p)
|
||||
(match-define (tcp-packet #f
|
||||
|
@ -222,7 +214,15 @@
|
|||
options
|
||||
data)
|
||||
p)
|
||||
(log-netstack/tcp-debug "TCP ~a" (summarize-tcp-packet p))
|
||||
(log-info "TCP ~a:~a -> ~a:~a (seq ~a, ack ~a, flags ~a, window ~a)"
|
||||
(ip-address->hostname src-ip)
|
||||
src-port
|
||||
(ip-address->hostname dst-ip)
|
||||
dst-port
|
||||
sequence-number
|
||||
ack-number
|
||||
flags
|
||||
window-size)
|
||||
(define (flag-bit sym) (if (set-member? flags sym) 1 0))
|
||||
(define payload (bit-string (src-port :: integer bytes 2)
|
||||
(dst-port :: integer bytes 2)
|
||||
|
@ -263,111 +263,16 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Per-connection state vector process
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; From the RFC:
|
||||
;;
|
||||
;; Send Sequence Variables
|
||||
;;
|
||||
;; SND.UNA - send unacknowledged
|
||||
;; SND.NXT - send next
|
||||
;; SND.WND - send window
|
||||
;; SND.UP - send urgent pointer
|
||||
;; SND.WL1 - segment sequence number used for last window update
|
||||
;; SND.WL2 - segment acknowledgment number used for last window
|
||||
;; update
|
||||
;; ISS - initial send sequence number
|
||||
;;
|
||||
;; Receive Sequence Variables
|
||||
;;
|
||||
;; RCV.NXT - receive next
|
||||
;; RCV.WND - receive window
|
||||
;; RCV.UP - receive urgent pointer
|
||||
;; IRS - initial receive sequence number
|
||||
;;
|
||||
;; The following diagrams may help to relate some of these variables to
|
||||
;; the sequence space.
|
||||
;;
|
||||
;; Send Sequence Space
|
||||
;;
|
||||
;; 1 2 3 4
|
||||
;; ----------|----------|----------|----------
|
||||
;; SND.UNA SND.NXT SND.UNA
|
||||
;; +SND.WND
|
||||
;;
|
||||
;; 1 - old sequence numbers which have been acknowledged
|
||||
;; 2 - sequence numbers of unacknowledged data
|
||||
;; 3 - sequence numbers allowed for new data transmission
|
||||
;; 4 - future sequence numbers which are not yet allowed
|
||||
;;
|
||||
;; Send Sequence Space
|
||||
;;
|
||||
;; Figure 4.
|
||||
;;
|
||||
;; The send window is the portion of the sequence space labeled 3 in
|
||||
;; figure 4.
|
||||
;;
|
||||
;; Receive Sequence Space
|
||||
;;
|
||||
;; 1 2 3
|
||||
;; ----------|----------|----------
|
||||
;; RCV.NXT RCV.NXT
|
||||
;; +RCV.WND
|
||||
;;
|
||||
;; 1 - old sequence numbers which have been acknowledged
|
||||
;; 2 - sequence numbers allowed for new reception
|
||||
;; 3 - future sequence numbers which are not yet allowed
|
||||
;;
|
||||
;; Receive Sequence Space
|
||||
;;
|
||||
;; Figure 5.
|
||||
;;
|
||||
;; The receive window is the portion of the sequence space labeled 2 in
|
||||
;; figure 5.
|
||||
;;
|
||||
;; There are also some variables used frequently in the discussion that
|
||||
;; take their values from the fields of the current segment.
|
||||
;;
|
||||
;; Current Segment Variables
|
||||
;;
|
||||
;; SEG.SEQ - segment sequence number
|
||||
;; SEG.ACK - segment acknowledgment number
|
||||
;; SEG.LEN - segment length
|
||||
;; SEG.WND - segment window
|
||||
;; SEG.UP - segment urgent pointer
|
||||
;; SEG.PRC - segment precedence value
|
||||
;;
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(struct buffer (data ;; bit-string
|
||||
seqn ;; names leftmost byte in data
|
||||
window ;; counts bytes from leftmost byte in data
|
||||
finished?) ;; boolean: true after FIN
|
||||
#:transparent)
|
||||
|
||||
;; Regarding acks:
|
||||
;;
|
||||
;; - we send an ack number that is (buffer-seqn (inbound)) plus the
|
||||
;; number of buffered bytes.
|
||||
;;
|
||||
;; - acks received allow us to advance (buffer-seqn (outbound)) (that
|
||||
;; is, SND.UNA) to that point, discarding buffered data to do so.
|
||||
|
||||
;; Regarding windows:
|
||||
;;
|
||||
;; - (buffer-window (outbound)) is the size of the peer's receive
|
||||
;; window. Do not allow more than this many bytes to be
|
||||
;; unacknowledged on the wire.
|
||||
;;
|
||||
;; - (buffer-window (inbound)) is the size of our receive window. The
|
||||
;; peer should not exceed this; we should ignore data received that
|
||||
;; extends beyond this. Once we implement flow control locally
|
||||
;; (ahem) we should move this around, but at present it is fixed.
|
||||
|
||||
;; TODO: Zero receive window probe when we have something to say.
|
||||
|
||||
(define (buffer-push b data)
|
||||
(struct-copy buffer b [data (bit-string-append (buffer-data b) data)]))
|
||||
|
||||
(define transmit-check-interval-msec 2000)
|
||||
(define inbound-buffer-limit 65535)
|
||||
(define maximum-segment-size 536) ;; bytes
|
||||
(define maximum-segment-lifetime-sec (* 2 60)) ;; two minutes; 2MSL is TIME-WAIT timeout
|
||||
|
@ -384,55 +289,12 @@
|
|||
(- larger smaller)))
|
||||
|
||||
(define (seq> a b)
|
||||
(not (seq>= b a)))
|
||||
|
||||
(define (seq>= a b)
|
||||
(< (seq- a b) #x80000000))
|
||||
|
||||
(define (seq-min a b) (if (seq> a b) b a))
|
||||
(define (seq-max a b) (if (seq> a b) a b))
|
||||
|
||||
(module+ test
|
||||
(check-equal? (seq+ 41724780 1) 41724781)
|
||||
(check-equal? (seq+ 0 1) 1)
|
||||
(check-equal? (seq+ #x80000000 1) #x80000001)
|
||||
(check-equal? (seq+ #xffffffff 1) #x00000000)
|
||||
|
||||
(check-equal? (seq> 41724780 41724780) #f)
|
||||
(check-equal? (seq> 41724781 41724780) #t)
|
||||
(check-equal? (seq> 41724780 41724781) #f)
|
||||
|
||||
(check-equal? (seq> 0 0) #f)
|
||||
(check-equal? (seq> 1 0) #t)
|
||||
(check-equal? (seq> 0 1) #f)
|
||||
|
||||
(check-equal? (seq> #x80000000 #x80000000) #f)
|
||||
(check-equal? (seq> #x80000001 #x80000000) #t)
|
||||
(check-equal? (seq> #x80000000 #x80000001) #f)
|
||||
|
||||
(check-equal? (seq> #xffffffff #xffffffff) #f)
|
||||
(check-equal? (seq> #x00000000 #xffffffff) #t)
|
||||
(check-equal? (seq> #xffffffff #x00000000) #f)
|
||||
|
||||
(check-equal? (seq>= 41724780 41724780) #t)
|
||||
(check-equal? (seq>= 41724781 41724780) #t)
|
||||
(check-equal? (seq>= 41724780 41724781) #f)
|
||||
|
||||
(check-equal? (seq>= 0 0) #t)
|
||||
(check-equal? (seq>= 1 0) #t)
|
||||
(check-equal? (seq>= 0 1) #f)
|
||||
|
||||
(check-equal? (seq>= #x80000000 #x80000000) #t)
|
||||
(check-equal? (seq>= #x80000001 #x80000000) #t)
|
||||
(check-equal? (seq>= #x80000000 #x80000001) #f)
|
||||
|
||||
(check-equal? (seq>= #xffffffff #xffffffff) #t)
|
||||
(check-equal? (seq>= #x00000000 #xffffffff) #t)
|
||||
(check-equal? (seq>= #xffffffff #x00000000) #f))
|
||||
|
||||
(define (spawn-state-vector src-ip src-port dst-ip dst-port)
|
||||
(define src (tcp-address (ip-address->hostname src-ip) src-port))
|
||||
(define dst (tcp-address (ip-address->hostname dst-ip) dst-port))
|
||||
(define (timer-name kind) (list 'tcp-timer kind src dst))
|
||||
|
||||
(spawn
|
||||
#:name (list 'tcp-state-vector
|
||||
|
@ -455,27 +317,21 @@
|
|||
(inexact->exact (truncate (* #x100000000 (random)))))
|
||||
|
||||
(field [outbound (buffer #"!" initial-outbound-seqn 0 #f)] ;; dummy data at SYN position
|
||||
[send-next initial-outbound-seqn] ;; SND.NXT
|
||||
[high-water-mark initial-outbound-seqn]
|
||||
|
||||
[inbound (buffer #"" #f inbound-buffer-limit #f)]
|
||||
[transmission-needed? #f]
|
||||
[syn-acked? #f]
|
||||
|
||||
[latest-peer-activity-time (current-inexact-milliseconds)]
|
||||
;; ^ the most recent time we heard from our peer
|
||||
[user-timeout-base-time (current-inexact-milliseconds)]
|
||||
;; ^ when the index of the first outbound unacknowledged byte changed
|
||||
|
||||
;; RFC 6298
|
||||
[rtt-estimate #f] ;; milliseconds; "SRTT"
|
||||
[rtt-mean-deviation #f] ;; milliseconds; "RTTVAR"
|
||||
[retransmission-timeout 1000] ;; milliseconds
|
||||
[retransmission-deadline #f]
|
||||
[rtt-estimate-seqn-target #f]
|
||||
[rtt-estimate-start-time #f]
|
||||
[most-recent-time (current-inexact-milliseconds)]
|
||||
;; ^ updated by timer expiry; a field, to trigger quit checks
|
||||
)
|
||||
|
||||
(let ()
|
||||
(local-require (submod syndicate/actor priorities))
|
||||
(on-event #:priority *query-priority*
|
||||
[_ (most-recent-time (current-inexact-milliseconds))]))
|
||||
|
||||
(define (next-expected-seqn)
|
||||
(define b (inbound))
|
||||
(define v (buffer-seqn b))
|
||||
|
@ -485,6 +341,7 @@
|
|||
(inbound (struct-copy buffer (inbound) [seqn seqn])))
|
||||
|
||||
(define (incorporate-segment! data)
|
||||
;; (log-info "GOT INBOUND STUFF TO DELIVER ~v" data)
|
||||
(when (not (buffer-finished? (inbound)))
|
||||
(inbound (buffer-push (inbound) data))))
|
||||
|
||||
|
@ -500,258 +357,149 @@
|
|||
;; (Setof Symbol) -> Void
|
||||
(define (check-fin! flags)
|
||||
(define b (inbound))
|
||||
(when (not (buffer-finished? b))
|
||||
(unless (bit-string-empty? (buffer-data b)) ;; assured by deliver-inbound-locally
|
||||
(error 'check-fin "Nonempty inbound buffer"))
|
||||
(when (set-member? flags 'fin)
|
||||
(log-netstack/tcp-debug "Closing inbound stream.")
|
||||
(inbound (struct-copy buffer b
|
||||
[seqn (seq+ (buffer-seqn b) 1)] ;; reliable: count fin as a byte
|
||||
[finished? #t]))
|
||||
(transmission-needed? #t)))) ;; we must send an ack
|
||||
|
||||
;; -> Void
|
||||
(define (arm-retransmission-timer!)
|
||||
(log-netstack/tcp-debug "Arming retransmission timer (~a ms)" (retransmission-timeout))
|
||||
(retransmission-deadline (+ (current-inexact-milliseconds) (retransmission-timeout))))
|
||||
|
||||
;; Timestamp -> Void
|
||||
(define (start-rtt-estimate! now)
|
||||
(define target (send-next))
|
||||
(when (seq>= target (high-water-mark))
|
||||
(log-netstack/tcp-debug "Starting RTT estimation; target seqn is ~a" target)
|
||||
(rtt-estimate-start-time now)
|
||||
(rtt-estimate-seqn-target target)))
|
||||
|
||||
;; -> Void
|
||||
(define (reset-rtt-estimate!)
|
||||
(rtt-estimate-start-time #f)
|
||||
(rtt-estimate-seqn-target #f))
|
||||
|
||||
;; Timestamp -> Void
|
||||
(define (finish-rtt-estimate! now)
|
||||
(define rtt-measurement (- now (rtt-estimate-start-time)))
|
||||
(reset-rtt-estimate!)
|
||||
(log-netstack/tcp-debug "RTT measurement: ~a ms" rtt-measurement)
|
||||
;; RFC 6298 Section 2.
|
||||
(cond [(rtt-estimate) => ;; we have a previous estimate, RFC 6298 rule (2.3)
|
||||
(lambda (prev-estimate)
|
||||
(rtt-mean-deviation (+ (* 0.75 (rtt-mean-deviation))
|
||||
(* 0.25 (abs (- rtt-measurement prev-estimate)))))
|
||||
(rtt-estimate (+ (* 0.875 prev-estimate)
|
||||
(* 0.125 rtt-measurement))))]
|
||||
[else ;; no previous estimate, RFC 6298 rule (2.2) applies
|
||||
(rtt-estimate rtt-measurement)
|
||||
(rtt-mean-deviation (/ rtt-measurement 2))])
|
||||
(default-retransmission-timeout!)
|
||||
(log-netstack/tcp-debug "RTT measurement ~a ms; estimate ~a ms; mean deviation ~a ms; RTO ~a ms"
|
||||
rtt-measurement
|
||||
(rtt-estimate)
|
||||
(rtt-mean-deviation)
|
||||
(retransmission-timeout)))
|
||||
|
||||
(define (default-retransmission-timeout!)
|
||||
(retransmission-timeout
|
||||
(max 200 ;; RFC 6298 rule (2.4), but cribbing from Linux's 200ms minimum
|
||||
(min 60000 ;; (2.5)
|
||||
(+ (rtt-estimate) (* 4 (rtt-mean-deviation))))))) ;; (2.2), (2.3)
|
||||
(unless (bit-string-empty? (buffer-data b)) ;; assured by deliver-inbound-locally
|
||||
(error 'check-fin "Nonempty inbound buffer"))
|
||||
(when (set-member? flags 'fin)
|
||||
(log-info "Closing inbound stream.")
|
||||
(inbound (struct-copy buffer b
|
||||
[seqn (seq+ (buffer-seqn b) 1)] ;; reliable: count fin as a byte
|
||||
[finished? #t]))))
|
||||
|
||||
;; Boolean SeqNum -> Void
|
||||
(define (discard-acknowledged-outbound! ack? ackn)
|
||||
(when ack?
|
||||
(let* ((b (outbound))
|
||||
(base (buffer-seqn b))
|
||||
(ackn (seq-min ackn (high-water-mark)))
|
||||
(ackn (seq-max ackn base))
|
||||
(limit (seq+ (buffer-seqn b) (bit-string-byte-count (buffer-data b))))
|
||||
(ackn (if (seq> ackn limit) limit ackn))
|
||||
(ackn (if (seq> base ackn) base ackn))
|
||||
(dist (seq- ackn base)))
|
||||
(define remaining-data (bit-string-drop (buffer-data b) (* dist 8))) ;; bit offset!
|
||||
(user-timeout-base-time (current-inexact-milliseconds))
|
||||
(when (positive? dist)
|
||||
(when (not (syn-acked?)) (syn-acked? #t))
|
||||
(log-netstack/tcp-debug "******** ackn ~a; send-next ~a; high-water-mark ~a"
|
||||
ackn
|
||||
(send-next)
|
||||
(high-water-mark))
|
||||
(when (seq> ackn (send-next)) (send-next ackn))
|
||||
(when (and (rtt-estimate-seqn-target) (seq>= ackn (rtt-estimate-seqn-target)))
|
||||
(finish-rtt-estimate! (current-inexact-milliseconds)))
|
||||
|
||||
(define remaining-data (bit-string-drop (buffer-data b) (* dist 8))) ;; bit offset!
|
||||
(outbound (struct-copy buffer b [data remaining-data] [seqn ackn]))
|
||||
|
||||
(default-retransmission-timeout!)
|
||||
(log-netstack/tcp-debug "Positive distance moved by ack, RTO now ~a"
|
||||
(retransmission-timeout))
|
||||
(arm-retransmission-timer!)))))
|
||||
(outbound (struct-copy buffer b [data remaining-data] [seqn ackn]))
|
||||
(syn-acked? (or (syn-acked?) (positive? dist))))))
|
||||
|
||||
;; Nat -> Void
|
||||
(define (update-outbound-window! peer-window)
|
||||
(log-netstack/tcp-debug "Peer's receive-window is now ~a" peer-window)
|
||||
(outbound (struct-copy buffer (outbound) [window peer-window])))
|
||||
|
||||
;; True iff there is no queued-up data waiting either for
|
||||
;; transmission or (if transmitted already) for acknowledgement.
|
||||
(define (all-output-acknowledged?)
|
||||
(bit-string-empty? (buffer-data (outbound))))
|
||||
|
||||
;; (Option SeqNum) -> Void
|
||||
(define (send-outbound! old-ackn)
|
||||
(define b (outbound))
|
||||
(define pending-byte-count (max 0 (- (bit-string-byte-count (buffer-data b))
|
||||
(if (buffer-finished? b) 1 0))))
|
||||
|
||||
(define segment-size (min maximum-segment-size
|
||||
(if (syn-acked?) (buffer-window b) 1)
|
||||
;; ^ can only send SYN until SYN is acked
|
||||
pending-byte-count))
|
||||
(define segment-offset (if (syn-acked?) 0 1))
|
||||
(define chunk0 (bit-string-take (buffer-data b) (* segment-size 8))) ;; bit offset!
|
||||
(define chunk (bit-string-drop chunk0 (* segment-offset 8))) ;; bit offset!
|
||||
(define ackn (next-expected-seqn))
|
||||
(define flags (set))
|
||||
(when ackn
|
||||
(set! flags (set-add flags 'ack)))
|
||||
(when (not (syn-acked?))
|
||||
(set! flags (set-add flags 'syn)))
|
||||
(when (and (buffer-finished? b)
|
||||
(syn-acked?)
|
||||
(= segment-size pending-byte-count)
|
||||
(not (all-output-acknowledged?))) ;; TODO: reexamine. This looks fishy
|
||||
(set! flags (set-add flags 'fin)))
|
||||
(define window (min 65535 ;; limit of field width
|
||||
(max 0 ;; can't be negative
|
||||
(- (buffer-window (inbound))
|
||||
(bit-string-byte-count (buffer-data (inbound)))))))
|
||||
(unless (and (equal? ackn old-ackn)
|
||||
(syn-acked?)
|
||||
(not (set-member? flags 'fin))
|
||||
(zero? (bit-string-byte-count chunk)))
|
||||
(local-require racket/pretty)
|
||||
(pretty-write `(send-outbound (old-ackn ,old-ackn)
|
||||
(flags ,flags)))
|
||||
(flush-output)
|
||||
(send! (tcp-packet #f dst-ip dst-port src-ip src-port
|
||||
(buffer-seqn b)
|
||||
(or ackn 0)
|
||||
flags
|
||||
window
|
||||
#""
|
||||
chunk))))
|
||||
|
||||
(define (bump-peer-activity-time!)
|
||||
(latest-peer-activity-time (current-inexact-milliseconds)))
|
||||
|
||||
;; Number -> Boolean
|
||||
(define (heard-from-peer-within-msec? msec)
|
||||
(<= (- (most-recent-time) (latest-peer-activity-time)) msec))
|
||||
|
||||
(define (user-timeout-expired?)
|
||||
(and (not (all-output-acknowledged?))
|
||||
(> (- (most-recent-time) (user-timeout-base-time))
|
||||
user-timeout-msec)))
|
||||
|
||||
(define (send-set-transmit-check-timer!)
|
||||
(send! (set-timer (timer-name 'transmit-check)
|
||||
transmit-check-interval-msec
|
||||
'relative)))
|
||||
|
||||
(define (reset! seqn ackn)
|
||||
(log-warning "Sending RST from ~a:~a to ~a:~a"
|
||||
(ip-address->hostname dst-ip)
|
||||
dst-port
|
||||
(ip-address->hostname src-ip)
|
||||
src-port)
|
||||
(stop-facet root-facet)
|
||||
(send! (tcp-packet #f dst-ip dst-port src-ip src-port
|
||||
seqn
|
||||
ackn
|
||||
(set 'ack 'rst)
|
||||
0
|
||||
#""
|
||||
#"")))
|
||||
|
||||
(define (close-outbound-stream!)
|
||||
(define b (outbound))
|
||||
(when (not (buffer-finished? b))
|
||||
(outbound (struct-copy buffer (buffer-push b #"!") ;; dummy FIN byte
|
||||
[finished? #t]))
|
||||
(transmission-needed? #t))) ;; the FIN machinery is awkwardly
|
||||
;; different from the usual
|
||||
;; advance-based decision on
|
||||
;; whether to send a packet or not
|
||||
|
||||
;; SeqNum Boolean Boolean Bytes -> TcpPacket
|
||||
(define (build-outbound-packet seqn mention-syn? mention-fin? payload)
|
||||
(define ackn (next-expected-seqn))
|
||||
(define window (min 65535 ;; limit of field width
|
||||
(max 0 ;; can't be negative
|
||||
(- (buffer-window (inbound))
|
||||
(bit-string-byte-count (buffer-data (inbound)))))))
|
||||
|
||||
(define flags (set))
|
||||
(when ackn (set! flags (set-add flags 'ack)))
|
||||
(when mention-syn? (set! flags (set-add flags 'syn)))
|
||||
(when mention-fin? (set! flags (set-add flags 'fin)))
|
||||
|
||||
(tcp-packet #f dst-ip dst-port src-ip src-port
|
||||
seqn
|
||||
(or ackn 0)
|
||||
flags
|
||||
window
|
||||
#""
|
||||
payload))
|
||||
|
||||
(define (outbound-data-chunk offset length)
|
||||
(bit-string-take (bit-string-drop (buffer-data (outbound)) (* offset 8)) (* length 8)))
|
||||
|
||||
;; Transmit acknowledgements and outbound data.
|
||||
(begin/dataflow
|
||||
(define in-flight-count (seq- (send-next) (buffer-seqn (outbound))))
|
||||
|
||||
(define-values (mention-syn? ;; whether to mention SYN
|
||||
payload-size ;; how many bytes of payload data to include
|
||||
mention-fin? ;; whether to mention FIN
|
||||
advance) ;; how far to advance send-next
|
||||
(if (syn-acked?)
|
||||
(let* ((effective-window (max 0 (- (buffer-window (outbound)) in-flight-count)))
|
||||
(stream-ended? (buffer-finished? (outbound)))
|
||||
(max-advance (- (bit-string-byte-count (buffer-data (outbound))) in-flight-count))
|
||||
(payload-size (min maximum-segment-size effective-window max-advance)))
|
||||
(if (and stream-ended? ;; there's a FIN enqueued,
|
||||
(positive? payload-size) ;; we aren't sending nothing at all,
|
||||
(= payload-size max-advance)) ;; and our payload would cover the FIN
|
||||
(values #f (- payload-size 1) #t payload-size)
|
||||
(values #f payload-size #f payload-size)))
|
||||
(cond [(= in-flight-count 0) (values #t 0 #f 1)]
|
||||
[(= in-flight-count 1) (values #t 0 #f 0)]
|
||||
[else (error 'send-outbound!
|
||||
"Invalid state: send-next had advanced too far before SYN")])))
|
||||
|
||||
(when (and (or (next-expected-seqn) (local-peer-seen?))
|
||||
;; ^ Talk only either if: we know the peer's seqn, or
|
||||
;; we don't, but a local peer exists, which means
|
||||
;; we're an outbound connection rather than a
|
||||
;; listener.
|
||||
(or (transmission-needed?)
|
||||
(positive? advance))
|
||||
;; ^ ... and we have something to say. Something to
|
||||
;; ack, or something to send.
|
||||
)
|
||||
(define packet-seqn (if mention-syn? (buffer-seqn (outbound)) (send-next)))
|
||||
(define packet (build-outbound-packet packet-seqn
|
||||
mention-syn?
|
||||
mention-fin?
|
||||
(outbound-data-chunk in-flight-count payload-size)))
|
||||
(when (positive? advance)
|
||||
(define new-send-next (seq+ (send-next) advance))
|
||||
(send-next new-send-next)
|
||||
(when (seq> new-send-next (high-water-mark))
|
||||
(high-water-mark new-send-next)))
|
||||
(when (transmission-needed?)
|
||||
(transmission-needed? #f))
|
||||
|
||||
;; (log-netstack/tcp-debug " sending ~v" packet)
|
||||
(send! packet)
|
||||
;; (if (> (random) 0.5)
|
||||
;; (begin (log-netstack/tcp-debug "Send ~a" (summarize-tcp-packet packet))
|
||||
;; (send! packet))
|
||||
;; (log-netstack/tcp-debug "Drop ~a" (summarize-tcp-packet packet)))
|
||||
|
||||
(when (or mention-syn? mention-fin? (positive? advance))
|
||||
(when (not (retransmission-deadline))
|
||||
(arm-retransmission-timer!))
|
||||
(when (not (rtt-estimate-start-time))
|
||||
(start-rtt-estimate! (current-inexact-milliseconds))))))
|
||||
|
||||
(begin/dataflow
|
||||
(when (and (retransmission-deadline) (all-output-acknowledged?))
|
||||
(log-netstack/tcp-debug "All output acknowledged; disarming retransmission timer")
|
||||
(retransmission-deadline #f)))
|
||||
|
||||
(on #:when (retransmission-deadline) (asserted (later-than (retransmission-deadline)))
|
||||
(send-next (buffer-seqn (outbound)))
|
||||
(log-netstack/tcp-debug "Retransmission deadline fired, RTO was ~a; reset to ~a"
|
||||
(retransmission-timeout)
|
||||
(send-next))
|
||||
(update-outbound-window! maximum-segment-size) ;; temporary. Will reopen on next ack
|
||||
(transmission-needed? #t)
|
||||
(retransmission-deadline #f)
|
||||
(reset-rtt-estimate!) ;; give up on current RTT estimation
|
||||
(retransmission-timeout (min 64000 (* 2 (retransmission-timeout))))
|
||||
(log-netstack/tcp-debug " RTO now ~a" (retransmission-timeout)))
|
||||
|
||||
(define (reset! seqn ackn)
|
||||
(define reset-packet (tcp-packet #f dst-ip dst-port src-ip src-port
|
||||
seqn
|
||||
ackn
|
||||
(set 'ack 'rst)
|
||||
0
|
||||
#""
|
||||
#""))
|
||||
(log-netstack/tcp-warning "Reset ~a" (summarize-tcp-packet reset-packet))
|
||||
(stop-facet root-facet)
|
||||
(send! reset-packet))
|
||||
[finished? #t]))))
|
||||
|
||||
(assert #:when (and (syn-acked?) (not (buffer-finished? (inbound))))
|
||||
(advertise (tcp-channel src dst _)))
|
||||
|
||||
(on-start (log-netstack/tcp-info "Starting state vector ~a-~a" src-port dst-port))
|
||||
(on-stop (log-netstack/tcp-info "Stopping state vector ~a-~a" src-port dst-port))
|
||||
|
||||
(stop-when #:when (and (buffer-finished? (outbound))
|
||||
(buffer-finished? (inbound))
|
||||
(all-output-acknowledged?))
|
||||
(asserted (later-than (+ (latest-peer-activity-time)
|
||||
(* 2 1000 maximum-segment-lifetime-sec))))
|
||||
(stop-when-true
|
||||
(and (buffer-finished? (outbound))
|
||||
(buffer-finished? (inbound))
|
||||
(all-output-acknowledged?)
|
||||
(not (heard-from-peer-within-msec? (* 2 1000 maximum-segment-lifetime-sec))))
|
||||
;; Everything is cleanly shut down, and we just need to wait a while for unexpected
|
||||
;; packets before we release the state vector.
|
||||
)
|
||||
|
||||
(stop-when #:when (not (all-output-acknowledged?))
|
||||
(asserted (later-than (+ (user-timeout-base-time) user-timeout-msec)))
|
||||
(stop-when-true (user-timeout-expired?)
|
||||
;; We've been plaintively retransmitting for user-timeout-msec without hearing anything
|
||||
;; back; this is a crude approximation of the real condition for TCP_USER_TIMEOUT, but
|
||||
;; it will do for now? TODO
|
||||
(log-netstack/tcp-warning "TCP_USER_TIMEOUT fired."))
|
||||
(log-info "TCP_USER_TIMEOUT fired."))
|
||||
|
||||
(define/query-value local-peer-seen? #f (observe (tcp-channel src dst _)) #t
|
||||
#:on-remove (begin
|
||||
(log-netstack/tcp-debug "Closing outbound stream.")
|
||||
(close-outbound-stream!)))
|
||||
(log-info "Closing outbound stream.")
|
||||
(close-outbound-stream!)
|
||||
(send-outbound! (buffer-seqn (inbound)))))
|
||||
|
||||
(define/query-value listener-listening?
|
||||
#f
|
||||
(observe (advertise (tcp-channel _ (tcp-listener dst-port) _)))
|
||||
#t)
|
||||
|
||||
(define (trigger-ack!)
|
||||
(transmission-needed? #t))
|
||||
|
||||
(on (message (tcp-packet #t src-ip src-port dst-ip dst-port
|
||||
$seqn $ackn $flags $window $options $data))
|
||||
(define old-ackn (buffer-seqn (inbound)))
|
||||
(define expected (next-expected-seqn))
|
||||
(define is-syn? (set-member? flags 'syn))
|
||||
(define is-fin? (set-member? flags 'fin))
|
||||
|
@ -769,28 +517,38 @@
|
|||
(cond
|
||||
[(not expected) ;; haven't seen syn yet, but we know this is it
|
||||
(set-inbound-seqn! (seq+ seqn 1))
|
||||
(incorporate-segment! data)
|
||||
(trigger-ack!)]
|
||||
(incorporate-segment! data)]
|
||||
[(= expected seqn)
|
||||
(incorporate-segment! data)
|
||||
(when (positive? (bit-string-byte-count data)) (trigger-ack!))]
|
||||
[else
|
||||
(trigger-ack!)])
|
||||
(incorporate-segment! data)]
|
||||
[else (void)])
|
||||
(deliver-inbound-locally!)
|
||||
(check-fin! flags)
|
||||
(discard-acknowledged-outbound! (set-member? flags 'ack) ackn)
|
||||
(update-outbound-window! window)
|
||||
(latest-peer-activity-time (current-inexact-milliseconds))]))
|
||||
(send-outbound! old-ackn)
|
||||
(bump-peer-activity-time!)]))
|
||||
|
||||
(on (message (tcp-channel dst src $bs))
|
||||
;; (log-netstack/tcp-debug "GOT MORE STUFF TO DELIVER ~v" bs)
|
||||
(define old-ackn (buffer-seqn (inbound)))
|
||||
;; (log-info "GOT MORE STUFF TO DELIVER ~v" bs)
|
||||
|
||||
(when (all-output-acknowledged?)
|
||||
;; Only move user-timeout-base-time if there wasn't
|
||||
;; already some outstanding output.
|
||||
(user-timeout-base-time (current-inexact-milliseconds)))
|
||||
|
||||
(outbound (buffer-push (outbound) bs)))))
|
||||
(outbound (buffer-push (outbound) bs))
|
||||
(send-outbound! old-ackn))
|
||||
|
||||
(on-start (send-set-transmit-check-timer!))
|
||||
(on (message (timer-expired (timer-name 'transmit-check) _))
|
||||
(define old-ackn (buffer-seqn (inbound)))
|
||||
;; TODO: I am abusing this timer for multiple tasks. Notably, this is a (crude) means of
|
||||
;; retransmitting outbound data as well as a means of checking for an expired
|
||||
;; TCP_USER_TIMEOUT. A better design would have separate timers and a more fine-grained
|
||||
;; approach.
|
||||
(send-set-transmit-check-timer!)
|
||||
(send-outbound! old-ackn))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
|
@ -1,55 +0,0 @@
|
|||
// bin/syndicatec compiler/demo-synthetic-patch-2.js | node
|
||||
//
|
||||
// Analogous example to syndicate/racket/syndicate/examples/actor/example-synthetic-patch-2.rkt.
|
||||
//
|
||||
// Symptomatic output:
|
||||
//
|
||||
// Outer value 4 = 4
|
||||
// Value 0 = 0
|
||||
// Value 1 = 1
|
||||
// Value 2 = 2
|
||||
// Value 3 = 3
|
||||
//
|
||||
// Correct output:
|
||||
//
|
||||
// Outer value 4 = 4
|
||||
// Value 0 = 0
|
||||
// Value 1 = 1
|
||||
// Value 2 = 2
|
||||
// Value 3 = 3
|
||||
// Value 4 = 4
|
||||
// Value 5 = 5
|
||||
|
||||
var Syndicate = require('./src/main.js');
|
||||
|
||||
assertion type mapping(key, value);
|
||||
assertion type ready();
|
||||
|
||||
ground dataspace {
|
||||
spawn {
|
||||
field this.ofInterest = 0;
|
||||
during ready() {
|
||||
on asserted mapping(this.ofInterest, $v) {
|
||||
console.log("Value", this.ofInterest, "=", v);
|
||||
this.ofInterest += 1;
|
||||
}
|
||||
}
|
||||
on asserted mapping(4, $v) {
|
||||
console.log("Outer value", 4, "=", v);
|
||||
}
|
||||
}
|
||||
|
||||
spawn {
|
||||
assert mapping(0, 0);
|
||||
assert mapping(1, 1);
|
||||
assert mapping(2, 2);
|
||||
assert mapping(3, 3);
|
||||
assert mapping(4, 4);
|
||||
assert mapping(5, 5);
|
||||
on start {
|
||||
react {
|
||||
assert ready();
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
|
@ -88,14 +88,8 @@ Actor.prototype.quiesce = function() {
|
|||
if (!facet.terminated) {
|
||||
withCurrentFacet(facet, function () {
|
||||
var patch = Patch.retract(__).andThen(endpoint.subscriptionFn.call(facet.fields));
|
||||
var newInterests = patch.prunedBy(facet.actor.mux.interestsOf(endpoint.eid));
|
||||
var newlyRelevantKnowledge =
|
||||
Patch.biasedIntersection(facet.actor.knowledge, newInterests.added);
|
||||
var r = facet.actor.mux.updateStream(endpoint.eid, patch);
|
||||
Dataspace.stateChange(r.deltaAggregate);
|
||||
facet.handleEvent(_Dataspace.stateChange(new Patch.Patch(newlyRelevantKnowledge,
|
||||
Trie.emptyTrie)),
|
||||
true);
|
||||
});
|
||||
}
|
||||
});
|
||||
|
|
|
@ -1,38 +1,26 @@
|
|||
#lang setup/infotab
|
||||
(define collection 'multi)
|
||||
(define deps '(
|
||||
(define deps '("rfc6455"
|
||||
"base"
|
||||
"data-lib"
|
||||
"htdp-lib"
|
||||
"net-lib"
|
||||
"web-server-lib"
|
||||
"profile-lib"
|
||||
"rackunit-lib"
|
||||
"sha"
|
||||
"automata"
|
||||
"auxiliary-macro-context"
|
||||
"htdp-lib"
|
||||
"data-enumerate-lib"
|
||||
"datalog"
|
||||
"db-lib"
|
||||
"draw-lib"
|
||||
"gui-lib"
|
||||
"images-lib"
|
||||
"macrotypes-lib"
|
||||
"pict-lib"
|
||||
"rackunit-macrotypes-lib"
|
||||
"rfc6455"
|
||||
"sandbox-lib"
|
||||
"sgl"
|
||||
"struct-defaults"
|
||||
"turnstile-example"
|
||||
"turnstile-lib"
|
||||
"web-server-lib"
|
||||
))
|
||||
(define build-deps '(
|
||||
"draw-doc"
|
||||
"gui-doc"
|
||||
"htdp-doc"
|
||||
"pict-doc"
|
||||
"racket-doc"
|
||||
"auxiliary-macro-context"
|
||||
"sandbox-lib"
|
||||
"images-lib"
|
||||
"automata"
|
||||
"sha"))
|
||||
(define build-deps '("racket-doc"
|
||||
"scribble-lib"
|
||||
"sha"
|
||||
))
|
||||
"draw-doc" "gui-doc" "htdp-doc" "pict-doc"))
|
||||
|
|
|
@ -1,44 +0,0 @@
|
|||
#lang syndicate
|
||||
|
||||
;; actor adapter for canvas-double-click% and cells-canvas%
|
||||
(require 7GUI/canvas-double-click)
|
||||
(require 7GUI/task-7-view)
|
||||
(require (only-in "../../widgets.rkt" qc))
|
||||
|
||||
(provide spawn-cells-canvas
|
||||
(struct-out single-click)
|
||||
(struct-out double-click)
|
||||
(struct-out update-grid))
|
||||
|
||||
(require racket/gui/base
|
||||
(except-in racket/class field))
|
||||
|
||||
(message-struct single-click (x y))
|
||||
(message-struct double-click (x y))
|
||||
(message-struct update-grid (cells))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
(define cells-canvas%
|
||||
(class canvas-double-click%
|
||||
(define/augment-final (on-click x y) (send-ground-message (single-click x y)))
|
||||
(define/augment-final (on-double-click x y) (send-ground-message (double-click x y)))
|
||||
(define *content #f)
|
||||
(define/public (update-grid cells)
|
||||
(set! *content cells)
|
||||
(qc (define dc (send this get-dc))
|
||||
(paint-grid dc *content)))
|
||||
(super-new [paint-callback (lambda (_self dc) (when *content (paint-grid dc *content)))])))
|
||||
|
||||
(define (spawn-cells-canvas parent width height)
|
||||
(define parent-component (seal-contents parent))
|
||||
(define canvas (new cells-canvas% [parent parent-component] [style '(hscroll vscroll)]))
|
||||
(qc (send canvas init-auto-scrollbars width height 0. 0.)
|
||||
(send canvas show-scrollbars #t #t))
|
||||
|
||||
(spawn
|
||||
(on (message (update-grid $cells))
|
||||
(qc (send canvas update-grid cells)))
|
||||
(on (message (inbound (single-click $x $y)))
|
||||
(send! (single-click x y)))
|
||||
(on (message (inbound (double-click $x $y)))
|
||||
(send! (double-click x y)))))
|
|
@ -1,22 +0,0 @@
|
|||
#lang syndicate
|
||||
|
||||
(require "../../widgets.rkt")
|
||||
(require (only-in racket/format ~a))
|
||||
|
||||
;; a mouse-click counter
|
||||
|
||||
(define frame (spawn-frame #:label "Counter"))
|
||||
(define pane (spawn-horizontal-pane #:parent frame))
|
||||
(define view (spawn-text-field #:parent pane #:label "" #:init-value "0" #:enabled #f #:min-width 100))
|
||||
(define _but (spawn-button #:parent pane #:label "Count"))
|
||||
|
||||
(spawn
|
||||
(field [counter 0])
|
||||
(on (message (button-press _but))
|
||||
(counter (add1 (counter)))
|
||||
(send! (set-text-field view (~a (counter)))))
|
||||
(on-start
|
||||
(send! (show frame #t))))
|
||||
|
||||
(module+ main
|
||||
(void))
|
|
@ -1,59 +0,0 @@
|
|||
#lang syndicate
|
||||
|
||||
(require "../../widgets.rkt")
|
||||
(require (only-in racket/format ~a ~r))
|
||||
|
||||
;; a bi-directional temperature converter (Fahrenheit vs Celsius)
|
||||
|
||||
(define ((callback setter) field val)
|
||||
(define-values (field:num last) (string->number* val))
|
||||
(cond
|
||||
[(and field:num (rational? field:num))
|
||||
(define inexact-n (* #i1.0 field:num))
|
||||
(setter inexact-n)
|
||||
(render field inexact-n last)]
|
||||
[else (send! (set-text-field-background field "red"))]))
|
||||
|
||||
(define (string->number* str)
|
||||
(define n (string->number str))
|
||||
(values n (and n (string-ref str (- (string-length str) 1)))))
|
||||
|
||||
(define (flow *from --> *to to-field)
|
||||
(λ (x)
|
||||
(*from x)
|
||||
(*to (--> x))
|
||||
(render to-field (*to) "")))
|
||||
|
||||
(define (render to-field *to last)
|
||||
(send! (set-text-field-background to-field "white"))
|
||||
(send! (set-text-field to-field (~a (~r *to #:precision 4) (if (eq? #\. last) "." "")))))
|
||||
|
||||
(define frame (spawn-frame #:label "temperature converter"))
|
||||
(define pane (spawn-horizontal-pane #:parent frame))
|
||||
|
||||
(define (make-field v0 lbl)
|
||||
(spawn-text-field #:parent pane
|
||||
#:min-width 199
|
||||
#:label lbl
|
||||
#:init-value v0))
|
||||
|
||||
(define C0 0)
|
||||
(define F0 32)
|
||||
|
||||
(define C-field (make-field (~a C0) "celsius:"))
|
||||
(define F-field (make-field (~a F0) " = fahrenheit:"))
|
||||
|
||||
(spawn
|
||||
|
||||
(field [*C C0]
|
||||
[*F F0])
|
||||
|
||||
(define celsius->fahrenheit (callback (flow *C (λ (c) (+ (* c 9/5) 32)) *F F-field)))
|
||||
(define fahrenheit->celsius (callback (flow *F (λ (f) (* (- f 32) 5/9)) *C C-field)))
|
||||
|
||||
(on (message (text-field-update C-field $val))
|
||||
(celsius->fahrenheit C-field val))
|
||||
(on (message (text-field-update F-field $val))
|
||||
(fahrenheit->celsius F-field val))
|
||||
(on-start
|
||||
(send! (show frame #t))))
|
|
@ -1,67 +0,0 @@
|
|||
#lang syndicate
|
||||
|
||||
(require "../../widgets.rkt")
|
||||
|
||||
;; a flight booker that allows a choice between one-way and return bookings
|
||||
;; and, depending on the choice, a start date or a start date and an end date.
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
(require gregor)
|
||||
|
||||
;; gregor should not raise an exception when parsing fails, but return #f
|
||||
(define (to-date d) (with-handlers ([exn? (λ (_) #f)]) (parse-date d "d.M.y")))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
(define DATE0 "27.03.2014")
|
||||
(define ONE "one-way flight")
|
||||
(define RETURN "return flight")
|
||||
(define CHOICES `(,ONE ,RETURN))
|
||||
(define RED "red")
|
||||
(define WHITE "white")
|
||||
|
||||
(define (make-field enabled)
|
||||
(spawn-text-field #:parent frame
|
||||
#:label ""
|
||||
#:init-value DATE0
|
||||
#:enabled enabled))
|
||||
|
||||
(define frame (spawn-frame #:label "flight booker"))
|
||||
(define choice (spawn-choice #:label "" #:parent frame #:choices CHOICES))
|
||||
(define start-d (make-field #t))
|
||||
(define return-d (make-field #f))
|
||||
(define book (spawn-button #:label "Book" #:parent frame))
|
||||
|
||||
(spawn
|
||||
(field [*kind-flight (list-ref CHOICES 0)] ;; one of the CHOICES
|
||||
[*start-date (to-date DATE0)] ;; date
|
||||
[*return-date (to-date DATE0)]) ;; date
|
||||
|
||||
(define (field-cb self val date-setter!)
|
||||
(define date (to-date val))
|
||||
(cond
|
||||
[date (send! (set-text-field-background self WHITE)) (date-setter! date) (enable-book)]
|
||||
[else (send! (set-text-field-background self RED)) (enable-book #f #f)]))
|
||||
|
||||
(define (enable-book [start-date (*start-date)] [return-date (*return-date)])
|
||||
(send! (enable book #f))
|
||||
(when (and start-date (date<=? (today) start-date)
|
||||
(or (and (string=? ONE (*kind-flight)))
|
||||
(and return-date (date<=? start-date return-date))))
|
||||
(send! (enable book #t))))
|
||||
|
||||
(define (enable-return-book selection)
|
||||
(*kind-flight selection)
|
||||
(send! (enable return-d (string=? RETURN (*kind-flight))))
|
||||
(enable-book))
|
||||
|
||||
(on (message (text-field-update start-d $val))
|
||||
(field-cb start-d val *start-date))
|
||||
(on (message (text-field-update return-d $val))
|
||||
(field-cb return-d val *return-date))
|
||||
(on (message (choice-selection choice $sel))
|
||||
(enable-return-book sel))
|
||||
(on (message (button-press book))
|
||||
(displayln "confirmed"))
|
||||
|
||||
(on-start (send! (show frame #t))
|
||||
(enable-return-book (*kind-flight))))
|
|
@ -1,58 +0,0 @@
|
|||
#lang syndicate
|
||||
|
||||
(require "../../widgets.rkt")
|
||||
(require/activate syndicate/drivers/timestate)
|
||||
|
||||
;; notes on MF impl:
|
||||
;; - reset button doesn't do anything if duration is at 0
|
||||
;; - duration is meant to update as slider is moved, not just when released
|
||||
|
||||
;; a timer that permits the continuous setting of a new interval, plusanything if duration is at 0
|
||||
;; - duration is meant to update as slider is moved, not just when released
|
||||
;; a gauge and a text field that display the fraction of the elapsed time
|
||||
;; a reset button that sends the elapsed time back to 0
|
||||
|
||||
(define INTERVAL 100)
|
||||
|
||||
(define (next-time) (+ (current-milliseconds) INTERVAL))
|
||||
|
||||
(define frame (spawn-frame #:label "timer"))
|
||||
(define elapsed (spawn-gauge #:label "elapsed" #:parent frame #:enabled #f #:range 100))
|
||||
(define text (spawn-text-field #:parent frame #:init-value "0" #:label ""))
|
||||
(define slider (spawn-slider #:label "duration" #:parent frame #:min-value 0 #:max-value 100))
|
||||
(define button (spawn-button #:label "reset" #:parent frame))
|
||||
|
||||
(spawn
|
||||
(field [*elapsed 0] ;; INTERVAL/1000 ms accumulated elapsed time
|
||||
[*duration 0] ;; INTERVAL/1000 ms set duration interval
|
||||
[t (next-time)])
|
||||
|
||||
(define (timer-cb)
|
||||
(unless (>= (*elapsed) (*duration))
|
||||
(*elapsed (+ (*elapsed) 1))
|
||||
(t (next-time))
|
||||
(elapsed-cb)))
|
||||
|
||||
(define (elapsed-cb)
|
||||
(send! (set-text-field text (format "elapsed ~a" (*elapsed))))
|
||||
(unless (zero? (*duration))
|
||||
(define r (quotient (* 100 (*elapsed)) (*duration)))
|
||||
(send! (set-gauge-value elapsed r))))
|
||||
|
||||
(define (reset-cb)
|
||||
(*elapsed 0)
|
||||
(timer-cb))
|
||||
|
||||
(define (duration-cb new-duration)
|
||||
(unless (= new-duration (*duration))
|
||||
(*duration new-duration)
|
||||
(timer-cb)))
|
||||
|
||||
(on (asserted (later-than (t)))
|
||||
(timer-cb))
|
||||
(on (message (button-press button))
|
||||
(reset-cb))
|
||||
(on (message (slider-update slider $val))
|
||||
(duration-cb val))
|
||||
(on-start (elapsed-cb)
|
||||
(send! (show frame #t))))
|
|
@ -1,71 +0,0 @@
|
|||
#lang syndicate
|
||||
|
||||
(require "../../widgets.rkt")
|
||||
(require (only-in racket/string string-prefix?))
|
||||
(require (only-in racket/function curry))
|
||||
(require (only-in racket/list first rest))
|
||||
|
||||
;; a create-read-update-deleted MVC implementation
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
(define frame (spawn-frame #:label "CRUD"))
|
||||
(define hpane1 (spawn-horizontal-pane #:parent frame #:border 10 #:alignment '(left bottom)))
|
||||
(define vpane1 (spawn-vertical-pane #:parent hpane1))
|
||||
(define filter-tf (spawn-text-field #:parent vpane1 #:label "Filter prefix: " #:init-value ""))
|
||||
(define lbox (spawn-list-box #:parent vpane1 #:label #f #:choices '() #:min-width 100 #:min-height 100))
|
||||
(define vpane2 (spawn-vertical-pane #:parent hpane1 #:alignment '(right center)))
|
||||
(define name (spawn-text-field #:parent vpane2 #:label "Name: " #:init-value "" #:min-width 200))
|
||||
(define surname (spawn-text-field #:parent vpane2 #:label "Surname: " #:init-value "" #:min-width 200))
|
||||
(define hpane2 (spawn-horizontal-pane #:parent frame))
|
||||
(define create-but (spawn-button #:label "Create" #:parent hpane2))
|
||||
(define update-but (spawn-button #:label "Update" #:parent hpane2))
|
||||
(define delete-but (spawn-button #:label "Delete" #:parent hpane2))
|
||||
|
||||
(spawn
|
||||
(field [*data '("Emil, Hans" "Mustermann, Max" "Tisch, Roman")]
|
||||
[*selector ""]
|
||||
[*selected (*data)]) ;; selected = (filter select data)
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
(define (selector! nu) (*selector nu) (data->selected!))
|
||||
(define (select s) (string-prefix? s (*selector)))
|
||||
(define (data->selected!) (*selected (if (string=? "" (*selector)) (*data) (filter select (*data)))))
|
||||
|
||||
(define-syntax-rule (def-! (name x ...) exp) (define (name x ...) (*data exp) (data->selected!)))
|
||||
(def-! (create-entry new-entry) (append (*data) (list new-entry)))
|
||||
(def-! (update-entry new-entry i) (operate-on i (curry cons new-entry) (*data) select (*selected)))
|
||||
(def-! (delete-from i) (operate-on i values))
|
||||
|
||||
#; {N [[Listof X] -> [Listof X]] [Listof X] [X -> Boolean] [Listof X] -> [Listof X]}
|
||||
;; traverse list to the i-th position of selected in data, then apply operator to rest (efficiency)
|
||||
;; ASSUME selected = (filter selector data)
|
||||
;; ASSUME i <= (length selected)
|
||||
(define (operate-on i operator [data (*data)] [select select] [selected (*selected)])
|
||||
(let sync ((i i) (data data) (selected selected))
|
||||
(if (select (first data))
|
||||
(if (zero? i)
|
||||
(operator (rest data))
|
||||
(cons (first data) (sync (sub1 i) (rest data) (rest selected))))
|
||||
(cons (first data) (sync i (rest data) selected)))))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
(define-syntax-rule (def-cb (name x) exp ...) (define (name x) exp ... (send! (set-list-box-choices lbox (*selected)))))
|
||||
(def-cb (prefix-cb prefix) (selector! prefix))
|
||||
(def-cb (Create-cb _b) (create-entry (retrieve-name)))
|
||||
(def-cb (Update-cb _b) (common-cb (curry update-entry (retrieve-name))))
|
||||
(def-cb (Delete-cb _b) (common-cb delete-from))
|
||||
|
||||
(on (message (text-field-update filter-tf $prefix)) (prefix-cb prefix))
|
||||
(on (message (button-press create-but)) (Create-cb create-but))
|
||||
(on (message (button-press update-but)) (Update-cb update-but))
|
||||
(on (message (button-press delete-but)) (Delete-cb delete-but))
|
||||
|
||||
(define/query-value current-selection #f (list-box@ lbox $selection) selection)
|
||||
(define/query-value *surname "" (text-field@ surname $val) val)
|
||||
(define/query-value *name "" (text-field@ name $val) val)
|
||||
|
||||
(local-require 7GUI/should-be-racket)
|
||||
(define (common-cb f) (when* (current-selection) => f))
|
||||
(define (retrieve-name) (string-append (*surname) ", " (*name)))
|
||||
|
||||
(on-start (prefix-cb "")
|
||||
(send! (show frame #t))))
|
|
@ -1,206 +0,0 @@
|
|||
#lang syndicate
|
||||
|
||||
(require "../../widgets.rkt")
|
||||
(require racket/list
|
||||
racket/gui/base
|
||||
(except-in racket/class field))
|
||||
|
||||
;; a circle drawer with undo/redo facilities (unclear spec for resizing)
|
||||
|
||||
(message-struct circle-canvas-event (type x y))
|
||||
(message-struct resize (circ d))
|
||||
(message-struct draw-circles (closest others))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
(define Default-Diameter 20)
|
||||
|
||||
(struct circle (x y d action) #:transparent)
|
||||
|
||||
(define (draw-1-circle dc brush c)
|
||||
(match-define (circle x y d _a) c)
|
||||
(send dc set-brush brush)
|
||||
(define r (/ d 2))
|
||||
(send dc draw-ellipse (- x r) (- y r) d d))
|
||||
|
||||
|
||||
;; N N (Circle -> Real]
|
||||
(define ((distance xm ym) c)
|
||||
(match-define (circle xc yc _d _a) c)
|
||||
(sqrt (+ (expt (- xc xm) 2) (expt (- yc ym) 2))))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
(define solid-gray (new brush% [color "gray"]))
|
||||
(define white-brush (new brush% [color "white"]))
|
||||
|
||||
(define circle-canvas%
|
||||
(class canvas%
|
||||
(inherit on-paint get-dc)
|
||||
|
||||
(define/override (on-event evt)
|
||||
(define type (send evt get-event-type))
|
||||
(define x (send evt get-x))
|
||||
(define y (send evt get-y))
|
||||
(send-ground-message (circle-canvas-event type x y)))
|
||||
|
||||
(define (paint-callback _self _evt)
|
||||
(draw-circles *last-closest *last-others))
|
||||
|
||||
(define *last-closest #f)
|
||||
(define *last-others #f)
|
||||
|
||||
(define/public (draw-circles closest (others-without-closest #f))
|
||||
(set! *last-closest closest)
|
||||
(set! *last-others others-without-closest)
|
||||
(define dc (get-dc))
|
||||
(send dc clear)
|
||||
(when others-without-closest
|
||||
(for ((c others-without-closest)) (draw-1-circle dc white-brush c)))
|
||||
(when closest (draw-1-circle dc solid-gray closest)))
|
||||
|
||||
(super-new [paint-callback paint-callback])))
|
||||
|
||||
(define (spawn-circle-canvas parent frame undo-but redo-but)
|
||||
(define cc (new circle-canvas% [parent (seal-contents parent)][style '(border)]))
|
||||
|
||||
(spawn
|
||||
(field [*circles '()]
|
||||
[*history '()]
|
||||
[*x 0]
|
||||
[*y 0]
|
||||
[*in-adjuster #f])
|
||||
|
||||
(define (add-circle! x y)
|
||||
(define added (circle x y Default-Diameter 'added))
|
||||
(*circles (cons added (*circles))))
|
||||
|
||||
(define (resize! old-closest new-d)
|
||||
(match-define (circle x y d a) old-closest)
|
||||
(define resized
|
||||
(match a
|
||||
['added (circle x y new-d `(resized (,d)))]
|
||||
[`(resized . ,old-sizes) (circle x y new-d `(resized ,(cons d old-sizes)))]))
|
||||
(*circles (cons resized (remq old-closest (*circles)))))
|
||||
|
||||
(define (undo)
|
||||
(when (cons? (*circles))
|
||||
(define fst (first (*circles)))
|
||||
(match fst
|
||||
[(circle x y d 'added) (*circles (rest (*circles)))]
|
||||
[(circle x y d `(resized (,r0 . ,sizes)))
|
||||
(*circles (cons (circle x y r0 `(resized (,d))) (rest (*circles))))])
|
||||
(*history (cons fst (*history)))))
|
||||
|
||||
(define (redo)
|
||||
(when (cons? (*history))
|
||||
(define fst (first (*history)))
|
||||
(if (eq? (circle-action fst) 'added)
|
||||
(begin (*circles (cons fst (*circles))) (*history (rest (*history))))
|
||||
(begin (*circles (cons fst (rest (*circles)))) (*history (rest (*history)))))))
|
||||
|
||||
(define (the-closest xm ym (circles (*circles)))
|
||||
(define cdistance (distance xm ym))
|
||||
(define-values (good-circles distance*)
|
||||
(for*/fold ([good-circles '()][distance* '()])
|
||||
((c circles) (d (in-value (cdistance c))) #:when (< d (/ (circle-d c) 2)))
|
||||
(values (cons c good-circles) (cons d distance*))))
|
||||
(and (cons? distance*) (first (argmin second (map list good-circles distance*)))))
|
||||
|
||||
(define (is-empty-area xm ym (circles (*circles)))
|
||||
(define dist (distance xm ym))
|
||||
(for/and ((c circles)) (> (dist c) (/ (+ (circle-d c) Default-Diameter) 2))))
|
||||
|
||||
(on (message 'unlock-canvas) (*in-adjuster #f))
|
||||
(on (message 'lock-canvas) (*in-adjuster #t))
|
||||
|
||||
;; no closest
|
||||
(define (draw!)
|
||||
(send cc draw-circles #f (*circles)))
|
||||
|
||||
(on (message (resize $old-closest $new-d))
|
||||
(resize! old-closest new-d)
|
||||
(draw!))
|
||||
|
||||
(on (message (draw-circles $close $others))
|
||||
(send cc draw-circles close others))
|
||||
|
||||
(on (message (button-press undo-but))
|
||||
(undo)
|
||||
(draw!))
|
||||
|
||||
(on (message (button-press redo-but))
|
||||
(redo)
|
||||
(draw!))
|
||||
|
||||
(on (message (inbound (circle-canvas-event $type $x $y)))
|
||||
(unless (*in-adjuster)
|
||||
(*x x)
|
||||
(*y y)
|
||||
(cond
|
||||
[(eq? 'leave type) (*x #f)]
|
||||
[(eq? 'enter type) (*x 0)]
|
||||
[(and (eq? 'left-down type) (is-empty-area (*x) (*y)))
|
||||
(add-circle! (*x) (*y))
|
||||
(draw!)]
|
||||
[(and (eq? 'right-down type) (the-closest (*x) (*y)))
|
||||
=> (λ (tc)
|
||||
(*in-adjuster #t)
|
||||
(popup-adjuster tc *circles frame)
|
||||
(send cc draw-circles tc (*circles)))])))
|
||||
))
|
||||
|
||||
(define (popup-adjuster closest-circle *circles frame)
|
||||
(define pid (gensym 'popup))
|
||||
(send! (popup-menu frame pid "adjuster" 100 100 (list "adjust radius")))
|
||||
(react (stop-when (message (no-popdown-selected pid)) (send! 'unlock-canvas))
|
||||
(stop-when (message (popdown-item-selected pid _)) (adjuster! closest-circle *circles))))
|
||||
|
||||
(define (adjuster! closest-circle *circles)
|
||||
(define d0 (circle-d closest-circle))
|
||||
(define frame (spawn-adjuster-dialog closest-circle (remq closest-circle (*circles))))
|
||||
(spawn-adjuster-slider #:parent frame #:init-value d0))
|
||||
|
||||
(define adjuster-dialog%
|
||||
(class frame% (init-field closest-circle)
|
||||
(match-define (circle x* y* _d _a) closest-circle)
|
||||
|
||||
(define/augment (on-close)
|
||||
(send-ground-message 'adjuster-closed))
|
||||
|
||||
(super-new [label (format "Adjust radius of circle at (~a,~a)" x* y*)])))
|
||||
|
||||
(define (spawn-adjuster-dialog closest-circle others)
|
||||
(match-define (circle x* y* old-d _a) closest-circle)
|
||||
(define dialog
|
||||
(parameterize ((current-eventspace (make-eventspace)))
|
||||
(new adjuster-dialog% [closest-circle closest-circle])))
|
||||
(send dialog show #t)
|
||||
(spawn
|
||||
;; well, there's only one slider
|
||||
(define/query-value *d old-d (slider@ _ $v) v)
|
||||
(on (message (slider-update _ $v))
|
||||
;; resize locally while adjusting
|
||||
(send! (draw-circles (circle x* y* (*d) '_dummy_) others)))
|
||||
(on (message (inbound 'adjuster-closed))
|
||||
;; resize globally
|
||||
(send! 'unlock-canvas)
|
||||
(send! (resize closest-circle (*d)))
|
||||
(stop-current-facet)))
|
||||
(seal dialog))
|
||||
|
||||
|
||||
(define (spawn-adjuster-slider #:parent parent
|
||||
#:init-value init-value)
|
||||
(spawn-slider #:parent parent #:label "" #:min-value 10 #:max-value 100 #:init-value init-value))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
(define frame (spawn-frame #:label "Circle Drawer" #:width 400))
|
||||
(define hpane1 (spawn-horizontal-pane #:parent frame #:min-height 20 #:alignment '(center center)))
|
||||
(define undo-but (spawn-button #:label "Undo" #:parent hpane1))
|
||||
(define redo-but (spawn-button #:label "Redo" #:parent hpane1))
|
||||
(define hpane2 (spawn-horizontal-panel #:parent frame #:min-height 400 #:alignment '(center center)))
|
||||
(define canvas (spawn-circle-canvas hpane2 frame undo-but redo-but))
|
||||
|
||||
(spawn
|
||||
(on (asserted (frame@ frame))
|
||||
(send! (show frame #t))
|
||||
(stop-current-facet)))
|
|
@ -1,96 +0,0 @@
|
|||
#lang syndicate
|
||||
|
||||
(require "../../widgets.rkt")
|
||||
(require "cells-canvas.rkt")
|
||||
(require racket/set racket/list racket/format)
|
||||
|
||||
;; a simple spreadsheet (will not check for circularities)
|
||||
|
||||
(require 7GUI/task-7-exp)
|
||||
(require 7GUI/task-7-view)
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
(struct formula (formula dependents) #:transparent)
|
||||
#; {Formula = [formula Exp* || Number || (Setof Ref*)]}
|
||||
|
||||
(define (spawn-control frame)
|
||||
(spawn
|
||||
(field [*content (make-immutable-hash)] ;; [Hashof Ref* Integer]
|
||||
[*formulas (make-immutable-hash)] ;; [Hashof Ref* Formula]
|
||||
)
|
||||
|
||||
|
||||
(define-syntax-rule (iff selector e default) (let ([v e]) (if v (selector v) default)))
|
||||
(define (get-exp ref*) (iff formula-formula (hash-ref (*formulas) ref* #f) 0))
|
||||
(define (get-dep ref*) (iff formula-dependents (hash-ref (*formulas) ref* #f) (set)))
|
||||
(define (get-content ref*) (hash-ref (*content) ref* 0))
|
||||
|
||||
(local-require 7GUI/should-be-racket)
|
||||
(define (set-content! ref* vc)
|
||||
(define current (get-content ref*))
|
||||
(*content (hash-set (*content) ref* vc))
|
||||
(when (and current (not (= current vc)))
|
||||
(when* (get-dep ref*) => propagate-to)))
|
||||
|
||||
(define (propagate-to dependents)
|
||||
(for ((d (in-set dependents)))
|
||||
(set-content! d (evaluate (get-exp d) (*content)))))
|
||||
|
||||
(define (set-formula! ref* exp*)
|
||||
(define new (formula exp* (or (get-dep ref*) (set))))
|
||||
(*formulas (hash-set (*formulas) ref* new))
|
||||
(register-with-dependents (depends-on exp*) ref*)
|
||||
(set-content! ref* (evaluate exp* (*content))))
|
||||
|
||||
(define (register-with-dependents dependents ref*)
|
||||
(for ((d (in-set dependents)))
|
||||
(*formulas (hash-set (*formulas) d (formula (get-exp d) (set-add (get-dep d) ref*))))))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
;; cells and contents
|
||||
(define ((mk-edit title-fmt validator registration source frame) x y)
|
||||
(define cell (list (x->A x) (y->0 y)))
|
||||
(when (and (first cell) (second cell))
|
||||
(react
|
||||
(define value0 (~a (or (source cell) "")))
|
||||
;; maybe need to make use of queue-callback ?
|
||||
(define dialog (spawn-dialog #:parent #f
|
||||
#:style '(close-button)
|
||||
#:label (format title-fmt cell)))
|
||||
(define tf (spawn-text-field #:parent dialog
|
||||
#:label #f
|
||||
#:min-width 200
|
||||
#:min-height 80
|
||||
#:init-value value0))
|
||||
(on (message (text-field-enter tf $contents))
|
||||
(when* (validator contents)
|
||||
=> (lambda (valid)
|
||||
(stop-current-facet
|
||||
(send! (show dialog #f))
|
||||
(registration cell valid)
|
||||
(send! (update-grid (*content)))))))
|
||||
(on (asserted (dialog@ dialog))
|
||||
(send! (show dialog #t))))))
|
||||
|
||||
(define content-edit (mk-edit "content for cell ~a" valid-content set-content! get-content frame))
|
||||
|
||||
(define formula-fmt "a formula for cell ~a")
|
||||
(define formula-edit (mk-edit formula-fmt string->exp* set-formula! (compose exp*->string get-exp) frame))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
(on (message (single-click $x $y))
|
||||
(content-edit x y))
|
||||
(on (message (double-click $x $y))
|
||||
(formula-edit x y))
|
||||
(on-start (send! (update-grid (*content))))
|
||||
))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
(define frame (spawn-frame #:label "Cells" #:width (/ WIDTH 2) #:height (/ HEIGHT 3)))
|
||||
(define canvas (spawn-cells-canvas frame WIDTH HEIGHT))
|
||||
(spawn-control frame)
|
||||
|
||||
(spawn
|
||||
(on (asserted (frame@ frame))
|
||||
(send! (show frame #t))
|
||||
(stop-current-facet)))
|
|
@ -1,8 +0,0 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define compile-omit-paths
|
||||
'("examples"))
|
||||
|
||||
(define test-omit-paths
|
||||
'(;; depends on Matthias's 7GUI project which is not on the package server
|
||||
"examples"))
|
|
@ -1,387 +0,0 @@
|
|||
#lang syndicate
|
||||
|
||||
(provide gui-eventspace
|
||||
gui-callback
|
||||
qc
|
||||
spawn-frame
|
||||
spawn-horizontal-pane
|
||||
spawn-horizontal-panel
|
||||
spawn-vertical-pane
|
||||
spawn-text-field
|
||||
spawn-button
|
||||
spawn-choice
|
||||
spawn-gauge
|
||||
spawn-slider
|
||||
spawn-list-box
|
||||
spawn-dialog
|
||||
(struct-out frame@)
|
||||
(struct-out show)
|
||||
(struct-out horizontal-pane@)
|
||||
(struct-out horizontal-panel@)
|
||||
(struct-out vertical-pane@)
|
||||
(struct-out text-field@)
|
||||
(struct-out set-text-field)
|
||||
(struct-out button@)
|
||||
(struct-out button-press)
|
||||
(struct-out set-text-field-background)
|
||||
(struct-out text-field-update)
|
||||
(struct-out text-field-enter)
|
||||
(struct-out choice@)
|
||||
(struct-out choice-selection)
|
||||
(struct-out set-selection)
|
||||
(struct-out enable)
|
||||
(struct-out gauge@)
|
||||
(struct-out set-gauge-value)
|
||||
(struct-out slider@)
|
||||
(struct-out slider-update)
|
||||
(struct-out list-box@)
|
||||
(struct-out list-box-selection)
|
||||
(struct-out set-list-box-choices)
|
||||
(struct-out popup-menu)
|
||||
(struct-out no-popdown-selected)
|
||||
(struct-out popdown-item-selected)
|
||||
(struct-out dialog@))
|
||||
|
||||
(require (only-in racket/class
|
||||
new
|
||||
send
|
||||
make-object))
|
||||
(require racket/gui/base)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Eventspace Shennanigans
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define gui-eventspace (make-parameter (make-eventspace)))
|
||||
|
||||
(define (gui-callback thnk)
|
||||
(parameterize ([current-eventspace (gui-eventspace)])
|
||||
(queue-callback thnk)))
|
||||
|
||||
(define-syntax-rule (qc expr ...)
|
||||
(gui-callback (lambda () expr ...)))
|
||||
|
||||
|
||||
;; an ID is a (Sealof Any)
|
||||
;; an Alignment is a (List (U 'left 'center 'right) (U 'top 'center 'bottom))
|
||||
|
||||
(message-struct enable (id val))
|
||||
|
||||
(assertion-struct frame@ (id))
|
||||
(message-struct show (id value))
|
||||
(message-struct popup-menu (parent-id id title x y items))
|
||||
(message-struct no-popdown-selected (id))
|
||||
(message-struct popdown-item-selected (id item))
|
||||
|
||||
(assertion-struct horizontal-pane@ (id))
|
||||
(assertion-struct vertical-pane@ (id))
|
||||
(assertion-struct horizontal-panel@ (id))
|
||||
|
||||
(assertion-struct text-field@ (id value))
|
||||
(message-struct set-text-field (id value))
|
||||
(message-struct set-text-field-background (id color))
|
||||
(message-struct text-field-update (id value))
|
||||
(message-struct text-field-enter (id value))
|
||||
|
||||
(assertion-struct button@ (id))
|
||||
(message-struct button-press (id))
|
||||
|
||||
(assertion-struct choice@ (id selection))
|
||||
(message-struct choice-selection (id val))
|
||||
(message-struct set-selection (id idx))
|
||||
|
||||
(assertion-struct gauge@ (id))
|
||||
(message-struct set-gauge-value (id value))
|
||||
|
||||
(assertion-struct slider@ (id value))
|
||||
(message-struct slider-update (id value))
|
||||
|
||||
(assertion-struct list-box@ (id idx))
|
||||
(message-struct list-box-selection (id idx))
|
||||
(message-struct set-list-box-choices (id choices))
|
||||
|
||||
(assertion-struct dialog@ (id))
|
||||
|
||||
(define (enable/disable-handler self my-id)
|
||||
(on (message (enable my-id $val))
|
||||
(qc (send self enable val))))
|
||||
|
||||
;; String -> ID
|
||||
(define (spawn-frame #:label label
|
||||
#:width [width #f]
|
||||
#:height [height #f])
|
||||
(define frame
|
||||
(parameterize ((current-eventspace (gui-eventspace)))
|
||||
(new frame%
|
||||
[label label]
|
||||
[width width]
|
||||
[height height])))
|
||||
(define id (seal frame))
|
||||
|
||||
(define ((on-popdown! pid) self evt)
|
||||
(when (eq? (send evt get-event-type) 'menu-popdown-none)
|
||||
(send-ground-message (no-popdown-selected pid))))
|
||||
(define ((popdown-item! pid i) . _x)
|
||||
(send-ground-message (popdown-item-selected pid i)))
|
||||
|
||||
(spawn
|
||||
(assert (frame@ id))
|
||||
(on (message (show id $val))
|
||||
(qc (send frame show val)))
|
||||
(on (message (popup-menu id $pid $title $x $y $items))
|
||||
(define pm (new popup-menu% [title title] [popdown-callback (on-popdown! pid)]))
|
||||
(for ([i (in-list items)])
|
||||
(new menu-item% [parent pm] [label i] [callback (popdown-item! pid i)]))
|
||||
(qc (send frame popup-menu pm x y))
|
||||
(react (stop-when (message (inbound (no-popdown-selected pid))) (send! (no-popdown-selected pid)))
|
||||
(stop-when (message (inbound (popdown-item-selected pid $i))) (send! (popdown-item-selected pid i))))))
|
||||
id)
|
||||
|
||||
;; ID ... -> ID
|
||||
(define (spawn-horizontal-pane #:parent parent
|
||||
#:border [border 0]
|
||||
#:min-height [min-height #f]
|
||||
#:alignment [alignment '(left center)])
|
||||
(define parent-component (seal-contents parent))
|
||||
(define pane (new horizontal-pane%
|
||||
[parent parent-component]
|
||||
[border border]
|
||||
[min-height min-height]
|
||||
[alignment alignment]))
|
||||
(define id (seal pane))
|
||||
|
||||
(spawn
|
||||
(assert (horizontal-pane@ id)))
|
||||
|
||||
id)
|
||||
|
||||
;; ID ... -> ID
|
||||
(define (spawn-horizontal-panel #:parent parent
|
||||
#:border [border 0]
|
||||
#:min-height [min-height #f]
|
||||
#:alignment [alignment '(left center)])
|
||||
(define parent-component (seal-contents parent))
|
||||
(define panel (new horizontal-panel%
|
||||
[parent parent-component]
|
||||
[border border]
|
||||
[min-height min-height]
|
||||
[alignment alignment]))
|
||||
(define id (seal panel))
|
||||
|
||||
(spawn
|
||||
(assert (horizontal-panel@ id)))
|
||||
|
||||
id)
|
||||
|
||||
;; ID Alignment -> ID
|
||||
(define (spawn-vertical-pane #:parent parent
|
||||
#:alignment [alignment '(center top)])
|
||||
(define parent-component (seal-contents parent))
|
||||
(define pane (new vertical-pane%
|
||||
[parent parent-component]
|
||||
[alignment alignment]))
|
||||
(define id (seal pane))
|
||||
|
||||
(spawn
|
||||
(assert (vertical-pane@ id)))
|
||||
|
||||
id)
|
||||
|
||||
; ID String String Bool Nat -> ID
|
||||
(define (spawn-text-field #:parent parent
|
||||
#:label label
|
||||
#:init-value init
|
||||
#:enabled [enabled? #t]
|
||||
#:min-width [min-width #f]
|
||||
#:min-height [min-height #f])
|
||||
(define parent-component (seal-contents parent))
|
||||
|
||||
(define (inject-text-field-update! _ evt)
|
||||
(case (send evt get-event-type)
|
||||
[(text-field)
|
||||
(send-ground-message (text-field-update id (send tf get-value)))]
|
||||
[(text-field-enter)
|
||||
(send-ground-message (text-field-enter id (send tf get-value)))]))
|
||||
|
||||
(define tf (new text-field%
|
||||
[parent parent-component]
|
||||
[label label]
|
||||
[init-value init]
|
||||
[enabled enabled?]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[callback inject-text-field-update!]))
|
||||
(define id (seal tf))
|
||||
|
||||
(spawn
|
||||
(field [val (send tf get-value)])
|
||||
(assert (text-field@ id (val)))
|
||||
(enable/disable-handler tf id)
|
||||
(on (message (set-text-field id $value))
|
||||
(qc (send tf set-value value))
|
||||
(val value))
|
||||
(on (message (set-text-field-background id $color))
|
||||
(define c (make-object color% color))
|
||||
(qc (send tf set-field-background c)))
|
||||
(on (message (inbound (text-field-update id $value)))
|
||||
(val value)
|
||||
(send! (text-field-update id value)))
|
||||
(on (message (inbound (text-field-enter id $value)))
|
||||
(val value)
|
||||
(send! (text-field-enter id value))))
|
||||
|
||||
id)
|
||||
|
||||
;; ID String -> ID
|
||||
(define (spawn-button #:parent parent
|
||||
#:label label)
|
||||
(define (inject-button-press! b e)
|
||||
(send-ground-message (button-press id)))
|
||||
(define parent-component (seal-contents parent))
|
||||
(define but (new button%
|
||||
[parent parent-component]
|
||||
[label label]
|
||||
[callback inject-button-press!]))
|
||||
(define id (seal but))
|
||||
|
||||
(spawn
|
||||
(assert (button@ id))
|
||||
(enable/disable-handler but id)
|
||||
;; NOTE - this assumes we are one level away from ground
|
||||
(on (message (inbound (button-press id)))
|
||||
(send! (button-press id))))
|
||||
|
||||
id)
|
||||
|
||||
;; ID String (Listof String) -> ID
|
||||
(define (spawn-choice #:parent parent
|
||||
#:label label
|
||||
#:choices choices)
|
||||
(define (inject-selection! c e)
|
||||
(send-ground-message (choice-selection id (send ch get-string-selection))))
|
||||
(define parent-component (seal-contents parent))
|
||||
(define ch (new choice%
|
||||
[parent parent-component]
|
||||
[label label]
|
||||
[choices choices]
|
||||
[callback inject-selection!]))
|
||||
(define id (seal ch))
|
||||
|
||||
(spawn
|
||||
(field [selection (send ch get-string-selection)])
|
||||
(assert (choice@ id (selection)))
|
||||
|
||||
(enable/disable-handler ch id)
|
||||
(on (message (inbound (choice-selection id $val)))
|
||||
(selection val)
|
||||
(send! (choice-selection id val)))
|
||||
(on (message (set-selection id $idx))
|
||||
(qc (send ch set-selection idx))
|
||||
(selection (send ch get-string-selection))))
|
||||
|
||||
id)
|
||||
|
||||
;; ID String Bool Nat -> ID
|
||||
(define (spawn-gauge #:parent parent
|
||||
#:label label
|
||||
#:enabled [enabled? #t]
|
||||
#:range [range 100])
|
||||
(define parent-component (seal-contents parent))
|
||||
(define g (new gauge%
|
||||
[parent parent-component]
|
||||
[label label]
|
||||
[enabled enabled?]
|
||||
[range range]))
|
||||
(define id (seal g))
|
||||
|
||||
(spawn
|
||||
(assert (gauge@ id))
|
||||
(on (message (set-gauge-value id $v))
|
||||
(qc (send g set-value v))))
|
||||
|
||||
id)
|
||||
|
||||
;; ID String Nat Nat -> ID
|
||||
(define (spawn-slider #:parent parent
|
||||
#:label label
|
||||
#:min-value min-value
|
||||
#:max-value max-value
|
||||
#:init-value [init-value min-value])
|
||||
(define (inject-slider-event! self evt)
|
||||
(send-ground-message (slider-update id (get))))
|
||||
|
||||
(define parent-component (seal-contents parent))
|
||||
(define s (new slider%
|
||||
[parent parent-component]
|
||||
[label label]
|
||||
[min-value min-value]
|
||||
[max-value max-value]
|
||||
[init-value init-value]
|
||||
[callback inject-slider-event!]))
|
||||
(define id (seal s))
|
||||
|
||||
(define (get) (send s get-value))
|
||||
|
||||
(spawn
|
||||
(field [current (get)])
|
||||
(assert (slider@ id (current)))
|
||||
(on (message (inbound (slider-update id $val)))
|
||||
(current val)
|
||||
(send! (slider-update id val))))
|
||||
|
||||
id)
|
||||
|
||||
;; ID (U String #f) (Listof String) ... -> ID
|
||||
(define (spawn-list-box #:parent parent
|
||||
#:label label
|
||||
#:choices choices
|
||||
#:min-width [min-width #f]
|
||||
#:min-height [min-height #f])
|
||||
(define (inject-list-box-selection! self evt)
|
||||
(send-ground-message (list-box-selection id (get))))
|
||||
(define parent-component (seal-contents parent))
|
||||
(define lb (new list-box%
|
||||
[parent parent-component]
|
||||
[label label]
|
||||
[choices choices]
|
||||
[min-width min-width]
|
||||
[min-height min-height]
|
||||
[callback inject-list-box-selection!]))
|
||||
(define id (seal lb))
|
||||
(define (get)
|
||||
(send lb get-selection))
|
||||
|
||||
(spawn
|
||||
(field [selection (get)])
|
||||
(assert (list-box@ id (selection)))
|
||||
(on (message (inbound (list-box-selection id $val)))
|
||||
(selection val)
|
||||
(send! (list-box-selection id val)))
|
||||
(on (message (set-list-box-choices id $val))
|
||||
(qc (send lb set val))
|
||||
(selection (get))))
|
||||
|
||||
id)
|
||||
|
||||
(define (spawn-dialog #:label label
|
||||
#:parent [parent #f]
|
||||
#:style [style null])
|
||||
(define parent-component (and parent (seal-contents parent)))
|
||||
(define evt-spc (if parent-component
|
||||
(send parent-component get-eventspace)
|
||||
(make-eventspace) #;(gui-eventspace)))
|
||||
(define d (parameterize ((current-eventspace evt-spc))
|
||||
(new dialog%
|
||||
[label label]
|
||||
[parent parent-component]
|
||||
[style style])))
|
||||
(define id (seal d))
|
||||
|
||||
(spawn
|
||||
(assert (dialog@ id))
|
||||
|
||||
(on (message (show id $show?))
|
||||
(qc (send d show show?))
|
||||
(unless show? (stop-current-facet))))
|
||||
|
||||
id)
|
|
@ -31,9 +31,6 @@
|
|||
retracted
|
||||
rising-edge
|
||||
(rename-out [core:message message])
|
||||
know
|
||||
forget
|
||||
realize
|
||||
|
||||
let-event
|
||||
|
||||
|
@ -61,7 +58,6 @@
|
|||
perform-actions!
|
||||
flush!
|
||||
quit-dataspace!
|
||||
realize!
|
||||
|
||||
syndicate-effects-available?
|
||||
|
||||
|
@ -84,7 +80,6 @@
|
|||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require racket/contract)
|
||||
(require (only-in racket/list flatten))
|
||||
|
||||
(require (for-syntax racket/base))
|
||||
(require (for-syntax syntax/parse))
|
||||
|
@ -203,15 +198,10 @@
|
|||
endpoints ;; (Hash EID Endpoint)
|
||||
stop-scripts ;; (Listof Script) -- IN REVERSE ORDER
|
||||
children ;; (Setof FID)
|
||||
previous-knowledge ;; AssertionSet of internal knowledge
|
||||
knowledge ;; AssertionSet of internal knowledge
|
||||
) #:prefab)
|
||||
|
||||
(struct endpoint (id patch-fn handler-fn) #:prefab)
|
||||
|
||||
(struct internal-knowledge (v) #:prefab)
|
||||
(define internal-knowledge-parenthesis (open-parenthesis 1 struct:internal-knowledge))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Script priorities. These are used to ensure that the results of
|
||||
;; some *side effects* are visible to certain pieces of code.
|
||||
|
@ -259,12 +249,6 @@
|
|||
;; Storeof (Constreeof Action)
|
||||
(define current-pending-actions (make-store))
|
||||
|
||||
;; Storeof Patch
|
||||
(define current-pending-internal-patch (make-store))
|
||||
|
||||
;; Storeof (Constreeof Action)
|
||||
(define current-pending-internal-events (make-store))
|
||||
|
||||
;; Storeof (Vector (Queue Script) ...)
|
||||
;; Mutates the vector!
|
||||
(define current-pending-scripts (make-store))
|
||||
|
@ -409,7 +393,6 @@
|
|||
[(_ [id:id init maybe-contract ...] ...)
|
||||
(quasisyntax/loc stx
|
||||
(begin
|
||||
(ensure-in-endpoint-context! 'field)
|
||||
(when (and (in-script?) (pair? (current-facet-id)))
|
||||
(error 'field
|
||||
"~a: Cannot declare fields in a script; are you missing a (react ...)?"
|
||||
|
@ -424,7 +407,6 @@
|
|||
(analyze-pattern stx #'P))
|
||||
(quasisyntax/loc stx
|
||||
(add-endpoint! #,(source-location->string stx)
|
||||
#f
|
||||
(lambda ()
|
||||
#,(let ((patch-stx #`(core:assert #,pat)))
|
||||
(if #'w.Pred
|
||||
|
@ -432,22 +414,6 @@
|
|||
patch-stx)))
|
||||
void))]))
|
||||
|
||||
(define-syntax (know stx)
|
||||
(syntax-parse stx
|
||||
[(_ w:when-pred P)
|
||||
(define-values (proj pat bindings _instantiated)
|
||||
(analyze-pattern stx #'P))
|
||||
(quasisyntax/loc stx
|
||||
(add-endpoint!
|
||||
#,(source-location->string stx)
|
||||
#t
|
||||
(lambda ()
|
||||
#,(let ((patch-stx #`(core:assert (internal-knowledge #,pat))))
|
||||
(if #'w.Pred
|
||||
#`(if w.Pred #,patch-stx patch-empty)
|
||||
patch-stx)))
|
||||
void))]))
|
||||
|
||||
(define (fid-ancestor? fid maybe-ancestor)
|
||||
(and (pair? fid) ;; empty fid lists obviously no ancestors at all!
|
||||
(or (equal? fid maybe-ancestor)
|
||||
|
@ -488,17 +454,13 @@
|
|||
(syntax-parse stx
|
||||
[(_ script ...)
|
||||
(quasisyntax/loc stx
|
||||
(begin
|
||||
(ensure-in-endpoint-context! 'on-start)
|
||||
(schedule-script! (lambda () (begin/void-default script ...)))))]))
|
||||
(schedule-script! (lambda () (begin/void-default script ...))))]))
|
||||
|
||||
(define-syntax (on-stop stx)
|
||||
(syntax-parse stx
|
||||
[(_ script ...)
|
||||
(quasisyntax/loc stx
|
||||
(begin
|
||||
(ensure-in-endpoint-context! 'on-stop)
|
||||
(add-stop-script! (lambda () (begin/void-default script ...)))))]))
|
||||
(add-stop-script! (lambda () (begin/void-default script ...))))]))
|
||||
|
||||
(define-syntax (on-event stx)
|
||||
(syntax-parse stx
|
||||
|
@ -512,7 +474,6 @@
|
|||
|
||||
(define (on-event* where proc #:priority [priority *normal-priority*])
|
||||
(add-endpoint! where
|
||||
#f
|
||||
(lambda () patch-empty)
|
||||
(lambda (e _current-interests _synthetic?)
|
||||
(schedule-script! #:priority priority (lambda () (proc e))))))
|
||||
|
@ -528,18 +489,14 @@
|
|||
|
||||
(define-syntax (during stx)
|
||||
(syntax-parse stx
|
||||
#:literals (know)
|
||||
[(_ (~or (~and K (know P)) P) O ...)
|
||||
(define E-stx (quasisyntax/loc #'P #,(if (attribute K)
|
||||
#'K
|
||||
#'(asserted P))))
|
||||
(define R-stx (if (attribute K) #'forget #'retracted))
|
||||
[(_ P O ...)
|
||||
(define E-stx (syntax/loc #'P (asserted P)))
|
||||
(define-values (_proj _pat _bindings instantiated)
|
||||
(analyze-pattern E-stx #'P))
|
||||
(quasisyntax/loc stx
|
||||
(on #,E-stx
|
||||
(let ((p #,instantiated))
|
||||
(react (stop-when (#,R-stx p))
|
||||
(react (stop-when (retracted p))
|
||||
O ...))))]))
|
||||
|
||||
(define-syntax (during/spawn stx)
|
||||
|
@ -590,7 +547,6 @@
|
|||
(quasisyntax/loc stx
|
||||
(let ()
|
||||
(add-endpoint! #,(source-location->string stx)
|
||||
#f
|
||||
(lambda ()
|
||||
(define subject-id (current-dataflow-subject-id))
|
||||
(schedule-script!
|
||||
|
@ -614,8 +570,6 @@
|
|||
(define-syntax (asserted stx) (raise-syntax-error #f "asserted: Used outside event spec" stx))
|
||||
(define-syntax (retracted stx) (raise-syntax-error #f "retracted: Used outside event spec" stx))
|
||||
(define-syntax (rising-edge stx) (raise-syntax-error #f "rising-edge: Used outside event spec" stx))
|
||||
(define-syntax (forget stx) (raise-syntax-error #f "forget: Used outside event spec" stx))
|
||||
(define-syntax (realize stx) (raise-syntax-error #f "realize: Used outside event spec" stx))
|
||||
|
||||
(define-syntax (suspend-script stx)
|
||||
(syntax-parse stx
|
||||
|
@ -818,125 +772,62 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Syntax-time support
|
||||
|
||||
(define (interests-pre-and-post-patch pat synthetic? retrieve-knowledge)
|
||||
(define (interests-pre-and-post-patch pat synthetic?)
|
||||
(define (or* x y) (or x y))
|
||||
(define-values (prev current) (retrieve-knowledge synthetic?))
|
||||
(define old (trie-lookup prev pat #f #:wildcard-union or*))
|
||||
(define new (trie-lookup current pat #f #:wildcard-union or*))
|
||||
(values old new))
|
||||
|
||||
(define (interest-just-appeared-matching? pat synthetic? retrieve-knowledge)
|
||||
(define-values (old new) (interests-pre-and-post-patch pat synthetic? retrieve-knowledge))
|
||||
(and (not old) new))
|
||||
|
||||
(define (interest-just-disappeared-matching? pat synthetic? retrieve-knowledge)
|
||||
(define-values (old new) (interests-pre-and-post-patch pat synthetic? retrieve-knowledge))
|
||||
(and old (not new)))
|
||||
|
||||
;; Bool -> (Values AssertionSet AssertionSet)
|
||||
;; retrieve the previous and current knowledge fields from the current actor state
|
||||
(define (current-actor-state-knowledges synthetic?)
|
||||
(define a (current-actor-state))
|
||||
(define previous-knowledge (if synthetic? trie-empty (actor-state-previous-knowledge a)))
|
||||
(define current-knowledge (actor-state-knowledge a))
|
||||
(values previous-knowledge current-knowledge))
|
||||
(define old (trie-lookup previous-knowledge pat #f #:wildcard-union or*))
|
||||
(define new (trie-lookup (actor-state-knowledge a) pat #f #:wildcard-union or*))
|
||||
(values old new))
|
||||
|
||||
;; Bool -> (Values AssertionSet AssertionSet)
|
||||
;; retrieve the previous and current knowledge fields from the current facet
|
||||
(define (current-facet-knowledges synthetic?)
|
||||
(define f (lookup-facet (current-facet-id)))
|
||||
(define previous-knowledge (if synthetic? trie-empty (facet-previous-knowledge f)))
|
||||
(define current-knowledge (facet-knowledge f))
|
||||
(values previous-knowledge current-knowledge))
|
||||
(define (interest-just-appeared-matching? pat synthetic?)
|
||||
(define-values (old new) (interests-pre-and-post-patch pat synthetic?))
|
||||
(and (not old) new))
|
||||
|
||||
(define-for-syntax (analyze-appear/disappear outer-expr-stx
|
||||
when-pred-stx
|
||||
event-stx
|
||||
script-stx
|
||||
asserted?
|
||||
P-stx
|
||||
priority-stx
|
||||
internal?)
|
||||
(define P+
|
||||
(if internal? #`(internal-knowledge #,P-stx) P-stx))
|
||||
(define (interest-just-disappeared-matching? pat synthetic?)
|
||||
(define-values (old new) (interests-pre-and-post-patch pat synthetic?))
|
||||
(and old (not new)))
|
||||
|
||||
(define-for-syntax (analyze-asserted/retracted outer-expr-stx
|
||||
when-pred-stx
|
||||
event-stx
|
||||
script-stx
|
||||
asserted?
|
||||
P-stx
|
||||
priority-stx)
|
||||
(define-values (proj-stx pat bindings _instantiated)
|
||||
(analyze-pattern event-stx P+))
|
||||
(define interest-stx
|
||||
(if internal?
|
||||
#`(patch-seq (core:sub #,pat)
|
||||
;; Allow other facets to see our interest
|
||||
(core:assert (internal-knowledge (observe #,(cadr pat)))))
|
||||
#`(core:sub #,pat)))
|
||||
(analyze-pattern event-stx P-stx))
|
||||
(define event-predicate-stx (if asserted? #'patch/added? #'patch/removed?))
|
||||
(define patch-accessor-stx (if asserted? #'patch-added #'patch-removed))
|
||||
(define change-detector-stx
|
||||
(if asserted? #'interest-just-appeared-matching? #'interest-just-disappeared-matching?))
|
||||
(define knowledge-retriever
|
||||
(if internal? #'current-facet-knowledges #'current-actor-state-knowledges))
|
||||
(quasisyntax/loc outer-expr-stx
|
||||
(add-endpoint!
|
||||
#,(source-location->string outer-expr-stx)
|
||||
#,internal?
|
||||
(lambda () (if #,when-pred-stx
|
||||
#,interest-stx
|
||||
patch-empty))
|
||||
(lambda (e current-interests synthetic?)
|
||||
(when (not (trie-empty? current-interests))
|
||||
(core:match-event e
|
||||
[(? #,event-predicate-stx p)
|
||||
(define proj #,proj-stx)
|
||||
(define proj-arity (projection-arity proj))
|
||||
(define entry-set (trie-project/set #:take proj-arity
|
||||
(#,patch-accessor-stx p)
|
||||
proj))
|
||||
(when (not entry-set)
|
||||
(error 'asserted
|
||||
"Wildcard interest discovered while projecting by ~v at ~a"
|
||||
proj
|
||||
#,(source-location->string P-stx)))
|
||||
(for [(entry (in-set entry-set))]
|
||||
(let ((instantiated (instantiate-projection proj entry)))
|
||||
(and (#,change-detector-stx instantiated synthetic? #,knowledge-retriever)
|
||||
(schedule-script!
|
||||
#:priority #,priority-stx
|
||||
(lambda ()
|
||||
(match-define (list #,@bindings) entry)
|
||||
#,script-stx)))))]))))))
|
||||
|
||||
(define-for-syntax (analyze-message outer-expr-stx
|
||||
when-pred-stx
|
||||
event-stx
|
||||
script-stx
|
||||
P-stx
|
||||
priority-stx
|
||||
internal?)
|
||||
(define-values (proj pat bindings _instantiated)
|
||||
(analyze-pattern event-stx P-stx))
|
||||
(define sub
|
||||
(if internal? #`(internal-knowledge #,pat) pat))
|
||||
(define matchp
|
||||
(if internal? #'(internal-knowledge body) #'body))
|
||||
(quasisyntax/loc outer-expr-stx
|
||||
(add-endpoint!
|
||||
#,(source-location->string outer-expr-stx)
|
||||
#,internal?
|
||||
(lambda () (if #,when-pred-stx
|
||||
(core:sub #,sub)
|
||||
patch-empty))
|
||||
(lambda (e current-interests _synthetic?)
|
||||
(when (not (trie-empty? current-interests))
|
||||
(core:match-event e
|
||||
[(core:message #,matchp)
|
||||
(define capture-vals
|
||||
(match-value/captures
|
||||
body
|
||||
#,proj))
|
||||
(and capture-vals
|
||||
(schedule-script!
|
||||
#:priority #,priority-stx
|
||||
(lambda ()
|
||||
(apply (lambda #,bindings #,script-stx)
|
||||
capture-vals))))]))))))
|
||||
(add-endpoint! #,(source-location->string outer-expr-stx)
|
||||
(lambda () (if #,when-pred-stx
|
||||
(core:sub #,pat)
|
||||
patch-empty))
|
||||
(lambda (e current-interests synthetic?)
|
||||
(when (not (trie-empty? current-interests))
|
||||
(core:match-event e
|
||||
[(? #,event-predicate-stx p)
|
||||
(define proj #,proj-stx)
|
||||
(define proj-arity (projection-arity proj))
|
||||
(define entry-set (trie-project/set #:take proj-arity
|
||||
(#,patch-accessor-stx p)
|
||||
proj))
|
||||
(when (not entry-set)
|
||||
(error 'asserted
|
||||
"Wildcard interest discovered while projecting by ~v at ~a"
|
||||
proj
|
||||
#,(source-location->string P-stx)))
|
||||
(for [(entry (in-set entry-set))]
|
||||
(let ((instantiated (instantiate-projection proj entry)))
|
||||
(and (#,change-detector-stx instantiated synthetic?)
|
||||
(schedule-script!
|
||||
#:priority #,priority-stx
|
||||
(lambda ()
|
||||
(match-define (list #,@bindings) entry)
|
||||
#,script-stx)))))]))))))
|
||||
|
||||
(define-for-syntax orig-insp
|
||||
(variable-reference->module-declaration-inspector (#%variable-reference)))
|
||||
|
@ -948,7 +839,7 @@
|
|||
priority-stx)
|
||||
(define event-stx (syntax-disarm armed-event-stx orig-insp))
|
||||
(syntax-parse event-stx
|
||||
#:literals [core:message asserted retracted rising-edge know forget realize]
|
||||
#:literals [core:message asserted retracted rising-edge]
|
||||
[(expander args ...)
|
||||
#:when (event-expander-id? #'expander)
|
||||
(event-expander-transform
|
||||
|
@ -960,23 +851,33 @@
|
|||
script-stx
|
||||
priority-stx)))]
|
||||
[(core:message P)
|
||||
(analyze-message outer-expr-stx when-pred-stx event-stx script-stx
|
||||
#'P priority-stx #f)]
|
||||
(define-values (proj pat bindings _instantiated)
|
||||
(analyze-pattern event-stx #'P))
|
||||
(quasisyntax/loc outer-expr-stx
|
||||
(add-endpoint! #,(source-location->string outer-expr-stx)
|
||||
(lambda () (if #,when-pred-stx
|
||||
(core:sub #,pat)
|
||||
patch-empty))
|
||||
(lambda (e current-interests _synthetic?)
|
||||
(when (not (trie-empty? current-interests))
|
||||
(core:match-event e
|
||||
[(core:message body)
|
||||
(define capture-vals
|
||||
(match-value/captures
|
||||
body
|
||||
#,proj))
|
||||
(and capture-vals
|
||||
(schedule-script!
|
||||
#:priority #,priority-stx
|
||||
(lambda ()
|
||||
(apply (lambda #,bindings #,script-stx)
|
||||
capture-vals))))])))))]
|
||||
[(asserted P)
|
||||
(analyze-appear/disappear outer-expr-stx when-pred-stx event-stx script-stx
|
||||
#t #'P priority-stx #f)]
|
||||
(analyze-asserted/retracted outer-expr-stx when-pred-stx event-stx script-stx
|
||||
#t #'P priority-stx)]
|
||||
[(retracted P)
|
||||
(analyze-appear/disappear outer-expr-stx when-pred-stx event-stx script-stx
|
||||
#f #'P priority-stx #f)]
|
||||
[(realize P)
|
||||
(analyze-message outer-expr-stx when-pred-stx event-stx script-stx
|
||||
#'P priority-stx #t)]
|
||||
[(know P)
|
||||
(analyze-appear/disappear outer-expr-stx when-pred-stx event-stx script-stx
|
||||
#t #'P priority-stx #t)]
|
||||
[(forget P)
|
||||
(analyze-appear/disappear outer-expr-stx when-pred-stx event-stx script-stx
|
||||
#f #'P priority-stx #t)]
|
||||
(analyze-asserted/retracted outer-expr-stx when-pred-stx event-stx script-stx
|
||||
#f #'P priority-stx)]
|
||||
[(rising-edge Pred)
|
||||
(define field-name
|
||||
(datum->syntax event-stx
|
||||
|
@ -986,7 +887,6 @@
|
|||
(let ()
|
||||
(field [#,field-name #f])
|
||||
(add-endpoint! #,(source-location->string outer-expr-stx)
|
||||
#f
|
||||
(lambda ()
|
||||
(when #,when-pred-stx
|
||||
(define old-val (#,field-name))
|
||||
|
@ -1103,30 +1003,14 @@
|
|||
(current-pending-actions (list (current-pending-actions)
|
||||
((current-action-transformer) p)))))
|
||||
|
||||
(define (schedule-internal-event! ac)
|
||||
(if (patch? ac)
|
||||
(when (patch-non-empty? ac)
|
||||
(current-pending-internal-patch (compose-patch ac (current-pending-internal-patch))))
|
||||
(begin (flush-pending-internal-patch!)
|
||||
(current-pending-internal-events (list (current-pending-internal-events)
|
||||
((current-action-transformer) ac))))))
|
||||
|
||||
(define (flush-pending-internal-patch!)
|
||||
(define p (current-pending-internal-patch))
|
||||
(when (patch-non-empty? p)
|
||||
(current-pending-internal-patch patch-empty)
|
||||
(current-pending-internal-events (list (current-pending-internal-events)
|
||||
((current-action-transformer) p)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Endpoint Creation
|
||||
|
||||
(define (ensure-in-endpoint-context! who)
|
||||
(when (or (in-script?) (null? (current-facet-id)))
|
||||
(error who "Attempt to add endpoint out of installation context; are you missing a (react ...)?")))
|
||||
|
||||
(define (add-endpoint! where internal? patch-fn handler-fn)
|
||||
(ensure-in-endpoint-context! 'add-endpoint!)
|
||||
(define (add-endpoint! where patch-fn handler-fn)
|
||||
(when (in-script?)
|
||||
(error 'add-endpoint!
|
||||
"~a: Cannot add endpoint in script; are you missing a (react ...)?"
|
||||
where))
|
||||
(define-values (new-eid delta-aggregate)
|
||||
(let ()
|
||||
(define a (current-actor-state))
|
||||
|
@ -1146,9 +1030,7 @@
|
|||
(hash-set (facet-endpoints f)
|
||||
new-eid
|
||||
(endpoint new-eid patch-fn handler-fn))]))))
|
||||
(if internal?
|
||||
(schedule-internal-event! delta-aggregate)
|
||||
(schedule-action! delta-aggregate)))
|
||||
(schedule-action! delta-aggregate))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Facet Lifecycle
|
||||
|
@ -1163,7 +1045,7 @@
|
|||
(define fid-uid next-fid-uid)
|
||||
(define fid (cons fid-uid parent-fid))
|
||||
(set! next-fid-uid (+ next-fid-uid 1))
|
||||
(update-facet! fid (lambda (_f) (facet fid (hasheqv) '() (set) trie-empty trie-empty)))
|
||||
(update-facet! fid (lambda (_f) (facet fid (hasheqv) '() (set))))
|
||||
(update-facet! parent-fid
|
||||
(lambda (pf)
|
||||
(and pf (struct-copy facet pf
|
||||
|
@ -1212,21 +1094,8 @@
|
|||
(dataflow-forget-subject! (actor-state-field-dataflow a) (list fid eid))
|
||||
(define-values (new-mux _eid _delta delta-aggregate)
|
||||
(mux-remove-stream (actor-state-mux a) eid))
|
||||
(define-values (internal external) (split-internal/external delta-aggregate))
|
||||
(current-actor-state (struct-copy actor-state a
|
||||
[mux new-mux]))
|
||||
(schedule-script!
|
||||
#:priority *gc-priority*
|
||||
;; need to do this later for the forget change detector
|
||||
(lambda ()
|
||||
(define a (current-actor-state))
|
||||
(define new-knowledge
|
||||
(apply-patch (actor-state-knowledge a) internal))
|
||||
(current-actor-state (struct-copy actor-state a
|
||||
[knowledge new-knowledge]))))
|
||||
|
||||
(schedule-internal-event! internal)
|
||||
(schedule-action! external))))
|
||||
(current-actor-state (struct-copy actor-state a [mux new-mux]))
|
||||
(schedule-action! delta-aggregate))))
|
||||
|
||||
(schedule-script!
|
||||
#:priority *gc-priority*
|
||||
|
@ -1255,8 +1124,6 @@
|
|||
(make-dataflow-graph)))
|
||||
(current-pending-patch patch-empty)
|
||||
(current-pending-actions '())
|
||||
(current-pending-internal-patch patch-empty)
|
||||
(current-pending-internal-events '())
|
||||
(current-pending-scripts (make-empty-pending-scripts))
|
||||
(current-action-transformer values)]
|
||||
(with-current-facet '() #f
|
||||
|
@ -1284,7 +1151,6 @@
|
|||
(when script
|
||||
(script)
|
||||
(refresh-facet-assertions!)
|
||||
(dispatch-internal-events!)
|
||||
(run-all-pending-scripts!)))
|
||||
|
||||
(define (run-scripts!)
|
||||
|
@ -1296,20 +1162,6 @@
|
|||
(core:quit pending-actions)
|
||||
(core:transition (current-actor-state) pending-actions)))
|
||||
|
||||
;; dispatch the internal events that have accumulated during script execution
|
||||
(define (dispatch-internal-events!)
|
||||
(flush-pending-internal-patch!)
|
||||
(define pending (flatten (current-pending-internal-events)))
|
||||
(current-pending-internal-events '())
|
||||
(define a (current-actor-state))
|
||||
(for* ([e (in-list pending)]
|
||||
[(fid f) (in-hash (actor-state-facets a))])
|
||||
(when (patch? e)
|
||||
(define a (current-actor-state))
|
||||
(current-actor-state (struct-copy actor-state a
|
||||
[knowledge (apply-patch (actor-state-knowledge a) e)])))
|
||||
(facet-handle-event! fid f e #f)))
|
||||
|
||||
(define (refresh-facet-assertions!)
|
||||
(dataflow-repair-damage! (actor-state-field-dataflow (current-actor-state))
|
||||
(lambda (subject-id)
|
||||
|
@ -1319,27 +1171,15 @@
|
|||
(with-current-facet fid #f
|
||||
(define ep (hash-ref (facet-endpoints f) eid))
|
||||
(define new-patch ((endpoint-patch-fn ep)))
|
||||
(define a (current-actor-state))
|
||||
(define new-interests
|
||||
(trie-subtract (patch-added new-patch)
|
||||
(mux-interests-of (actor-state-mux a) eid)
|
||||
#:combiner (lambda (v1 v2) trie-empty)))
|
||||
(define newly-relevant-knowledge
|
||||
(biased-intersection (actor-state-knowledge a) new-interests))
|
||||
(update-stream! eid (compose-patch new-patch (core:retract ?)))
|
||||
(facet-handle-event! fid
|
||||
(lookup-facet fid)
|
||||
(patch newly-relevant-knowledge trie-empty)
|
||||
#t))))))
|
||||
(update-stream! eid (compose-patch new-patch
|
||||
(core:retract ?))))))))
|
||||
|
||||
(define (update-stream! eid patch)
|
||||
(define a (current-actor-state))
|
||||
(define-values (new-mux _eid _delta delta-aggregate)
|
||||
(mux-update-stream (actor-state-mux a) eid patch))
|
||||
(current-actor-state (struct-copy actor-state a [mux new-mux]))
|
||||
(define-values (internal external) (split-internal/external delta-aggregate))
|
||||
(schedule-internal-event! internal)
|
||||
(schedule-action! external))
|
||||
(schedule-action! delta-aggregate))
|
||||
|
||||
(define (actor-behavior e a)
|
||||
(and e
|
||||
|
@ -1347,12 +1187,10 @@
|
|||
(if (patch? e)
|
||||
(struct-copy actor-state a
|
||||
[previous-knowledge (actor-state-knowledge a)]
|
||||
[knowledge (apply-patch (actor-state-knowledge a) e)])
|
||||
[knowledge (update-interests (actor-state-knowledge a) e)])
|
||||
a))
|
||||
(current-pending-patch patch-empty)
|
||||
(current-pending-actions '())
|
||||
(current-pending-internal-patch patch-empty)
|
||||
(current-pending-internal-events '())
|
||||
(current-pending-scripts (make-empty-pending-scripts))
|
||||
(current-action-transformer values)]
|
||||
(for [((fid f) (in-hash (actor-state-facets a)))]
|
||||
|
@ -1362,14 +1200,6 @@
|
|||
(define (facet-handle-event! fid f e synthetic?)
|
||||
(define mux (actor-state-mux (current-actor-state)))
|
||||
(with-current-facet fid #f
|
||||
(when (patch? e)
|
||||
(define internal (internal-patch e))
|
||||
(update-facet! fid
|
||||
(lambda (f)
|
||||
(and f
|
||||
(struct-copy facet f
|
||||
[previous-knowledge (facet-knowledge f)]
|
||||
[knowledge (apply-patch (facet-knowledge f) internal)])))))
|
||||
(for [(ep (in-hash-values (facet-endpoints f)))]
|
||||
((endpoint-handler-fn ep) e (mux-interests-of mux (endpoint-id ep)) synthetic?))))
|
||||
|
||||
|
@ -1466,10 +1296,6 @@
|
|||
(ensure-in-script! 'send!)
|
||||
(schedule-action! (core:message M)))
|
||||
|
||||
(define (realize! M)
|
||||
(ensure-in-script! 'realize!)
|
||||
(schedule-internal-event! (core:message (internal-knowledge M))))
|
||||
|
||||
(define *adhoc-label* -1)
|
||||
|
||||
(define (assert! P)
|
||||
|
@ -1501,23 +1327,6 @@
|
|||
(ensure-in-script! 'quit-dataspace!)
|
||||
(schedule-action! (core:quit-dataspace)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Helpers
|
||||
|
||||
;; Patch -> (Values Patch Patch)
|
||||
;; split a patch into its internal and external components
|
||||
(define (split-internal/external e)
|
||||
(define internal (internal-patch e))
|
||||
(values internal
|
||||
(patch (trie-subtract (patch-added e) (patch-added internal))
|
||||
(trie-subtract (patch-removed e) (patch-removed internal)))))
|
||||
|
||||
;; Patch -> Patch
|
||||
;; Remove all items from a patch not constructed with internal-knowledge
|
||||
(define (internal-patch e)
|
||||
(patch-prepend internal-knowledge-parenthesis
|
||||
(patch-step e internal-knowledge-parenthesis)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (format-field-descriptor d)
|
||||
|
@ -1533,7 +1342,7 @@
|
|||
(fprintf p " - Knowledge:\n ~a" (trie->pretty-string knowledge #:indent 3))
|
||||
(fprintf p " - Facets:\n")
|
||||
(for ([(fid f) (in-hash facets)])
|
||||
(match-define (facet _fid endpoints _ children _ _) f)
|
||||
(match-define (facet _fid endpoints _ children) f)
|
||||
(fprintf p " ---- facet ~a, children=~a" fid (set->list children))
|
||||
(when (not (hash-empty? endpoints))
|
||||
(fprintf p ", endpoints=~a" (hash-keys endpoints)))
|
||||
|
|
|
@ -12,7 +12,6 @@
|
|||
(struct-out mouse-event)
|
||||
(struct-out mouse-state)
|
||||
(struct-out active-window)
|
||||
(struct-out frame-dimensions)
|
||||
update-window
|
||||
(all-from-out 2htdp/image))
|
||||
|
||||
|
@ -42,7 +41,6 @@
|
|||
(struct mouse-event (x y window type) #:transparent)
|
||||
(struct mouse-state (x y window) #:transparent)
|
||||
(struct active-window (id) #:transparent)
|
||||
(struct frame-dimensions (width height) #:transparent)
|
||||
|
||||
(define (update-window id x y image #:z [z 0])
|
||||
(patch-seq (retract (outbound (window id ? ? ? ?)))
|
||||
|
@ -50,7 +48,7 @@
|
|||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(struct bb (proc windows inbound outbound halted? x y width height) #:transparent)
|
||||
(struct bb (proc windows inbound outbound halted? x y) #:transparent)
|
||||
|
||||
(define window-projection (?! (window ? ? ? ? ?)))
|
||||
|
||||
|
@ -134,18 +132,16 @@
|
|||
(patch-seq (retract (active-window ?))
|
||||
(assert (active-window active-id))))
|
||||
|
||||
(define-syntax-rule (big-bang-dataspace* width height boot-actions extra-clause ...)
|
||||
(define-syntax-rule (big-bang-dataspace* boot-actions extra-clause ...)
|
||||
(let-values (((proc initial-transition _initial-assertions-always-empty)
|
||||
(actor->process+transition/assertions (dataspace-actor boot-actions))))
|
||||
(big-bang (interpret-actions (bb proc
|
||||
'()
|
||||
(list (assert (frame-dimensions width height)))
|
||||
'()
|
||||
'()
|
||||
#f
|
||||
0
|
||||
0
|
||||
width
|
||||
height)
|
||||
0)
|
||||
initial-transition
|
||||
#t)
|
||||
(on-tick (lambda (b)
|
||||
|
@ -165,43 +161,27 @@
|
|||
(stop-when bb-halted?)
|
||||
extra-clause ...)))
|
||||
|
||||
(define-syntax-rule (big-bang-dataspace** fullscreen? width height exit? boot-actions
|
||||
extra-clause ...)
|
||||
(define-syntax-rule (big-bang-dataspace** width height exit? boot-actions extra-clause ...)
|
||||
(begin
|
||||
(cond
|
||||
[fullscreen?
|
||||
(big-bang-dataspace* width height boot-actions (to-draw render)
|
||||
(display-mode 'fullscreen
|
||||
(lambda (b w h)
|
||||
(inject (struct-copy bb b [width w] [height h])
|
||||
(list
|
||||
(patch-seq (retract (frame-dimensions ? ?))
|
||||
(assert (frame-dimensions w h)))))))
|
||||
extra-clause ...)]
|
||||
[(and width height)
|
||||
(big-bang-dataspace* width height boot-actions (to-draw render width height)
|
||||
extra-clause ...)]
|
||||
[else
|
||||
(big-bang-dataspace* width height boot-actions (to-draw render)
|
||||
extra-clause ...)])
|
||||
(if (and width height)
|
||||
(big-bang-dataspace* boot-actions (to-draw render width height) extra-clause ...)
|
||||
(big-bang-dataspace* boot-actions (to-draw render) extra-clause ...))
|
||||
(when exit? (exit 0))))
|
||||
|
||||
(define ((big-bang-dataspace #:width [width #f]
|
||||
#:height [height #f]
|
||||
#:exit? [exit? #t]
|
||||
#:fullscreen? [fullscreen? #f])
|
||||
#:exit? [exit? #t])
|
||||
. boot-actions)
|
||||
(big-bang-dataspace** fullscreen? width height exit? boot-actions))
|
||||
(big-bang-dataspace** width height exit? boot-actions))
|
||||
|
||||
(define ((big-bang-dataspace/universe #:width [width #f]
|
||||
#:height [height #f]
|
||||
#:exit? [exit? #t]
|
||||
#:register [ip LOCALHOST]
|
||||
#:port [port-number SQPORT]
|
||||
#:name [world-name (gensym 'syndicate)]
|
||||
#:fullscreen? [fullscreen? #f])
|
||||
#:name [world-name (gensym 'syndicate)])
|
||||
. boot-actions)
|
||||
(big-bang-dataspace** fullscreen? width height exit? boot-actions
|
||||
(big-bang-dataspace** width height exit? boot-actions
|
||||
(on-receive (lambda (b sexps)
|
||||
(inject b (for/list ((m sexps)) (message (from-server m))))))
|
||||
(register ip)
|
||||
|
|
|
@ -1,14 +1,11 @@
|
|||
#lang racket/base
|
||||
|
||||
(require (for-syntax racket/base syntax/kerncase))
|
||||
(require (for-syntax syntax/parse))
|
||||
(require (for-syntax (only-in racket/list make-list)))
|
||||
|
||||
(require racket/match)
|
||||
(require "main.rkt")
|
||||
(require (submod "actor.rkt" for-module-begin))
|
||||
(require "store.rkt")
|
||||
(require (only-in "core.rkt" clean-actions))
|
||||
|
||||
(provide (rename-out [module-begin #%module-begin])
|
||||
activate
|
||||
|
@ -46,85 +43,52 @@
|
|||
(raise-syntax-error #f "allowed only around a module body" stx))
|
||||
(syntax-case stx ()
|
||||
[(_ forms ...)
|
||||
;; the inclusion of (module+ syndicate-main) is because it seems that the appearance order
|
||||
;; of module+ forms determines the mutual visibility. So syndicate-main is ensured to be the
|
||||
;; first module+ and consequently the main submodule can require it.
|
||||
#'(#%module-begin
|
||||
(syndicate-module () ((module+ syndicate-main)
|
||||
(module+ main (current-ground-dataspace run-ground))
|
||||
forms ...)))]))
|
||||
|
||||
;; Identifier -> Bool
|
||||
;; Is the identifier a form that shouldn't capture actor actions?
|
||||
;; note the absence of define-values
|
||||
(define-for-syntax (kernel-id? x)
|
||||
(ormap (lambda (i) (free-identifier=? x i))
|
||||
(syntax->list #'(require
|
||||
provide
|
||||
define-values
|
||||
define-syntaxes
|
||||
begin-for-syntax
|
||||
module
|
||||
module*
|
||||
module+
|
||||
#%require
|
||||
#%provide
|
||||
#%declare
|
||||
begin-for-declarations))))
|
||||
|
||||
(define (ensure-spawn-actions! acts)
|
||||
(define cleaned-acts (clean-actions acts))
|
||||
(for ([act (in-list cleaned-acts)]
|
||||
#:unless (actor? act))
|
||||
(raise-argument-error 'syndicate-module "top-level actor creation action" act))
|
||||
cleaned-acts)
|
||||
|
||||
(define-syntax (syndicate-module stx)
|
||||
(syntax-parse stx
|
||||
[(_ (action-ids ...) (form forms ...))
|
||||
(define expanded (local-expand #'form
|
||||
'module
|
||||
(append (list #'module+
|
||||
#'begin-for-declarations)
|
||||
(kernel-form-identifier-list))))
|
||||
(syntax-parse expanded
|
||||
#:literals (begin define-values)
|
||||
[(begin more-forms ...)
|
||||
#'(syndicate-module (action-ids ...) (more-forms ... forms ...))]
|
||||
[(define-values (x:id ...) e)
|
||||
#:with action-id (car (generate-temporaries (list #'form)))
|
||||
#:with (tmp ...) (generate-temporaries #'(x ...))
|
||||
#`(begin
|
||||
(define-values (tmp ...) (values #,@(make-list (length (syntax->list #'(x ...))) #'#f)))
|
||||
(define action-id
|
||||
(ensure-spawn-actions!
|
||||
(capture-actor-actions
|
||||
(lambda () (set!-values (tmp ...) e)))))
|
||||
(define-values (x ...) (values tmp ...))
|
||||
(syndicate-module (action-ids ... action-id) (forms ...)))]
|
||||
[(head rest ...)
|
||||
(cond
|
||||
[(kernel-id? #'head)
|
||||
#`(begin #,expanded (syndicate-module (action-ids ...) (forms ...)))]
|
||||
[else
|
||||
(with-syntax ([action-id (car (generate-temporaries (list #'form)))])
|
||||
#`(begin
|
||||
(define action-id (ensure-spawn-actions! (capture-actor-actions (lambda () #,expanded))))
|
||||
(syndicate-module (action-ids ... action-id) (forms ...))))])]
|
||||
[non-pair-syntax
|
||||
#'(begin form (syndicate-module (action-ids ...) (forms ...)))])]
|
||||
[(_ (action-ids ...) ())
|
||||
(let ([final-stx
|
||||
#`(begin (module+ syndicate-main
|
||||
(provide boot-actions activate!)
|
||||
(define activated? #f)
|
||||
(define boot-actions (list action-ids ...))
|
||||
(define (activate!)
|
||||
(when (not activated?)
|
||||
(set! activated? #t)
|
||||
boot-actions)))
|
||||
(module+ main
|
||||
(require (submod ".." syndicate-main))
|
||||
((current-ground-dataspace) (activate!))))])
|
||||
(let ()
|
||||
(define (accumulate-actions action-ids final-forms forms)
|
||||
(if (null? forms)
|
||||
(let ((final-stx
|
||||
#`(#%module-begin (module+ syndicate-main
|
||||
(provide boot-actions activate!)
|
||||
(define activated? #f)
|
||||
(define boot-actions (list #,@(reverse action-ids)))
|
||||
(define (activate!)
|
||||
(when (not activated?)
|
||||
(set! activated? #t)
|
||||
boot-actions)))
|
||||
(module+ main
|
||||
(current-ground-dataspace run-ground))
|
||||
#,@(reverse final-forms)
|
||||
(module+ main
|
||||
(require (submod ".." syndicate-main))
|
||||
((current-ground-dataspace) (activate!))))))
|
||||
;;(pretty-print (syntax->datum final-stx))
|
||||
final-stx)]))
|
||||
final-stx)
|
||||
(syntax-case (local-expand (car forms)
|
||||
'module
|
||||
(append (list #'module+
|
||||
#'begin-for-declarations)
|
||||
(kernel-form-identifier-list))) ()
|
||||
[(head rest ...)
|
||||
(if (free-identifier=? #'head #'begin)
|
||||
(accumulate-actions action-ids
|
||||
final-forms
|
||||
(append (syntax->list #'(rest ...)) (cdr forms)))
|
||||
(if (ormap (lambda (i) (free-identifier=? #'head i))
|
||||
(syntax->list #'(define-values define-syntaxes begin-for-syntax
|
||||
module module* module+
|
||||
#%module-begin
|
||||
#%require #%provide
|
||||
begin-for-declarations)))
|
||||
(accumulate-actions action-ids
|
||||
(cons (car forms) final-forms)
|
||||
(cdr forms))
|
||||
(accumulate-action (car forms) action-ids final-forms (cdr forms))))]
|
||||
[non-pair-syntax
|
||||
(accumulate-action (car forms) action-ids final-forms (cdr forms))])))
|
||||
(define (accumulate-action action action-ids final-forms remaining-forms)
|
||||
(define temp (car (generate-temporaries (list action))))
|
||||
(accumulate-actions (cons temp action-ids)
|
||||
(cons #`(define #,temp (capture-actor-actions (lambda () #,action)))
|
||||
final-forms)
|
||||
remaining-forms))
|
||||
(accumulate-actions '() '() (syntax->list #'(forms ...))))]))
|
||||
|
|
|
@ -129,10 +129,7 @@
|
|||
;; Seals are used by protocols to prevent the routing tries from
|
||||
;; examining internal structure of values.
|
||||
|
||||
(struct seal (contents) ;; NB. Neither transparent nor prefab
|
||||
#:methods gen:custom-write
|
||||
[(define (write-proc s port mode)
|
||||
(fprintf port "#{~v}" (seal-contents s)))])
|
||||
(struct seal (contents)) ;; NB. Neither transparent nor prefab
|
||||
|
||||
;; contract -> contract
|
||||
(define ((sealof c) x)
|
||||
|
|
|
@ -111,15 +111,16 @@
|
|||
(define (spawn-tcp-connection local-addr remote-addr)
|
||||
(match-define (tcp-address remote-hostname remote-port) remote-addr)
|
||||
(define-values (cin cout)
|
||||
(with-handlers ([exn:fail? (lambda (e)
|
||||
;; TODO: it'd be nice to somehow
|
||||
;; communicate the actual error to
|
||||
;; the local peer.
|
||||
(log-error "~a" (exn->string e))
|
||||
(define o (open-output-string))
|
||||
(close-output-port o)
|
||||
(values (open-input-string "")
|
||||
o))])
|
||||
(with-handlers ([exn:fail:network? (lambda (e)
|
||||
;; TODO: it'd be nice to
|
||||
;; somehow communicate the
|
||||
;; actual error to the local
|
||||
;; peer.
|
||||
(log-error "~a" (exn->string e))
|
||||
(define o (open-output-string))
|
||||
(close-output-port o)
|
||||
(values (open-input-string "")
|
||||
o))])
|
||||
(tcp:tcp-connect remote-hostname remote-port)))
|
||||
(spawn-connection local-addr remote-addr cin cout))
|
||||
|
||||
|
|
|
@ -1,7 +1,6 @@
|
|||
#lang syndicate
|
||||
|
||||
(provide (struct-out later-than)
|
||||
on-timeout
|
||||
stop-when-timeout
|
||||
sleep)
|
||||
|
||||
|
@ -16,13 +15,10 @@
|
|||
(on (message (timer-expired timer-id _))
|
||||
(react (assert (later-than msecs))))))
|
||||
|
||||
(define-syntax-rule (on-timeout relative-msecs body ...)
|
||||
(define-syntax-rule (stop-when-timeout relative-msecs body ...)
|
||||
(let ((timer-id (gensym 'timeout)))
|
||||
(on-start (send! (set-timer timer-id relative-msecs 'relative)))
|
||||
(on (message (timer-expired timer-id _)) body ...)))
|
||||
|
||||
(define-syntax-rule (stop-when-timeout relative-msecs body ...)
|
||||
(on-timeout relative-msecs (stop-current-facet body ...)))
|
||||
(stop-when (message (timer-expired timer-id _)) body ...)))
|
||||
|
||||
(define (sleep sec)
|
||||
(define timer-id (gensym 'sleep))
|
||||
|
|
|
@ -93,7 +93,7 @@
|
|||
[(message (inbound (? udp-packet? p)))
|
||||
(transition s (message p))]
|
||||
[(message (udp-packet _ (udp-remote-address host port) body))
|
||||
(thread (lambda () (udp:udp-send-to socket host port body)))
|
||||
(udp:udp-send-to socket host port body)
|
||||
#f]
|
||||
[_ #f]))
|
||||
(void)
|
||||
|
|
|
@ -215,19 +215,16 @@
|
|||
|
||||
(define (spawn-connection local-addr remote-addr id c control-ch)
|
||||
(actor #:name (list 'drivers/websocket:connect local-addr remote-addr id)
|
||||
#:assertions*
|
||||
(patch-added
|
||||
(patch-seq
|
||||
(let-values (((la lp ra rp) (ws-conn-peer-addresses c)))
|
||||
(assert (websocket-peer-details local-addr remote-addr la lp ra rp)))
|
||||
(sub (observe (websocket-message remote-addr local-addr ?))) ;; monitor peer
|
||||
(pub (websocket-message remote-addr local-addr ?)) ;; may send messages to peer
|
||||
(sub (websocket-message local-addr remote-addr ?)) ;; want segments from peer
|
||||
(sub (inbound (websocket-incoming-message id ?))) ;; segments from driver thd
|
||||
))
|
||||
websocket-connection-behaviour
|
||||
(connection-state local-addr remote-addr c control-ch)
|
||||
'()))
|
||||
(connection-state local-addr remote-addr c control-ch)
|
||||
(patch-seq
|
||||
(let-values (((la lp ra rp) (ws-conn-peer-addresses c)))
|
||||
(assert (websocket-peer-details local-addr remote-addr la lp ra rp)))
|
||||
(sub (observe (websocket-message remote-addr local-addr ?))) ;; monitor peer
|
||||
(pub (websocket-message remote-addr local-addr ?)) ;; may send messages to peer
|
||||
(sub (websocket-message local-addr remote-addr ?)) ;; want segments from peer
|
||||
(sub (inbound (websocket-incoming-message id ?))) ;; segments from driver thd
|
||||
)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
|
@ -13,6 +13,4 @@
|
|||
(define stdin-evt (read-bytes-line-evt (current-input-port) 'any))
|
||||
(stop-when (message (inbound (external-event stdin-evt (list (? eof-object? _))))))
|
||||
(on (message (inbound (external-event stdin-evt (list (? bytes? $line)))))
|
||||
(send! (tcp-out id line))
|
||||
;; chat-tcp2 uses the line-reader, so need line separators.
|
||||
(send! (tcp-out id #"\n"))))
|
||||
(send! (tcp-out id line))))
|
||||
|
|
|
@ -10,7 +10,7 @@
|
|||
;; Correct output:
|
||||
;; x=123 v=999
|
||||
;; x=124 v=999
|
||||
;; finally for x0=123 x=124 v=999
|
||||
;; finally for x=124 v=999
|
||||
;;
|
||||
;; Should eventually be turned into some kind of test case.
|
||||
|
||||
|
@ -19,8 +19,7 @@
|
|||
(spawn (field [x 123])
|
||||
(assert (foo (x) 999))
|
||||
(during (foo (x) $v)
|
||||
(define x0 (x))
|
||||
(log-info "x=~a v=~a" (x) v)
|
||||
(when (= (x) 123) (x 124))
|
||||
(on-stop
|
||||
(log-info "finally for x0=~a x=~a v=~a" x0 (x) v))))
|
||||
(log-info "finally for x=~a v=~a" (x) v))))
|
||||
|
|
|
@ -1,32 +0,0 @@
|
|||
#lang syndicate
|
||||
|
||||
(require/activate syndicate/drivers/timestate)
|
||||
|
||||
(assertion-struct memoized (req resp))
|
||||
(assertion-struct underlying (req resp))
|
||||
|
||||
(spawn (during (observe (underlying $req _))
|
||||
(on-start (printf "**** Computing underlying ~a\n" req))
|
||||
(on-stop (printf "**** Releasing underlying ~a\n" req))
|
||||
(assert (underlying req (+ req 1)))))
|
||||
|
||||
(spawn (during (observe (memoized $req _))
|
||||
(on-start (printf "Outer memo entry for ~a created\n" req))
|
||||
(on-stop (printf "Outer memo entry for ~a released\n" req))
|
||||
(assert (observe (memoized req _))) ;; keep self alive
|
||||
(stop-when-timeout 3000)
|
||||
(on-start
|
||||
(react (stop-when (asserted (underlying req $resp))
|
||||
(printf "Underlying response ~a for ~a received\n" resp req)
|
||||
(react (on-start (printf "Memo entry for ~a => ~a created\n" req resp))
|
||||
(on-stop (printf "Memo entry for ~a => ~a released\n" req resp))
|
||||
(assert (memoized req resp))))))))
|
||||
|
||||
(spawn (stop-when (asserted (memoized 1 $n))
|
||||
(printf "First result for 1: ~a\n" n)
|
||||
(sleep 1)
|
||||
(react (stop-when (asserted (memoized 1 $m))
|
||||
(printf "Second result for 1: ~a\n" m)
|
||||
(sleep 3)
|
||||
(react (stop-when (asserted (memoized 1 $k))
|
||||
(printf "Third result for 1: ~a\n" k)))))))
|
|
@ -1,41 +0,0 @@
|
|||
#lang syndicate
|
||||
;; Illustrates a (fixed) bug where an endpoint whose interest moves
|
||||
;; with time, where that interest eventually overlaps with existing
|
||||
;; interest, fails to be notified of an otherwise-known assertion.
|
||||
;;
|
||||
;; Symptomatic output:
|
||||
;;
|
||||
;; Outer value 4 = 4
|
||||
;; Value 0 = 0
|
||||
;; Value 1 = 1
|
||||
;; Value 2 = 2
|
||||
;; Value 3 = 3
|
||||
;;
|
||||
;; Correct output:
|
||||
;;
|
||||
;; Outer value 4 = 4
|
||||
;; Value 0 = 0
|
||||
;; Value 1 = 1
|
||||
;; Value 2 = 2
|
||||
;; Value 3 = 3
|
||||
;; Value 4 = 4
|
||||
;; Value 5 = 5
|
||||
|
||||
(spawn (field [of-interest 0])
|
||||
|
||||
(during 'ready
|
||||
(on (asserted (list (of-interest) $v))
|
||||
(printf "Value ~a = ~a\n" (of-interest) v)
|
||||
(of-interest (+ (of-interest) 1))))
|
||||
|
||||
(on (asserted (list 4 $v))
|
||||
(printf "Outer value ~a = ~a\n" 4 v)))
|
||||
|
||||
(spawn (assert (list 0 0))
|
||||
(assert (list 1 1))
|
||||
(assert (list 2 2))
|
||||
(assert (list 3 3))
|
||||
(assert (list 4 4))
|
||||
(assert (list 5 5))
|
||||
(on-start (flush!)
|
||||
(assert! 'ready)))
|
|
@ -1,619 +0,0 @@
|
|||
#lang syndicate
|
||||
|
||||
(require racket/set)
|
||||
(require (only-in racket/list
|
||||
first
|
||||
partition
|
||||
empty?
|
||||
split-at))
|
||||
(require (only-in racket/hash
|
||||
hash-union))
|
||||
(require (only-in racket/string
|
||||
string-split
|
||||
string-trim))
|
||||
(require (only-in racket/sequence
|
||||
sequence->list))
|
||||
(require (only-in racket/function const))
|
||||
|
||||
(module+ test
|
||||
(require rackunit))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
;; Protocol
|
||||
|
||||
#|
|
||||
Conversations in the flink dataspace primarily concern two topics: presence and
|
||||
task execution.
|
||||
|
||||
Presence Protocol
|
||||
-----------------
|
||||
|
||||
The JobManager (JM) asserts its presence with (job-manager-alive). The operation
|
||||
of each TaskManager (TM) is contingent on the presence of a job manager.
|
||||
|#
|
||||
(assertion-struct job-manager-alive ())
|
||||
#|
|
||||
In turn, TaskManagers advertise their presence with (task-manager ID slots),
|
||||
where ID is a unique id, and slots is a natural number. The number of slots
|
||||
dictates how many tasks the TM can take on. To reduce contention, the JM
|
||||
should only assign a task to a TM if the TM actually has the resources to
|
||||
perform a task.
|
||||
|#
|
||||
(assertion-struct task-manager (id slots))
|
||||
;; an ID is a symbol or a natural number.
|
||||
;; Any -> Bool
|
||||
;; recognize IDs
|
||||
(define (id? x)
|
||||
(or (symbol? x) (exact-nonnegative-integer? x)))
|
||||
#|
|
||||
The resources available to a TM are its associated TaskRunners (TRs). TaskRunners
|
||||
assert their presence with (task-runner ID)
|
||||
|
||||
|#
|
||||
(assertion-struct task-runner (id))
|
||||
#|
|
||||
a Status is one of
|
||||
- IDLE, when the TR is not executing a task
|
||||
- (executing ID), when the TR is executing the task with the given ID
|
||||
- OVERLOAD, when the TR has been asked to perform a task before it has
|
||||
finished its previous assignment. For the purposes of this model, it indicates a
|
||||
failure in the protocol; like the exchange between the JM and the TM, a TR
|
||||
should only receive tasks when it is IDLE.
|
||||
|#
|
||||
(define IDLE 'idle)
|
||||
(define OVERLOAD 'overload)
|
||||
(struct executing (id) #:transparent)
|
||||
|
||||
#|
|
||||
Task Delegation Protocol
|
||||
-----------------------
|
||||
|
||||
Task Delegation has two roles, TaskAssigner (TA) and TaskPerformer (TP).
|
||||
|
||||
A TaskAssigner requests the performance of a Task with a particular TaskPerformer
|
||||
through the assertion of interest
|
||||
(observe (task-performance ID Task ★))
|
||||
where the ID identifies the TP
|
||||
|#
|
||||
(assertion-struct task-performance (assignee task desc))
|
||||
#|
|
||||
A Task is a (task TaskID Work), where Work is one of
|
||||
- (map-work String)
|
||||
- (reduce-work (U ID TaskResult) (U ID TaskResult)), referring to either the
|
||||
ID of the dependent task or its results. A reduce-work is ready to be executed
|
||||
when it has both results.
|
||||
|
||||
A TaskID is a (list ID ID), where the first ID is specific to the individual
|
||||
task and the second identifies the job it belongs to.
|
||||
|
||||
A TaskResult is a (Hashof String Natural), counting the occurrences of words
|
||||
|#
|
||||
(struct task (id desc) #:transparent)
|
||||
(struct map-work (data) #:transparent)
|
||||
(struct reduce-work (left right) #:transparent)
|
||||
|
||||
#|
|
||||
The TaskPerformer responds to a request by describing its state with respect
|
||||
to that task,
|
||||
(task-performance ID Task TaskStateDesc)
|
||||
|
||||
A TaskStateDesc is one of
|
||||
- ACCEPTED, when the TP has the resources to perform the task. (TODO - not sure if this is ever visible, currently)
|
||||
- OVERLOAD, when the TP does not have the resources to perform the task.
|
||||
- RUNNING, indicating that the task is being performed
|
||||
- (finished TaskResult), describing the results
|
||||
|#
|
||||
(struct finished (data) #:transparent)
|
||||
(define ACCEPTED 'accepted)
|
||||
(define RUNNING 'running)
|
||||
#|
|
||||
Two instances of the Task Delegation Protocol take place: one between the
|
||||
JobManager and the TaskManager, and one between the TaskManager and its
|
||||
TaskRunners.
|
||||
|#
|
||||
|
||||
#|
|
||||
Job Submission Protocol
|
||||
-----------------------
|
||||
|
||||
Finally, Clients submit their jobs to the JobManager by asserting interest
|
||||
(observe (job-completion ID (Listof Task) ★))
|
||||
|
||||
The JobManager then performs the job and, when finished, asserts
|
||||
(job-completion ID (Listof Task) TaskResults)
|
||||
|#
|
||||
(struct job (id tasks) #:transparent)
|
||||
(assertion-struct job-completion (id data result))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
;; Logging
|
||||
|
||||
(define (log fmt . args)
|
||||
(displayln (apply format fmt args)))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
;; Generic Implementation of Task Delegation Protocol
|
||||
|
||||
;; a TaskFun is a
|
||||
;; (Task ID (TaskResults -> Void) ((U ACCEPTED OVERLOAD RUNNING) -> Void) -> Void)
|
||||
|
||||
;; ID (-> Bool) TaskFun -> TaskPerformer
|
||||
;; doesn't really account for long-running tasks
|
||||
;; gonna need some effect polymorphism to type uses of this
|
||||
(define (task-performer my-id can-accept? perform-task)
|
||||
(react
|
||||
(during (observe (task-performance my-id $task _))
|
||||
(field [status #f])
|
||||
(assert (task-performance my-id task (status)))
|
||||
(cond
|
||||
[(can-accept?)
|
||||
(status RUNNING)
|
||||
(define (on-complete results)
|
||||
(status (finished results)))
|
||||
(perform-task task on-complete status)]
|
||||
[else
|
||||
(status OVERLOAD)]))))
|
||||
|
||||
;; Task
|
||||
;; ID
|
||||
;; (-> Void)
|
||||
;; (TaskResults -> Void)
|
||||
;; -> TaskAssigner
|
||||
(define (task-assigner tsk performer on-overload! on-complete!)
|
||||
(react
|
||||
(on (asserted (task-performance performer tsk $status))
|
||||
(match status
|
||||
[(or (== ACCEPTED)
|
||||
(== RUNNING))
|
||||
(void)]
|
||||
[(== OVERLOAD)
|
||||
(stop-current-facet (on-overload!))]
|
||||
[(finished results)
|
||||
(stop-current-facet (on-complete! results))]))))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
;; TaskRunner
|
||||
;; ID ID -> Spawn
|
||||
(define (spawn-task-runner id tm-id)
|
||||
(spawn #:name id
|
||||
(assert (task-runner id))
|
||||
(stop-when (retracted (task-manager tm-id _)))
|
||||
;; Task (TaskStateDesc -> Void) -> Void
|
||||
(define (perform-task tsk on-complete! update-status!)
|
||||
(match-define (task tid desc) tsk)
|
||||
(match desc
|
||||
[(map-work data)
|
||||
(define wc (count-new-words (hash) (string->words data)))
|
||||
(on-complete! wc)]
|
||||
[(reduce-work left right)
|
||||
(define wc (hash-union left right #:combine +))
|
||||
(on-complete! wc)]))
|
||||
(on-start
|
||||
(task-performer id (const #t) perform-task))))
|
||||
|
||||
;; (Hash String Nat) String -> (Hash String Nat)
|
||||
(define (word-count-increment h word)
|
||||
(hash-update h
|
||||
word
|
||||
add1
|
||||
(λ x 0)))
|
||||
|
||||
;; (Hash String Nat) (Listof String) -> (Hash String Nat)
|
||||
(define (count-new-words word-count words)
|
||||
(for/fold ([result word-count])
|
||||
([word words])
|
||||
(word-count-increment result word)))
|
||||
|
||||
;; String -> (Listof String)
|
||||
;; Return the white space-separated words, trimming off leading & trailing punctuation
|
||||
(define (string->words s)
|
||||
(map (lambda (w) (string-trim w #px"\\p{P}")) (string-split s)))
|
||||
|
||||
(module+ test
|
||||
(check-equal? (string->words "good day sir")
|
||||
(list "good" "day" "sir"))
|
||||
(check-equal? (string->words "")
|
||||
(list))
|
||||
(check-equal? (string->words "good eve ma'am")
|
||||
(list "good" "eve" "ma'am"))
|
||||
(check-equal? (string->words "please sir. may I have another?")
|
||||
(list "please" "sir" "may" "I" "have" "another"))
|
||||
;; currently fails, doesn't seem worth fixing
|
||||
#;(check-equal? (string->words "but wait---there's more")
|
||||
(list "but" "wait" "there's" "more")))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
;; TaskManager
|
||||
|
||||
;; PosInt -> Spawn
|
||||
(define (spawn-task-manager num-task-runners)
|
||||
(define id (gensym 'task-manager))
|
||||
(spawn #:name id
|
||||
(log "Task Manager (TM) ~a is running" id)
|
||||
(during (job-manager-alive)
|
||||
(log "TM ~a learns about JM" id)
|
||||
|
||||
(field [task-runners (set)])
|
||||
|
||||
;; Create & Monitor Task Runners
|
||||
(on-start
|
||||
(for ([_ (in-range num-task-runners)])
|
||||
(define tr-id (gensym 'task-runner))
|
||||
(react
|
||||
(on-start (spawn-task-runner tr-id id))
|
||||
(on (asserted (task-runner tr-id))
|
||||
(log "TM ~a successfully created task-runner ~a" id tr-id)
|
||||
(task-runners (set-add (task-runners) tr-id)))
|
||||
(on (retracted (task-runner tr-id))
|
||||
(log "TM ~a detected failure of task runner ~a, restarting" id tr-id)
|
||||
(task-runners (set-remove (task-runners) tr-id))
|
||||
(spawn-task-runner tr-id id)))))
|
||||
|
||||
;; Assign incoming tasks
|
||||
(field [busy-runners (set)])
|
||||
|
||||
(define (idle-runners)
|
||||
(set-count (set-subtract (task-runners) (busy-runners))))
|
||||
|
||||
(assert (task-manager id (idle-runners)))
|
||||
|
||||
(define (can-accept?)
|
||||
(positive? (idle-runners)))
|
||||
(define (select-runner)
|
||||
(define runner (for/first ([r (in-set (task-runners))]
|
||||
#:unless (set-member? (busy-runners) r))
|
||||
r))
|
||||
(unless runner
|
||||
(log "ERROR: TM ~a failed to select a runner.\nrunners: ~a\nbusy: ~a" id (task-runners) (busy-runners)))
|
||||
(busy-runners (set-add (busy-runners) runner))
|
||||
runner)
|
||||
(define (perform-task tsk on-complete! update-status!)
|
||||
(match-define (task task-id desc) tsk)
|
||||
(define runner (select-runner))
|
||||
(log "TM ~a assigns task ~a to runner ~a" id task-id runner)
|
||||
(on-stop (busy-runners (set-remove (busy-runners) runner)))
|
||||
(on-start
|
||||
(task-assigner tsk runner
|
||||
(lambda () (update-status! OVERLOAD))
|
||||
(lambda (results) (on-complete! results)))))
|
||||
(on-start
|
||||
(task-performer id can-accept? perform-task)))))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
;; JobManager
|
||||
|
||||
;; assertions used for internal slot-management protocol
|
||||
(assertion-struct slots (v))
|
||||
(assertion-struct slot-assignment (who mngr))
|
||||
;; tid is the TaskID, rid is a unique symbol to a particular request for a slot
|
||||
(struct request-id (tid rid) #:prefab)
|
||||
|
||||
(message-struct task-is-ready (job-id task))
|
||||
|
||||
(define (spawn-job-manager)
|
||||
(spawn
|
||||
(assert (job-manager-alive))
|
||||
(log "Job Manager Up")
|
||||
|
||||
(on-start
|
||||
(react
|
||||
|
||||
;; keep track of task managers, how many slots they say are open, and how many tasks we have assigned.
|
||||
;; (Hashof TaskManagerID Nat)
|
||||
(define/query-hash task-managers (task-manager $id $slots) id slots
|
||||
#:on-add (log "JM learns that ~a has ~v slots" id slots))
|
||||
|
||||
(field [requests-in-flight (hash)] ;; (Hashof ID Nat)
|
||||
[assignments (hash)]) ;; (Hashof ID ID) request ID to manager ID
|
||||
|
||||
;; to better understand the supply of slots for each task manager, keep track of the number
|
||||
;; of requested tasks that we have yet to hear back about
|
||||
(define (slots-available)
|
||||
(for/sum ([(id v) (in-hash (task-managers))])
|
||||
(max 0 (- v (hash-ref (requests-in-flight) id 0)))))
|
||||
|
||||
;; ID -> (U #f ID)
|
||||
(define (try-take-slot! me)
|
||||
(define mngr
|
||||
(for/first ([(id slots) (in-hash (task-managers))]
|
||||
#:when (positive? (- slots (hash-ref (requests-in-flight) id 0))))
|
||||
id))
|
||||
(when mngr
|
||||
(assignments (hash-set (assignments) me mngr))
|
||||
(requests-in-flight (hash-update (requests-in-flight) mngr add1 0)))
|
||||
mngr)
|
||||
|
||||
(know (slots (slots-available)))
|
||||
|
||||
(during (know (observe (slot-assignment (request-id $tid $who) _)))
|
||||
(on-start
|
||||
(react
|
||||
;; what if one manager gains a slot but another loses one, so n stays the same?
|
||||
(on (know (slots $n))
|
||||
#;(log "Dispatcher request ~a learns there are ~a slots" tid n)
|
||||
(unless (or (zero? n) (hash-has-key? (assignments) who))
|
||||
(define mngr (try-take-slot! who))
|
||||
(when mngr
|
||||
(stop-current-facet
|
||||
(log "Dispatcher assigns task ~a to ~a" tid mngr)
|
||||
(react (know (slot-assignment (request-id tid who) mngr)))
|
||||
(react
|
||||
(define waiting-for-answer (current-facet-id))
|
||||
(on (asserted (observe (task-performance mngr (task tid $x) _)))
|
||||
(react (on (asserted (task-performance mngr (task tid x) _))
|
||||
(log "Dispatcher sees answer for ~a" tid)
|
||||
(stop-facet waiting-for-answer))))
|
||||
(on-stop
|
||||
(requests-in-flight (hash-update (requests-in-flight) mngr sub1))))))))))
|
||||
(on-stop (assignments (hash-remove (assignments) who))))))
|
||||
|
||||
(during (observe (job-completion $job-id $tasks _))
|
||||
(log "JM receives job ~a" job-id)
|
||||
(define-values (ready not-ready) (partition task-ready? tasks))
|
||||
(field [waiting-tasks not-ready]
|
||||
[tasks-in-progress 0])
|
||||
|
||||
(on-start (for [(t ready)] (add-ready-task! t)))
|
||||
(on (realize (task-is-ready job-id $t))
|
||||
(perform-task t push-results))
|
||||
|
||||
;; Task -> Void
|
||||
(define (add-ready-task! t)
|
||||
;; TODO - use functional-queue.rkt from ../../
|
||||
(log "JM marks task ~a as ready" (task-id t))
|
||||
(realize! (task-is-ready job-id t)))
|
||||
|
||||
;; Task (ID TaskResult -> Void) -> Void
|
||||
;; Requires (task-ready? t)
|
||||
(define (perform-task t k)
|
||||
(react
|
||||
(define task-facet (current-facet-id))
|
||||
(on-start (tasks-in-progress (add1 (tasks-in-progress))))
|
||||
(on-stop (tasks-in-progress (sub1 (tasks-in-progress))))
|
||||
(match-define (task this-id desc) t)
|
||||
(log "JM begins on task ~a" this-id)
|
||||
|
||||
|
||||
(define (select-a-task-manager)
|
||||
(react
|
||||
(define req-id (gensym 'perform-task))
|
||||
(on (know (slot-assignment (request-id this-id req-id) $mngr))
|
||||
(assign-task mngr))))
|
||||
|
||||
;; ID -> ...
|
||||
(define (assign-task mngr)
|
||||
(define this-facet (current-facet-id))
|
||||
(react
|
||||
#;(define this-facet (current-facet-id))
|
||||
(on (retracted (task-manager mngr _))
|
||||
;; our task manager has crashed
|
||||
(stop-current-facet (select-a-task-manager)))
|
||||
(on-start
|
||||
(log "JM assigns task ~a to manager ~a" this-id mngr)
|
||||
(task-assigner t mngr
|
||||
(lambda ()
|
||||
;; need to find a new task manager
|
||||
;; don't think we need a release-slot! here, because if we've heard back from a task manager,
|
||||
;; they should have told us a different slot count since we tried to give them work
|
||||
(log "JM overloaded manager ~a with task ~a" mngr this-id)
|
||||
(stop-facet this-facet (select-a-task-manager)))
|
||||
(lambda (results)
|
||||
(log "JM receives the results of task ~a" this-id)
|
||||
(stop-facet task-facet (k (first this-id) results)))))))
|
||||
|
||||
(on-start (select-a-task-manager))))
|
||||
|
||||
;; ID Data -> Void
|
||||
;; Update any dependent tasks with the results of the given task, moving
|
||||
;; them to the ready queue when possible
|
||||
(define (push-results task-id data)
|
||||
(cond
|
||||
;; this is an interesting scenario wrt stop handlers running; this code is assuming
|
||||
;; it runs after the on-stop above that decrements `tasks-in-progress`
|
||||
[(and (zero? (tasks-in-progress))
|
||||
(empty? (waiting-tasks)))
|
||||
(log "JM finished with job ~a" job-id)
|
||||
(react (assert (job-completion job-id tasks data)))]
|
||||
[else
|
||||
;; TODO - in MapReduce, there should be either 1 waiting task, or 0, meaning the job is done.
|
||||
(define still-waiting
|
||||
(for/fold ([ts '()])
|
||||
([t (in-list (waiting-tasks))])
|
||||
(define t+ (task+data t task-id data))
|
||||
(cond
|
||||
[(task-ready? t+)
|
||||
(add-ready-task! t+)
|
||||
ts]
|
||||
[else
|
||||
(cons t+ ts)])))
|
||||
(waiting-tasks still-waiting)]))
|
||||
#f)))
|
||||
|
||||
;; Task -> Bool
|
||||
;; Test if the task is ready to run
|
||||
(define (task-ready? t)
|
||||
(match t
|
||||
[(task _ (reduce-work l r))
|
||||
(not (or (id? l) (id? r)))]
|
||||
[_ #t]))
|
||||
|
||||
;; Task Id Any -> Task
|
||||
;; If the given task is waiting for this data, replace the waiting ID with the data
|
||||
(define (task+data t id data)
|
||||
(match t
|
||||
[(task tid (reduce-work (== id) r))
|
||||
(task tid (reduce-work data r))]
|
||||
[(task tid (reduce-work l (== id)))
|
||||
(task tid (reduce-work l data))]
|
||||
[_ t]))
|
||||
|
||||
|
||||
;; (Listof A) Nat -> (Values (Listof A) (Listof A))
|
||||
;; like split-at but allow a number larger than the length of the list
|
||||
(define (split-at/lenient lst n)
|
||||
(split-at lst (min n (length lst))))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
;; Client
|
||||
|
||||
;; Job -> Void
|
||||
(define (spawn-client j)
|
||||
(spawn
|
||||
(on (asserted (job-completion (job-id j) (job-tasks j) $data))
|
||||
(printf "job done!\n~a\n" data))))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
;; Observe interaction between task and job manager
|
||||
|
||||
(define (spawn-observer)
|
||||
(spawn
|
||||
(during (job-manager-alive)
|
||||
(during (task-manager $tm-id _)
|
||||
(define/query-set requests (observe (task-performance tm-id (task $tid _) _)) tid)
|
||||
(field [high-water-mark 0])
|
||||
(on (asserted (task-manager tm-id $slots))
|
||||
(when (> slots (high-water-mark))
|
||||
(high-water-mark slots)))
|
||||
(begin/dataflow
|
||||
(when (> (set-count (requests)) (high-water-mark))
|
||||
(log "!! DEMAND > SUPPLY !!")))))))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
;; Creating a Job
|
||||
|
||||
;; (Listof WorkDesc) -> (Values (Listof WorkDesc) (Optionof WorkDesc))
|
||||
;; Pair up elements of the input list into a list of reduce tasks, and if the input list is odd also
|
||||
;; return the odd-one out.
|
||||
;; Conceptually, it does something like this:
|
||||
;; '(a b c d) => '((a b) (c d))
|
||||
;; '(a b c d e) => '((a b) (c d) e)
|
||||
(define (pair-up ls)
|
||||
(let loop ([ls ls]
|
||||
[reductions '()])
|
||||
(match ls
|
||||
['()
|
||||
(values reductions #f)]
|
||||
[(list x)
|
||||
(values reductions x)]
|
||||
[(list-rest x y more)
|
||||
(loop more (cons (reduce-work x y) reductions))])))
|
||||
|
||||
|
||||
;; a TaskTree is one of
|
||||
;; (map-work data)
|
||||
;; (reduce-work TaskTree TaskTree)
|
||||
|
||||
;; (Listof String) -> TaskTree
|
||||
;; Create a tree structure of tasks
|
||||
(define (create-task-tree lines)
|
||||
(define map-works
|
||||
(for/list ([line (in-list lines)])
|
||||
(map-work line)))
|
||||
;; build the tree up from the leaves
|
||||
(let loop ([nodes map-works])
|
||||
(match nodes
|
||||
['()
|
||||
;; input was empty
|
||||
(map-work "")]
|
||||
[(list x)
|
||||
x]
|
||||
[_
|
||||
(define-values (reductions left-over?)
|
||||
(pair-up nodes))
|
||||
(loop (if left-over?
|
||||
(cons left-over? reductions)
|
||||
reductions))])))
|
||||
|
||||
;; TaskTree -> (Listof Task)
|
||||
;; flatten a task tree by assigning job-unique IDs
|
||||
(define (task-tree->list tt job-id)
|
||||
(define-values (tasks _)
|
||||
;; TaskTree ID -> (Values (Listof Task) ID)
|
||||
;; the input id is for the current node of the tree
|
||||
;; returned id is the "next available" id, given ids are assigned in strict ascending order
|
||||
(let loop ([tt tt]
|
||||
[next-id 0])
|
||||
(match tt
|
||||
[(map-work _)
|
||||
(values (list (task (list next-id job-id) tt))
|
||||
(add1 next-id))]
|
||||
[(reduce-work left right)
|
||||
(define left-id (add1 next-id))
|
||||
(define-values (lefts right-id)
|
||||
(loop left left-id))
|
||||
(define-values (rights next)
|
||||
(loop right right-id))
|
||||
(values (cons (task (list next-id job-id) (reduce-work left-id right-id))
|
||||
(append lefts rights))
|
||||
next)])))
|
||||
tasks)
|
||||
|
||||
;; InputPort -> Job
|
||||
(define (create-job in)
|
||||
(define job-id (gensym 'job))
|
||||
(define input-lines (sequence->list (in-lines in)))
|
||||
(define tasks (task-tree->list (create-task-tree input-lines) job-id))
|
||||
(job job-id tasks))
|
||||
|
||||
;; String -> Job
|
||||
(define (string->job s)
|
||||
(create-job (open-input-string s)))
|
||||
|
||||
;; PathString -> Job
|
||||
(define (file->job path)
|
||||
(define in (open-input-file path))
|
||||
(define j (create-job in))
|
||||
(close-input-port in)
|
||||
j)
|
||||
|
||||
(module+ test
|
||||
(test-case
|
||||
"two-line job parsing"
|
||||
(define input "a b c\nd e f")
|
||||
(define j (string->job input))
|
||||
(check-true (job? j))
|
||||
(match-define (job jid tasks) j)
|
||||
(check-true (id? jid))
|
||||
(check-true (list? tasks))
|
||||
(check-true (andmap task? tasks))
|
||||
(match tasks
|
||||
[(list-no-order (task rid (reduce-work left right))
|
||||
(task mid1 (map-work data1))
|
||||
(task mid2 (map-work data2)))
|
||||
(check-true (id? left))
|
||||
(check-true (id? right))
|
||||
(check-equal? (set left right) (set (first mid1) (first mid2)))
|
||||
(check-equal? (set data1 data2)
|
||||
(set "a b c" "d e f"))]
|
||||
[_
|
||||
(displayln tasks)]))
|
||||
(test-case
|
||||
"empty input"
|
||||
(define input "")
|
||||
(define j (string->job input))
|
||||
(check-true (job? j))
|
||||
(match-define (job jid tasks) j)
|
||||
(check-true (id? jid))
|
||||
(check-true (list? tasks))
|
||||
(check-equal? (length tasks) 1)
|
||||
(check-equal? (task-desc (car tasks))
|
||||
(map-work ""))))
|
||||
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
;; Main
|
||||
|
||||
(define input "a b c a b c\na b\n a b\na b")
|
||||
(define j (string->job input))
|
||||
;; expected:
|
||||
;; #hash((a . 5) (b . 5) (c . 2))
|
||||
|
||||
(spawn-client j)
|
||||
(spawn-client (file->job "lorem.txt"))
|
||||
(spawn-job-manager)
|
||||
(spawn-task-manager 2)
|
||||
(spawn-task-manager 3)
|
||||
(spawn-observer)
|
||||
|
||||
(module+ main
|
||||
(void))
|
|
@ -1,61 +0,0 @@
|
|||
#lang syndicate
|
||||
|
||||
;; Expected Output:
|
||||
#|
|
||||
balance = 0
|
||||
balance = 5
|
||||
balance = 0
|
||||
JEEPERS
|
||||
know overdraft!
|
||||
balance = -1
|
||||
balance = -2
|
||||
no longer in overdraft
|
||||
balance = 8
|
||||
|#
|
||||
|
||||
(assertion-struct balance (v))
|
||||
(message-struct deposit (v))
|
||||
|
||||
(spawn
|
||||
;; Internal Events
|
||||
(message-struct new-transaction (old new))
|
||||
(assertion-struct overdraft ())
|
||||
|
||||
(field [account 0])
|
||||
|
||||
(assert (balance (account)))
|
||||
|
||||
(on (message (deposit $v))
|
||||
(define prev (account))
|
||||
(account (+ v (account)))
|
||||
(realize! (new-transaction prev (account))))
|
||||
|
||||
(on (realize (new-transaction $old $new))
|
||||
(when (and (negative? new)
|
||||
(not (negative? old)))
|
||||
(react
|
||||
;; (this print is to make sure only one of these facets is created)
|
||||
(printf "JEEPERS\n")
|
||||
(know (overdraft))
|
||||
(on (realize (new-transaction $old $new))
|
||||
(when (not (negative? new))
|
||||
(stop-current-facet))))))
|
||||
|
||||
(during (know (overdraft))
|
||||
(on-start (printf "know overdraft!\n"))
|
||||
(on-stop (printf "no longer in overdraft\n"))))
|
||||
|
||||
(spawn
|
||||
(on (asserted (balance $v))
|
||||
(printf "balance = ~a\n" v)))
|
||||
|
||||
(spawn*
|
||||
(send! (deposit 5))
|
||||
(flush!)
|
||||
(send! (deposit -5))
|
||||
(flush!)
|
||||
(send! (deposit -1))
|
||||
(flush!)
|
||||
(send! (deposit -1))
|
||||
(flush!)
|
||||
(send! (deposit 10)))
|
|
@ -1,48 +0,0 @@
|
|||
Lorem ipsum dolor sit amet, consectetur adipiscing elit. Nullam vehicula
|
||||
accumsan tristique. Integer sit amet sem metus. Nam porta tempus nisl ac
|
||||
ullamcorper. Nulla interdum ante ut odio ultricies lobortis. Nam sollicitudin
|
||||
lorem quis pellentesque consequat. Aenean pulvinar diam sed nulla semper, eget
|
||||
varius tortor faucibus. Nam sodales mattis elit, ac convallis sem pretium sed.
|
||||
Aliquam nibh velit, facilisis sit amet aliquam quis, dapibus vel mauris. Cras
|
||||
pharetra arcu tortor, id pharetra massa aliquet non. Maecenas elit libero,
|
||||
malesuada nec enim ut, ornare sagittis lectus. Praesent bibendum sed magna id
|
||||
euismod. Maecenas vulputate nunc mauris, a dignissim magna volutpat consectetur.
|
||||
Fusce malesuada neque sapien, sit amet ultricies urna finibus non. Fusce
|
||||
ultrices ipsum vel ligula eleifend, eget eleifend magna interdum. Curabitur
|
||||
semper quam nunc, sed laoreet ipsum facilisis at. Etiam ut quam ac eros
|
||||
ullamcorper mattis eget vel leo.
|
||||
|
||||
Integer ac ipsum augue. Ut molestie ac mi vel varius. Praesent at est et nulla
|
||||
facilisis viverra sit amet eu augue. Nullam diam odio, elementum vehicula
|
||||
convallis id, hendrerit non magna. Suspendisse porta faucibus feugiat. In
|
||||
rhoncus semper diam eu malesuada. Suspendisse ligula metus, rhoncus eget nunc
|
||||
et, cursus rutrum sem. Fusce iaculis commodo magna, vitae viverra arcu. Fusce et
|
||||
eros et massa sollicitudin bibendum. Etiam convallis, nibh accumsan porttitor
|
||||
sollicitudin, mauris orci consectetur nisl, sit amet venenatis nulla enim eget
|
||||
risus. Phasellus quam diam, commodo in sodales eget, scelerisque sed odio. Sed
|
||||
aliquam massa vel efficitur volutpat. Mauris ut elit dictum, euismod turpis in,
|
||||
feugiat lectus.
|
||||
|
||||
Vestibulum leo est, feugiat sit amet metus nec, ullamcorper commodo purus. Sed
|
||||
non mauris non tellus ullamcorper congue interdum et mauris. Donec sit amet
|
||||
mauris urna. Sed in enim nisi. Praesent accumsan sagittis euismod. Donec vel
|
||||
nisl turpis. Ut non efficitur erat. Vestibulum quis fermentum elit. Mauris
|
||||
molestie nibh posuere fringilla rutrum. Praesent mattis tortor sapien, semper
|
||||
varius elit ultrices in.
|
||||
|
||||
Etiam non leo lacus. Cras id tincidunt ante. Donec mattis urna fermentum ex
|
||||
elementum blandit. Sed ornare vestibulum nulla luctus malesuada. Maecenas
|
||||
pulvinar metus tortor. Sed dapibus enim vel sem bibendum, sit amet tincidunt
|
||||
ligula varius. Nullam vitae augue at dui blandit cursus. Suspendisse faucibus
|
||||
posuere luctus.
|
||||
|
||||
Class aptent taciti sociosqu ad litora torquent per conubia nostra, per inceptos
|
||||
himenaeos. Aenean suscipit diam eu luctus auctor. Donec non magna quis ex
|
||||
tincidunt condimentum. Ut porta maximus quam, non varius sem mattis eu. Fusce
|
||||
sit amet vestibulum libero. Aliquam vestibulum sagittis mi a pellentesque. Cras
|
||||
maximus cursus libero vitae porttitor. Aenean fermentum erat eget turpis mattis,
|
||||
quis commodo magna pharetra. Praesent eu hendrerit arcu. Proin mollis, sem ac
|
||||
accumsan dignissim, velit risus ultricies mauris, eu imperdiet dolor ipsum at
|
||||
augue. Fusce bibendum, tortor eget pulvinar auctor, leo mi volutpat urna, nec
|
||||
convallis sem quam non tellus. Vestibulum fermentum sodales faucibus. Nunc quis
|
||||
feugiat quam. Donec pulvinar feugiat mauris non porttitor.
|
|
@ -1,19 +0,0 @@
|
|||
#lang syndicate
|
||||
|
||||
;; Expected Output:
|
||||
#|
|
||||
received message bad
|
||||
realized good
|
||||
|#
|
||||
|
||||
(message-struct ping (v))
|
||||
|
||||
(spawn
|
||||
(on (realize (ping $v))
|
||||
(printf "realized ~a\n" v))
|
||||
(on (message (ping $v))
|
||||
(printf "received message ~a\n" v)
|
||||
(realize! (ping 'good))))
|
||||
|
||||
(spawn*
|
||||
(send! (ping 'bad)))
|
|
@ -1,33 +0,0 @@
|
|||
#lang syndicate
|
||||
;; Sketch of a DNS intra-program protocol
|
||||
|
||||
(assertion-struct dns-entry (name address))
|
||||
|
||||
(require/activate syndicate/drivers/timestate)
|
||||
|
||||
(spawn #:name 'server
|
||||
(during (observe (dns-entry "localhost" _))
|
||||
(on-start (printf "asserting localhost record\n"))
|
||||
(on-stop (printf "retracting localhost record\n"))
|
||||
(assert (dns-entry "localhost" "127.0.0.1"))))
|
||||
|
||||
(spawn #:name 'cache
|
||||
(on (asserted (observe (dns-entry $name _)))
|
||||
(define deadline (+ (current-inexact-milliseconds) 2000))
|
||||
(react (stop-when (asserted (later-than deadline)))
|
||||
(on-start (printf "caching ~a\n" name))
|
||||
(on-stop (printf "uncaching ~a\n" name))
|
||||
(assert (observe (dns-entry name _))))))
|
||||
|
||||
(spawn #:name 'main
|
||||
(stop-when (asserted (dns-entry "localhost" $addr))
|
||||
(printf "localhost is ~a\n" addr)
|
||||
(sleep 1)
|
||||
(react (stop-when (asserted (dns-entry "localhost" $addr))
|
||||
(printf "localhost is still ~a\n" addr)
|
||||
(sleep 2)
|
||||
(react (stop-when (asserted (dns-entry "localhost" $addr))
|
||||
(printf "localhost is STILL ~a\n" addr)))))))
|
||||
|
||||
(module+ main
|
||||
(file-stream-buffer-mode (current-output-port) 'line))
|
|
@ -1,32 +0,0 @@
|
|||
#lang syndicate
|
||||
;; Simple TCP relay
|
||||
|
||||
(require/activate syndicate/drivers/tcp2)
|
||||
|
||||
(define (read-tcp-line id)
|
||||
(react/suspend (k)
|
||||
(on (message (tcp-in-line id $line-bytes))
|
||||
(k (bytes->string/utf-8 line-bytes)))))
|
||||
|
||||
(spawn #:name 'server
|
||||
(during (tcp-connection $id (tcp-listener 5000))
|
||||
(assert (tcp-accepted id))
|
||||
(on-start (printf "Accepted ~a\n" id))
|
||||
(on-stop (printf "Disconnected ~a\n" id))
|
||||
(define connection-facet-id (current-facet-id))
|
||||
(on-start (send! (tcp-out id #"Please enter the host to connect to: "))
|
||||
(define host (read-tcp-line id))
|
||||
(send! (tcp-out id #"Please enter the port to connect to: "))
|
||||
(define port (string->number (read-tcp-line id)))
|
||||
(define outbound-id (gensym 'outbound-id))
|
||||
(react (assert (tcp-connection outbound-id (tcp-address host port)))
|
||||
(during (tcp-accepted outbound-id)
|
||||
(on-start (printf "Connected ~a => ~a\n" id outbound-id))
|
||||
(on-stop (printf "Disconnected ~a => ~a\n" id outbound-id))
|
||||
(on-stop (stop-facet connection-facet-id))
|
||||
(on (message (tcp-in id $bs))
|
||||
(printf "Relaying ~a -> ~a: ~v\n" id outbound-id bs)
|
||||
(send! (tcp-out outbound-id bs)))
|
||||
(on (message (tcp-in outbound-id $bs))
|
||||
(printf "Relaying ~a <- ~a: ~v\n" id outbound-id bs)
|
||||
(send! (tcp-out id bs))))))))
|
|
@ -1,18 +0,0 @@
|
|||
#lang syndicate
|
||||
;; Simple TCP relay
|
||||
|
||||
(require/activate syndicate/drivers/tcp2)
|
||||
|
||||
(spawn (during (tcp-connection $id (tcp-listener 5000))
|
||||
(assert (tcp-accepted id))
|
||||
|
||||
(define root-facet-id (current-facet-id))
|
||||
(define outbound-id (gensym 'outbound-id))
|
||||
|
||||
(assert (tcp-connection outbound-id (tcp-address "localhost" 5999)))
|
||||
(during (tcp-accepted outbound-id)
|
||||
(on-stop (stop-facet root-facet-id))
|
||||
(on (message (tcp-in id $bs))
|
||||
(send! (tcp-out outbound-id bs)))
|
||||
(on (message (tcp-in outbound-id $bs))
|
||||
(send! (tcp-out id bs))))))
|
|
@ -60,10 +60,7 @@
|
|||
(quit))]
|
||||
[_ #f]))
|
||||
|
||||
(actor (lambda (e s) (quit))
|
||||
#f
|
||||
(message (set-timer 'tick 1000 'relative)))
|
||||
|
||||
(message (set-timer 'tick 1000 'relative))
|
||||
(actor ticker
|
||||
1
|
||||
(patch-seq (sub (observe (set-timer ? ? ?)))
|
||||
|
|
|
@ -3,8 +3,3 @@
|
|||
(define racket-launcher-names '("syndicate-broker" "syndicate-render-msd"))
|
||||
(define racket-launcher-libraries '("broker/server.rkt" "trace/render-msd.rkt"))
|
||||
(define test-include-paths '("syndicate/tests"))
|
||||
(define test-omit-paths
|
||||
'(;; Sam: example-plain is interactive, I think
|
||||
"examples/example-plain.rkt"
|
||||
;; Sam: for whatever reason I get a failure to load libcrypto for f-to-c
|
||||
"examples/actor/f-to-c.rkt"))
|
||||
|
|
|
@ -13,7 +13,6 @@
|
|||
(require (for-syntax syntax/parse))
|
||||
(require rackunit)
|
||||
(require racket/engine)
|
||||
(require racket/exn)
|
||||
|
||||
(define mt-scn (scn trie-empty))
|
||||
|
||||
|
@ -290,7 +289,7 @@
|
|||
;; leaf behavior function
|
||||
(define (actor-behavior e s)
|
||||
(when e
|
||||
(with-handlers ([exn:fail? (lambda (e) (printf "exception: ~v\n" (exn->string e)) (quit #:exception e (list)))])
|
||||
(with-handlers ([exn:fail? (lambda (e) (eprintf "exception: ~v\n" e) (quit #:exception e (list)))])
|
||||
(match-define (actor-state π-old fts) s)
|
||||
(define-values (actions next-fts)
|
||||
(for/fold ([as '()]
|
||||
|
@ -546,7 +545,7 @@
|
|||
;; boot-actor : actor Γ -> Action
|
||||
(define (boot-actor a Γ)
|
||||
(with-handlers ([exn:fail? (lambda (e)
|
||||
(printf "booting actor died with: ~a\n" (exn->string e))
|
||||
(eprintf "booting actor died with: ~v\n" e)
|
||||
#f)])
|
||||
(match a
|
||||
[`(spawn ,O ...)
|
||||
|
|
|
@ -14,7 +14,6 @@
|
|||
limit-patch
|
||||
patch-step
|
||||
patch-step*
|
||||
patch-prepend
|
||||
compute-aggregate-patch
|
||||
apply-patch
|
||||
update-interests
|
||||
|
@ -126,13 +125,6 @@
|
|||
(define (patch-step* p keys)
|
||||
(foldl (lambda (key p) (patch-step p key)) p keys))
|
||||
|
||||
;; (U Sigma OpenParenthesis) Trie -> Trie
|
||||
;; Prepend both added and removed sets
|
||||
(define (patch-prepend key p)
|
||||
(match-define (patch added removed) p)
|
||||
(patch (trie-prepend key added)
|
||||
(trie-prepend key removed)))
|
||||
|
||||
;; Entries labelled with `label` may already exist in `base`; the
|
||||
;; patch `p` MUST already have been limited to add only where no
|
||||
;; `label`-labelled portions of `base` exist, and to remove only where
|
||||
|
|
|
@ -3,578 +3,27 @@
|
|||
@(require (for-label (except-in racket process field)
|
||||
syndicate/actor))
|
||||
|
||||
@title{Dataspace Programming with Syndicate}
|
||||
@title{High Level Syntax for Syndicate}
|
||||
|
||||
|
||||
@defmodule[syndicate/actor]
|
||||
|
||||
@section{Overview}
|
||||
@section{Instantaneous Actions (I)}
|
||||
|
||||
Syndicate is an actor language where all communication occurs through a tightly
|
||||
controlled shared memory, dubbed the @emph{dataspace}. The values in the
|
||||
dataspace are called @emph{assertions}, representing the information that the
|
||||
actors in the system are currently sharing with each other. Assertions are
|
||||
@emph{read-only} and @emph{owned} by the actor that entered them into the
|
||||
dataspace. Only the originating actor has permission to withdraw an assertion.
|
||||
Assertions are linked to the lifetime of their actor, and are withdrawn from the
|
||||
dataspace when that actor exits, either normally or via exception.
|
||||
@defform[(spawn I ...)]{
|
||||
Spawns an actor that executes each instantaneous action @racket[I] in
|
||||
sequence.}
|
||||
|
||||
To respond to assertions in the dataspace, an actor expresses an @emph{interest}
|
||||
in the shape of assertions it wishes to receive. An interest is an assertion
|
||||
constructed with @racket[observe] and wildcards where the actor wishes to
|
||||
receive any matching assertion. When an actor makes an assertion of interest,
|
||||
the dataspace dispatches the set of all matching assertions to that actor.
|
||||
Moreover, the dataspace keeps the actor @emph{up-to-date}, informing it when a
|
||||
new assertion appears matching its interest, as well as when a matching
|
||||
assertion disappears from the dataspace. Thus, dataspaces implement a form of
|
||||
publish/subscribe communication.
|
||||
@defform[(dataspace I ...)]{
|
||||
Spawns a dataspace as a child of the dataspace enclosing the executing actor. The
|
||||
new dataspace executes each instantaneous action @racket[I].}
|
||||
|
||||
@;{would be nice to link pub/sub}
|
||||
|
||||
In addition to assertions, dataspaces support instantaneous @racket[message]
|
||||
broadcast. At the time a message is sent, all actors with a matching interest
|
||||
receive notification.
|
||||
|
||||
In response to an event, that is, a message broadcast or assertion
|
||||
appearance/disappearance matching an expressed interest, a Syndicate actor may
|
||||
take any of the following actions:
|
||||
@itemlist[
|
||||
@item{Updating its internal state;}
|
||||
@item{Making or withdrawing assertions;}
|
||||
@item{Sending broadcast messages;}
|
||||
@item{Spawning additional actors;}
|
||||
@item{Exiting;}
|
||||
@item{Or any combination of these.}
|
||||
]
|
||||
|
||||
Thus, each individual Syndicate actor has three fudamental concerns:
|
||||
|
||||
@itemlist[
|
||||
@item{Defining local state and updating it in response to events;}
|
||||
@item{Publishing aspects of local state/knowledge as assertions; and}
|
||||
@item{Reacting to relevant assertions and messages.}
|
||||
]
|
||||
|
||||
Each concern is addressed by a separate language construct, which are
|
||||
collectively dubbed @emph{endpoints}:
|
||||
|
||||
@itemlist[
|
||||
@item{The @racket[field]s of an actor hold its state;}
|
||||
@item{An actor publishes information using @racket[assert]; and}
|
||||
@item{An event-handler endpoint uses @racket[on] to define reactions to
|
||||
particular messages and assertions.}
|
||||
]
|
||||
|
||||
Endpoints are tied together via @emph{dataflow}. Thus, the assertions of an
|
||||
actor automatically reflect the current value of its fields.
|
||||
|
||||
Implementing an actor's role in a particular conversation typically involves
|
||||
some combination of these behaviors; a @emph{facet} is a collection of related
|
||||
endpoints constituting the actor's participation in a particular conversation.
|
||||
|
||||
Each actor starts with a single facet, and may add new facets or terminate
|
||||
current ones in response to events. The facets of an actor form a tree, where
|
||||
the parent of a particular facet is the facet in which it was created. The tree
|
||||
structure affects facet shutdown; terminating a facet also terminates all of its
|
||||
descendants.
|
||||
|
||||
To recap: an actor is a tree of facets, each of which comprises of a collection
|
||||
of endpoints.
|
||||
|
||||
@section{Programming Syndicate Actors with Facets}
|
||||
|
||||
Code within Syndicate actors executes in one of two contexts:
|
||||
@itemlist[
|
||||
@item{The @emph{endpoint-installation} context occurs during the creation of a
|
||||
new facet, when all of its endpoints are created.}
|
||||
@item{The @emph{script} context occurs during the execution of event handlers,
|
||||
and permits creating/terminating facets, sending messages, and spawning
|
||||
actors.}
|
||||
]
|
||||
|
||||
The actions permitted by the two contexts are mutually exclusive, and trying to
|
||||
perform an action in the wrong context will give rise to a run-time
|
||||
@racket[error].
|
||||
|
||||
Within the following descriptions, we use @emph{EI} as a shorthand for
|
||||
expressions that execute in an endpoint-installation context and @emph{S} for
|
||||
expressions in a script context.
|
||||
|
||||
@subsection{Script Actions: Starting and Stopping Actors and Facets}
|
||||
|
||||
@defform[(spawn maybe-name
|
||||
maybe-assertions
|
||||
maybe-linkage
|
||||
EI ...+)
|
||||
#:grammar
|
||||
[(maybe-name (code:line)
|
||||
(code:line #:name name-expr))
|
||||
(maybe-assertions (code:line)
|
||||
(code:line #:assertions assertion-expr)
|
||||
(code:line #:assertions* assertions-expr))
|
||||
(maybe-linkage (code:line)
|
||||
(code:line #:linkage [linkage-expr ...]))]
|
||||
#:contracts
|
||||
([assertion-expr any/c]
|
||||
[assertions-expr trie?])]{
|
||||
Spawn an actor with a single inital facet whose endpoints are installed by
|
||||
@racket[EI]. That is, there is an implicit @racket[react] around @racket[EI
|
||||
...]. Allowed within a script and module-top-level.
|
||||
|
||||
An optionally provided @racket[name-expr] is associated with the created actor.
|
||||
The name is only used for error and log messages, thus is mainly useful for
|
||||
debugging.
|
||||
|
||||
The actor may optionally be given some initial assertions, which come into being
|
||||
at the same time as the actor. (Otherwise, the actor spawns, then boots its
|
||||
initial facet(s), then establishes any ensuing assertions.) When
|
||||
@racket[assertion-expr] is provided, the actors initial assertions are the
|
||||
result of interpreting the expression as a @racket[trie] pattern, with
|
||||
@racket[?] giving rise to infinte sets. On the other hand,
|
||||
@racket[assertions-expr] may be used to specify an entire set of initial
|
||||
assertions as an arbitrary @racket[trie].
|
||||
|
||||
The optional @racket[linkage-expr]s are executed during facet startup; your
|
||||
simple documentation author is not sure why they are useful, as opposed to just
|
||||
putting them in the body of the @racket[spawn].
|
||||
}
|
||||
|
||||
@defform[(react EI ...+)]{
|
||||
Create a new facet in the current actor whose endpoints are the result of
|
||||
executing @racket[EI ...]. Allowed within a script.
|
||||
}
|
||||
|
||||
@defform[(stop-facet fid S ...)
|
||||
#:contracts ([fid facet-id?])]{
|
||||
Terminate the facet with ID @racket[fid], as well as all of its children.
|
||||
Allowed within a script.
|
||||
|
||||
The optional script actions @racket[S ...] function like a continuation. They
|
||||
run @emph{after} the facet and all of its children finish shutting down, i.e.
|
||||
after all @racket[stop] handlers have executed. Moreover, @racket[S ...] runs in
|
||||
the context of the @emph{parent} of @racket[fid]. Thus, any facet created by the
|
||||
script survives termination and will have @racket[fid]'s parent as its own
|
||||
parent.
|
||||
|
||||
Note that @racket[fid] must be an ancestor of the current facet.
|
||||
}
|
||||
|
||||
@defform[(stop-current-facet S ...)]{
|
||||
Stop the currently running facet; equivalent to
|
||||
@racketblock[(stop-facet (current-facet-id) S ...)].
|
||||
|
||||
Allowed within a script.
|
||||
}
|
||||
|
||||
@defproc[(current-facet-id) facet-id?]{
|
||||
Retrieves the ID of the currently running facet.
|
||||
}
|
||||
|
||||
@defproc[(send! [v any/c])
|
||||
@defproc[(send! [v any/c]
|
||||
[#:meta-level level natural-number/c 0])
|
||||
void?]{
|
||||
Sends a @racket[message] with body @racket[v].
|
||||
|
||||
Allowed within a script.
|
||||
}
|
||||
|
||||
@subsection{Installing Endpoints}
|
||||
|
||||
@defform[(field [x init-expr maybe-contract] ...+)
|
||||
#:grammar
|
||||
[(maybe-contract (code:line)
|
||||
(code:line #:contract in)
|
||||
(code:line #:contract in out))]]{
|
||||
Define fields for the current facet. Each @racket[x] is bound to a handle
|
||||
function: calling @racket[(x)] retrieves the current value, while @racket[(x v)]
|
||||
sets the field to @racket[v].
|
||||
|
||||
Fields may optionally have a contract; the @racket[in] contract is applied when
|
||||
writing to a field, while the (optional) @racket[out] contract applies when
|
||||
reading a value from a field.
|
||||
|
||||
Allowed within an endpoint installation context.
|
||||
}
|
||||
|
||||
@defform[(assert maybe-pred exp)
|
||||
#:grammar
|
||||
[(maybe-pred (code:line)
|
||||
(code:line #:when pred))]
|
||||
#:contracts ([pred boolean?])]{
|
||||
Make the assertion @racket[exp] while the enclosing facet is active. Publishing
|
||||
the assertion can be made conditional on a boolean expression by supplying a
|
||||
@racket[#:when] predicate, in which case the assertion is made only when
|
||||
@racket[pred] evaluates to a truthy value.
|
||||
|
||||
If the expression @racket[exp] refers to any fields, then the assertion created
|
||||
by the endpoint is automatically kept up-to-date each time any of those fields
|
||||
is updated. More specifically, the will issue a patch retracting the assertion
|
||||
of the previous value, replacing it with the results of reevaluating
|
||||
@racket[exp] with the current values of each field.
|
||||
|
||||
Allowed within an endpoint installation context.
|
||||
}
|
||||
|
||||
@defform[#:literals (message asserted retracted _ $ ?)
|
||||
(on maybe-pred event-description
|
||||
S ...+)
|
||||
|
||||
#:grammar
|
||||
[(maybe-pred (code:line)
|
||||
(code:line #:when pred))
|
||||
(event-description (code:line (message pattern))
|
||||
(code:line (asserted pattern))
|
||||
(code:line (retracted pattern)))
|
||||
(pattern (code:line _)
|
||||
(code:line $id)
|
||||
(code:line ($ id pattern))
|
||||
(code:line (? pred pattern))
|
||||
(code:line (ctor pattern ...))
|
||||
(code:line expr))]
|
||||
#:contracts ([pred boolean?])]{
|
||||
Creates an event handler endpoint that responds to the event specified by
|
||||
@racket[event-description]. Executes the body @racket[S ...] for each matching
|
||||
event, with any pattern variables bound to their matched value.
|
||||
|
||||
The actor will make an assertion of interest in events that could match
|
||||
@racket[event-description]. Like with @racket[assert], the interest will be
|
||||
refreshed any time a field referenced within the @racket[event-description]
|
||||
pattern changes.
|
||||
|
||||
The event handler can optionally be made conditional on a boolean expression by
|
||||
supplying a @racket[#:when] predicate, in which case the endpoint only reacts to
|
||||
events, and only expresses the corresponding assertion of interest, when
|
||||
@racket[pred] evaluates to a truthy value.
|
||||
|
||||
Allowed within an endpoint installation context.
|
||||
|
||||
Event descriptions have one of the following forms:
|
||||
@itemlist[
|
||||
@item{@racket[(message pattern)] activates when a message is received with a
|
||||
body matching @racket[pat].}
|
||||
|
||||
@item{@racket[(asserted pattern)] activates when a patch is received with an
|
||||
added assertion matching @racket[pattern]. Additionally, if the actor has
|
||||
@emph{already} received a patch with matching assertions, which can occur if
|
||||
multiple facets in a single actor have overlapping interests, then the
|
||||
endpoint will match those assertions upon facet start up.}
|
||||
|
||||
@item{@racket[(retracted pat)] is similar to @racket[asserted], but for
|
||||
assertions withdrawn in a patch.}
|
||||
|
||||
@;{@item{@racket[(rising-edge expr)] activates when @racket[expr] evaluates to
|
||||
anything besides @racket[#f] (having previously evaluated to @racket[#f]). The
|
||||
condition is checked after each received event.}}
|
||||
]
|
||||
|
||||
While patterns have the following meanings:
|
||||
@itemlist[
|
||||
@item{@racket[_] matches anything.}
|
||||
|
||||
@item{@racket[$id] matches anything and binds the value to @racket[id].}
|
||||
|
||||
@item{@racket[($ id pattern)] matches values that match @racket[pattern] and
|
||||
binds the value to @racket[id].}
|
||||
|
||||
@item{@racket[(? pred pattern)] matches values where @racket[(pred val)] is not
|
||||
@racket[#f] and that match @racket[pattern].}
|
||||
|
||||
@item{@racket[(ctor pat ...)] matches values built by applying the constructor
|
||||
@racket[ctor] to values matching @racket[pat ...]. @racket[ctor] is usually
|
||||
a @racket[struct] name.}
|
||||
|
||||
@item{@racket[expr] patterns match values that are @racket[equal?] to
|
||||
@racket[expr].}
|
||||
]
|
||||
}
|
||||
|
||||
@defform[(during pattern EI ...+)]{
|
||||
Engage in behavior for the duration of a matching assertion. Roughly equivalent
|
||||
to:
|
||||
|
||||
@racketblock[
|
||||
(on (asserted pattern)
|
||||
(react
|
||||
EI ...
|
||||
(on (retracted inst-pattern)
|
||||
(stop-current-facet))))]
|
||||
|
||||
where @racket[inst-pattern] is the @racket[pattern] with variables instantiated
|
||||
to their matching values.
|
||||
|
||||
Allowed within an endpoint installation context.
|
||||
}
|
||||
|
||||
@defform[(during/spawn pattern
|
||||
maybe-actor-wrapper
|
||||
maybe-name
|
||||
maybe-assertions
|
||||
maybe-parent-let
|
||||
maybe-on-crash
|
||||
EI ...)
|
||||
#:grammar
|
||||
[(maybe-actor-wrapper (code:line)
|
||||
(code:line #:spawn wrapper-stx))
|
||||
(maybe-parent-let (code:line)
|
||||
(code:line #:let [x expr] ...))
|
||||
(maybe-on-crash (code:line)
|
||||
(code:line #:on-crash on-crash-expr))]]{
|
||||
Like @racket[during], but in addition to creating a new facet for each matching
|
||||
assertion, @racket[spawn]s a new actor. The difference is primarily relevant for
|
||||
error propagation; an exception inside @racket[during] causes the entire actor
|
||||
to crash, while an exception inside @racket[during/spawn] crashes only the newly
|
||||
spawned actor.
|
||||
|
||||
The assertion triggering the @racket[during/spawn] may disappear @emph{before}
|
||||
the spawned actor boots, in which case it fails to see the retraction event. To
|
||||
avoid potential glitches, the @emph{spawning} actor maintains an assertion that
|
||||
lets the @racket[spawned] actor know whether the originial assertion still
|
||||
exists.
|
||||
|
||||
The @racket[maybe-name] and @racket[maybe-assertions] have the same meaning they
|
||||
do for @racket[spawn], applied to the newly spawned actor.
|
||||
|
||||
The @racket[wrapper-stx] serves as an interposition point; it may be provided to
|
||||
change the meaning of "spawning an actor" in response to an assertion. By
|
||||
default, it is @racket[#'spawn].
|
||||
|
||||
The optional @racket[#:let] clauses can be used to read the values of fields in
|
||||
the @emph{spawning} actor so that they can be used in the @emph{spawned} actor.
|
||||
Otherwise, the spawned actor has no access to the parent's fields, and trying to
|
||||
read or write to such a field will cause a runtime @racket[error].
|
||||
|
||||
The @racket[on-crash-expr] provides a hook for script actions that can be
|
||||
performed in the @emph{spawning} actor if the @emph{spawned} actor crashes.
|
||||
|
||||
Allowed within an endpoint installation context.
|
||||
}
|
||||
|
||||
@defform[(stop-when maybe-pred event-description S ...)
|
||||
#:grammar
|
||||
[(maybe-pred (code:line)
|
||||
(code:line #:when pred))]
|
||||
#:contracts ([pred boolean?])]{
|
||||
Stop the current facet when an event matching @racket[event-description] occurs.
|
||||
Roughly equivalent to
|
||||
@racketblock[
|
||||
(on event-description
|
||||
(stop-current-facet S ...))]
|
||||
|
||||
Allowed within an endpoint installation context.
|
||||
}
|
||||
|
||||
@subsection{Handling Facet Startup and Shutdown}
|
||||
|
||||
In addition to external events, such as assertion (dis)appearance and message
|
||||
broadcast, facets can react to their own startup and shutdown. This provides a
|
||||
handy way to perform initialization, cleanup, as well as setting up and tearing
|
||||
down resources.
|
||||
|
||||
@defform[(on-start S ...)]{
|
||||
Perform the script actions @racket[S ...] upon facet startup.
|
||||
|
||||
Allowed within an endpoint installation context.
|
||||
}
|
||||
|
||||
@defform[(on-stop S ...)]{
|
||||
Perform the script actions @racket[S ...] upon facet shutdown.
|
||||
|
||||
The script @racket[S ...] differs from that of @racket[stop-facet] in that it
|
||||
executes in the context of the terminating facet, not its parent. Thus, any
|
||||
facets created in @racket[S ...] will start up and then immediately shut down.
|
||||
|
||||
Allowed within an endpoint installation context.
|
||||
}
|
||||
|
||||
Note that a single facet may have any number of @racket[on-start] and
|
||||
@racket[on-stop] handlers, which do not compete with each other. That is, each
|
||||
@racket[on-start] handler runs during facet startup and, likewise, each
|
||||
@racket[on-stop] during facet shutdown.
|
||||
|
||||
@subsection{Streaming Query Fields}
|
||||
|
||||
Syndicate actors often aggregate information about current assertions as part of
|
||||
their local state, that is, in a @racket[field]. Since these patterns are
|
||||
exceedingly common, Syndicate provides a number of forms for defining fields
|
||||
that behave as streaming queries over the assertions in the dataspace.
|
||||
|
||||
@defform[(define/query-set name pattern expr maybe-on-add maybe-on-remove)
|
||||
#:grammar
|
||||
[(maybe-on-add (code:line)
|
||||
(code:line #:on-add on-add-expr))
|
||||
(maybe-on-remove (code:line)
|
||||
(code:line #:on-remove on-remove-expr))]]{
|
||||
Define a @racket[field] called @racket[name] that is the @racket[set] of values
|
||||
extracted from assertions matching @racket[pattern]. Each value is extracted
|
||||
from a matching assertion by evaluating @racket[expr], which may refer to
|
||||
variables bound by @racket[pattern].
|
||||
|
||||
The query set expands to roughly the following code:
|
||||
@racketblock[
|
||||
(begin
|
||||
(field [name (set)])
|
||||
(on (asserted pattern)
|
||||
(name (set-add (name) expr)))
|
||||
(on (retracted pattern)
|
||||
(name (set-remove (name) expr))))]
|
||||
|
||||
The optional @racket[on-add-expr] is performed inside the @racket[on asserted]
|
||||
handler, while @racket[on-remove-expr] runs in the @racket[on retracted]
|
||||
handler.
|
||||
|
||||
Allowed within an endpoint installation context.
|
||||
}
|
||||
|
||||
@defform[(define/query-hash name pattern key-expr value-expr
|
||||
maybe-on-add
|
||||
maybe-on-remove)
|
||||
#:grammar
|
||||
[(maybe-on-add (code:line)
|
||||
(code:line #:on-add on-add-expr))
|
||||
(maybe-on-remove (code:line)
|
||||
(code:line #:on-remove on-remove-expr))]]{
|
||||
Define a @racket[field] called @racket[name] that is a @racket[hash] based on
|
||||
assertions matching @racket[pattern]. Each matching assertion establishes a key
|
||||
in the hash based on @racket[key-expr] whose value is the result of
|
||||
@racket[value-expr], with each expression referring to variables bound by
|
||||
@racket[pattern]. When a matching assertion disappears from the dataspace, the
|
||||
associated key is removed from the hash.
|
||||
|
||||
The optional @racket[maybe-on-add] and @racket[maybe-on-expr] behave the same
|
||||
way they do for @racket[define/query-set].
|
||||
|
||||
Allowed within an endpoint installation context.
|
||||
}
|
||||
|
||||
@defform[(define/query-value name absent-expr pattern expr
|
||||
maybe-on-add
|
||||
maybe-on-remove)
|
||||
#:grammar
|
||||
[(maybe-on-add (code:line)
|
||||
(code:line #:on-add on-add-expr))
|
||||
(maybe-on-remove (code:line)
|
||||
(code:line #:on-remove on-remove-expr))]]{
|
||||
Define a @racket[field] called @racket[name] whose value is based on the
|
||||
presence of an assertion matching @racket[pattern] in the dataspace. When such
|
||||
an assertion is present, the value of the @racket[name] field is the result of
|
||||
evaluating @racket[expr], which may refer to @racket[pattern]. When no such
|
||||
assertion exists, including initially, the value of @racket[name] is the result
|
||||
of @racket[absent-expr].
|
||||
|
||||
The optional @racket[maybe-on-add] and @racket[maybe-on-expr] behave the same
|
||||
way they do for @racket[define/query-set].
|
||||
|
||||
Allowed within an endpoint installation context.
|
||||
}
|
||||
|
||||
@defform[(define/query-count name pattern key-expr
|
||||
maybe-on-add
|
||||
maybe-on-remove)
|
||||
#:grammar
|
||||
[(maybe-on-add (code:line)
|
||||
(code:line #:on-add on-add-expr))
|
||||
(maybe-on-remove (code:line)
|
||||
(code:line #:on-remove on-remove-expr))]]{
|
||||
Define a @racket[field] called @racket[name] whose value is a @racket[hash]
|
||||
counting occurrences of matching assertions in the dataspace. More precisely,
|
||||
for each assertion @racket[pattern], evaluating @racket[key-expr] determines a
|
||||
key in the hash; the value for that key is incremented when the assertion
|
||||
appears and decremented when it disappears. When the count associated with a
|
||||
particular key falls to @racket[0], that key is removed from the hash.
|
||||
|
||||
The optional @racket[maybe-on-add] and @racket[maybe-on-expr] behave the same
|
||||
way they do for @racket[define/query-set].
|
||||
|
||||
Allowed within an endpoint installation context.
|
||||
}
|
||||
|
||||
@subsection{Generalizing Dataflow}
|
||||
|
||||
The dataflow mechanism that automatically refreshes @racket[assert] endpoints
|
||||
when a referenced field changes may be used to react to local state updates in
|
||||
arbitrary ways using @racket[begin/dataflow].
|
||||
|
||||
@defform[(begin/dataflow S ...+)]{
|
||||
Evaluate and perform the script actions @racket[S ...] during facet startup, and
|
||||
then again each time a field referenced by the script updates.
|
||||
|
||||
Conceptually, @racket[begin/dataflow] may be thought of as an event handler
|
||||
endpoint in the vein of @racket[on], where the event of interest is @emph{update
|
||||
of local state}.
|
||||
|
||||
Allowed within an endpoint installation context.
|
||||
}
|
||||
|
||||
@defform[(define/dataflow name expr maybe-default)
|
||||
#:grammar
|
||||
[(maybe-default (code:line)
|
||||
(code:line #:default default-expr))]]{
|
||||
Define a @racket[field] named @racket[name], whose value is reevaluated to the
|
||||
result of @racket[expr] each time any referenced field changes.
|
||||
|
||||
The value of @racket[name] is either @racket[#f] or, if provided,
|
||||
@racket[default-expr]. This initial value is observable for a short time during
|
||||
facet startup.
|
||||
|
||||
Note that when a field referenced by @racket[expr] changes, there may be some
|
||||
time before @racket[name] refreshes, during which "stale" values may be read
|
||||
from the field.
|
||||
|
||||
Allowed within an endpoint installation context.
|
||||
}
|
||||
|
||||
|
||||
@subsection{Generalizing Actor-Internal Communication}
|
||||
|
||||
Talk about internal assertions and messages.
|
||||
|
||||
@subsection{Nesting Dataspaces}
|
||||
|
||||
Nested dataspaces, inbound and outbound assertions, quit-datapace.
|
||||
|
||||
@defform[(dataspace S ...)]{
|
||||
Spawns a dataspace as a child of the dataspace enclosing the executing actor.
|
||||
The new dataspace executes each action @racket[S].
|
||||
|
||||
Allowed within a script.
|
||||
}
|
||||
|
||||
|
||||
@section{@hash-lang[] @racket[syndicate] Programs}
|
||||
|
||||
In a @hash-lang[] @racket[syndicate] program, the results of top-level
|
||||
expressions define the initial group of actors in the dataspace. That is,
|
||||
evaluating @racket[spawn] or @racket[dataspace] in the context of the module
|
||||
top-level adds that actor specification to the initial dataspace of the program.
|
||||
For example, a module such as:
|
||||
|
||||
@codeblock[#:line-numbers 0]|{
|
||||
#lang syndicate
|
||||
|
||||
(define (spawn-fun)
|
||||
(spawn ...))
|
||||
|
||||
(spawn ...)
|
||||
|
||||
(spawn-fun)
|
||||
}|
|
||||
|
||||
launches a syndicate program with two initial actors, one the result of the
|
||||
@racket[spawn] expression on line 5 and one the result of evaluating the
|
||||
@racket[spawn] expresion on line 3 during the course of calling
|
||||
@racket[spawn-fun] on line 7.
|
||||
|
||||
The initial dataspace is referred to as the @emph{ground} dataspace, and it
|
||||
plays a special role in Syndicate programming; see below.
|
||||
|
||||
@section{Interacting with the Outside World}
|
||||
|
||||
ground dataspace, drivers, etc.
|
||||
|
||||
@section{Actors with an Agenda}
|
||||
|
||||
Here we talk about @racket[spawn*] and @racket[react/suspend].
|
||||
|
||||
@section{Odds and Ends}
|
||||
Sends a message with body @racket[v]. The message is sent @racket[level]
|
||||
dataspaces removed from the dataspace containing the actor performing the
|
||||
@racket[send!].}
|
||||
|
||||
@defproc[(assert! [v any/c]
|
||||
[#:meta-level level natural-number/c 0])
|
||||
|
@ -590,6 +39,8 @@ distance from the dataspace containing the enclosing actor.}
|
|||
Retracts any assertions made by the immediately enclosing actor at
|
||||
@racket[level] dataspaces above the enclosing dataspace of the form @racket[v].}
|
||||
|
||||
@section{Ongoing Behaviors (O)}
|
||||
|
||||
@defform[(state maybe-init (maybe-bindings O ...) ([E I ...] ...))
|
||||
#:grammar
|
||||
[(maybe-init (code:line)
|
||||
|
@ -651,3 +102,79 @@ termination event but before the @racket[until] actor exits.}
|
|||
#:contracts ([id identifier?])]{
|
||||
The @racket[forever] behavior is analogous to a @racket[state] form with no
|
||||
termination events.}
|
||||
|
||||
@defform[(during pat O ...)]{
|
||||
Runs the behaviors @racket[O ...] for the duration of each assertion matching
|
||||
@racket[pat].
|
||||
|
||||
Roughly equivalent to
|
||||
@racket[(on (asserted pat)
|
||||
(until (retracted pat)
|
||||
O ...))]
|
||||
where the @racket[pat] in the @racket[until] clause is specialized to the actual
|
||||
value matched by @racket[pat] in the @racket[asserted] clause.
|
||||
}
|
||||
|
||||
@defform[(assert maybe-pred exp maybe-level)
|
||||
#:grammar
|
||||
[(maybe-pred (code:line)
|
||||
(code:line #:when pred))
|
||||
(maybe-level (code:line)
|
||||
(code:line #:meta-level level))]
|
||||
#:contracts ([pred boolean?]
|
||||
[level natural-number/c])]{
|
||||
Makes the assertion @racket[exp] while the enclosing actor is running. If a
|
||||
@racket[#:when] predicate is given, the assertion is made conditionally on the
|
||||
predicate expression evaluating to true.}
|
||||
|
||||
@defform[(on E
|
||||
I ...)]{
|
||||
When the event @racket[E] becomes active, executes the instantaneous actions
|
||||
@racket[I ...] in the body. The result of the final action is the result of the
|
||||
entire behavior.}
|
||||
|
||||
@section{Events (E)}
|
||||
|
||||
@defform[(message pat)]{
|
||||
Activates when a message is received with a body matching @racket[pat].
|
||||
The message event establishes the enclosing actor's interest in @racket[pat].}
|
||||
|
||||
@defform[(asserted pat)]{
|
||||
Activates when a patch is received with an added assertion matching
|
||||
@racket[pat]. Establishes the enclosing actor's interest in @racket[pat].}
|
||||
|
||||
@defform[(retracted pat)]{
|
||||
Similar to @racket[asserted], except for assertions removed in a patch.}
|
||||
|
||||
@defform[(rising-edge expr)]{
|
||||
Activates when @racket[expr] evaluates to anything besides @racket[#f] (having
|
||||
previously evaluated to @racket[#f]). The condition is checked after each
|
||||
received event, corresponding to after each instantaneous action is executed.}
|
||||
|
||||
@section{Patterns}
|
||||
|
||||
@(racketgrammar
|
||||
pat
|
||||
(code:line)
|
||||
(code:line _)
|
||||
(code:line $id)
|
||||
(code:line ($ id pat))
|
||||
(code:line (? pred pat))
|
||||
(code:line (ctor pat ...))
|
||||
(code:line expr))
|
||||
|
||||
@racket[_] matches anything.
|
||||
|
||||
@racket[$id] matches anything and binds the value to @racket[id].
|
||||
|
||||
@racket[($ id pat)] matches values that match @racket[pat] and binds the value
|
||||
to @racket[id].
|
||||
|
||||
@racket[(? pred pat)] matches values where @racket[(pred val)] is not
|
||||
@racket[#f] and that match @racket[pat].
|
||||
|
||||
@racket[(ctor pat ...)] matches values built by applying the constructor
|
||||
@racket[ctor] to values matching @racket[pat ...].
|
||||
|
||||
@racket[expr] patterns match values that are exactly equal to @racket[expr].
|
||||
|
||||
|
|
|
@ -1,8 +1,7 @@
|
|||
#lang syndicate/test
|
||||
|
||||
;; The facet in the on-stop should immediately die and its assertion should never be visible.
|
||||
;; Pretty sure the little implementation gets that wrong.
|
||||
;; the trace does not have a way of saying there should never be a "here" assertion
|
||||
;; Reflects the current behavior of the little implementation,
|
||||
;; but quite possibly *not* what should happen
|
||||
|
||||
(spawn
|
||||
(on-stop (react (assert (outbound "here"))))
|
||||
|
@ -10,4 +9,4 @@
|
|||
|
||||
(spawn (on-start (send! "stop")))
|
||||
|
||||
(trace (message "stop"))
|
||||
(trace (assertion-added (outbound "here")))
|
|
@ -5,10 +5,6 @@
|
|||
;; dubious behavior by little implementation;
|
||||
;; create new facets from more nested facets
|
||||
|
||||
;; The facet in the on-stop should immediately die and its assertion should never be visible.
|
||||
;; Pretty sure the little implementation gets that wrong.
|
||||
;; the trace does not have a way of saying there should never be an "inner" assertion
|
||||
|
||||
(spawn (on-start
|
||||
(react (on-stop
|
||||
(react (assert (outbound "inner"))))))
|
||||
|
@ -17,4 +13,4 @@
|
|||
|
||||
(spawn (on-start (send! "stop")))
|
||||
|
||||
(trace (message "stop"))
|
||||
(trace (assertion-added (outbound "inner")))
|
||||
|
|
|
@ -1,7 +1,5 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide start-tracing!)
|
||||
|
||||
(require racket/match)
|
||||
(require racket/set)
|
||||
(require racket/string)
|
||||
|
@ -14,7 +12,7 @@
|
|||
|
||||
(define-logger syndicate/trace/msd)
|
||||
|
||||
(define (start-tracing! output-filename)
|
||||
(let ((output-filename (getenv "SYNDICATE_MSD")))
|
||||
(when output-filename
|
||||
(define names (make-hash (list (cons '() "'ground"))))
|
||||
(define (open-output cause)
|
||||
|
@ -106,5 +104,3 @@
|
|||
(loop)))))
|
||||
(channel-get ch)
|
||||
(current-trace-procedures (cons msd-trace (current-trace-procedures))))))
|
||||
|
||||
(start-tracing! (getenv "SYNDICATE_MSD"))
|
||||
|
|
|
@ -1,11 +0,0 @@
|
|||
pan : pan.c
|
||||
gcc -o pan pan.c
|
||||
|
||||
pan.c : leader-and-seller.pml
|
||||
spin -a leader-and-seller.pml
|
||||
|
||||
# -a to analyze, -f for (weak) fairness
|
||||
# -n to elide report of unreached states
|
||||
# -N spec-name to verify a particular specification
|
||||
check: pan
|
||||
./pan -a -f -n
|
File diff suppressed because it is too large
Load Diff
|
@ -1,65 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
;; Expected Output
|
||||
;; 0
|
||||
;; 70
|
||||
;; #f
|
||||
|
||||
(define-constructor (account balance)
|
||||
#:type-constructor AccountT
|
||||
#:with Account (AccountT Int)
|
||||
#:with AccountRequest (AccountT ★/t))
|
||||
|
||||
(define-constructor (deposit amount)
|
||||
#:type-constructor DepositT
|
||||
#:with Deposit (DepositT Int)
|
||||
#:with DepositRequest (DepositT ★/t))
|
||||
|
||||
(define-type-alias ds-type
|
||||
(U Account
|
||||
(Observe AccountRequest)
|
||||
(Observe (Observe AccountRequest))
|
||||
Deposit
|
||||
(Observe DepositRequest)
|
||||
(Observe (Observe DepositRequest))))
|
||||
|
||||
(define-type-alias account-manager-role
|
||||
(Role (account-manager)
|
||||
(Shares Account)
|
||||
(Reacts (Asserted Deposit))))
|
||||
|
||||
(define-type-alias client-role
|
||||
(Role (client)
|
||||
(Reacts (Asserted Account))))
|
||||
|
||||
|
||||
(run-ground-dataspace ds-type
|
||||
|
||||
(spawn ds-type
|
||||
(lift+define-role acct-mngr-role
|
||||
(start-facet account-manager
|
||||
(field [balance Int 0])
|
||||
(assert (account (ref balance)))
|
||||
(on (asserted (deposit (bind amount Int)))
|
||||
(set! balance (+ (ref balance) amount))))))
|
||||
|
||||
(spawn ds-type
|
||||
(lift+define-role obs-role
|
||||
(start-facet observer
|
||||
(on (asserted (account (bind amount Int)))
|
||||
(displayln amount)))))
|
||||
|
||||
(spawn ds-type
|
||||
(lift+define-role buyer-role
|
||||
(start-facet buyer
|
||||
(on (asserted (observe (deposit discard)))
|
||||
(start-facet deposits
|
||||
(assert (deposit 100))
|
||||
(assert (deposit -30))))))))
|
||||
|
||||
(module+ test
|
||||
(check-simulates acct-mngr-role account-manager-role)
|
||||
(check-simulates obs-role client-role)
|
||||
;; Tried to write this, then it failed, I looked and buyer doesn't actually implement that spec
|
||||
#;(check-simulates buyer-role client-role)
|
||||
)
|
|
@ -1,209 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
;; Expected Output
|
||||
;; leader learns that there are 5 copies of The Wind in the Willows
|
||||
;; tony responds to suggested book The Wind in the Willows: #f
|
||||
;; sam responds to suggested book The Wind in the Willows: #f
|
||||
;; leader finds enough negative nancys for The Wind in the Willows
|
||||
;; leader learns that there are 2 copies of Catch 22
|
||||
;; leader learns that there are 3 copies of Candide
|
||||
;; tony responds to suggested book Candide: #t
|
||||
;; sam responds to suggested book Candide: #t
|
||||
;; leader finds enough affirmation for Candide
|
||||
|
||||
(define-constructor (price v)
|
||||
#:type-constructor PriceT
|
||||
#:with Price (PriceT Int))
|
||||
|
||||
(define-constructor (book-quote title quantity)
|
||||
#:type-constructor BookQuoteT
|
||||
#:with BookQuote (BookQuoteT String Int))
|
||||
|
||||
(define-constructor (club-member name)
|
||||
#:type-constructor ClubMemberT
|
||||
#:with ClubMember (ClubMemberT String))
|
||||
|
||||
(define-constructor (book-interest title client id)
|
||||
#:type-constructor BookInterestT
|
||||
#:with BookInterest (BookInterestT String String Bool))
|
||||
|
||||
(define-constructor (book-of-the-month title)
|
||||
#:type-constructor BookOfTheMonthT
|
||||
#:with BookOfTheMonth (BookOfTheMonthT String))
|
||||
|
||||
(define-type-alias τc
|
||||
(U BookQuote
|
||||
(Observe (BookQuoteT String ★/t))
|
||||
(Observe (Observe (BookQuoteT ★/t ★/t)))
|
||||
ClubMember
|
||||
(Observe (ClubMemberT ★/t))
|
||||
BookInterest
|
||||
(Observe (BookInterestT String ★/t ★/t))
|
||||
(Observe (Observe (BookInterestT ★/t ★/t ★/t)))
|
||||
BookOfTheMonth
|
||||
(Observe (BookOfTheMonthT ★/t))))
|
||||
|
||||
(define-type-alias Inventory (List (Tuple String Int)))
|
||||
|
||||
(define (lookup [title : String]
|
||||
[inv : Inventory] -> Int)
|
||||
(for/fold ([stock 0])
|
||||
([item inv])
|
||||
(if (equal? title (select 0 item))
|
||||
(select 1 item)
|
||||
stock)))
|
||||
|
||||
(define-type-alias seller-role
|
||||
(Role (seller)
|
||||
(Reacts (Asserted (Observe (BookQuoteT String ★/t)))
|
||||
(Role (_)
|
||||
;; nb no mention of retracting this assertion
|
||||
(Shares (BookQuoteT String Int))))))
|
||||
(export-type "seller-role.rktd" seller-role)
|
||||
|
||||
(define (spawn-seller [inventory : Inventory])
|
||||
(spawn τc
|
||||
(export-roles "seller-impl.rktd"
|
||||
(lift+define-role seller-impl
|
||||
(start-facet seller
|
||||
(field [books Inventory inventory])
|
||||
|
||||
;; Give quotes to interested parties.
|
||||
(during (observe (book-quote $title _))
|
||||
;; TODO - lookup
|
||||
(assert (book-quote title (lookup title (ref books))))))))))
|
||||
|
||||
(define-type-alias leader-role
|
||||
(Role (leader)
|
||||
(Reacts (Asserted (BookQuoteT String Int))
|
||||
(Role (poll)
|
||||
(Reacts (Asserted (BookInterestT String String Bool))
|
||||
;; this is actually implemented indirectly through dataflow
|
||||
(Branch (Stop leader
|
||||
(Role (_)
|
||||
(Shares (BookOfTheMonthT String))))
|
||||
(Stop poll)))))))
|
||||
|
||||
(define-type-alias leader-actual
|
||||
(Role (get-quotes)
|
||||
(Reacts (Asserted (BookQuoteT String (Bind Int)))
|
||||
(Stop get-quotes)
|
||||
(Role (poll-members)
|
||||
(Reacts OnDataflow
|
||||
(Stop poll-members
|
||||
(Stop get-quotes))
|
||||
(Stop get-quotes
|
||||
(Role (announce39)
|
||||
(Shares (BookOfTheMonthT String)))))
|
||||
(Reacts (Retracted (BookInterestT String (Bind String) Bool)))
|
||||
(Reacts (Asserted (BookInterestT String (Bind String) Bool)))
|
||||
(Reacts (Retracted (BookInterestT String (Bind String) Bool)))
|
||||
(Reacts (Asserted (BookInterestT String (Bind String) Bool)))))
|
||||
(Reacts (Retracted (ClubMemberT (Bind String))))
|
||||
(Reacts (Asserted (ClubMemberT (Bind String))))))
|
||||
|
||||
(define (spawn-leader [titles : (List String)])
|
||||
(spawn τc
|
||||
(export-roles "leader-impl.rktd"
|
||||
(lift+define-role leader-impl
|
||||
(start-facet get-quotes
|
||||
(field [book-list (List String) (rest titles)]
|
||||
[title String (first titles)])
|
||||
(define (next-book)
|
||||
(cond
|
||||
[(empty? (ref book-list))
|
||||
(printf "leader fails to find a suitable book\n")
|
||||
(stop get-quotes)]
|
||||
[#t
|
||||
(set! title (first (ref book-list)))
|
||||
(set! book-list (rest (ref book-list)))]))
|
||||
|
||||
;; keep track of book club members
|
||||
(define/query-set members (club-member $name) name
|
||||
#;#:on-add #;(printf "leader acknowledges member ~a\n" name))
|
||||
|
||||
(on (asserted (book-quote (ref title) $quantity))
|
||||
(printf "leader learns that there are ~a copies of ~a\n" quantity (ref title))
|
||||
(cond
|
||||
[(< quantity (+ 1 (set-count (ref members))))
|
||||
;; not enough in stock for each member
|
||||
(next-book)]
|
||||
[#t
|
||||
;; find out if at least half of the members want to read the book
|
||||
(start-facet poll-members
|
||||
(define/query-set yays (book-interest (ref title) $name #t) name)
|
||||
(define/query-set nays (book-interest (ref title) $name #f) name)
|
||||
(on (asserted (book-interest (ref title) $name _))
|
||||
;; count the leader as a 'yay'
|
||||
(when (>= (set-count (ref yays))
|
||||
(/ (set-count (ref members)) 2))
|
||||
(printf "leader finds enough affirmation for ~a\n" (ref title))
|
||||
(stop get-quotes
|
||||
(start-facet announce
|
||||
(assert (book-of-the-month (ref title))))))
|
||||
(when (> (set-count (ref nays))
|
||||
(/ (set-count (ref members)) 2))
|
||||
(printf "leader finds enough negative nancys for ~a\n" (ref title))
|
||||
(stop poll-members (next-book))))
|
||||
;; begin/dataflow is a problem for simulation checking
|
||||
#;(begin/dataflow
|
||||
;; count the leader as a 'yay'
|
||||
(when (>= (set-count (ref yays))
|
||||
(/ (set-count (ref members)) 2))
|
||||
(printf "leader finds enough affirmation for ~a\n" (ref title))
|
||||
(stop get-quotes
|
||||
(start-facet announce
|
||||
(assert (book-of-the-month (ref title))))))
|
||||
(when (> (set-count (ref nays))
|
||||
(/ (set-count (ref members)) 2))
|
||||
(printf "leader finds enough negative nancys for ~a\n" (ref title))
|
||||
(stop poll-members (next-book)))))])))))))
|
||||
|
||||
(define-type-alias member-role
|
||||
(Role (member)
|
||||
(Shares (ClubMemberT String))
|
||||
;; should this be the type of the pattern? or lowered to concrete types?
|
||||
(Reacts (Asserted (Observe (BookInterestT String ★/t ★/t)))
|
||||
(Role (_)
|
||||
(Shares (BookInterestT String String Bool))))))
|
||||
|
||||
(define (spawn-club-member [name : String]
|
||||
[titles : (List String)])
|
||||
(spawn τc
|
||||
(export-roles "member-impl.rktd"
|
||||
(lift+define-role member-impl
|
||||
(start-facet member
|
||||
;; assert our presence
|
||||
(assert (club-member name))
|
||||
;; respond to polls
|
||||
(during (observe (book-interest $title _ _))
|
||||
(define answer (member? title titles))
|
||||
(printf "~a responds to suggested book ~a: ~a\n" name title answer)
|
||||
(assert (book-interest title name answer))))))))
|
||||
|
||||
(run-ground-dataspace τc
|
||||
(spawn-seller (list (tuple "The Wind in the Willows" 5)
|
||||
(tuple "Catch 22" 2)
|
||||
(tuple "Candide" 3)))
|
||||
(spawn-leader (list "The Wind in the Willows"
|
||||
"Catch 22"
|
||||
"Candide"
|
||||
"Encyclopaedia Brittannica"))
|
||||
(spawn-club-member "tony" (list "Candide"))
|
||||
(spawn-club-member "sam" (list "Encyclopaedia Brittannica" "Candide")))
|
||||
|
||||
(module+ test
|
||||
(verify-actors (And (Eventually (A BookQuote))
|
||||
(Always (Implies (A (Observe (BookQuoteT String ★/t)))
|
||||
(Eventually (A BookQuote))))
|
||||
(Always (Implies (A (Observe (BookInterestT String ★/t ★/t)))
|
||||
(Eventually (A BookInterest)))))
|
||||
leader-impl
|
||||
seller-impl
|
||||
member-impl))
|
||||
|
||||
(module+ test
|
||||
(check-simulates leader-impl leader-impl)
|
||||
(check-has-simulating-subgraph leader-impl leader-role)
|
||||
(check-simulates seller-impl seller-impl)
|
||||
(check-has-simulating-subgraph seller-impl seller-role))
|
|
@ -1,71 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
;; adapted from section 8.3 of Tony's dissertation
|
||||
|
||||
(define-constructor* (cell : CellT id value))
|
||||
(define-constructor* (create-cell : CreateCellT id value))
|
||||
(define-constructor* (update-cell : UpdateCellT id value))
|
||||
(define-constructor* (delete-cell : DeleteCellT id))
|
||||
|
||||
(define-type-alias ID Int)
|
||||
(define-type-alias Value String)
|
||||
|
||||
(define-type-alias Cell
|
||||
(Role (cell)
|
||||
(Shares (CellT ID Value))
|
||||
(Reacts (Message (UpdateCellT ID ★/t))
|
||||
)
|
||||
(Reacts (Message (DeleteCellT ID))
|
||||
(Stop cell))))
|
||||
|
||||
(define-type-alias CellFactory
|
||||
(Role (cell-factory)
|
||||
(Reacts (Message (CreateCellT ID Value))
|
||||
;; want to say that what it spawns is a Cell
|
||||
(Spawns ★/t))))
|
||||
|
||||
(define-type-alias Reader
|
||||
(Role (reader)
|
||||
(Shares (Observe (CellT ID ★/t)))))
|
||||
|
||||
(define-type-alias Writer
|
||||
(Role (writer)
|
||||
;; sends update and delete messages
|
||||
))
|
||||
|
||||
(define-type-alias ds-type
|
||||
(U (CellT ID Value)
|
||||
(Observe (CellT ID ★/t))
|
||||
(Message (CreateCellT ID Value))
|
||||
(Message (UpdateCellT ID Value))
|
||||
(Message (DeleteCellT ID))
|
||||
(Observe (CreateCellT ★/t ★/t))
|
||||
(Observe (UpdateCellT ID ★/t))
|
||||
(Observe (DeleteCellT ID))))
|
||||
|
||||
(define (spawn-cell! [initial-value : Value])
|
||||
(define id 1234)
|
||||
(send! (create-cell id initial-value))
|
||||
id)
|
||||
|
||||
(define (spawn-cell-factory)
|
||||
(spawn ds-type
|
||||
(start-facet cell-factory
|
||||
(on (message (create-cell (bind id ID) (bind init Value)))
|
||||
(spawn ds-type
|
||||
(start-facet the-cell
|
||||
(field [value Value init])
|
||||
(assert (cell id (ref value)))
|
||||
(on (message (update-cell id (bind new-value Value)))
|
||||
(set! value new-value))
|
||||
(on (message (delete-cell id))
|
||||
(stop the-cell))))))))
|
||||
|
||||
|
||||
(define (spawn-cell-monitor [id : ID])
|
||||
(spawn ds-type
|
||||
(start-facet monitor
|
||||
(on (asserted (cell id (bind value Value)))
|
||||
(printf "Cell ~a updated to: ~a\n" id value))
|
||||
(on (retracted (cell id discard))
|
||||
(printf "Cell ~a deleted\n" id)))))
|
|
@ -1,41 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
(require typed/syndicate/drivers/tcp)
|
||||
|
||||
;; message
|
||||
(define-constructor (speak who what)
|
||||
#:type-constructor SpeakT
|
||||
#:with Speak (SpeakT Symbol String))
|
||||
|
||||
(define-constructor (present who)
|
||||
#:type-constructor PresentT
|
||||
#:with Present (PresentT Symbol))
|
||||
|
||||
(define-type-alias chat-comm
|
||||
(U Present
|
||||
(Message Speak)
|
||||
(Observe (PresentT ★/t))
|
||||
(Observe (SpeakT Symbol ★/t))))
|
||||
|
||||
(define-type-alias chat-ds
|
||||
(U chat-comm
|
||||
Tcp2Driver))
|
||||
|
||||
(run-ground-dataspace chat-ds
|
||||
(activate!)
|
||||
|
||||
(spawn chat-ds
|
||||
(start-facet chat-server
|
||||
(during/spawn (tcp-connection (bind id Symbol) (tcp-listener 5999))
|
||||
(assert (tcp-accepted id))
|
||||
(let ([me (gensym 'user)])
|
||||
(assert (present me))
|
||||
(on (message (tcp-in-line id (bind bs ByteString)))
|
||||
(send! (speak me (bytes->string/utf-8 bs))))
|
||||
(during (present (bind user Symbol))
|
||||
(on start
|
||||
(send! (tcp-out id (string->bytes/utf-8 (~a user " arrived\n")))))
|
||||
(on stop
|
||||
(send! (tcp-out id (string->bytes/utf-8 (~a user " left\n")))))
|
||||
(on (message (speak user (bind text String)))
|
||||
(send! (tcp-out id (string->bytes/utf-8 (~a user " says '" text "'\n")))))))))))
|
|
@ -1,63 +0,0 @@
|
|||
#lang typed/syndicate/core
|
||||
|
||||
(define-constructor (account balance)
|
||||
#:type-constructor AccountT
|
||||
#:with Account (AccountT Int))
|
||||
|
||||
(define-constructor (transaction id amount)
|
||||
#:type-constructor TransactionT
|
||||
#:with Transaction (TransactionT Int Int))
|
||||
|
||||
(define-type-alias τc
|
||||
(U Account
|
||||
Transaction
|
||||
(Observe (AccountT ★/t))
|
||||
(Observe (TransactionT ★/t ★/t))))
|
||||
|
||||
(define account-manager
|
||||
(actor τc
|
||||
(lambda ([e : (Event τc)]
|
||||
[b : Int])
|
||||
(let ([new-balance
|
||||
(for/fold [balance b]
|
||||
[txn (project [(transaction discard (bind v Int)) (patch-added e)] v)]
|
||||
(+ balance txn))])
|
||||
(transition new-balance
|
||||
(list (patch (make-assertion-set (account new-balance))
|
||||
(make-assertion-set (account ★)))))))
|
||||
0
|
||||
(make-assertion-set (account 0)
|
||||
(observe (transaction ★ ★)))))
|
||||
|
||||
(define (make-transaction [id : Int] [amount : Int] → (Actor Transaction))
|
||||
(actor Transaction
|
||||
(lambda ([e : (Event (U))]
|
||||
[s : ★/t])
|
||||
idle)
|
||||
#f
|
||||
(make-assertion-set (transaction id amount))))
|
||||
|
||||
(define client
|
||||
(actor τc
|
||||
(lambda ([e : (Event τc)]
|
||||
[s : ★/t])
|
||||
(quit (list (make-transaction 0 100)
|
||||
(make-transaction 1 -70))))
|
||||
#f
|
||||
(make-assertion-set (observe (account ★)))))
|
||||
|
||||
(define observer
|
||||
(actor τc
|
||||
(lambda ([e : (Event τc)]
|
||||
[s : ★/t])
|
||||
(project [(account (bind value Int)) (patch-added e)]
|
||||
(displayln value))
|
||||
idle)
|
||||
#f
|
||||
(make-assertion-set (observe (account ★)))))
|
||||
|
||||
(dataspace τc
|
||||
(list
|
||||
account-manager
|
||||
observer
|
||||
client))
|
|
@ -1,223 +0,0 @@
|
|||
#lang typed/syndicate/core
|
||||
|
||||
(define-constructor (in-stock title quantity)
|
||||
#:type-constructor InStock)
|
||||
|
||||
(define-constructor (order title client id)
|
||||
#:type-constructor Order)
|
||||
|
||||
(define-constructor (club-member name)
|
||||
#:type-constructor ClubMember)
|
||||
|
||||
(define-constructor (book-interest title name answer)
|
||||
#:type-constructor BookInterest)
|
||||
|
||||
(define-constructor (book-of-the-month title)
|
||||
#:type-constructor BookOfTheMonth)
|
||||
|
||||
(define-type-alias τc
|
||||
(U (ClubMember String)
|
||||
(Observe (ClubMember ★/t))
|
||||
(BookInterest String String Bool)
|
||||
(Observe (BookInterest String ★/t ★/t))
|
||||
(Observe (Observe (BookInterest ★/t ★/t ★/t)))
|
||||
(InStock String Int)
|
||||
(Observe (InStock String ★/t))
|
||||
(Observe (Observe (InStock ★/t ★/t)))
|
||||
(BookOfTheMonth String)
|
||||
(Observe (BookOfTheMonth ★/t))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Leader
|
||||
|
||||
(define-type-alias LeaderState
|
||||
(Tuple String (List String) (Set String) String (Set String) (Set String)))
|
||||
|
||||
(define (leader-state-current-title [ls : LeaderState] -> String)
|
||||
(select 0 ls))
|
||||
|
||||
(define (leader-state-interests [ls : LeaderState] -> (List String))
|
||||
(select 1 ls))
|
||||
|
||||
(define (leader-state-members [ls : LeaderState] -> (Set String))
|
||||
(select 2 ls))
|
||||
|
||||
(define (leader-state-conv [ls : LeaderState] -> String)
|
||||
(select 3 ls))
|
||||
|
||||
(define (leader-state-yays [ls : LeaderState] -> (Set String))
|
||||
(select 4 ls))
|
||||
|
||||
(define (leader-state-nays [ls : LeaderState] -> (Set String))
|
||||
(select 5 ls))
|
||||
|
||||
(define (leader-state [current-title : String]
|
||||
[interests : (List String)]
|
||||
[members : (Set String)]
|
||||
[conv : String]
|
||||
[yays : (Set String)]
|
||||
[nays : (Set String)]
|
||||
-> LeaderState)
|
||||
(tuple current-title interests members conv yays nays))
|
||||
|
||||
(define (update-members [members : (Set String)]
|
||||
[added : (AssertionSet τc)]
|
||||
[retracted : (AssertionSet τc)]
|
||||
-> (Set String))
|
||||
(let ([as (project [(club-member (bind name String)) added] name)]
|
||||
[rs (project [(club-member (bind name String)) retracted] name)])
|
||||
(set-subtract (set-union members (list->set as)) (list->set rs))))
|
||||
|
||||
(define (next-book [books : (List String)]
|
||||
[members : (Set String)]
|
||||
-> (Instruction LeaderState τc τc))
|
||||
(if (empty? books)
|
||||
(begin (displayln "leader fails to find a suitable book")
|
||||
(quit))
|
||||
(let ([next (first books)]
|
||||
[remaining (rest books)])
|
||||
(transition (leader-state next remaining members "quote" (set) (set))
|
||||
(list (patch-seq (unsub (in-stock ★ ★))
|
||||
(unsub (book-interest ★ ★ ★))
|
||||
(sub (in-stock next ★))))))))
|
||||
|
||||
(define (leader-learns [quantity : Int]
|
||||
[title : String]
|
||||
-> (Tuple))
|
||||
(displayln "leader learns that there are")
|
||||
(displayln quantity)
|
||||
(displayln "copies of")
|
||||
(displayln title)
|
||||
(tuple))
|
||||
|
||||
(define (respond-to-quotes [added : (AssertionSet τc)]
|
||||
[title : String]
|
||||
[interests : (List String)]
|
||||
[members : (Set String)]
|
||||
[changed? Bool]
|
||||
-> (Instruction LeaderState τc τc))
|
||||
(let ([answers (project [(in-stock title (bind n Int)) added] n)])
|
||||
(if (empty? answers)
|
||||
(if changed?
|
||||
(transition (leader-state title interests members "quote" (set) (set)) (list))
|
||||
idle)
|
||||
(let ([quantity (first answers)])
|
||||
(leader-learns quantity title)
|
||||
(if (<= quantity (set-count members))
|
||||
(begin (displayln "there aren't enough copies to go around")
|
||||
(next-book interests members))
|
||||
(transition (leader-state title interests members "poll" (set) (set))
|
||||
(list (sub (book-interest title ★ ★)))))))))
|
||||
|
||||
(define (respond-to-interests [added : (AssertionSet τc)]
|
||||
[title : String]
|
||||
[books : (List String)]
|
||||
[members : (Set String)]
|
||||
[yays : (Set String)]
|
||||
[nays : (Set String)]
|
||||
-> (Instruction LeaderState τc τc))
|
||||
(let ([yups (set-union yays (list->set (project [(book-interest title (bind name String) #t) added]
|
||||
name)))]
|
||||
[nups (set-union nays (list->set (project [(book-interest title (bind name String) #f) added]
|
||||
name)))])
|
||||
(if (>= (set-count yups) (/ (set-count members) 2))
|
||||
(begin (displayln "leader finds enough affirmation for") (displayln title)
|
||||
(transition (leader-state title books members "complete" yays nays)
|
||||
(list (patch-seq (assert (book-of-the-month title))
|
||||
(unsub (book-interest ★ ★ ★))))))
|
||||
(if (> (set-count nups) (/ (set-count members) 2))
|
||||
(begin (displayln "leader finds enough negative nancys for") (displayln title)
|
||||
(next-book books members))
|
||||
(transition (leader-state title books members "poll" yups nups) (list))))))
|
||||
|
||||
(define (leader-behavior [e : (Event τc)]
|
||||
[s : LeaderState]
|
||||
-> (Instruction LeaderState τc τc))
|
||||
(let* ([added (patch-added e)]
|
||||
[retracted (patch-removed e)]
|
||||
[title (leader-state-current-title s)]
|
||||
[books (leader-state-interests s)]
|
||||
[members (leader-state-members s)]
|
||||
[state (leader-state-conv s)]
|
||||
[yays (leader-state-yays s)]
|
||||
[nays (leader-state-nays s)]
|
||||
[new-members (update-members members added retracted)]
|
||||
[changed? (not (equal? new-members members))])
|
||||
(if changed?
|
||||
(begin (displayln "leader knows about") (displayln new-members) #f)
|
||||
#f)
|
||||
(if (equal? state "quote")
|
||||
(respond-to-quotes added title books new-members changed?)
|
||||
(if (equal? state "poll")
|
||||
(respond-to-interests added title books new-members yays nays)
|
||||
idle))))
|
||||
|
||||
(define (make-leader [interests : (List String)] -> (Actor τc))
|
||||
(let ([first-book (first interests)]
|
||||
[books (rest interests)])
|
||||
(actor τc
|
||||
leader-behavior
|
||||
(leader-state first-book books (set) "quote" (set) (set))
|
||||
(make-assertion-set (observe (in-stock first-book ★))
|
||||
(observe (club-member ★))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Seller
|
||||
|
||||
(define-type-alias Inventory (List (Tuple String Int)))
|
||||
|
||||
(define (lookup/default [title : String]
|
||||
[inv : Inventory]
|
||||
[default : Int]
|
||||
-> Int)
|
||||
(for/fold [answer default]
|
||||
[item inv]
|
||||
(if (equal? title (select 0 item))
|
||||
(select 1 item)
|
||||
answer)))
|
||||
|
||||
(define (answer-inquiries [e : (AssertionSet τc)]
|
||||
[inventory : Inventory]
|
||||
-> (Patch (InStock String Int) (U)))
|
||||
(patch-seq*
|
||||
(project [(observe (in-stock (bind title String) discard)) e]
|
||||
(assert (in-stock title (lookup/default title inventory 0))))))
|
||||
|
||||
(define (make-book-seller [initial-inventory : Inventory] -> (Actor τc))
|
||||
(actor τc
|
||||
(lambda ([e : (Event τc)]
|
||||
[inv : Inventory])
|
||||
(transition inv (list (answer-inquiries (patch-added e) inv))))
|
||||
initial-inventory
|
||||
(make-assertion-set (observe (observe (in-stock ★ ★))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Members
|
||||
|
||||
(define (make-club-member [name : String] [preferences : (List String)] -> (Actor τc))
|
||||
(actor τc
|
||||
(lambda ([e : (Event τc)]
|
||||
[s : ★/t])
|
||||
(let ([answers
|
||||
(project [(observe (book-interest (bind title String) discard discard)) (patch-added e)]
|
||||
(patch (make-assertion-set (book-interest title name (member? title preferences)))
|
||||
(make-assertion-set)))])
|
||||
(transition s answers)))
|
||||
#f
|
||||
(make-assertion-set (club-member name)
|
||||
(observe (observe (book-interest ★ ★ ★))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Main
|
||||
|
||||
(dataspace τc
|
||||
(list
|
||||
(make-book-seller (list (tuple "The Wind in the Willows" 5)
|
||||
(tuple "Catch 22" 2)
|
||||
(tuple "Candide" 3)))
|
||||
(make-leader (list "The Wind in the Willows"
|
||||
"Catch 22"
|
||||
"Candide"
|
||||
"Encyclopaedia Brittannica"))
|
||||
(make-club-member "tony" (list "Candide"))
|
||||
(make-club-member "sam" (list "Encyclopaedia Brittannica" "Candide"))))
|
|
@ -1,45 +0,0 @@
|
|||
#lang typed/syndicate/core
|
||||
|
||||
(define-constructor (set-box new-value)
|
||||
#:type-constructor SetBoxT
|
||||
#:with SetBox (SetBoxT Int))
|
||||
|
||||
(define-constructor (box-state value)
|
||||
#:type-constructor BoxStateT
|
||||
#:with BoxState (BoxStateT Int))
|
||||
|
||||
(define-type-alias τ-c
|
||||
(U BoxState
|
||||
(Observe (BoxStateT ★/t))
|
||||
SetBox
|
||||
(Observe (SetBoxT ★/t))))
|
||||
|
||||
(dataspace τ-c
|
||||
(list
|
||||
(actor τ-c
|
||||
(lambda ([e : (Event τ-c)]
|
||||
[current-value : Int])
|
||||
(let ([sets (project [(set-box (bind v Int)) (patch-added e)] v)])
|
||||
(if (empty? sets)
|
||||
idle
|
||||
(let ([new-value (first sets)])
|
||||
(displayln new-value)
|
||||
(transition new-value (list (patch (make-assertion-set (box-state new-value))
|
||||
(make-assertion-set (box-state current-value)))))))))
|
||||
0
|
||||
(make-assertion-set (box-state 0)
|
||||
(observe (set-box ★))))
|
||||
|
||||
(actor τ-c
|
||||
(lambda ([e : (Event τ-c)]
|
||||
[s : (Tuple)])
|
||||
(let ([updates (project [(box-state (bind v Int)) (patch-added e)] v)])
|
||||
(if (empty? updates)
|
||||
idle
|
||||
(let ([new-value (first updates)])
|
||||
(if (> new-value 9)
|
||||
(quit)
|
||||
(transition s (list (patch (make-assertion-set (set-box (+ new-value 1)))
|
||||
(make-assertion-set (set-box ★))))))))))
|
||||
(tuple)
|
||||
(make-assertion-set (observe (box-state ★))))))
|
|
@ -1,34 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
(define-constructor (file name content)
|
||||
#:type-constructor FileT
|
||||
#:with File (FileT String String))
|
||||
|
||||
(define-type-alias FileDemand
|
||||
(Observe (FileT String ★/t)))
|
||||
|
||||
(define-constructor (save name content)
|
||||
#:type-constructor SaveT
|
||||
#:with Save (SaveT String String))
|
||||
|
||||
(define-constructor (delete name)
|
||||
#:type-constructor DeleteT
|
||||
#:with Delete (DeleteT String))
|
||||
|
||||
;; unique role
|
||||
(define-type-alias Server
|
||||
(Role (server)
|
||||
(Reacts (Know FileDemand)
|
||||
(Role (_)
|
||||
(Shares File)))
|
||||
(Reacts (Message Save))
|
||||
(Reacts (Message Delete))))
|
||||
|
||||
(define-type-alias Reader
|
||||
(Role (reader)
|
||||
(Shares FileDemand)))
|
||||
|
||||
(define-type-alias Writer
|
||||
(Role (writer)
|
||||
(Sends Save)
|
||||
(Sends Delete)))
|
|
@ -1,132 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
(provide string->words
|
||||
split-at/lenient-
|
||||
(struct-out job)
|
||||
(struct-out task)
|
||||
(struct-out map-work)
|
||||
(struct-out reduce-work)
|
||||
string->job
|
||||
file->job)
|
||||
|
||||
(require (only-in racket/list
|
||||
split-at))
|
||||
(module+ test
|
||||
(require rackunit))
|
||||
|
||||
(define (string->words s)
|
||||
(map (lambda (w) (string-trim w #px"\\p{P}")) (string-split s)))
|
||||
|
||||
(module+ test
|
||||
(check-equal? (string->words "good day sir")
|
||||
(list "good" "day" "sir"))
|
||||
(check-equal? (string->words "")
|
||||
(list))
|
||||
(check-equal? (string->words "good eve ma'am")
|
||||
(list "good" "eve" "ma'am"))
|
||||
(check-equal? (string->words "please sir. may I have another?")
|
||||
(list "please" "sir" "may" "I" "have" "another"))
|
||||
;; TODO - currently fails
|
||||
#;(check-equal? (string->words "but wait---there's more")
|
||||
(list "but" "wait" "there's" "more")))
|
||||
|
||||
;; (Listof A) Nat -> (List (Listof A) (Listof A))
|
||||
;; like split-at but allow a number larger than the length of the list
|
||||
(define (split-at/lenient- lst n)
|
||||
(define-values (a b)
|
||||
(split-at lst (min n (length lst))))
|
||||
(list a b))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
;; Creating a Job
|
||||
|
||||
(struct job (id tasks) #:transparent)
|
||||
(struct task (id desc) #:transparent)
|
||||
(struct map-work (data) #:transparent)
|
||||
(struct reduce-work (left right) #:transparent)
|
||||
|
||||
;; (Listof WorkDesc) -> (Values (Listof WorkDesc) (Optionof WorkDesc))
|
||||
;; Pair up elements of the input list into a list of reduce tasks, and if the input list is odd also
|
||||
;; return the odd-one out.
|
||||
;; Conceptually, it does something like this:
|
||||
;; '(a b c d) => '((a b) (c d))
|
||||
;; '(a b c d e) => '((a b) (c d) e)
|
||||
(define (pair-up ls)
|
||||
(let loop ([ls ls]
|
||||
[reductions '()])
|
||||
(match ls
|
||||
['()
|
||||
(values reductions #f)]
|
||||
[(list x)
|
||||
(values reductions x)]
|
||||
[(list-rest x y more)
|
||||
(loop more (cons (reduce-work x y) reductions))])))
|
||||
|
||||
|
||||
;; a TaskTree is one of
|
||||
;; (map-work data)
|
||||
;; (reduce-work TaskTree TaskTree)
|
||||
|
||||
;; (Listof String) -> TaskTree
|
||||
;; Create a tree structure of tasks
|
||||
(define (create-task-tree lines)
|
||||
(define map-works
|
||||
(for/list ([line (in-list lines)])
|
||||
(map-work line)))
|
||||
;; build the tree up from the leaves
|
||||
(let loop ([nodes map-works])
|
||||
(match nodes
|
||||
['()
|
||||
;; input was empty
|
||||
(map-work "")]
|
||||
[(list x)
|
||||
x]
|
||||
[_
|
||||
(define-values (reductions left-over?)
|
||||
(pair-up nodes))
|
||||
(loop (if left-over?
|
||||
(cons left-over? reductions)
|
||||
reductions))])))
|
||||
|
||||
;; TaskTree ID -> (Listof Task)
|
||||
;; flatten a task tree by assigning job-unique IDs
|
||||
(define (task-tree->list tt job-id)
|
||||
(define-values (tasks _)
|
||||
;; TaskTree ID -> (Values (Listof Task) ID)
|
||||
;; the input id is for the current node of the tree
|
||||
;; returned id is the "next available" id, given ids are assigned in strict ascending order
|
||||
(let loop ([tt tt]
|
||||
[next-id 0])
|
||||
(match tt
|
||||
[(map-work _)
|
||||
;; NOTE : utilizing knowledge of Tuple representation here
|
||||
(values (list (task (list 'tuple next-id job-id) tt))
|
||||
(add1 next-id))]
|
||||
[(reduce-work left right)
|
||||
(define left-id (add1 next-id))
|
||||
(define-values (lefts right-id)
|
||||
(loop left left-id))
|
||||
(define-values (rights next)
|
||||
(loop right right-id))
|
||||
(values (cons (task (list 'tuple next-id job-id) (reduce-work left-id right-id))
|
||||
(append lefts rights))
|
||||
next)])))
|
||||
tasks)
|
||||
|
||||
;; InputPort -> Job
|
||||
(define (create-job in)
|
||||
(define job-id (gensym 'job))
|
||||
(define input-lines (sequence->list (in-lines in)))
|
||||
(define tasks (task-tree->list (create-task-tree input-lines) job-id))
|
||||
(job job-id tasks))
|
||||
|
||||
;; String -> Job
|
||||
(define (string->job s)
|
||||
(create-job (open-input-string s)))
|
||||
|
||||
;; PathString -> Job
|
||||
(define (file->job path)
|
||||
(define in (open-input-file path))
|
||||
(define j (create-job in))
|
||||
(close-input-port in)
|
||||
j)
|
|
@ -1,576 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
;; Protocol
|
||||
|
||||
|
||||
#|
|
||||
Conversations in the flink dataspace primarily concern two topics: presence and
|
||||
task execution.
|
||||
|
||||
Presence Protocol
|
||||
-----------------
|
||||
|
||||
The JobManager (JM) asserts its presence with (job-manager-alive). The operation
|
||||
of each TaskManager (TM) is contingent on the presence of a job manager.
|
||||
|#
|
||||
(assertion-struct job-manager-alive : JobManagerAlive ())
|
||||
#|
|
||||
In turn, TaskManagers advertise their presence with (task-manager ID slots),
|
||||
where ID is a unique id, and slots is a natural number. The number of slots
|
||||
dictates how many tasks the TM can take on. To reduce contention, the JM
|
||||
should only assign a task to a TM if the TM actually has the resources to
|
||||
perform a task.
|
||||
|#
|
||||
(assertion-struct task-manager : TaskManager (id slots))
|
||||
;; an ID is a symbol
|
||||
(define-type-alias ID Symbol)
|
||||
#|
|
||||
The resources available to a TM are its associated TaskRunners (TRs). TaskRunners
|
||||
assert their presence with (task-runner ID),
|
||||
|#
|
||||
(assertion-struct task-runner : TaskRunner (id))
|
||||
|
||||
#|
|
||||
A Status is one of
|
||||
- IDLE, when the TR is not executing a task
|
||||
- (executing Int), when the TR is executing the task with identified by the Int
|
||||
- OVERLOAD, when the TR has been asked to perform a task before it has
|
||||
finished its previous assignment. For the purposes of this model, it indicates a
|
||||
failure in the protocol; like the exchange between the JM and the TM, a TR
|
||||
should only receive tasks when it is IDLE.
|
||||
|#
|
||||
(define-constructor* (executing : Executing id))
|
||||
(define-type-alias Status (U Symbol (Executing Int)))
|
||||
(define IDLE : Status 'idle)
|
||||
(define OVERLOAD : Status 'overload)
|
||||
|
||||
#|
|
||||
Task Delegation Protocol
|
||||
-----------------------
|
||||
|
||||
Task Delegation has two roles, TaskAssigner (TA) and TaskPerformer (TP).
|
||||
|
||||
A TaskAssigner requests the performance of a Task with a particular TaskPerformer
|
||||
through the assertion of interest
|
||||
(observe (task-performance ID Task ★))
|
||||
where the ID identifies the TP
|
||||
|#
|
||||
(assertion-struct task-performance : TaskPerformance (assignee task desc))
|
||||
#|
|
||||
A Task is a (task TaskID Work), where Work is one of
|
||||
- (map-work String)
|
||||
- (reduce-work (U Int TaskResult) (U Int TaskResult)), referring to either the
|
||||
ID of the dependent task or its results. A reduce-work is ready to be executed
|
||||
when it has both results.
|
||||
|
||||
A TaskID is a (Tuple Int ID), where the first Int is specific to the individual
|
||||
task and the second identifies the job it belongs to.
|
||||
|
||||
A TaskResult is a (Hashof String Natural), counting the occurrences of words
|
||||
|#
|
||||
(require-struct task #:as Task #:from "flink-support.rkt")
|
||||
(require-struct map-work #:as MapWork #:from "flink-support.rkt")
|
||||
(require-struct reduce-work #:as ReduceWork #:from "flink-support.rkt")
|
||||
(define-type-alias TaskID (Tuple Int ID))
|
||||
(define-type-alias WordCount (Hash String Int))
|
||||
(define-type-alias TaskResult WordCount)
|
||||
(define-type-alias Reduce
|
||||
(ReduceWork (Either Int TaskResult)
|
||||
(Either Int TaskResult)))
|
||||
(define-type-alias ReduceInput
|
||||
(ReduceWork Int Int))
|
||||
(define-type-alias Work
|
||||
(U Reduce (MapWork String)))
|
||||
(define-type-alias ConcreteWork
|
||||
(U (ReduceWork TaskResult TaskResult)
|
||||
(MapWork String)))
|
||||
(define-type-alias InputTask
|
||||
(Task TaskID (U ReduceInput (MapWork String))))
|
||||
(define-type-alias PendingTask
|
||||
(Task TaskID Work))
|
||||
(define-type-alias ConcreteTask
|
||||
(Task TaskID ConcreteWork))
|
||||
#|
|
||||
The TaskPerformer responds to a request by describing its state with respect
|
||||
to that task,
|
||||
(task-performance ID Task TaskStateDesc)
|
||||
|
||||
A TaskStateDesc is one of
|
||||
- ACCEPTED, when the TP has the resources to perform the task. (TODO - not sure if this is ever visible, currently)
|
||||
- OVERLOAD/ts, when the TP does not have the resources to perform the task.
|
||||
- RUNNING, indicating that the task is being performed
|
||||
- (finished TaskResult), describing the results
|
||||
|#
|
||||
(define-constructor* (finished : Finished data))
|
||||
(define-type-alias TaskStateDesc
|
||||
(U Symbol (Finished TaskResult)))
|
||||
(define ACCEPTED : TaskStateDesc 'accepted)
|
||||
(define RUNNING : TaskStateDesc 'running)
|
||||
;; this is gross, it's needed in part because equal? requires two of args of the same type
|
||||
(define OVERLOAD/ts : TaskStateDesc 'overload)
|
||||
#|
|
||||
Two instances of the Task Delegation Protocol take place: one between the
|
||||
JobManager and the TaskManager, and one between the TaskManager and its
|
||||
TaskRunners.
|
||||
|#
|
||||
|
||||
;; I think this is wrong by explicitly requiring that the facet stop in response
|
||||
(define-type-alias TaskAssigner-v1
|
||||
(Role (assign)
|
||||
(Shares (Observe (TaskPerformance ID ConcreteTask ★/t)))
|
||||
;; would be nice to say how the TaskIDs relate to each other
|
||||
(Reacts (Asserted (TaskPerformance ID ConcreteTask ★/t))
|
||||
(Branch (Stop assign)
|
||||
(Effs)))))
|
||||
|
||||
(define-type-alias TaskAssigner
|
||||
(Role (assign)
|
||||
;; would be nice to say how the TaskIDs relate to each other
|
||||
(Reacts (Asserted (TaskPerformance ID ConcreteTask TaskStateDesc))
|
||||
)))
|
||||
|
||||
(export-type "task-assigner.rktd" TaskAssigner)
|
||||
|
||||
(define-type-alias TaskPerformer
|
||||
(Role (listen)
|
||||
(During (Observe (TaskPerformance ID ConcreteTask ★/t))
|
||||
;; would be nice to say how the IDs and TaskIDs relate to each other
|
||||
;; BUG in spec; ConcreteTask used to be just TaskID (when I streamlined protocol)
|
||||
(Shares (TaskPerformance ID ConcreteTask TaskStateDesc)))))
|
||||
|
||||
#|
|
||||
Job Submission Protocol
|
||||
-----------------------
|
||||
|
||||
Finally, Clients submit their jobs to the JobManager by asserting interest
|
||||
(observe (job-completion ID (Listof Task) ★))
|
||||
|
||||
The JobManager then performs the job and, when finished, asserts
|
||||
(job-completion ID (Listof Task) TaskResult)
|
||||
|
||||
|#
|
||||
(require-struct job #:as Job #:from "flink-support.rkt")
|
||||
(assertion-struct job-completion : JobCompletion (id data result))
|
||||
(define-type-alias JobDesc (Job ID (List InputTask)))
|
||||
|
||||
(define-type-alias τc
|
||||
(U (TaskRunner ID)
|
||||
(Observe (TaskPerformance ID ConcreteTask ★/t))
|
||||
(TaskPerformance ID ConcreteTask TaskStateDesc)
|
||||
(Observe (Observe (TaskPerformance ID ★/t ★/t)))
|
||||
(JobManagerAlive)
|
||||
(Observe (JobManagerAlive))
|
||||
(Observe (TaskRunner ★/t))
|
||||
(TaskManager ID Int)
|
||||
(Observe (TaskManager ★/t ★/t))
|
||||
(JobCompletion ID (List InputTask) TaskResult)
|
||||
(Observe (JobCompletion ID (List InputTask) ★/t))
|
||||
(Observe (Observe (JobCompletion ★/t ★/t ★/t)))))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
;; Util Macros
|
||||
|
||||
(require syntax/parse/define)
|
||||
|
||||
(define-simple-macro (log fmt . args)
|
||||
(begin
|
||||
(printf fmt . args)
|
||||
(printf "\n")))
|
||||
|
||||
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
;; TaskRunner
|
||||
|
||||
|
||||
(define (word-count-increment [h : WordCount]
|
||||
[word : String]
|
||||
-> WordCount)
|
||||
(hash-update/failure h
|
||||
word
|
||||
add1
|
||||
0))
|
||||
|
||||
(define (count-new-words [word-count : WordCount]
|
||||
[words : (List String)]
|
||||
-> WordCount)
|
||||
(for/fold ([result word-count])
|
||||
([word words])
|
||||
(word-count-increment result word)))
|
||||
|
||||
(require/typed "flink-support.rkt"
|
||||
[string->words : (→fn String (List String))])
|
||||
|
||||
(define (spawn-task-runner [id : ID] [tm-id : ID])
|
||||
(spawn τc
|
||||
(export-roles "task-runner-impl.rktd"
|
||||
(lift+define-role task-runner-impl
|
||||
(start-facet runner ;; #:includes-behavior TaskPerformer
|
||||
(assert (task-runner id))
|
||||
(on (retracted (task-manager tm-id _))
|
||||
(stop runner))
|
||||
(during (observe (task-performance id $t _))
|
||||
(match-define (task $task-id $desc) t)
|
||||
(field [state TaskStateDesc ACCEPTED])
|
||||
(assert (task-performance id t (ref state)))
|
||||
;; since we currently finish everything in one turn, these changes to status aren't
|
||||
;; actually visible.
|
||||
(set! state RUNNING)
|
||||
(match desc
|
||||
[(map-work $data)
|
||||
(define wc (count-new-words (ann (hash) WordCount) (string->words data)))
|
||||
(set! state (finished wc))]
|
||||
[(reduce-work $left $right)
|
||||
(define wc (hash-union/combine left right +))
|
||||
(set! state (finished wc))])))))))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
;; TaskManager
|
||||
|
||||
|
||||
(define (spawn-task-manager [num-task-runners : Int])
|
||||
(define id (gensym 'task-manager))
|
||||
(spawn τc
|
||||
(export-roles "task-manager-impl.rktd"
|
||||
(#;begin lift+define-role task-manager-impl
|
||||
(start-facet tm ;; #:includes-behavior TaskAssigner
|
||||
(log "Task Manager (TM) ~a is running" id)
|
||||
(during (job-manager-alive)
|
||||
(log "TM ~a learns about JM" id)
|
||||
|
||||
(field [task-runners (Set ID) (set)])
|
||||
|
||||
(on start
|
||||
(for ([_ (in-range num-task-runners)])
|
||||
(define tr-id (gensym 'task-runner))
|
||||
(start-facet monitor-task-runner
|
||||
(on start (spawn-task-runner tr-id id))
|
||||
(on (asserted (task-runner tr-id))
|
||||
(log "TM ~a successfully created task-runner ~a" id tr-id)
|
||||
(set! task-runners (set-add (ref task-runners) tr-id)))
|
||||
(on (retracted (task-runner tr-id))
|
||||
(log "TM ~a detected failure of task runner ~a, restarting" id tr-id)
|
||||
(set! task-runners (set-remove (ref task-runners) tr-id))
|
||||
(spawn-task-runner tr-id id)))))
|
||||
|
||||
|
||||
(field [busy-runners (Set ID) (set)])
|
||||
|
||||
(define/dataflow idle-runners
|
||||
(set-count (set-subtract (ref task-runners) (ref busy-runners))))
|
||||
|
||||
(assert (task-manager id (ref idle-runners)))
|
||||
|
||||
(define (can-accept?)
|
||||
(positive? (ref idle-runners)))
|
||||
|
||||
(define (select-runner)
|
||||
(define runner (for/first ([r (in-set (ref task-runners))]
|
||||
#:unless (set-member? (ref busy-runners) r))
|
||||
r))
|
||||
(match runner
|
||||
[(some $r)
|
||||
(set! busy-runners (set-add (ref busy-runners) r))
|
||||
r]
|
||||
[none
|
||||
(error "need to call can-accept? before selecting a runner")]))
|
||||
|
||||
(during (observe (task-performance id $t _))
|
||||
(match-define (task $task-id $desc) t)
|
||||
(define status0 : TaskStateDesc
|
||||
(if (can-accept?)
|
||||
RUNNING
|
||||
OVERLOAD/ts))
|
||||
(field [status TaskStateDesc status0])
|
||||
(assert (task-performance id t (ref status)))
|
||||
(when (can-accept?)
|
||||
(define runner (select-runner))
|
||||
(log "TM ~a assigns task ~a to runner ~a" id task-id runner)
|
||||
(on stop (set! busy-runners (set-remove (ref busy-runners) runner)))
|
||||
(on (asserted (task-performance runner t $st))
|
||||
(match st
|
||||
[ACCEPTED #f]
|
||||
[RUNNING #f]
|
||||
[OVERLOAD/ts
|
||||
(set! status OVERLOAD/ts)]
|
||||
[(finished discard)
|
||||
(set! status st)]))))))))))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
;; JobManager
|
||||
|
||||
;; Task Int Any -> Task
|
||||
;; If the given task is waiting for this data, replace the waiting ID with the data
|
||||
(define (task+data [t : PendingTask]
|
||||
[id : Int]
|
||||
[data : TaskResult]
|
||||
-> PendingTask)
|
||||
(match t
|
||||
[(task $tid (reduce-work (left id) $r))
|
||||
(task tid (reduce-work (right data) r))]
|
||||
[(task $tid (reduce-work $l (left id)))
|
||||
(task tid (reduce-work l (right data)))]
|
||||
[_ t]))
|
||||
|
||||
|
||||
(require/typed "flink-support.rkt"
|
||||
[split-at/lenient- : (∀ (X) (→fn (List X) Int (List (List X))))])
|
||||
|
||||
(define (∀ (X) (split-at/lenient [xs : (List X)]
|
||||
[n : Int]
|
||||
-> (Tuple (List X) (List X))))
|
||||
(define l (split-at/lenient- xs n))
|
||||
(tuple (first l) (second l)))
|
||||
|
||||
;; Task -> Bool
|
||||
;; Test if the task is ready to run
|
||||
(define (task-ready? [t : PendingTask] -> (Maybe ConcreteTask))
|
||||
(match t
|
||||
[(task $tid (map-work $s))
|
||||
;; having to re-produce this is directly bc of no occurrence typing
|
||||
(some (task tid (map-work s)))]
|
||||
[(task $tid (reduce-work (right $v1)
|
||||
(right $v2)))
|
||||
(some (task tid (reduce-work v1 v2)))]
|
||||
[_
|
||||
none]))
|
||||
|
||||
|
||||
(define (partition-ready-tasks [tasks : (List PendingTask)]
|
||||
-> (Tuple (List PendingTask)
|
||||
(List ConcreteTask)))
|
||||
(define part (inst partition/either PendingTask PendingTask ConcreteTask))
|
||||
(part tasks
|
||||
(lambda ([t : PendingTask])
|
||||
(match (task-ready? t)
|
||||
[(some $ct)
|
||||
(right ct)]
|
||||
[none
|
||||
(left t)]))))
|
||||
|
||||
|
||||
(define (input->pending-task [t : InputTask] -> PendingTask)
|
||||
(match t
|
||||
[(task $id (map-work $s))
|
||||
;; with occurrence typing, could just return t
|
||||
(task id (map-work s))]
|
||||
[(task $id (reduce-work $l $r))
|
||||
(task id (reduce-work (left l) (left r)))]))
|
||||
|
||||
|
||||
(message-struct tasks-finished : TasksFinished (id results))
|
||||
|
||||
;; assertions used for internal slot-management protocol
|
||||
(assertion-struct slots : Slots (v))
|
||||
(assertion-struct slot-assignment : SlotAssignment (who mngr))
|
||||
;; tid is the TaskID, rid is a unique symbol to a particular request for a slot
|
||||
(define-constructor* (request-id : ReqID tid rid))
|
||||
(define-type-alias RequestID (ReqID TaskID ID))
|
||||
(message-struct task-is-ready : TaskIsReady (job-id task))
|
||||
|
||||
(define (spawn-job-manager)
|
||||
(spawn τc
|
||||
(lift+define-role job-manager-impl ;; export-roles "job-manager-impl.rktd"
|
||||
(start-facet jm ;; #:includes-behavior TaskAssigner
|
||||
(assert (job-manager-alive))
|
||||
(log "Job Manager Up")
|
||||
|
||||
(on start
|
||||
(start-facet slot-manager
|
||||
;; keep track of task managers, how many slots they say are open, and how many tasks we have assigned.
|
||||
(define/query-hash task-managers (task-manager $id:ID $slots:Int) id slots
|
||||
#:on-add (log "JM learns that ~a has ~v slots" id (hash-ref (ref task-managers) id)))
|
||||
|
||||
(field ;; how many outstanding assignments there are for each task manager
|
||||
[requests-in-flight (Hash ID Int) (hash)]
|
||||
;; map a request's ID to the manager it is assigned to
|
||||
[assignments (Hash ID ID) (hash)])
|
||||
(define (slots-available)
|
||||
(for/sum ([(id v) (ref task-managers)])
|
||||
(max 0 (- v (hash-ref/failure (ref requests-in-flight) id 0)))))
|
||||
|
||||
(define (try-take-slot! [me : ID] -> (Maybe ID))
|
||||
(define mngr?
|
||||
(for/first ([(id slots) (ref task-managers)]
|
||||
#:when (positive? (- slots (hash-ref/failure (ref requests-in-flight) id 0))))
|
||||
id))
|
||||
(match mngr?
|
||||
[(some $m)
|
||||
(set! assignments (hash-set (ref assignments) me m))
|
||||
(set! requests-in-flight (hash-update/failure (ref requests-in-flight) m add1 0))]
|
||||
[none
|
||||
#f])
|
||||
mngr?)
|
||||
|
||||
(know (slots (slots-available)))
|
||||
|
||||
(during (know (observe (slot-assignment (request-id $tid:TaskID $who:ID) _)))
|
||||
(on start
|
||||
(start-facet assign-manager
|
||||
;; what if one manager gains a slot but another loses one, so n stays the same?
|
||||
(on (know (slots $n:Int))
|
||||
#;(log "Dispatcher request ~a learns there are ~a slots" tid n)
|
||||
(unless (or (zero? n) (hash-has-key? (ref assignments) who))
|
||||
(define mngr? (try-take-slot! who))
|
||||
(match mngr?
|
||||
[(some $mngr)
|
||||
(stop assign-manager
|
||||
(log "Dispatcher assigns task ~a to ~a" tid mngr)
|
||||
(start-facet _ (know (slot-assignment (request-id tid who) mngr)))
|
||||
(start-facet waiting-for-answer
|
||||
(on (asserted (observe (task-performance mngr (task tid $x) _)))
|
||||
(start-facet _ (on (asserted (task-performance mngr (task tid x) _))
|
||||
(log "Dispatcher sees answer for ~a" tid)
|
||||
(stop waiting-for-answer))))
|
||||
(on stop
|
||||
(set! requests-in-flight (hash-update (ref requests-in-flight) mngr sub1)))))]
|
||||
[_ #f])))))
|
||||
(on stop (set! assignments (hash-remove (ref assignments) who))))))
|
||||
|
||||
(during (observe (job-completion $job-id $tasks _))
|
||||
(log "JM receives job ~a" job-id)
|
||||
(define pending (for/list ([t tasks])
|
||||
(input->pending-task t)))
|
||||
(define-tuple (not-ready ready) (partition-ready-tasks pending))
|
||||
(field [waiting-tasks (List PendingTask) not-ready]
|
||||
[tasks-in-progress Int 0])
|
||||
|
||||
;; Task -> Void
|
||||
(define (add-ready-task! [t : ConcreteTask])
|
||||
;; TODO - use functional-queue.rkt from ../../
|
||||
(match-define (task $tid _) t)
|
||||
(log "JM marks task ~a as ready" tid)
|
||||
(realize! (task-is-ready job-id t)))
|
||||
|
||||
;; ID Data -> Void
|
||||
;; Update any dependent tasks with the results of the given task, moving
|
||||
;; them to the ready queue when possible
|
||||
(define (push-results [task-id : TaskID]
|
||||
[data : TaskResult])
|
||||
(cond
|
||||
[(and (zero? (ref tasks-in-progress))
|
||||
(empty? (ref waiting-tasks)))
|
||||
(log "JM finished with job ~a" job-id)
|
||||
(realize! (tasks-finished job-id data))]
|
||||
[else
|
||||
;; TODO - in MapReduce, there should be either 1 waiting task, or 0, meaning the job is done.
|
||||
(define still-waiting
|
||||
(for/fold ([ts : (List PendingTask) (list)])
|
||||
([t (ref waiting-tasks)])
|
||||
(define t+ (task+data t (select 0 task-id) data))
|
||||
(match (task-ready? t+)
|
||||
[(some $ready)
|
||||
(add-ready-task! ready)
|
||||
ts]
|
||||
[_
|
||||
(cons t+ ts)])))
|
||||
(set! waiting-tasks still-waiting)]))
|
||||
|
||||
;; Task (ID TaskResult -> Void) -> Void
|
||||
;; Requires (task-ready? t)
|
||||
(define (∀ (ρ) (perform-task [t : ConcreteTask]
|
||||
[k : (proc TaskID TaskResult -> ★/t
|
||||
#:roles (ρ))]))
|
||||
(start-facet perform
|
||||
(on start (set! tasks-in-progress (add1 (ref tasks-in-progress))))
|
||||
(on stop (set! tasks-in-progress (sub1 (ref tasks-in-progress))))
|
||||
(match-define (task $this-id $desc) t)
|
||||
(log "JM begins on task ~a" this-id)
|
||||
|
||||
;; ID -> ...
|
||||
(define (assign-task [mngr : ID]
|
||||
[request-again! : (→fn ★/t)])
|
||||
(start-facet assign
|
||||
(on (retracted (task-manager mngr _))
|
||||
;; our task manager has crashed
|
||||
(stop assign (request-again!)))
|
||||
(on (asserted (task-performance mngr t $status))
|
||||
(match status
|
||||
[ACCEPTED #f]
|
||||
[RUNNING #f]
|
||||
[OVERLOAD/ts
|
||||
;; need to find a new task manager
|
||||
;; don't think we need a release-slot! here, because if we've heard back from a task manager,
|
||||
;; they should have told us a different slot count since we tried to give them work
|
||||
(log "JM overloaded manager ~a with task ~a" mngr this-id)
|
||||
(stop assign (request-again!))]
|
||||
[(finished $results)
|
||||
(log "JM receives the results of task ~a" this-id)
|
||||
(stop perform (k this-id results))]))))
|
||||
|
||||
(define (select-a-task-manager)
|
||||
(start-facet select
|
||||
(field [req-id ID (gensym 'perform-task)])
|
||||
(define (request-again!) (set! req-id (gensym 'perform-task)))
|
||||
(on (know (slot-assignment (request-id this-id (ref req-id)) $mngr:ID))
|
||||
(assign-task mngr request-again!))))
|
||||
|
||||
(on start (select-a-task-manager))))
|
||||
|
||||
(on start
|
||||
(start-facet delegate-tasks
|
||||
(on (realize (tasks-finished job-id $data:TaskResult))
|
||||
(stop delegate-tasks
|
||||
(start-facet done (assert (job-completion job-id tasks data)))))
|
||||
(on (realize (task-is-ready job-id $t:ConcreteTask))
|
||||
(perform-task t push-results)))
|
||||
(for ([t (in-list ready)])
|
||||
(add-ready-task! t))))))))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
;; Client
|
||||
|
||||
;; Job -> Void
|
||||
(define (spawn-client [j : JobDesc])
|
||||
(spawn τc
|
||||
(export-roles "client-impl.rktd"
|
||||
(lift+define-role client-impl
|
||||
(start-facet _
|
||||
(match-define (job $id $tasks) j)
|
||||
(on (asserted (job-completion id tasks $data))
|
||||
(printf "job done!\n~a\n" data)))))))
|
||||
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
;; Main
|
||||
|
||||
(require/typed "flink-support.rkt"
|
||||
[string->job : (→fn String JobDesc)]
|
||||
[file->job : (→fn String JobDesc)])
|
||||
|
||||
(define INPUT "a b c a b c\na b\n a b\na b")
|
||||
;; expected:
|
||||
;; #hash((a . 5) (b . 5) (c . 2))
|
||||
|
||||
(run-ground-dataspace τc
|
||||
(spawn-job-manager)
|
||||
(spawn-task-manager 2)
|
||||
(spawn-task-manager 3)
|
||||
(spawn-client (file->job "lorem.txt"))
|
||||
(spawn-client (string->job INPUT)))
|
||||
|
||||
(module+ test
|
||||
#;(verify-actors #;(Eventually (A (JobCompletion ID (List InputTask) TaskResult)))
|
||||
(Always (Implies (A (Observe (JobCompletion ID (List InputTask) ★/t)))
|
||||
(Eventually (A (JobCompletion ID (List InputTask) TaskResult)))))
|
||||
job-manager-impl
|
||||
task-manager-impl
|
||||
client-impl)
|
||||
|
||||
(verify-actors (And (Always (Implies (A (Observe (TaskPerformance ID ConcreteTask ★/t)))
|
||||
(Eventually (A (TaskPerformance ID ConcreteTask TaskStateDesc)))))
|
||||
(Eventually (A (TaskPerformance ID ConcreteTask TaskStateDesc))))
|
||||
TaskAssigner
|
||||
TaskPerformer))
|
||||
|
||||
(module+ test
|
||||
(check-simulates task-runner-impl task-runner-impl)
|
||||
(check-has-simulating-subgraph task-runner-impl TaskPerformer)
|
||||
(check-simulates task-manager-impl task-manager-impl)
|
||||
(check-has-simulating-subgraph task-manager-impl TaskPerformer)
|
||||
(check-has-simulating-subgraph task-manager-impl TaskAssigner)
|
||||
(check-has-simulating-subgraph job-manager-impl TaskAssigner))
|
||||
|
||||
;; infinite loop?
|
||||
#;(module+ test
|
||||
(check-simulates job-manager-impl job-manager-impl))
|
|
@ -1,88 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
;; Expected Output:
|
||||
#|
|
||||
balance = 0
|
||||
balance = 5
|
||||
balance = 0
|
||||
JEEPERS
|
||||
know overdraft!
|
||||
balance = -1
|
||||
balance = -2
|
||||
no longer in overdraft
|
||||
balance = 8
|
||||
|#
|
||||
|
||||
(assertion-struct balance : Balance (v))
|
||||
(message-struct deposit : Deposit (v))
|
||||
|
||||
;; Internal Events
|
||||
(message-struct new-transaction : NewTransaction (old new))
|
||||
(assertion-struct overdraft : Overdraft ())
|
||||
|
||||
(define-type-alias τc/external
|
||||
(U (Balance Int)
|
||||
(Message (Deposit Int))
|
||||
(Observe ★/t)))
|
||||
|
||||
(define-type-alias τc/internal
|
||||
(U (Message (NewTransaction Int Int))
|
||||
(Overdraft)
|
||||
(Observe ★/t)))
|
||||
|
||||
(define-type-alias τc
|
||||
(U τc/external
|
||||
τc/internal))
|
||||
|
||||
(run-ground-dataspace τc/external
|
||||
|
||||
(spawn
|
||||
(begin
|
||||
(start-facet bank
|
||||
(field [account Int 0])
|
||||
|
||||
(assert (balance (ref account)))
|
||||
|
||||
(on (message (deposit $v))
|
||||
(define prev (ref account))
|
||||
(set! account (+ v prev))
|
||||
(realize! (new-transaction prev (ref account))))
|
||||
|
||||
(on (realize (new-transaction $old:Int $new:Int))
|
||||
(when (and (negative? new)
|
||||
(not (negative? old)))
|
||||
(start-facet neg
|
||||
;; (this print is to make sure only one of these facets is created)
|
||||
(printf "JEEPERS\n")
|
||||
(know (overdraft))
|
||||
(on (realize (new-transaction _ $new:Int))
|
||||
(when (not (negative? new))
|
||||
(stop neg))))))
|
||||
|
||||
(during (know (overdraft))
|
||||
(on-start (printf "know overdraft!\n"))
|
||||
(on-stop (printf "no longer in overdraft\n"))))))
|
||||
|
||||
(spawn
|
||||
(start-facet obs
|
||||
(on (asserted (balance $v))
|
||||
(printf "balance = ~a\n" v))))
|
||||
|
||||
(spawn
|
||||
(start-facet _
|
||||
(on start
|
||||
(send! (deposit 5))
|
||||
(spawn
|
||||
(start-facet _
|
||||
(on start
|
||||
(send! (deposit -5))
|
||||
(spawn
|
||||
(start-facet _
|
||||
(on start
|
||||
(send! (deposit -1))
|
||||
(spawn
|
||||
(start-facet _
|
||||
(on start
|
||||
(send! (deposit -1))
|
||||
(spawn (start-facet _ (on start (send! (deposit 10)))))))))))))))))
|
||||
)
|
|
@ -1,48 +0,0 @@
|
|||
Lorem ipsum dolor sit amet, consectetur adipiscing elit. Nullam vehicula
|
||||
accumsan tristique. Integer sit amet sem metus. Nam porta tempus nisl ac
|
||||
ullamcorper. Nulla interdum ante ut odio ultricies lobortis. Nam sollicitudin
|
||||
lorem quis pellentesque consequat. Aenean pulvinar diam sed nulla semper, eget
|
||||
varius tortor faucibus. Nam sodales mattis elit, ac convallis sem pretium sed.
|
||||
Aliquam nibh velit, facilisis sit amet aliquam quis, dapibus vel mauris. Cras
|
||||
pharetra arcu tortor, id pharetra massa aliquet non. Maecenas elit libero,
|
||||
malesuada nec enim ut, ornare sagittis lectus. Praesent bibendum sed magna id
|
||||
euismod. Maecenas vulputate nunc mauris, a dignissim magna volutpat consectetur.
|
||||
Fusce malesuada neque sapien, sit amet ultricies urna finibus non. Fusce
|
||||
ultrices ipsum vel ligula eleifend, eget eleifend magna interdum. Curabitur
|
||||
semper quam nunc, sed laoreet ipsum facilisis at. Etiam ut quam ac eros
|
||||
ullamcorper mattis eget vel leo.
|
||||
|
||||
Integer ac ipsum augue. Ut molestie ac mi vel varius. Praesent at est et nulla
|
||||
facilisis viverra sit amet eu augue. Nullam diam odio, elementum vehicula
|
||||
convallis id, hendrerit non magna. Suspendisse porta faucibus feugiat. In
|
||||
rhoncus semper diam eu malesuada. Suspendisse ligula metus, rhoncus eget nunc
|
||||
et, cursus rutrum sem. Fusce iaculis commodo magna, vitae viverra arcu. Fusce et
|
||||
eros et massa sollicitudin bibendum. Etiam convallis, nibh accumsan porttitor
|
||||
sollicitudin, mauris orci consectetur nisl, sit amet venenatis nulla enim eget
|
||||
risus. Phasellus quam diam, commodo in sodales eget, scelerisque sed odio. Sed
|
||||
aliquam massa vel efficitur volutpat. Mauris ut elit dictum, euismod turpis in,
|
||||
feugiat lectus.
|
||||
|
||||
Vestibulum leo est, feugiat sit amet metus nec, ullamcorper commodo purus. Sed
|
||||
non mauris non tellus ullamcorper congue interdum et mauris. Donec sit amet
|
||||
mauris urna. Sed in enim nisi. Praesent accumsan sagittis euismod. Donec vel
|
||||
nisl turpis. Ut non efficitur erat. Vestibulum quis fermentum elit. Mauris
|
||||
molestie nibh posuere fringilla rutrum. Praesent mattis tortor sapien, semper
|
||||
varius elit ultrices in.
|
||||
|
||||
Etiam non leo lacus. Cras id tincidunt ante. Donec mattis urna fermentum ex
|
||||
elementum blandit. Sed ornare vestibulum nulla luctus malesuada. Maecenas
|
||||
pulvinar metus tortor. Sed dapibus enim vel sem bibendum, sit amet tincidunt
|
||||
ligula varius. Nullam vitae augue at dui blandit cursus. Suspendisse faucibus
|
||||
posuere luctus.
|
||||
|
||||
Class aptent taciti sociosqu ad litora torquent per conubia nostra, per inceptos
|
||||
himenaeos. Aenean suscipit diam eu luctus auctor. Donec non magna quis ex
|
||||
tincidunt condimentum. Ut porta maximus quam, non varius sem mattis eu. Fusce
|
||||
sit amet vestibulum libero. Aliquam vestibulum sagittis mi a pellentesque. Cras
|
||||
maximus cursus libero vitae porttitor. Aenean fermentum erat eget turpis mattis,
|
||||
quis commodo magna pharetra. Praesent eu hendrerit arcu. Proin mollis, sem ac
|
||||
accumsan dignissim, velit risus ultricies mauris, eu imperdiet dolor ipsum at
|
||||
augue. Fusce bibendum, tortor eget pulvinar auctor, leo mi volutpat urna, nec
|
||||
convallis sem quam non tellus. Vestibulum fermentum sodales faucibus. Nunc quis
|
||||
feugiat quam. Donec pulvinar feugiat mauris non porttitor.
|
|
@ -1,36 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
;; Expected Output
|
||||
;; pong: 8339
|
||||
|
||||
(message-struct ping : Ping (v))
|
||||
(message-struct pong : Pong (v))
|
||||
|
||||
(define-type-alias ds-type
|
||||
(U (Message (Ping Int))
|
||||
(Message (Pong Int))
|
||||
(Observe (Ping ★/t))
|
||||
(Observe (Pong ★/t))
|
||||
(Observe (Observe (Ping ★/t)))))
|
||||
|
||||
(run-ground-dataspace ds-type
|
||||
(spawn ds-type
|
||||
(lift+define-role ponger
|
||||
(start-facet echo
|
||||
(on (message (ping $v))
|
||||
(send! (pong v))))))
|
||||
(spawn ds-type
|
||||
(lift+define-role pinger
|
||||
(start-facet serve
|
||||
(on (asserted (observe (ping _)))
|
||||
(send! (ping 8339)))
|
||||
(on (message (pong $x))
|
||||
(printf "pong: ~v\n" x))))))
|
||||
|
||||
(module+ test
|
||||
(verify-actors (And (Eventually (M (Ping Int)))
|
||||
(Eventually (M (Pong Int)))
|
||||
(Always (Implies (M (Ping Int))
|
||||
(Eventually (M (Pong Int))))))
|
||||
pinger
|
||||
ponger))
|
|
@ -1,8 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
(provide a-fun)
|
||||
|
||||
(define (a-fun [x : Int] -> Int)
|
||||
(+ x 1))
|
||||
|
||||
#;(a-fun 5)
|
|
@ -1,27 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
;; Expected Output:
|
||||
#|
|
||||
received message bad
|
||||
realized good
|
||||
|#
|
||||
|
||||
(message-struct ping : Ping (v))
|
||||
|
||||
(define-type-alias τc
|
||||
(U (Message (Ping Symbol))
|
||||
(Observe ★/t)))
|
||||
|
||||
(run-ground-dataspace τc
|
||||
(spawn
|
||||
(start-facet _
|
||||
(on (realize (ping $v:Symbol))
|
||||
(printf "realized ~a\n" v))
|
||||
(on (message (ping $v))
|
||||
(printf "received message ~a\n" v)
|
||||
(realize! (ping 'good)))))
|
||||
|
||||
(spawn
|
||||
(start-facet _
|
||||
(on start (send! (ping 'bad)))))
|
||||
)
|
|
@ -1,16 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
(require-struct msg #:as Msg
|
||||
#:from "driver.rkt")
|
||||
|
||||
(define m (msg 1 "hi"))
|
||||
|
||||
(msg-in m)
|
||||
(msg-out m)
|
||||
|
||||
(match m
|
||||
[(msg (bind x Int) discard)
|
||||
(displayln x)])
|
||||
|
||||
;; error: msg/checked: arity mismatch
|
||||
#;(msg 1 2 3)
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
(provide (struct-out msg))
|
||||
|
||||
(struct msg (in out) #:transparent)
|
|
@ -1,12 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
(struct egg (size day) #:transparent)
|
||||
|
||||
(provide (except-out (struct-out egg)
|
||||
egg-size
|
||||
egg-day))
|
||||
|
||||
|
||||
(struct chicken (eggs) #:transparent)
|
||||
|
||||
(provide chicken)
|
|
@ -1,18 +0,0 @@
|
|||
#lang typed/syndicate/roles
|
||||
|
||||
(require-struct egg #:as Egg #:from "lib.rkt" #:omit-accs)
|
||||
|
||||
(define e (egg 5 "Sun"))
|
||||
|
||||
(match e
|
||||
[(egg $sz $d)
|
||||
(displayln sz)
|
||||
(displayln d)])
|
||||
|
||||
(require-struct chicken #:as Chicken #:from "lib.rkt" #:omit-accs)
|
||||
|
||||
(define c (chicken (list e e e)))
|
||||
|
||||
(match c
|
||||
[(chicken $eggs)
|
||||
(displayln eggs)])
|
|
@ -1,5 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
(require/typed "lib.rkt" [x : Int])
|
||||
|
||||
(displayln (+ x 1))
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
(provide x)
|
||||
|
||||
(define x 42)
|
|
@ -1,8 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
(require/typed "lib.rkt"
|
||||
[#:opaque Vec #:arity = 3]
|
||||
[ones : (Vec Int Int Int)]
|
||||
[vec+ : (→fn (Vec Int Int Int) (Vec Int Int Int) (Vec Int Int Int))])
|
||||
|
||||
(vec+ ones ones)
|
|
@ -1,8 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
(require/typed "lib.rkt"
|
||||
[#:opaque Vec]
|
||||
[ones : Vec]
|
||||
[vec+ : (→fn Vec Vec Vec)])
|
||||
|
||||
(vec+ ones ones)
|
|
@ -1,13 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
(provide ones
|
||||
vec+)
|
||||
|
||||
(struct vec (x y z) #:transparent)
|
||||
|
||||
(define ones (vec 1 1 1))
|
||||
|
||||
(define (vec+ v1 v2)
|
||||
(vec (+ (vec-x v1) (vec-x v2))
|
||||
(+ (vec-y v1) (vec-y v2))
|
||||
(+ (vec-z v1) (vec-z v2))))
|
|
@ -1,5 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
(require "provides.rkt")
|
||||
|
||||
(a-fun 5)
|
|
@ -1,21 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
;; Expected Output
|
||||
;; f: 0
|
||||
;; f: 18
|
||||
|
||||
(define-type-alias ds-type
|
||||
(U (Tuple String Int)
|
||||
(Observe ★/t)))
|
||||
|
||||
(run-ground-dataspace ds-type
|
||||
(spawn ds-type
|
||||
(start-facet server
|
||||
(field [f Int 0])
|
||||
(begin/dataflow
|
||||
(printf "f = ~v\n" (ref f)))
|
||||
(on (asserted (tuple "key" (bind v Int)))
|
||||
(set! f v))))
|
||||
(spawn ds-type
|
||||
(start-facet client
|
||||
(assert (tuple "key" 18)))))
|
|
@ -1,6 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
(run-ground-dataspace Int
|
||||
(spawn Int
|
||||
(start-facet _
|
||||
(assert 42))))
|
|
@ -1,33 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
;; Expected Output
|
||||
;; +parent
|
||||
;; +GO
|
||||
;; +ready
|
||||
;; -parent
|
||||
;; -GO
|
||||
;; -ready
|
||||
|
||||
(define-type-alias ds-type
|
||||
(U (Tuple String) (Observe (Tuple ★/t))))
|
||||
|
||||
(run-ground-dataspace ds-type
|
||||
(spawn ds-type
|
||||
(start-facet parent
|
||||
(assert (tuple "parent"))
|
||||
(during/spawn (tuple "GO")
|
||||
(assert (tuple "ready")))
|
||||
(on (asserted (tuple "ready"))
|
||||
(stop parent))))
|
||||
(spawn ds-type
|
||||
(start-facet flag
|
||||
(assert (tuple "GO"))
|
||||
(on (retracted (tuple "parent"))
|
||||
(stop flag))))
|
||||
(spawn ds-type
|
||||
(start-facet obs
|
||||
(during (tuple (bind s String))
|
||||
(on start
|
||||
(printf "+~a\n" s))
|
||||
(on stop
|
||||
(printf "-~a\n" s))))))
|
|
@ -1,29 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
;; Expected Output
|
||||
;; +GO
|
||||
;; +ready
|
||||
;; -GO
|
||||
;; -ready
|
||||
|
||||
(define-type-alias ds-type
|
||||
(U (Tuple String) (Observe (Tuple ★/t))))
|
||||
|
||||
(run-ground-dataspace ds-type
|
||||
(spawn ds-type
|
||||
(start-facet _
|
||||
(during (tuple "GO")
|
||||
(assert (tuple "ready")))))
|
||||
(spawn ds-type
|
||||
(start-facet flag
|
||||
;; type error when this was mistakenly just "GO"
|
||||
(assert (tuple "GO"))
|
||||
(on (asserted (tuple "ready"))
|
||||
(stop flag))))
|
||||
(spawn ds-type
|
||||
(start-facet obs
|
||||
(during (tuple (bind s String))
|
||||
(on start
|
||||
(printf "+~a\n" s))
|
||||
(on stop
|
||||
(printf "-~a\n" s))))))
|
|
@ -1,36 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
;; Expected Output
|
||||
;; adding key2 -> 88
|
||||
;; adding key1 -> 18
|
||||
;; size: 0
|
||||
;; size: 2
|
||||
;; removing key2
|
||||
;; adding key2 -> 99
|
||||
|
||||
(assertion-struct output : Output (v))
|
||||
|
||||
(define-type-alias ds-type
|
||||
(U (Tuple String Int)
|
||||
(Output Int)
|
||||
(Observe ★/t)))
|
||||
|
||||
(run-ground-dataspace ds-type
|
||||
(spawn ds-type
|
||||
(start-facet querier
|
||||
(define/query-hash key# (tuple (bind k String) (bind v Int)) k v
|
||||
#:on-add (printf "adding ~a -> ~a\n" k v)
|
||||
#:on-remove (printf "removing ~a\n" k))
|
||||
(assert (output (hash-count (ref key#))))))
|
||||
(spawn ds-type
|
||||
(start-facet client
|
||||
(assert (tuple "key1" 18))
|
||||
(on start
|
||||
(start-facet tmp
|
||||
(field [v Int 88])
|
||||
(assert (tuple "key2" (ref v)))
|
||||
(on (asserted (output 2))
|
||||
(set! v 99))))
|
||||
(during (output (bind v Int))
|
||||
(on start
|
||||
(printf "size: ~v\n" v))))))
|
|
@ -1,22 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
;; Expected Output
|
||||
;; size: 0
|
||||
;; size: 2
|
||||
|
||||
(define-type-alias ds-type
|
||||
(U (Tuple String Int)
|
||||
(Observe ★/t)))
|
||||
|
||||
(run-ground-dataspace ds-type
|
||||
(spawn ds-type
|
||||
(start-facet querier
|
||||
(define/query-set key (tuple "key" (bind v Int)) v)
|
||||
(assert (tuple "size" (set-count (ref key))))))
|
||||
(spawn ds-type
|
||||
(start-facet client
|
||||
(assert (tuple "key" 18))
|
||||
(assert (tuple "key" 88))
|
||||
(during (tuple "size" (bind v Int))
|
||||
(on start
|
||||
(printf "size: ~v\n" v))))))
|
|
@ -1,21 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
;; Expected Output
|
||||
;; query: 0
|
||||
;; query: 19
|
||||
|
||||
(define-type-alias ds-type
|
||||
(U (Tuple String Int)
|
||||
(Observe ★/t)))
|
||||
|
||||
(run-ground-dataspace ds-type
|
||||
(spawn ds-type
|
||||
(start-facet querier
|
||||
(define/query-value key 0 (tuple "key" (bind v Int)) (+ v 1))
|
||||
(assert (tuple "query" (ref key)))))
|
||||
(spawn ds-type
|
||||
(start-facet client
|
||||
(assert (tuple "key" 18))
|
||||
(during (tuple "query" (bind v Int))
|
||||
(on start
|
||||
(printf "query: ~v\n" v))))))
|
|
@ -1,38 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
;; Expected Output:
|
||||
;; +42
|
||||
;; +18
|
||||
;; +9
|
||||
;; +88
|
||||
;; -18
|
||||
;; -9
|
||||
|
||||
(define-type-alias ds-type
|
||||
(U (Tuple Int)
|
||||
(Observe (Tuple ★/t))))
|
||||
|
||||
(run-ground-dataspace ds-type
|
||||
(spawn ds-type
|
||||
(print-role
|
||||
(start-facet doomed
|
||||
(assert (tuple 18))
|
||||
(on (asserted (tuple 42))
|
||||
(stop doomed
|
||||
(start-facet the-afterlife
|
||||
(assert (tuple 88))))))))
|
||||
|
||||
(spawn ds-type
|
||||
(start-facet obs
|
||||
(assert (tuple 42))
|
||||
(on (asserted (tuple (bind x Int)))
|
||||
(printf "+~v\n" x))
|
||||
(on (retracted (tuple (bind x Int)))
|
||||
(printf "-~v\n" x))))
|
||||
|
||||
;; null-ary stop
|
||||
(spawn ds-type
|
||||
(start-facet meep
|
||||
(assert (tuple 9))
|
||||
(on (asserted (tuple 88))
|
||||
(stop meep)))))
|
|
@ -1,7 +0,0 @@
|
|||
#lang typed/syndicate/roles
|
||||
|
||||
(require "typed-out.rkt")
|
||||
|
||||
(define c : (Cow Int) (cow 5))
|
||||
|
||||
(cow-moos c)
|
|
@ -1,7 +0,0 @@
|
|||
#lang typed/syndicate/roles
|
||||
|
||||
(require "struct-out.rkt")
|
||||
|
||||
(happy-days (happy 5))
|
||||
|
||||
(define classic : (Happy Int) (happy 100))
|
|
@ -1,5 +0,0 @@
|
|||
#lang typed/syndicate/roles
|
||||
|
||||
(provide (struct-out happy))
|
||||
|
||||
(define-constructor* (happy : Happy days))
|
|
@ -1,5 +0,0 @@
|
|||
#lang typed/syndicate/roles
|
||||
|
||||
(require-struct cow #:as Cow #:from "untyped.rkt")
|
||||
|
||||
(provide (struct-out cow))
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket
|
||||
|
||||
(provide (struct-out cow))
|
||||
|
||||
(struct cow (moos) #:transparent)
|
|
@ -1,163 +0,0 @@
|
|||
#lang typed/syndicate
|
||||
|
||||
;; Expected Output
|
||||
;; Completed Order:
|
||||
;; Catch 22
|
||||
;; 10001483
|
||||
;; March 9th
|
||||
|
||||
(define-constructor (price v)
|
||||
#:type-constructor PriceT
|
||||
#:with Price (PriceT Int))
|
||||
|
||||
(define-constructor (out-of-stock)
|
||||
#:type-constructor OutOfStockT
|
||||
#:with OutOfStock (OutOfStockT))
|
||||
|
||||
(define-type-alias QuoteAnswer
|
||||
(U Price OutOfStock))
|
||||
|
||||
(define-constructor (quote title answer)
|
||||
#:type-constructor QuoteT
|
||||
#:with Quote (QuoteT String QuoteAnswer)
|
||||
#:with QuoteRequest (Observe (QuoteT String ★/t))
|
||||
#:with QuoteInterest (Observe (QuoteT ★/t ★/t)))
|
||||
|
||||
(define-constructor (split-proposal title price contribution accepted)
|
||||
#:type-constructor SplitProposalT
|
||||
#:with SplitProposal (SplitProposalT String Int Int Bool)
|
||||
#:with SplitRequest (Observe (SplitProposalT String Int Int ★/t))
|
||||
#:with SplitInterest (Observe (SplitProposalT ★/t ★/t ★/t ★/t)))
|
||||
|
||||
(define-constructor (order-id id)
|
||||
#:type-constructor OrderIdT
|
||||
#:with OrderId (OrderIdT Int))
|
||||
|
||||
(define-constructor (delivery-date date)
|
||||
#:type-constructor DeliveryDateT
|
||||
#:with DeliveryDate (DeliveryDateT String))
|
||||
|
||||
(define-type-alias (Maybe t)
|
||||
(U t Bool))
|
||||
|
||||
(define-constructor (order title price oid delivery-date)
|
||||
#:type-constructor OrderT
|
||||
#:with Order (OrderT String Int (Maybe OrderId) (Maybe DeliveryDate))
|
||||
#:with OrderRequest (Observe (OrderT String Int ★/t ★/t))
|
||||
#:with OrderInterest (Observe (OrderT ★/t ★/t ★/t ★/t)))
|
||||
|
||||
(define-type-alias ds-type
|
||||
(U ;; quotes
|
||||
Quote
|
||||
QuoteRequest
|
||||
(Observe QuoteInterest)
|
||||
;; splits
|
||||
SplitProposal
|
||||
SplitRequest
|
||||
(Observe SplitInterest)
|
||||
;; orders
|
||||
Order
|
||||
OrderRequest
|
||||
(Observe OrderInterest)))
|
||||
|
||||
(define-type-alias seller-role
|
||||
(Role (seller)
|
||||
(During (Observe (QuoteT String ★/t))
|
||||
(Shares (QuoteT String QuoteAnswer)))
|
||||
#;(Reacts (Asserted (Observe (QuoteT String ★/t)))
|
||||
(Role (_)
|
||||
;; QuoteAnswer was originally, erroneously, Int
|
||||
(Shares (QuoteT String QuoteAnswer))))))
|
||||
|
||||
(run-ground-dataspace ds-type
|
||||
|
||||
;; seller
|
||||
(spawn ds-type
|
||||
(lift+define-role seller-impl
|
||||
(start-facet _ ;; #:implements seller-role
|
||||
(field [book (Tuple String Int) (tuple "Catch 22" 22)]
|
||||
[next-order-id Int 10001483])
|
||||
(on (asserted (observe (quote (bind title String) discard)))
|
||||
(start-facet x
|
||||
(on (retracted (observe (quote title discard)))
|
||||
(stop x))
|
||||
(define answer
|
||||
(match title
|
||||
["Catch 22"
|
||||
(price 22)]
|
||||
[_
|
||||
(out-of-stock)]))
|
||||
(assert (quote title answer))))
|
||||
(on (asserted (observe (order (bind title String) (bind offer Int) discard discard)))
|
||||
(start-facet x
|
||||
(on (retracted (observe (order title offer discard discard)))
|
||||
(stop x))
|
||||
(let ([asking-price 22])
|
||||
(if (and (equal? title "Catch 22") (>= offer asking-price))
|
||||
(let ([id (ref next-order-id)])
|
||||
(set! next-order-id (+ 1 id))
|
||||
(assert (order title offer (order-id id) (delivery-date "March 9th"))))
|
||||
(assert (order title offer #f #f)))))))))
|
||||
|
||||
;; buyer A
|
||||
(spawn ds-type
|
||||
(lift+define-role buyer-a-impl
|
||||
(start-facet buyer
|
||||
(field [title String "Catch 22"]
|
||||
[budget Int 1000])
|
||||
(on (asserted (quote (ref title) (bind answer QuoteAnswer)))
|
||||
(match answer
|
||||
[(out-of-stock)
|
||||
(stop buyer)]
|
||||
[(price (bind amount Int))
|
||||
(start-facet negotiation
|
||||
(field [contribution Int (/ amount 2)])
|
||||
(on (asserted (split-proposal (ref title) amount (ref contribution) (bind accept? Bool)))
|
||||
(if accept?
|
||||
(stop buyer)
|
||||
(if (> (ref contribution) (- amount 5))
|
||||
(stop negotiation (displayln "negotiation failed"))
|
||||
(set! contribution
|
||||
(+ (ref contribution) (/ (- amount (ref contribution)) 2)))))))])))))
|
||||
|
||||
;; buyer B
|
||||
(spawn ds-type
|
||||
(lift+define-role buyer-b-impl
|
||||
(start-facet buyer-b
|
||||
(field [funds Int 5])
|
||||
(on (asserted (observe (split-proposal (bind title String) (bind price Int) (bind their-contribution Int) discard)))
|
||||
(let ([my-contribution (- price their-contribution)])
|
||||
(cond
|
||||
[(> my-contribution (ref funds))
|
||||
(start-facet decline
|
||||
(assert (split-proposal title price their-contribution #f))
|
||||
(on (retracted (observe (split-proposal title price their-contribution discard)))
|
||||
(stop decline)))]
|
||||
[#t
|
||||
(start-facet accept
|
||||
(assert (split-proposal title price their-contribution #t))
|
||||
(on (retracted (observe (split-proposal title price their-contribution discard)))
|
||||
(stop accept))
|
||||
(on start
|
||||
(spawn ds-type
|
||||
(start-facet purchase
|
||||
(on (asserted (order title price (bind order-id? (Maybe OrderId)) (bind delivery-date? (Maybe DeliveryDate))))
|
||||
(match (tuple order-id? delivery-date?)
|
||||
[(tuple (order-id (bind id Int)) (delivery-date (bind date String)))
|
||||
;; complete!
|
||||
(begin (displayln "Completed Order:")
|
||||
(displayln title)
|
||||
(displayln id)
|
||||
(displayln date)
|
||||
(stop purchase))]
|
||||
[discard
|
||||
(begin (displayln "Order Rejected")
|
||||
(stop purchase))]))))))]))))))
|
||||
)
|
||||
|
||||
(module+ test
|
||||
(check-simulates seller-impl seller-impl)
|
||||
;; found a bug in spec, see seller-role above
|
||||
(check-simulates seller-impl seller-role)
|
||||
(check-simulates buyer-a-impl buyer-a-impl)
|
||||
(check-simulates buyer-b-impl buyer-b-impl))
|
|
@ -1,12 +0,0 @@
|
|||
#lang info
|
||||
|
||||
(define scribblings '(("scribblings/typed-syndicate.scrbl" ())))
|
||||
|
||||
(define compile-omit-paths
|
||||
'("examples"
|
||||
"tests"))
|
||||
|
||||
(define test-omit-paths
|
||||
;; a number of the examples use SPIN for model checking which I need
|
||||
;; to figure out how to get working on the package server
|
||||
'("examples/"))
|
|
@ -1,174 +0,0 @@
|
|||
/* Useful macros */
|
||||
|
||||
#define ASSERTED(x) (x##_assertions > 0)
|
||||
#define ASSERT(x) x##_assertions = x##_assertions + 1
|
||||
#define RETRACT(x) x##_assertions = x##_assertions - 1
|
||||
|
||||
/* Global stuff */
|
||||
|
||||
/* Book Quote */
|
||||
int BQ_assertions = 0;
|
||||
int IBQ_assertions = 0;
|
||||
int IIBQ_assertions = 0;
|
||||
|
||||
/* Book Interest */
|
||||
int BI_assertions = 0;
|
||||
int IBI_assertions = 0;
|
||||
int IIBI_assertions = 0;
|
||||
|
||||
/* Club Members */
|
||||
int CM_assertions = 0;
|
||||
int ICM_assertions = 0;
|
||||
|
||||
/* Announcements */
|
||||
int BoTM_assertions = 0;
|
||||
|
||||
/* Seller stuff */
|
||||
mtype = { seller, seller_during};
|
||||
|
||||
active proctype Seller() {
|
||||
mtype current_state = seller;
|
||||
bool asserting_IIBQ = true;
|
||||
bool asserting_BQ = false;
|
||||
bool know_IBQ = false;
|
||||
ASSERT(IIBQ);
|
||||
do
|
||||
:: current_state == seller ->
|
||||
if
|
||||
:: ASSERTED(IBQ) && !know_IBQ ->
|
||||
current_state = seller_during;
|
||||
asserting_BQ = true;
|
||||
ASSERT(BQ);
|
||||
fi;
|
||||
know_IBQ = ASSERTED(IBQ);
|
||||
:: current_state == seller_during ->
|
||||
if
|
||||
:: !ASSERTED(IBQ) && know_IBQ ->
|
||||
current_state = seller;
|
||||
asserting_BQ = false;
|
||||
RETRACT(BQ);
|
||||
fi;
|
||||
know_IBQ = ASSERTED(IBQ);
|
||||
od;
|
||||
}
|
||||
|
||||
mtype = { get_quotes, announce, poll, none };
|
||||
mtype leader_state = get_quotes;
|
||||
|
||||
active proctype Leader() {
|
||||
bool asserting_IBI = false;
|
||||
bool asserting_BoTM = false;
|
||||
bool asserting_IBQ = true;
|
||||
bool asserting_ICM = true;
|
||||
bool know_BQ = false;
|
||||
bool know_BI = false;
|
||||
ASSERT(IBQ);
|
||||
ASSERT(ICM);
|
||||
do
|
||||
:: leader_state == get_quotes ->
|
||||
if
|
||||
:: ASSERTED(BQ) && !know_BQ ->
|
||||
leader_state = poll;
|
||||
asserting_IBI = true;
|
||||
ASSERT(IBI);
|
||||
:: ASSERTED(BQ) && !know_BQ ->
|
||||
leader_state = none;
|
||||
asserting_IBQ = false;
|
||||
asserting_ICM = false;
|
||||
RETRACT(IBQ);
|
||||
RETRACT(ICM);
|
||||
fi;
|
||||
know_BQ = ASSERTED(BQ)
|
||||
:: leader_state == announce ->
|
||||
skip;
|
||||
:: leader_state == poll ->
|
||||
if
|
||||
:: ASSERTED(BI) && !know_BI ->
|
||||
leader_state = get_quotes;
|
||||
assert(asserting_IBI);
|
||||
asserting_IBI = false;
|
||||
RETRACT(IBI);
|
||||
:: ASSERTED(BI) && !know_BI ->
|
||||
leader_state = announce;
|
||||
assert(asserting_IBI);
|
||||
asserting_IBI = false;
|
||||
RETRACT(IBI);
|
||||
asserting_BoTM = true;
|
||||
ASSERT(BoTM);
|
||||
:: ASSERTED(BI) && !know_BI ->
|
||||
leader_state = none;
|
||||
assert(asserting_IBI);
|
||||
asserting_IBQ = false;
|
||||
asserting_ICM = false;
|
||||
asserting_IBI = false;
|
||||
RETRACT(IBQ);
|
||||
RETRACT(ICM);
|
||||
RETRACT(IBI);
|
||||
:: ASSERTED(BQ) && !know_BQ ->
|
||||
leader_state = none;
|
||||
assert(asserting_IBI);
|
||||
asserting_IBQ = false;
|
||||
asserting_ICM = false;
|
||||
asserting_IBI = false;
|
||||
RETRACT(IBQ);
|
||||
RETRACT(ICM);
|
||||
RETRACT(IBI);
|
||||
fi;
|
||||
know_BI = ASSERTED(BI);
|
||||
know_BQ = ASSERTED(BQ);
|
||||
:: leader_state == none ->
|
||||
skip;
|
||||
od
|
||||
}
|
||||
|
||||
mtype = { member, during_member };
|
||||
|
||||
active proctype Member() {
|
||||
mtype current_state = member;
|
||||
bool asserting_BI = false;
|
||||
bool asserting_IIBI = true;
|
||||
bool asserting_CM = true;
|
||||
ASSERT(IIBI);
|
||||
ASSERT(CM);
|
||||
bool know_IBI = false;
|
||||
do
|
||||
:: current_state == member ->
|
||||
if
|
||||
:: ASSERTED(IBI) && !know_IBI ->
|
||||
current_state = during_member;
|
||||
asserting_BI = true;
|
||||
ASSERT(BI);
|
||||
fi;
|
||||
know_IBI = ASSERTED(IBI);
|
||||
:: current_state == during_member ->
|
||||
if
|
||||
:: !ASSERTED(IBI) && know_IBI ->
|
||||
current_state = member;
|
||||
asserting_BI = false;
|
||||
RETRACT(BI);
|
||||
fi;
|
||||
know_IBI = ASSERTED(IBI);
|
||||
od
|
||||
}
|
||||
|
||||
ltl sanity {
|
||||
[](BQ_assertions >= 0 &&
|
||||
IBQ_assertions >= 0 &&
|
||||
IIBQ_assertions >= 0 &&
|
||||
BI_assertions >= 0 &&
|
||||
IBI_assertions >= 0 &&
|
||||
IIBI_assertions >= 0 &&
|
||||
CM_assertions >= 0 &&
|
||||
ICM_assertions >= 0 &&
|
||||
BoTM_assertions >= 0)
|
||||
&&
|
||||
<> (BQ_assertions > 0)
|
||||
&&
|
||||
[] (ASSERTED(IBQ) -> <> ASSERTED(BQ))
|
||||
&&
|
||||
[] (ASSERTED(IBI) -> <> ASSERTED(BI))
|
||||
/*
|
||||
&&
|
||||
<> (leader_state == announce || leader_state == none)
|
||||
*/
|
||||
}
|
|
@ -1,776 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require (for-label (only-in racket struct)
|
||||
typed/syndicate/roles)
|
||||
(prefix-in racket: (for-label racket))
|
||||
(prefix-in untyped: (for-label syndicate/actor)))
|
||||
|
||||
@title{Typed Syndicate}
|
||||
|
||||
|
||||
@defmodule[typed/syndicate/roles]
|
||||
|
||||
@section{Overview}
|
||||
|
||||
@section{Types}
|
||||
|
||||
@deftogether[(@defidform[Int]
|
||||
@defidform[Bool]
|
||||
@defidform[String]
|
||||
@defidform[ByteString]
|
||||
@defidform[Symbol])]{
|
||||
Base types.
|
||||
}
|
||||
|
||||
@defform[(U type ...)]{
|
||||
The type representing the union of @racket[type ...].
|
||||
}
|
||||
|
||||
@defidform[⊥]{
|
||||
An alias for @racket[(U)].
|
||||
}
|
||||
|
||||
@defidform[★/t]{
|
||||
The type representing any possible assertion, and, in an @racket[AssertionSet],
|
||||
the possibility for an infinite set of assertions.
|
||||
}
|
||||
|
||||
@defidform[Discard]{
|
||||
The type of @racket[_] patterns.
|
||||
}
|
||||
|
||||
@defform[(Bind type)]{
|
||||
The type of @racket[$] patterns.
|
||||
}
|
||||
|
||||
@defidform[FacetName]{
|
||||
The type associated with identifiers bound by @racket[start-facet].
|
||||
}
|
||||
|
||||
@defform[(Role (x) type ...)]{
|
||||
The type of a facet named @racket[x] and endpoints described by @racket[type
|
||||
...].
|
||||
}
|
||||
|
||||
@defform[(Stop X type ...)]{
|
||||
The type of a @racket[stop] action.
|
||||
}
|
||||
|
||||
@defform[(Field type)]{
|
||||
The type of a field containing values of @racket[type].
|
||||
}
|
||||
|
||||
|
||||
@defform[(Shares type)]{
|
||||
The type of an @racket[assert] endpoint.
|
||||
}
|
||||
|
||||
@defform[#:literals (OnStart OnStop Asserted Retracted)
|
||||
(Reacts EventDesc type ...)
|
||||
#:grammar
|
||||
[(EventDesc (code:line OnStart)
|
||||
(code:line OnStart)
|
||||
(code:line (Asserted event-type))
|
||||
(code:line (Retracted event-type)))]]{
|
||||
The type of a @racket[on] endpoint that reacts to events described by
|
||||
@racket[EventDesc] with the behavior given by @racket[type ...].
|
||||
}
|
||||
|
||||
@deftogether[(@defidform[OnStart]
|
||||
@defidform[OnStop]
|
||||
@defform[(Asserted type)]
|
||||
@defform[(Retracted type)])]{
|
||||
See @racket[Reacts].
|
||||
}
|
||||
|
||||
@defform[(Actor type)]{
|
||||
The type of an actor that operates in a dataspace with a certain communication
|
||||
@racket[type].
|
||||
}
|
||||
|
||||
@defform[(ActorWithRole comm-type behavior-type)]{
|
||||
An @racket[Actor] type with the additional @racket[behavior-type] describing the
|
||||
actor's behavior in terms of a @racket[Role].
|
||||
}
|
||||
|
||||
@defform[(Sends type)]{
|
||||
The type of a @racket[send!] action.
|
||||
}
|
||||
|
||||
@defform[(Realize type)]{
|
||||
The type of a @racket[realize!] action.
|
||||
}
|
||||
|
||||
@deftogether[(@defform[(Branch type ...)]
|
||||
@defform[(Effs type ...)])]{
|
||||
Types that may arise in descriptions in @racket[Role] types due to branching and
|
||||
sequencing.
|
||||
}
|
||||
|
||||
@defform[(Tuple type ...)]{
|
||||
The type of @racket[tuple] expressions.
|
||||
}
|
||||
|
||||
@defidform[Unit]{
|
||||
An alias for @racket[(Tuple)].
|
||||
}
|
||||
|
||||
@defform[(AssertionSet type)]{
|
||||
The type for a set of assertions of a certain @racket[type]. Note that these are
|
||||
not interoperable with the general purpose @racket[set] data structures.
|
||||
}
|
||||
|
||||
@defform[(∀ (X ...) type)]{
|
||||
Universal quantification over types.
|
||||
}
|
||||
|
||||
@defform[#:literals (Computation Value Endpoints Roles Spawns)
|
||||
(→ type ... (Computation (Value result-type)
|
||||
(Endpoints ep-type ...)
|
||||
(Roles role-type ...)
|
||||
(Spawns spawn-type ...)))]{
|
||||
The type of a function with parameters @racket[type ...] that returns @racket[result-type]. The type includes the effects of any actions performed by the function:
|
||||
@itemlist[
|
||||
@item{@racket[Endpoints]: includes any endpoint installation effects, such as from @racket[assert] and @racket[on].}
|
||||
@item{@racket[Roles]: includes any script action effects, such as from @racket[start-facet], @racket[stop], and @racket[send!].}
|
||||
@item{@racket[Spawns]: includes descriptions of any @racket[spawn] actions.}
|
||||
]
|
||||
}
|
||||
|
||||
@defform[(→fn type-in ... type-out)]{
|
||||
Shorthand for a @racket[→] type with no effects.
|
||||
}
|
||||
|
||||
@defform[(proc maybe-quantifiers type-in ... maybe-arrow type-out
|
||||
maybe-endpoints
|
||||
maybe-roles
|
||||
maybe-spawns)
|
||||
#:grammar
|
||||
[(maybe-quantifiers (code:line)
|
||||
(code:line #:forall (X ...)))
|
||||
(maybe-arrow (code:line)
|
||||
(code:line →)
|
||||
(code:line ->))
|
||||
(maybe-endpoints (code:line)
|
||||
(code:line #:endpoints (e ...)))
|
||||
(maybe-roles (code:line)
|
||||
(code:line #:roles (r ...)))
|
||||
(maybe-spawns (code:line)
|
||||
(code:line #:spawns (s ...)))]]{
|
||||
A more convenient notation for writing (potentially polymorphic) function types
|
||||
with effects. Shorthand for @racket[(∀ (X ...) (→ type-in ... (Computation
|
||||
(Value type-out) (Endpoints e ...) (Roles r ...) (Spawns s ...))))].
|
||||
}
|
||||
|
||||
@deftogether[(@defform[(Computation type ...)]
|
||||
@defform[(Value type)]
|
||||
@defform[(Endpoints type)]
|
||||
@defform[(Roles type)]
|
||||
@defform[(Spawns type)])]{
|
||||
See @racket[→].
|
||||
}
|
||||
|
||||
@section{User Defined Types}
|
||||
|
||||
@defform*[[(define-type-alias id type)
|
||||
(define-type-alias (ty-cons-id arg-id ...) type)]]{
|
||||
Define @racket[id] to be the same as @racket[type], or create a type constructor
|
||||
@racket[(ty-cons-id ty ...)] whose meaning is @racket[type] with references to
|
||||
@racket[arg-id ...] replaced by @racket[ty ...].
|
||||
}
|
||||
|
||||
@defform[(define-constructor (ctor-id slot-id ...)
|
||||
maybe-type-ctor
|
||||
maybe-alias ...)
|
||||
#:grammar
|
||||
[(maybe-type-ctor (code:line)
|
||||
(code:line #:type-constructor type-ctor-id))
|
||||
(maybe-alias (code:line)
|
||||
(code:line #:with alias alias-body))]]{
|
||||
Defines a container analagous to a prefab @racket[struct]. Includes accessor
|
||||
functions for each @racket[slot-id]. (But not, presently, a predicate function).
|
||||
|
||||
When a @racket[type-ctor-id] is provided, the type of such structures is
|
||||
@racket[(type-ctor-id type ...)], where each @racket[type] describes the value
|
||||
of the corresponding slot. When not provided, the type constructor is named by
|
||||
appending @racket["/t"] to @racket[ctor-id].
|
||||
|
||||
Each @racket[alias] and @racket[alias-body] creates an instance of
|
||||
@racket[define-type-alias].
|
||||
}
|
||||
|
||||
@defform[#:literals (:)
|
||||
(define-constructor* (ctor-id : type-ctor-id slot-id ...)
|
||||
maybe-alias ...)]{
|
||||
An abbreviated form of @racket[define-constructor].
|
||||
}
|
||||
|
||||
@defform[#:literals (:)
|
||||
(assertion-struct ctor-id : type-ctor-id (slot-id ...))]{
|
||||
An abbreviated form of @racket[define-constructor].
|
||||
}
|
||||
|
||||
@defform[#:literals (:)
|
||||
(message-struct ctor-id : type-ctor-id (slot-id ...))]{
|
||||
An abbreviated form of @racket[define-constructor].
|
||||
}
|
||||
|
||||
@section{Actor Forms}
|
||||
|
||||
@defform[(run-ground-dataspace type expr ...)]{
|
||||
Starts a ground, i.e. main, dataspace of the program, with the given
|
||||
communication @racket[type] and initial actors spawned by @racket[expr ...].
|
||||
}
|
||||
|
||||
@defform[(spawn maybe-type s)
|
||||
#:grammar
|
||||
[(maybe-type (code:line)
|
||||
(code:line type))]]{
|
||||
Spawns an actor with behavior given by @racket[s]. The @racket[type] gives the
|
||||
communication type of the enclosing dataspace. When absent, @racket[type] is
|
||||
supplied by the nearest lexically enclosing @racket[spawn] or @racket[dataspace]
|
||||
form, if any exist.
|
||||
}
|
||||
|
||||
@defform[(dataspace type expr ...)]{
|
||||
Spawns a dataspace with communication type @racket[type] as a child of the
|
||||
dataspace enclosing the executing actor. The script @racket[expr ...] spawns the
|
||||
initial actors of the new dataspace.
|
||||
}
|
||||
|
||||
@defform[(start-facet id maybe-spec expr ...+)
|
||||
#:grammar
|
||||
[(maybe-spec (code:line)
|
||||
(code:line #:implements type)
|
||||
(code:line #:includes-behavior type))]]{
|
||||
Start a facet with name @racket[id] and endpoints installed through the
|
||||
evaluation of @racket[expr ...].
|
||||
}
|
||||
|
||||
@defform[(stop id expr ...)]{
|
||||
Terminate the facet @racket[id] with continuation script @racket[expr ...]. Any
|
||||
facets started by the continuation script survive the termination of facet
|
||||
@racket[id].
|
||||
}
|
||||
|
||||
@defform[#:literals (start stop message asserted retracted _ $)
|
||||
(on event-description body ...+)
|
||||
#:grammar
|
||||
[(event-description (code:line start)
|
||||
(code:line stop)
|
||||
(code:line (message pattern))
|
||||
(code:line (asserted pattern))
|
||||
(code:line (retracted pattern)))
|
||||
(pattern (code:line _)
|
||||
(code:line ($ id type))
|
||||
(code:line ($ id))
|
||||
(code:line $id)
|
||||
(code:line $id:type)
|
||||
(code:line (ctor pattern ...))
|
||||
(code:line expr))]]{
|
||||
Creates an event handler endpoint that responds to the event specified by
|
||||
@racket[event-description]. Executes the @racket[body ...] for each matching
|
||||
event, with any pattern variables bound to their matched value.
|
||||
|
||||
Patterns have the following meanings:
|
||||
@itemlist[
|
||||
@item{@racket[_] matches anything.}
|
||||
|
||||
@item{@racket[($ id type)] matches any value and binds it to @racket[id] with
|
||||
assumed type @racket[type].}
|
||||
|
||||
@item{@racket[($ id)] is like @racket[($ id type)], but attempts to use the
|
||||
current communication type to fill in the @racket[type] of potential matches.
|
||||
May raise an error if no suitable communication type is in scope.}
|
||||
|
||||
@item{@racket[(? pred pattern)] matches values where @racket[(pred val)] is not
|
||||
@racket[#f] and that match @racket[pattern].}
|
||||
|
||||
@item{@racket[$id:type] is shorthand for @racket[($ id type)].}
|
||||
|
||||
@item{@racket[$id] is shorthand for @racket[($ id)].}
|
||||
|
||||
@item{@racket[(ctor pat ...)] matches values built by applying the constructor
|
||||
@racket[ctor] to values matching @racket[pat ...]. @racket[ctor] is usually
|
||||
a @racket[struct] name.}
|
||||
|
||||
@item{@racket[expr] patterns match values that are @racket[equal?] to
|
||||
@racket[expr].}
|
||||
]
|
||||
}
|
||||
|
||||
@defform[(on-start expr ...+)]{
|
||||
Shorthand for @racket[(on start expr ...)].
|
||||
}
|
||||
|
||||
@defform[(on-stop expr ...+)]{
|
||||
Shorthand for @racket[(on stop expr ...)].
|
||||
}
|
||||
|
||||
@defform[(assert expr)]{
|
||||
Creates an assertion endpoint with the value of @racket[expr].
|
||||
}
|
||||
|
||||
@defform[(know expr)]{
|
||||
Creates an internal assertion endpoint with the value of @racket[expr].
|
||||
}
|
||||
|
||||
@defform[(send! expr)]{
|
||||
Broadcast a dataspace message with the value of @racket[expr].
|
||||
}
|
||||
|
||||
@defform[(realize! expr)]{
|
||||
Broadcast an actor-internal message with the value of @racket[expr].
|
||||
}
|
||||
|
||||
@defform[#:literals (:)
|
||||
(field [id maybe-type expr] ...)
|
||||
#:grammar
|
||||
[(maybe-type (code:line)
|
||||
(code:line type)
|
||||
(code:line : type))]]{
|
||||
Defines fields of type @racket[type] with names @racket[id] and initial values
|
||||
@racket[expr]. If @racket[type] is not provided, the type of the initial
|
||||
expression is used as the type of the field.
|
||||
}
|
||||
|
||||
@defform[(ref id)]{
|
||||
Reference the @racket[field] named @racket[id].
|
||||
}
|
||||
|
||||
@defform[(set! id expr)]{
|
||||
Update the value the @racket[field] named @racket[id].
|
||||
}
|
||||
|
||||
@defform[(begin/dataflow expr ...+)]{
|
||||
Evaluate and perform the script @racket[expr ...], and then again each time a
|
||||
field referenced by the script updates.
|
||||
}
|
||||
|
||||
@defform[(during pattern expr ...+)]{
|
||||
Engage in behavior for the duration of a matching assertion. The syntax of
|
||||
@racket[pattern] is the same as described by @racket[on].
|
||||
}
|
||||
|
||||
@defform[(during/spawn pattern expr ...+)]{
|
||||
Like @racket[during], but spawns an actor for the behavior @racket[expr ...].
|
||||
}
|
||||
|
||||
@defform[(define/query-value name absent-expr pattern expr
|
||||
maybe-on-add
|
||||
maybe-on-remove)
|
||||
#:grammar
|
||||
[(maybe-on-add (code:line)
|
||||
(code:line #:on-add on-add-expr))
|
||||
(maybe-on-remove (code:line)
|
||||
(code:line #:on-remove on-remove-expr))]]{
|
||||
Equivalent to the untyped @racket[untyped:define/query-value].
|
||||
}
|
||||
|
||||
@defform[(define/query-set name pattern expr
|
||||
maybe-on-add
|
||||
maybe-on-remove)
|
||||
#:grammar
|
||||
[(maybe-on-add (code:line)
|
||||
(code:line #:on-add on-add-expr))
|
||||
(maybe-on-remove (code:line)
|
||||
(code:line #:on-remove on-remove-expr))]]{
|
||||
Equivalent to the untyped @racket[untyped:define/query-set].
|
||||
}
|
||||
|
||||
@defform[(define/query-hash name pattern key-expr value-expr
|
||||
maybe-on-add
|
||||
maybe-on-remove)
|
||||
#:grammar
|
||||
[(maybe-on-add (code:line)
|
||||
(code:line #:on-add on-add-expr))
|
||||
(maybe-on-remove (code:line)
|
||||
(code:line #:on-remove on-remove-expr))]]{
|
||||
Equivalent to the untyped @racket[untyped:define/query-hash].
|
||||
}
|
||||
|
||||
@defform[(define/dataflow name maybe-type expr)
|
||||
#:grammar
|
||||
[(maybe-type (code:line)
|
||||
(code:line type))]]{
|
||||
Define a @racket[field] named @racket[name], whose value is reevaluated to the
|
||||
result of @racket[expr] each time any referenced field changes. When
|
||||
@racket[type] is not supplied, the field has the type of the given
|
||||
@racket[expr].
|
||||
}
|
||||
|
||||
@section{Expressions}
|
||||
|
||||
@defform*[#:literals (:)
|
||||
[(ann expr : type)
|
||||
(ann expr type)]]{
|
||||
Ensure that @racket[expr] has the given @racket[type].
|
||||
}
|
||||
|
||||
@defform[(if test-expr then-expr else-expr)]{
|
||||
The same as Racket's @racket[racket:if].
|
||||
}
|
||||
|
||||
@deftogether[(@defform[(cond [test-expr body-expr ...+] ...+)]
|
||||
@defthing[else Bool #:value #t])]{
|
||||
Like Racket's @racket[racket:cond].
|
||||
}
|
||||
|
||||
@defform[(when test-expr expr)]{
|
||||
Like Racket's @racket[racket:when], but results in @racket[#f] when
|
||||
@racket[test-expr] is @racket[#f].
|
||||
}
|
||||
|
||||
@defform[(unless test-expr expr)]{
|
||||
Like Racket's @racket[racket:unless], but results in @racket[#f] when
|
||||
@racket[test-expr] is @racket[#f].
|
||||
}
|
||||
|
||||
@defform[(let ([id expr] ...) body ...+)]{
|
||||
The same as Racket's @racket[racket:let].
|
||||
}
|
||||
|
||||
@defform[(let* ([id expr] ...) body ...+)]{
|
||||
The same as Racket's @racket[racket:let*].
|
||||
}
|
||||
|
||||
@defform[#:literals (:)
|
||||
(lambda ([x opt-: type] ...) expr ...+)
|
||||
#:grammar
|
||||
[(opt-: (code:line)
|
||||
(code:line :))]]{
|
||||
Constructsa an anonymous function.
|
||||
}
|
||||
|
||||
@defidform[λ]{Synonym for @racket[lambda].}
|
||||
|
||||
@defform[(Λ (X ...) expr)]{
|
||||
Parametric abstraction over type variables @racket[X ...].
|
||||
}
|
||||
|
||||
@defform[(inst expr type ...)]{
|
||||
Instantiates the type variables @racket[X ...] with @racket[type ...], where
|
||||
@racket[expr] has type @racket[(∀ (X ...) t)].
|
||||
}
|
||||
|
||||
@defform*[#:literals (: → -> ∀)
|
||||
[(define id : type expr)
|
||||
(define id expr)
|
||||
(define (id [arg-id opt-: arg-type] ... opt-res-ty) expr ...+)
|
||||
(define (∀ (X ...) (id [arg-id opt-: arg-type] ... opt-res-ty)) expr ...+)]
|
||||
#:grammar
|
||||
[(opt-: (code:line) (code:line :))
|
||||
(opt-res-ty (code:line)
|
||||
(code:line arr res-type))
|
||||
(arr (code:line →) (code:line ->))]]{
|
||||
Define a constant or a (potentially polymorphic) function. Note that the
|
||||
function name @racket[id] is @emph{not} bound in the body.
|
||||
}
|
||||
|
||||
@defform[(define-tuple (id ...) expr)]{
|
||||
Define @racket[id ...] to each of the slots of the tuple produced by
|
||||
@racket[expr].
|
||||
}
|
||||
|
||||
@defform[(match-define pattern expr)]{
|
||||
Define the binders of @racket[pattern] to the matching values of @racket[expr].
|
||||
}
|
||||
|
||||
@defform[(begin expr ...+)]{
|
||||
Sequencing form whose value and type is that of the final @racket[expr].
|
||||
}
|
||||
|
||||
@defform[(block expr ...+)]{
|
||||
Like @racket[begin], but also introduces a definition context for its body.
|
||||
}
|
||||
|
||||
@defform[(match expr [pattern body-expr ...+] ...+)]{
|
||||
Like Racket's @racket[racket:match] but with the pattern syntax described by
|
||||
@racket[on].
|
||||
}
|
||||
|
||||
@defform[(tuple expr ...)]{
|
||||
Constructs a tuple of arbitrary arity.
|
||||
}
|
||||
|
||||
@defform[(select i expr)]{
|
||||
Extract the @racket[i]th element of a @racket[tuple].
|
||||
}
|
||||
|
||||
@defthing[unit Unit #:value (tuple)]
|
||||
|
||||
@defform[(error format-expr arg-expr ...)]{
|
||||
Raises an exception using @racket[format-expr] as a format string together with
|
||||
@racket[arg-expr ...].
|
||||
}
|
||||
|
||||
@deftogether[(
|
||||
@defthing[+ (→fn Int Int Int)]
|
||||
@defthing[- (→fn Int Int Int)]
|
||||
@defthing[* (→fn Int Int Int)]
|
||||
@defthing[< (→fn Int Int Bool)]
|
||||
@defthing[> (→fn Int Int Bool)]
|
||||
@defthing[<= (→fn Int Int Bool)]
|
||||
@defthing[>= (→fn Int Int Bool)]
|
||||
@defthing[= (→fn Int Int Bool)]
|
||||
@defthing[even? (→fn Int Bool)]
|
||||
@defthing[odd? (→fn Int Bool)]
|
||||
@defthing[add1 (→fn Int Int)]
|
||||
@defthing[sub1 (→fn Int Int)]
|
||||
@defthing[max (→fn Int Int Int)]
|
||||
@defthing[min (→fn Int Int Int)]
|
||||
@defthing[zero? (→fn Int Bool)]
|
||||
@defthing[positive? (→fn Int Bool)]
|
||||
@defthing[negative? (→fn Int Bool)]
|
||||
@defthing[current-inexact-milleseconds? (→fn Int)]
|
||||
@defthing[string=? (→fn String String Bool)]
|
||||
@defthing[bytes->string/utf-8 (→fn ByteString String)]
|
||||
@defthing[string->bytes/utf-8 (→fn String ByteString)]
|
||||
@defthing[gensym (→fn Symbol Symbol)]
|
||||
@defthing[symbol->string (→fn Symbol String)]
|
||||
@defthing[string->symbol (→fn String Symbol)]
|
||||
@defthing[not (→fn Bool Bool)]
|
||||
@defform[(/ e1 e2)]
|
||||
@defform[(and e ...)]
|
||||
@defform[(or e ...)]
|
||||
@defform[(equal? e1 e2)]
|
||||
@defform[(displayln e)]
|
||||
@defform[(printf fmt-expr val-expr ...)]
|
||||
@defform[(~a e ...)]
|
||||
)]{
|
||||
Primitive operations imported from Racket.
|
||||
}
|
||||
|
||||
@defform[#:literals (:)
|
||||
(for/fold ([acc-id maybe-:ty acc-expr] ...+)
|
||||
(for-clause ...)
|
||||
body-expr ...+)
|
||||
#:grammar
|
||||
[(maybe-:ty (code:line)
|
||||
(code:line : acc-type))
|
||||
(for-clause (code:line [id seq-expr])
|
||||
(code:line [id : type seq-expr])
|
||||
(code:line [(k-id v-id) hash-expr])
|
||||
(code:line #:when test-expr)
|
||||
(code:line #:unless test-expr)
|
||||
(code:line #:break test-expr))]]{
|
||||
Similar to Racket's @racket[racket:for/fold].
|
||||
|
||||
When more than one @racket[acc-id] is used, the body of the loop must evaluate
|
||||
to a @racket[tuple] with one value for each accumulator, with the final tuple
|
||||
also being the result of the entire expression.
|
||||
|
||||
Each @racket[seq-expr] should be of type @racket[Sequence], though expressions
|
||||
of type @racket[List] and @racket[Set] are automatically converted.
|
||||
}
|
||||
|
||||
@deftogether[(
|
||||
@defform[(for/list (for-clause ...) body ...+)]
|
||||
@defform[(for/set (for-clause ...) body ...+)]
|
||||
@defform[(for/sum (for-clause ...) body ...+)]
|
||||
@defform[(for (for-clause ...) body ...+)]
|
||||
@defform[(for/first (for-clause ...) body ...+)]
|
||||
)]{
|
||||
Like their Racket counterparts. See @racket[for/fold] for the description of
|
||||
@racket[for-clause].
|
||||
|
||||
Unlike @racket[racket:for/first], @racket[for/first] returns a @racket[Maybe]
|
||||
value to indicate success/failure.
|
||||
}
|
||||
|
||||
@section{Require & Provide}
|
||||
|
||||
@defform[(struct-out ctor-id)]{
|
||||
}
|
||||
|
||||
@subsection{Requiring From Outside Typed Syndicate}
|
||||
|
||||
@defform[#:literals (:)
|
||||
(require/typed lib clause ...)
|
||||
#:grammar
|
||||
[(clause (code:line [id : type])
|
||||
(code:line opaque))
|
||||
(opaque (code:line [#:opaque type-name])
|
||||
(code:line [#:opaque type-name #:arity op arity-nat]))
|
||||
(opaque (code:line =) (code:line >) (code:line >=))]]{
|
||||
Import and assign types to bindings from outside Typed Syndicate.
|
||||
|
||||
Note that @emph{unlike} Typed Racket, Typed Syndicate does not attach contracts
|
||||
to imported bindings.
|
||||
|
||||
An @racket[#:opaque] declaration defines a type @racket[type-name] (or, in the
|
||||
@racket[#:arity] case, a type constructor) that may be used to describe imports
|
||||
but otherwise has no other operations.
|
||||
}
|
||||
|
||||
@defform[(require-struct ctor-id #:as ty-ctor-id #:from lib maybe-omit-accs)
|
||||
#:grammar
|
||||
[(maybe-omit-accs (code:line)
|
||||
(code:line #:omit-accs))]]{
|
||||
Import a Racket @racket[struct] named @racket[ctor-id] and create a type
|
||||
constructor @racket[ty-ctor-id] for its instances.
|
||||
|
||||
Unless @racket[#:omit-accs] is specified, defines the accessor functions for the
|
||||
struct.
|
||||
}
|
||||
|
||||
|
||||
@section{Builtin Data Structures}
|
||||
|
||||
@deftogether[(@defstruct[observe ([claim any?]) #:omit-constructor]
|
||||
@defform[(Observe type)])]{
|
||||
Constructs an assertion of interest.
|
||||
}
|
||||
|
||||
@deftogether[(@defstruct[inbound ([assertion any?]) #:omit-constructor]
|
||||
@defform[(Inbound type)])]{
|
||||
Constructor for an assertion inbound from an outer dataspace.
|
||||
}
|
||||
|
||||
@deftogether[(@defstruct[outbound ([assertion any?]) #:omit-constructor]
|
||||
@defform[(Outbound type)])]{
|
||||
Constructor for an assertion outbound to an outer dataspace.
|
||||
}
|
||||
|
||||
@deftogether[(@defstruct[message ([body any?]) #:omit-constructor]
|
||||
@defform[(Message type)])]{
|
||||
Constructor for a broadcast message.
|
||||
}
|
||||
|
||||
@subsection{Lists}
|
||||
|
||||
@defform[(List type)]{
|
||||
The type for @racket[cons] lists whose elements are of type @racket[type].
|
||||
}
|
||||
|
||||
@deftogether[(
|
||||
@defthing[empty (List ⊥)]
|
||||
@defthing[empty? (∀ (X) (→fn (List X) Bool))]
|
||||
@defthing[cons (∀ (X) (→fn X (List X) (List X)))]
|
||||
@defthing[cons? (∀ (X) (→fn X (List X) Bool))]
|
||||
@defthing[first (∀ (X) (→fn (List X) X))]
|
||||
@defthing[second (∀ (X) (→fn (List X) X))]
|
||||
@defthing[rest (∀ (X) (→fn (List X) (List X)))]
|
||||
@defthing[member? (∀ (X) (→fn X (List X) Bool))]
|
||||
@defthing[reverse (∀ (X) (→fn (List X) (List X)))]
|
||||
@defthing[partition (∀ (X) (→fn (List X) (→fn X Bool) (List X)))]
|
||||
@defthing[map (∀ (X Y) (→fn (→fn X Y) (List X) (List Y)))]
|
||||
@defthing[argmax (∀ (X) (→fn (→fn X Int) (List X) X))]
|
||||
@defthing[argmin (∀ (X) (→fn (→fn X Int) (List X) X))]
|
||||
@defthing[remove (∀ (X) (→fn X (List X) (List X)))]
|
||||
@defthing[length (∀ (X) (→fn (List X) Int))]
|
||||
@defform[(list e ...)]
|
||||
)]{
|
||||
Like their Racket counterparts.
|
||||
}
|
||||
|
||||
@subsection{Sets}
|
||||
|
||||
@defform[(Set type)]{
|
||||
The type for sets whose elements are of type @racket[type].
|
||||
}
|
||||
|
||||
@deftogether[(
|
||||
@defform[(set e ...)]
|
||||
@defform[(set-union st ...+)]
|
||||
@defform[(set-intersect st ...+)]
|
||||
@defform[(set-subtract st ...+)]
|
||||
@defthing[set-first (∀ (X) (→fn (Set X) X))]
|
||||
@defthing[set-empty? (∀ (X) (→fn (Set X) Bool))]
|
||||
@defthing[set-count (∀ (X) (→fn (Set X) Int))]
|
||||
@defthing[set-add (∀ (X) (→fn (Set X) X (Set X)))]
|
||||
@defthing[set-remove (∀ (X) (→fn (Set X) X (Set X)))]
|
||||
@defthing[set-member? (∀ (X) (→fn (Set X) X Bool))]
|
||||
@defthing[list->set (∀ (X) (→fn (List X) (Set X)))]
|
||||
@defthing[set->list (∀ (X) (→fn (Set X) (List X)))]
|
||||
)]{
|
||||
Like their Racket counterparts.
|
||||
}
|
||||
|
||||
@subsection{Hashes}
|
||||
|
||||
@defform[(Hash key-type value-type)]{
|
||||
The type for key/value hash tables.
|
||||
}
|
||||
|
||||
@deftogether[(
|
||||
@defform[(hash key val ... ...)]
|
||||
@defthing[hash-set (∀ (K V) (→fn (Hash K V) K V (Hash K V)))]
|
||||
@defthing[hash-ref (∀ (K V) (→fn (Hash K V) K V))]
|
||||
@defthing[hash-ref/failure (∀ (K V) (→fn (Hash K V) K V V))]
|
||||
@defthing[hash-empty? (∀ (K V) (→fn (Hash K V) Bool))]
|
||||
@defthing[hash-has-key? (∀ (K V) (→fn (Hash K V) K Bool))]
|
||||
@defthing[hash-count (∀ (K V) (→fn (Hash K V) Int))]
|
||||
@defthing[hash-update (∀ (K V) (→fn (Hash K V) K (→fn V V) (Hash K V)))]
|
||||
@defthing[hash-update/failure (∀ (K V) (→fn (Hash K V) K (→fn V V) V (Hash K V)))]
|
||||
@defthing[hash-remove (∀ (K V) (→fn (Hash K V) K (Hash K V)))]
|
||||
@defthing[hash-map (∀ (K V R) (→fn (Hash K V) (→fn K V R) (List R)))]
|
||||
@defthing[hash-keys (∀ (K V) (→fn (Hash K V) (List K)))]
|
||||
@defthing[hash-values (∀ (K V) (→fn (Hash K V) (List V)))]
|
||||
@defthing[hash-union (∀ (K1 V1 K2 V2) (→fn (Hash K1 V1) (Hash K2 V2) (Hash (U K1 K2) (U V1 V2))))]
|
||||
@defthing[hash-union/combine (∀ (K V) (→fn (Hash K V) (Hash K V) (→fn V V V) (Hash K V)))]
|
||||
@defthing[hash-keys-subset? (∀ (K1 V1 K2 V2) (→fn (Hash K1 V1) (Hash K2 V2) Bool))]
|
||||
)]{
|
||||
Like their Racket counterparts. The /failure and /combine suffixes are in place
|
||||
of keyword arguments, which Typed Syndicate does not presently support.
|
||||
}
|
||||
|
||||
@subsection{Sequences}
|
||||
|
||||
@defform[(Sequence type)]{
|
||||
The type for a sequence of @racket[type] values.
|
||||
}
|
||||
|
||||
@deftogether[(
|
||||
@defthing[empty-sequence (Sequence ⊥)]
|
||||
@defthing[sequence->list (∀ (X) (→fn (Sequence X) (List X)))]
|
||||
@defthing[sequence-length (∀ (X) (→fn (Sequence X) Int))]
|
||||
@defthing[sequence-ref (∀ (X) (→fn (Sequence X) Int Int))]
|
||||
@defthing[sequence-tail (∀ (X) (→fn (Sequence X) Int (Sequence X)))]
|
||||
@defthing[sequence-append (∀ (X) (→fn (Sequence X) (Sequence X) (Sequence X)))]
|
||||
@defthing[sequence-map (∀ (A B) (→fn (→fn A B) (Sequence A) (Sequence B)))]
|
||||
@defthing[sequence-andmap (∀ (X) (→fn (→fn X Bool) (Sequence X) Bool))]
|
||||
@defthing[sequence-ormap (∀ (X) (→fn (→fn X Bool) (Sequence X) Bool))]
|
||||
@defthing[sequence-fold (∀ (A B) (→fn (→fn A B A) (Sequence B) A))]
|
||||
@defthing[sequence-count (∀ (X) (→fn (→fn X Bool) (Sequence X) Int))]
|
||||
@defthing[sequence-filter (∀ (X) (→fn (→fn X Bool) (Sequence X) (Sequence X)))]
|
||||
@defthing[sequence-add-between (∀ (X) (→fn (Sequence X) X (Sequence X)))]
|
||||
@defthing[in-list (∀ (X) (→fn (List X) (Sequence X)))]
|
||||
@defthing[in-hash-keys (∀ (K V) (→fn (Hash K V) (Sequence K)))]
|
||||
@defthing[in-hash-values (∀ (K V) (→fn (Hash K V) (Sequence V)))]
|
||||
@defthing[in-range (→fn Int (Sequence Int))]
|
||||
@defthing[in-set (∀ (X) (→fn (Set X) (Sequence X)))]
|
||||
)]{
|
||||
Like their Racket counterparts.
|
||||
}
|
||||
|
||||
@subsection{Maybe}
|
||||
|
||||
@deftogether[(
|
||||
@defidform[None]
|
||||
@defthing[none None]
|
||||
@defstruct[some ([v any?]) #:omit-constructor]
|
||||
@defform[(Some type)]
|
||||
@defform[(Maybe type)]
|
||||
)]{
|
||||
@racket[(Maybe type)] is an alias for @racket[(U None (Some type))].
|
||||
}
|
||||
|
||||
@subsection{Either}
|
||||
|
||||
@deftogether[(
|
||||
@defstruct[left ([v any?]) #:omit-constructor]
|
||||
@defform[(Left type)]
|
||||
@defstruct[right ([v any?]) #:omit-constructor]
|
||||
@defform[(Right type)]
|
||||
@defform[(Either left-type right-type)]
|
||||
)]{
|
||||
@racket[(Either left-type right-type)] is an alias for @racket[(U (Left
|
||||
left-type) (Right right-type))].
|
||||
}
|
||||
|
||||
@defthing[partition/either (∀ (X Y Z) (→fn (List X) (→fn X (Either Y Z)) (Tuple (List Y) (List Z))))]{
|
||||
Partition a list based on a function that returns an @racket[Either] value.
|
||||
}
|
||||
|
||||
@section{Behavioral Checking}
|
File diff suppressed because it is too large
Load Diff
|
@ -1,410 +0,0 @@
|
|||
#lang turnstile
|
||||
|
||||
(provide bind
|
||||
discard
|
||||
ann
|
||||
if
|
||||
when
|
||||
unless
|
||||
let
|
||||
let*
|
||||
cond
|
||||
else
|
||||
match
|
||||
tuple
|
||||
unit
|
||||
select
|
||||
error
|
||||
define-tuple
|
||||
match-define
|
||||
mk-tuple
|
||||
tuple-select
|
||||
(for-syntax (all-defined-out)))
|
||||
|
||||
(require "core-types.rkt")
|
||||
(require (only-in "prim.rkt" Bool String #%datum))
|
||||
(require (postfix-in - racket/match))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Patterns
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-typed-syntax (bind x:id τ:type) ≫
|
||||
----------------------------------------
|
||||
[⊢ (#%app- error- 'bind "escaped") (⇒ : (Bind τ))])
|
||||
|
||||
(define-typed-syntax discard
|
||||
[_ ≫
|
||||
--------------------
|
||||
[⊢ (#%app- error- 'discard "escaped") (⇒ : Discard)]])
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Core-ish forms
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; copied from stlc
|
||||
(define-typed-syntax (ann e (~optional (~datum :)) τ:type) ≫
|
||||
[⊢ e ≫ e- (⇐ : τ.norm)]
|
||||
#:fail-unless (pure? #'e-) "expression must be pure"
|
||||
------------------------------------------------
|
||||
[⊢ e- (⇒ : τ.norm) ])
|
||||
|
||||
;; copied from ext-stlc
|
||||
(define-typed-syntax if
|
||||
[(_ e_tst e1 e2) ⇐ τ-expected ≫
|
||||
[⊢ e_tst ≫ e_tst- ⇒ _] ; Any non-false value is truthy.
|
||||
#:fail-unless (pure? #'e_tst-) "expression must be pure"
|
||||
[⊢ e1 ≫ e1- (⇐ : τ-expected)
|
||||
(⇒ ν-ep (~effs eps1 ...)) (⇒ ν-f (~effs fs1 ...)) (⇒ ν-s (~effs ss1 ...))]
|
||||
[⊢ e2 ≫ e2- (⇐ : τ-expected)
|
||||
(⇒ ν-ep (~effs eps2 ...)) (⇒ ν-f (~effs fs2 ...)) (⇒ ν-s (~effs ss2 ...))]
|
||||
--------
|
||||
[⊢ (if- e_tst- e1- e2-)
|
||||
(⇒ : τ-expected)
|
||||
(⇒ ν-ep (eps1 ... eps2 ...))
|
||||
(⇒ ν-f #,(make-Branch #'((fs1 ...) (fs2 ...))))
|
||||
(⇒ ν-s (ss1 ... ss2 ...))]]
|
||||
[(_ e_tst e1 e2) ≫
|
||||
[⊢ e_tst ≫ e_tst- ⇒ _] ; Any non-false value is truthy.
|
||||
#:fail-unless (pure? #'e_tst-) "expression must be pure"
|
||||
[⊢ e1 ≫ e1- (⇒ : τ1)
|
||||
(⇒ ν-ep (~effs eps1 ...)) (⇒ ν-f (~effs fs1 ...)) (⇒ ν-s (~effs ss1 ...))]
|
||||
[⊢ e2 ≫ e2- (⇒ : τ2)
|
||||
(⇒ ν-ep (~effs eps2 ...)) (⇒ ν-f (~effs fs2 ...)) (⇒ ν-s (~effs ss2 ...))]
|
||||
#:with τ (mk-U- #'(τ1 τ2))
|
||||
--------
|
||||
[⊢ (if- e_tst- e1- e2-) (⇒ : τ)
|
||||
(⇒ ν-ep (eps1 ... eps2 ...))
|
||||
(⇒ ν-f #,(make-Branch #'((fs1 ...) (fs2 ...))))
|
||||
(⇒ ν-s (ss1 ... ss2 ...))]])
|
||||
|
||||
(define-typed-syntax (when e s ...+) ≫
|
||||
------------------------------------
|
||||
[≻ (if e (let () s ...) #f)])
|
||||
|
||||
(define-typed-syntax (unless e s ...+) ≫
|
||||
------------------------------------
|
||||
[≻ (if e #f (let () s ...))])
|
||||
|
||||
|
||||
;; copied from ext-stlc
|
||||
(define-typed-syntax let
|
||||
[(_ ([x e] ...) e_body ...) ⇐ τ_expected ≫
|
||||
[⊢ e ≫ e- ⇒ : τ_x] ...
|
||||
#:fail-unless (stx-andmap pure? #'(e- ...)) "expressions must be pure"
|
||||
[[x ≫ x- : τ_x] ... ⊢ (block e_body ...) ≫ e_body- (⇐ : τ_expected)
|
||||
(⇒ ν-ep (~effs eps ...))
|
||||
(⇒ ν-f (~effs fs ...))
|
||||
(⇒ ν-s (~effs ss ...))]
|
||||
----------------------------------------------------------
|
||||
[⊢ (let- ([x- e-] ...) e_body-) (⇒ : τ_expected)
|
||||
(⇒ ν-ep (eps ...))
|
||||
(⇒ ν-f (fs ...))
|
||||
(⇒ ν-s (ss ...))]]
|
||||
[(_ ([x e] ...) e_body ...) ≫
|
||||
[⊢ e ≫ e- ⇒ : τ_x] ...
|
||||
#:fail-unless (stx-andmap pure? #'(e- ...)) "expressions must be pure"
|
||||
[[x ≫ x- : τ_x] ... ⊢ (block e_body ...) ≫ e_body- (⇒ : τ_body)
|
||||
(⇒ ν-ep (~effs eps ...))
|
||||
(⇒ ν-f (~effs fs ...))
|
||||
(⇒ ν-s (~effs ss ...))]
|
||||
----------------------------------------------------------
|
||||
[⊢ (let- ([x- e-] ...) e_body-) (⇒ : τ_body)
|
||||
(⇒ ν-ep (eps ...))
|
||||
(⇒ ν-f (fs ...))
|
||||
(⇒ ν-s (ss ...))]])
|
||||
|
||||
;; copied from ext-stlc
|
||||
(define-typed-syntax let*
|
||||
[(_ () e_body ...) ≫
|
||||
--------
|
||||
[≻ (block e_body ...)]]
|
||||
[(_ ([x e] [x_rst e_rst] ...) e_body ...) ≫
|
||||
--------
|
||||
[≻ (let ([x e]) (let* ([x_rst e_rst] ...) e_body ...))]])
|
||||
|
||||
(define-typed-syntax (cond [pred:expr s ...+] ...+) ≫
|
||||
[⊢ pred ≫ pred- (⇐ : Bool)] ...
|
||||
#:fail-unless (stx-andmap pure? #'(pred- ...)) "predicates must be pure"
|
||||
[⊢ (block s ...) ≫ s- (⇒ : τ-s)
|
||||
(⇒ ν-ep (~effs eps ...))
|
||||
(⇒ ν-f (~effs fs ...))
|
||||
(⇒ ν-s (~effs ss ...))] ...
|
||||
------------------------------------------------
|
||||
[⊢ (cond- [pred- s-] ...) (⇒ : (U τ-s ...))
|
||||
(⇒ ν-ep (eps ... ...))
|
||||
(⇒ ν-f #,(make-Branch #'((fs ...) ...)))
|
||||
(⇒ ν-s (ss ... ...))])
|
||||
|
||||
(define else #t)
|
||||
|
||||
(define-typed-syntax (match e [p s ...+] ...+) ≫
|
||||
[⊢ e ≫ e- (⇒ : τ-e)]
|
||||
#:fail-unless (pure? #'e-) "expression must be pure"
|
||||
#:with (p/e ...) (for/list ([pat (in-syntax #'(p ...))])
|
||||
(elaborate-pattern/with-type pat #'τ-e))
|
||||
#:with (([x τ:type] ...) ...) (stx-map pat-bindings #'(p/e ...))
|
||||
[[x ≫ x- : τ.norm] ... ⊢ (block s ...) ≫ s- (⇒ : τ-s)
|
||||
(⇒ ν-ep (~effs eps ...))
|
||||
(⇒ ν-f (~effs fs ...))
|
||||
(⇒ ν-s (~effs ss ...))] ...
|
||||
;; REALLY not sure how to handle p/p-/p.match-pattern,
|
||||
;; particularly w.r.t. typed terms that appear in p.match-pattern
|
||||
[⊢ p/e ≫ p-- ⇒ τ-p] ...
|
||||
#:fail-unless (project-safe? #'τ-e (mk-U*- #'(τ-p ...))) "possibly unsafe pattern match"
|
||||
#:fail-unless (stx-andmap pure? #'(p-- ...)) "patterns must be pure"
|
||||
#:with (p- ...) (stx-map (lambda (p x-s xs) (substs x-s xs (compile-match-pattern p)))
|
||||
#'(p/e ...)
|
||||
#'((x- ...) ...)
|
||||
#'((x ...) ...))
|
||||
--------------------------------------------------------------
|
||||
[⊢ (match- e- [p- s-] ...
|
||||
[_ (#%app- error- "incomplete pattern match")])
|
||||
(⇒ : (U τ-s ...))
|
||||
(⇒ ν-ep #,(make-Branch #'((eps ...) ...)))
|
||||
(⇒ ν-f #,(make-Branch #'((fs ...) ...)))
|
||||
(⇒ ν-s #,(make-Branch #'((ss ...) ...)))])
|
||||
|
||||
|
||||
;; (Listof Value) -> Value
|
||||
(define- (mk-tuple es)
|
||||
(#%app- cons- 'tuple es))
|
||||
|
||||
(define-typed-syntax (tuple e:expr ...) ≫
|
||||
[⊢ e ≫ e- (⇒ : τ)] ...
|
||||
#:fail-unless (stx-andmap pure? #'(e- ...)) "expressions not allowed to have effects"
|
||||
-----------------------
|
||||
[⊢ (#%app- mk-tuple (#%app- list- e- ...)) (⇒ : (Tuple τ ...))])
|
||||
|
||||
(define unit : Unit (tuple))
|
||||
|
||||
(define-typed-syntax (select n:nat e:expr) ≫
|
||||
[⊢ e ≫ e- (⇒ : (~Tuple τ ...))]
|
||||
#:fail-unless (pure? #'e-) "expression not allowed to have effects"
|
||||
#:do [(define i (syntax->datum #'n))]
|
||||
#:fail-unless (< i (stx-length #'(τ ...))) "index out of range"
|
||||
#:with τr (list-ref (stx->list #'(τ ...)) i)
|
||||
--------------------------------------------------------------
|
||||
[⊢ (#%app- tuple-select n e-) (⇒ : τr)])
|
||||
|
||||
(define- (tuple-select n t)
|
||||
(#%app- list-ref- t (#%app- add1- n)))
|
||||
|
||||
(define-typed-syntax (error msg args ...) ≫
|
||||
[⊢ msg ≫ msg- (⇐ : String)]
|
||||
[⊢ args ≫ args- (⇒ : τ)] ...
|
||||
#:fail-unless (all-pure? #'(msg- args- ...)) "expressions must be pure"
|
||||
----------------------------------------
|
||||
[⊢ (#%app- error- msg- args- ...) (⇒ : ⊥)])
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Helpers
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; pat -> ([Id Type] ...)
|
||||
(define-for-syntax (pat-bindings stx)
|
||||
(syntax-parse stx
|
||||
#:datum-literals (bind tuple)
|
||||
[(bind x:id τ:type)
|
||||
#'([x τ])]
|
||||
[(tuple p ...)
|
||||
#:with (([x:id τ:type] ...) ...) (stx-map pat-bindings #'(p ...))
|
||||
#'([x τ] ... ...)]
|
||||
[(~constructor-exp cons p ...)
|
||||
#:with (([x:id τ:type] ...) ...) (stx-map pat-bindings #'(p ...))
|
||||
#'([x τ] ... ...)]
|
||||
[_
|
||||
#'()]))
|
||||
|
||||
(begin-for-syntax
|
||||
;; Any -> Bool
|
||||
(define (dollar-variable? x)
|
||||
(and (identifier? x)
|
||||
(char=? (string-ref (symbol->string (syntax-e x)) 0) #\$)))
|
||||
|
||||
;; dollar-id -> Identifier
|
||||
(define (un-dollar x)
|
||||
(datum->syntax x (string->symbol (substring (symbol->string (syntax-e x)) 1))))
|
||||
|
||||
(define-syntax-class dollar-id
|
||||
#:attributes (id)
|
||||
(pattern x:id
|
||||
#:when (dollar-variable? #'x)
|
||||
#:attr id (un-dollar #'x)))
|
||||
|
||||
;; match things of the for "$X...:Y..." where X and Y are things without
|
||||
;; spaces (i.e. likely but not definitely legal identifiers)
|
||||
(define DOLLAR-ANN-RX #px"^\\$(\\S*):(\\S*)$")
|
||||
|
||||
;; Any -> RegexpMatchResults
|
||||
(define (dollar-ann-variable? x)
|
||||
(and (identifier? x)
|
||||
(regexp-match DOLLAR-ANN-RX (symbol->string (syntax-e x)))))
|
||||
|
||||
(define-syntax-class dollar-ann-id
|
||||
#:attributes (id ty)
|
||||
(pattern x:id
|
||||
#:do [(define match? (dollar-ann-variable? #'x))]
|
||||
#:when match?
|
||||
#:attr id (datum->syntax #'x (string->symbol (second match?)))
|
||||
#:attr ty (datum->syntax #'x (string->symbol (third match?)))))
|
||||
|
||||
;; expand uses of $ short-hand
|
||||
;; doesn't handle uses of $id or ($) w/o a type
|
||||
(define (elaborate-pattern pat)
|
||||
(syntax-parse pat
|
||||
#:datum-literals (tuple _ $)
|
||||
[_
|
||||
#'discard]
|
||||
[x:dollar-ann-id
|
||||
(syntax/loc pat (bind x.id x.ty))]
|
||||
[($ x:id ty)
|
||||
(syntax/loc pat (bind x ty))]
|
||||
[(tuple p ...)
|
||||
(quasisyntax/loc pat
|
||||
(tuple #,@(stx-map elaborate-pattern #'(p ...))))]
|
||||
[(~constructor-exp ctor p ...)
|
||||
(quasisyntax/loc pat
|
||||
(ctor #,@(stx-map elaborate-pattern #'(p ...))))]
|
||||
[e:expr
|
||||
#'e]))
|
||||
|
||||
(define (elaborate-pattern/with-type pat ty)
|
||||
(syntax-parse pat
|
||||
#:datum-literals (tuple $)
|
||||
[(~datum _)
|
||||
#'discard]
|
||||
[x:dollar-ann-id
|
||||
(syntax/loc pat (bind x.id x.ty))]
|
||||
[x:dollar-id
|
||||
(when (bot? ty)
|
||||
(raise-syntax-error #f "unable to instantiate pattern with matching part of type" pat))
|
||||
(quasisyntax/loc pat (bind x.id #,ty))]
|
||||
[($ x:id ty)
|
||||
(syntax/loc pat (bind x ty))]
|
||||
[($ x:id)
|
||||
(when (bot? ty)
|
||||
(raise-syntax-error #f "unable to instantiate pattern with matching part of type" pat))
|
||||
(quasisyntax/loc pat (bind x #,ty))]
|
||||
[(tuple p ...)
|
||||
(define (matching? t)
|
||||
(syntax-parse t
|
||||
[(~Tuple tt ...)
|
||||
#:when (stx-length=? #'(p ...) #'(tt ...))
|
||||
#t]
|
||||
[_ #f]))
|
||||
(define (proj t i)
|
||||
(syntax-parse t
|
||||
[(~Tuple tt ...)
|
||||
(if (= i -1)
|
||||
t
|
||||
(stx-list-ref #'(tt ...) i))]
|
||||
[(~U* (~or (~and tt (~fail #:unless (or (U*? #'tt) (matching? #'tt))))
|
||||
_) ...)
|
||||
(mk-U- (stx-map (lambda (x) (proj x i)) #'(tt ...)))]
|
||||
[_
|
||||
(mk-U*- '())]))
|
||||
(define selected (proj ty -1))
|
||||
(define sub-pats
|
||||
(for/list ([pat (in-syntax #'(p ...))]
|
||||
[i (in-naturals)])
|
||||
(elaborate-pattern/with-type pat (proj selected i))))
|
||||
(quasisyntax/loc pat
|
||||
(tuple #,@sub-pats))]
|
||||
[(~constructor-exp ctor p ...)
|
||||
(define tag (ctor-type-tag #'ctor))
|
||||
(define (matching? t)
|
||||
(syntax-parse t
|
||||
[(~constructor-type tag2 tt ...)
|
||||
#:when (equal? tag (syntax-e #'tag2))
|
||||
#:when (stx-length=? #'(p ...) #'(tt ...))
|
||||
#t]
|
||||
[_ #f]))
|
||||
(define (proj t i)
|
||||
(syntax-parse t
|
||||
[(~constructor-type _ tt ...)
|
||||
#:when (matching? t)
|
||||
(if (= i -1)
|
||||
t
|
||||
(stx-list-ref #'(tt ...) i))]
|
||||
[(~U* (~or (~and tt (~fail #:unless (or (U*? #'tt) (matching? #'tt))))
|
||||
_) ...)
|
||||
(mk-U- (stx-map (lambda (x) (proj x i)) #'(tt ...)))]
|
||||
[_
|
||||
(mk-U*- '())]))
|
||||
(define selected (proj ty -1))
|
||||
(define sub-pats
|
||||
(for/list ([pat (in-syntax #'(p ...))]
|
||||
[i (in-naturals)])
|
||||
(elaborate-pattern/with-type pat (proj selected i))))
|
||||
(quasisyntax/loc pat
|
||||
(ctor #,@sub-pats))]
|
||||
[e:expr
|
||||
#'e])))
|
||||
|
||||
;; TODO - figure out why this needs different list identifiers
|
||||
(define-for-syntax (compile-pattern pat list-binding bind-id-transformer exp-transformer)
|
||||
(define (l-e stx) (local-expand stx 'expression '()))
|
||||
(let loop ([pat pat])
|
||||
(syntax-parse pat
|
||||
#:datum-literals (tuple discard bind)
|
||||
[(tuple p ...)
|
||||
#`(#,list-binding 'tuple #,@(stx-map loop #'(p ...)))]
|
||||
[(bind x:id τ:type)
|
||||
(bind-id-transformer #'x)]
|
||||
[discard
|
||||
#'_]
|
||||
[(~constructor-exp ctor p ...)
|
||||
(define/with-syntax uctor (untyped-ctor #'ctor))
|
||||
#`(uctor #,@(stx-map loop #'(p ...)))]
|
||||
[_
|
||||
;; local expanding "expression-y" syntax allows variable references to transform
|
||||
;; according to the mappings set up by turnstile.
|
||||
(exp-transformer (l-e pat))])))
|
||||
|
||||
(define-for-syntax (compile-match-pattern pat)
|
||||
(compile-pattern pat
|
||||
#'list
|
||||
identity
|
||||
(lambda (exp) #`(==- #,exp))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Derived Forms
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-typed-syntax (define-tuple (x:id ...) e:expr) ≫
|
||||
[⊢ e ≫ e- (⇒ (~Tuple τ ...))]
|
||||
#:fail-unless (stx-length=? #'(x ...) #'(τ ...))
|
||||
"mismatched size"
|
||||
#:fail-unless (pure? #'e-) "expr must be pure"
|
||||
#:with (sel ...) (for/list ([y (in-syntax #'(x ...))]
|
||||
[t (in-syntax #'(τ ...))]
|
||||
[i (in-naturals)])
|
||||
(quasisyntax/loc this-syntax
|
||||
(select #,i it)))
|
||||
----------------------------------------
|
||||
[≻ (begin
|
||||
(define it e-)
|
||||
(define x : τ sel) ...)])
|
||||
|
||||
(define-typed-syntax (match-define pat:expr e:expr) ≫
|
||||
[⊢ e ≫ e- (⇒ : τ-e)]
|
||||
#:with pat+ (elaborate-pattern/with-type #'pat #'τ-e)
|
||||
#:with ([x τ] ...) (pat-bindings #'pat+)
|
||||
----------------------------------------
|
||||
[≻ (define-tuple (x ...)
|
||||
(match e-
|
||||
[pat+
|
||||
(tuple x ...)]))])
|
||||
|
||||
;; extremely limited match-define for `define-constructor`-d things
|
||||
|
||||
#;(define-typed-syntax (match-define (~constructor-exp ctor x:id ...) e:expr) ≫
|
||||
[⊢ e ≫ e- (⇒ (~constructor-type tag1 τ ...))]
|
||||
#:fail-unless (stx-length=? #'(x ...) #'(τ ...))
|
||||
"mismatched size"
|
||||
[⊢ (ctor (bind x τ) ...) ≫ pat- (⇒ (~constructor-type tag2 _ ...))]
|
||||
#:fail-unless (equal? #'tag1 #'tag2)
|
||||
(~format "type mismatch: ~a, ~a" #'tag1 #'tag2)
|
||||
------------------------------------------------------------
|
||||
)
|
File diff suppressed because it is too large
Load Diff
|
@ -1,2 +0,0 @@
|
|||
#lang s-exp syntax/module-reader
|
||||
typed/core
|
|
@ -1,117 +0,0 @@
|
|||
#lang typed/syndicate/roles
|
||||
|
||||
(provide activate!
|
||||
tcp-connection
|
||||
tcp-accepted
|
||||
tcp-out
|
||||
tcp-in
|
||||
tcp-in-line
|
||||
tcp-address
|
||||
tcp-listener
|
||||
seal
|
||||
advertise
|
||||
Tcp2LineReaderFactory
|
||||
Tcp2Driver)
|
||||
|
||||
(require-struct tcp-connection
|
||||
#:as TcpConnection
|
||||
#:from syndicate/drivers/tcp2)
|
||||
|
||||
(require-struct tcp-accepted
|
||||
#:as TcpAccepted
|
||||
#:from syndicate/drivers/tcp2)
|
||||
|
||||
(require-struct tcp-out
|
||||
#:as TcpOut
|
||||
#:from syndicate/drivers/tcp2)
|
||||
|
||||
(require-struct tcp-in
|
||||
#:as TcpIn
|
||||
#:from syndicate/drivers/tcp2)
|
||||
|
||||
(require-struct tcp-in-line
|
||||
#:as TcpInLine
|
||||
#:from syndicate/drivers/tcp2)
|
||||
|
||||
(require-struct tcp-address
|
||||
#:as TcpAddress
|
||||
#:from syndicate/drivers/tcp2)
|
||||
|
||||
(require-struct tcp-listener
|
||||
#:as TcpListener
|
||||
#:from syndicate/drivers/tcp2)
|
||||
|
||||
(require-struct tcp-channel
|
||||
#:as TcpChannel
|
||||
#:from syndicate/drivers/tcp)
|
||||
|
||||
(require-struct tcp-handle
|
||||
#:as TcpHandle
|
||||
#:from syndicate/drivers/tcp)
|
||||
|
||||
(require-struct seal
|
||||
#:as Seal
|
||||
#:from syndicate/lang)
|
||||
|
||||
(require-struct advertise
|
||||
#:as Advertise
|
||||
#:from syndicate/protocol/advertise)
|
||||
|
||||
;; assertions and messages sent & received by the 'tcp2-listen-driver
|
||||
(define-type-alias Tcp2ListenDriver
|
||||
(U (Observe (Observe (TcpConnection ★/t (TcpListener ★/t))))
|
||||
(Observe (TcpConnection ★/t (TcpListener Int)))
|
||||
(Observe (TcpConnection ★/t (TcpListener Int)))
|
||||
(Advertise (Observe (TcpChannel ★/t (TcpListener (TcpHandle (Seal ★/t)) ★/t))))
|
||||
(Observe (Advertise (TcpChannel (TcpAddress String Int) (TcpHandle (Seal ★/t)) ★/t)))
|
||||
(TcpAccepted ★/t)
|
||||
(Advertise (TcpChannel (TcpHandle (Seal ★/t)) (TcpAddress String Int) ★/t))
|
||||
(Observe (TcpChannel (TcpAddress String Int) (TcpHandle (Seal ★/t)) ★/t))
|
||||
(Message (TcpChannel (TcpAddress String Int) (TcpHandle (Seal ★/t)) ByteString))
|
||||
(Message (TcpIn (Seal ★/t) ByteString))
|
||||
(Observe (TcpOut (Seal ★/t) ★/t))
|
||||
(Message (TcpOut (Seal ★/t) ByteString))
|
||||
(Message (TcpChannel (TcpHandle (Seal ★/t)) (TcpAddress String Int) ByteString))))
|
||||
|
||||
;; assertions and messages sent & received by the 'tcp2-connect-driver
|
||||
(define-type-alias Tcp2ConnectDriver
|
||||
(U (Observe (TcpConnection ★/t (TcpAddress ★/t ★/t)))
|
||||
(TcpConnection Symbol (TcpAddress String Int))
|
||||
(Observe (Advertise (TcpChannel (TcpAddress String Int) (TcpHandle (Seal ★/t)) ★/t)))
|
||||
(TcpAccepted ★/t)
|
||||
(Advertise (TcpChannel (TcpHandle (Seal ★/t)) (TcpAddress String Int) ★/t))
|
||||
(Observe (TcpChannel (TcpAddress String Int) (TcpHandle (Seal ★/t)) ★/t))
|
||||
(Message (TcpChannel (TcpAddress String Int) (TcpHandle (Seal ★/t)) ByteString))
|
||||
(Message (TcpIn ★/t ByteString))
|
||||
(Observe (TcpOut ★/t ★/t))
|
||||
(Message (TcpOut ★/t ByteString))
|
||||
(Message (TcpChannel (TcpHandle (Seal ★/t)) (TcpAddress String Int) ByteString))))
|
||||
|
||||
;; assertions and messages sent & received by the 'tcp2-line-reader-factory
|
||||
(define-type-alias Tcp2LineReaderFactory
|
||||
(U (Observe (Observe (TcpInLine ★/t ★/t)))
|
||||
(Observe (TcpInLine ★/t ★/t))
|
||||
(Observe (TcpIn ★/t ★/t))
|
||||
(Message (TcpIn ★/t ByteString))
|
||||
(Message (TcpInLine ★/t ByteString))))
|
||||
|
||||
(define-type-alias Tcp2Driver
|
||||
(U Tcp2ListenDriver
|
||||
Tcp2ConnectDriver
|
||||
Tcp2LineReaderFactory))
|
||||
|
||||
(require/typed syndicate/drivers/tcp2)
|
||||
(require/typed (submod syndicate/drivers/tcp2 syndicate-main)
|
||||
[activate! : (→ (Computation (Value (U))
|
||||
(Endpoints)
|
||||
(Roles)
|
||||
(Spawns (Actor Tcp2Driver))))])
|
||||
|
||||
;; TODO
|
||||
;;
|
||||
;; The tcp2 driver also "activates" the tcp driver, so in order to be sound the typed driver ought to
|
||||
;; indicate through the types that whatever assertions and messages that driver does can also happen.
|
||||
;;
|
||||
;; The require/activate model doesn't lend itself to the current workings of the type system very
|
||||
;; easily. Perhaps a require/activate/typed would be in order, where the provided type describes the
|
||||
;; dataspace type of the actors that get spawned.
|
|
@ -1,22 +0,0 @@
|
|||
#lang typed/syndicate/roles
|
||||
|
||||
(provide activate!
|
||||
later-than
|
||||
LaterThanT
|
||||
LaterThan
|
||||
TimeStateDriver)
|
||||
|
||||
(require-struct later-than
|
||||
#:as LaterThanT
|
||||
#:from syndicate/drivers/timestate)
|
||||
|
||||
(define-type-alias LaterThan (LaterThanT Int))
|
||||
|
||||
(define-type-alias TimeStateDriver
|
||||
(U LaterThan
|
||||
(Observe (LaterThanT ★/t))))
|
||||
|
||||
;; TODO ignoring other driver underneath it
|
||||
|
||||
(require/typed (submod syndicate/drivers/timestate syndicate-main)
|
||||
[activate! : (proc → ⊥ #:spawns ((Actor TimeStateDriver)))])
|
|
@ -1,35 +0,0 @@
|
|||
#lang turnstile
|
||||
|
||||
(provide Left
|
||||
Right
|
||||
Either
|
||||
left
|
||||
right
|
||||
partition/either)
|
||||
|
||||
(require "core-types.rkt")
|
||||
(require "core-expressions.rkt")
|
||||
(require "for-loops.rkt")
|
||||
(require "list.rkt")
|
||||
|
||||
(define-constructor* (left : Left v))
|
||||
(define-constructor* (right : Right v))
|
||||
|
||||
(define-type-alias (Either A B)
|
||||
(U (Left A)
|
||||
(Right B)))
|
||||
|
||||
(define (∀ (X Y Z) (partition/either [xs : (List X)]
|
||||
[pred : (→fn X (Either Y Z))]
|
||||
-> (Tuple (List Y) (List Z))))
|
||||
(for/fold ([lefts (List Y) (list)]
|
||||
[rights (List Z) (list)])
|
||||
([x xs])
|
||||
(define y-or-z (pred x))
|
||||
(match y-or-z
|
||||
[(left (bind y Y))
|
||||
(tuple (cons y lefts)
|
||||
rights)]
|
||||
[(right (bind z Z))
|
||||
(tuple lefts
|
||||
(cons z rights))])))
|
|
@ -1,947 +0,0 @@
|
|||
#lang turnstile
|
||||
|
||||
(provide (rename-out [syndicate:#%module-begin #%module-begin])
|
||||
(rename-out [typed-app #%app])
|
||||
(rename-out [syndicate:begin-for-declarations declare-types])
|
||||
#%top-interaction
|
||||
require only-in
|
||||
;; Types
|
||||
Int Bool String Tuple Bind Discard Case → Behavior FacetName Field ★
|
||||
Observe Inbound Outbound Actor U
|
||||
;; Statements
|
||||
let spawn dataspace facet set! begin stop unsafe-do
|
||||
;; endpoints
|
||||
assert on
|
||||
;; expressions
|
||||
tuple λ ref observe inbound outbound
|
||||
;; values
|
||||
#%datum
|
||||
;; patterns
|
||||
bind discard
|
||||
;; primitives
|
||||
+ - * / and or not > < >= <= = equal? displayln
|
||||
;; making types
|
||||
define-type-alias
|
||||
define-constructor
|
||||
;; DEBUG and utilities
|
||||
print-type
|
||||
(rename-out [printf- printf])
|
||||
;; Extensions
|
||||
match if cond
|
||||
)
|
||||
|
||||
(require (rename-in racket/match [match-lambda match-lambda-]))
|
||||
(require (rename-in racket/math [exact-truncate exact-truncate-]))
|
||||
(require (prefix-in syndicate: syndicate/actor-lang))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(require rackunit/turnstile))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Types
|
||||
|
||||
(define-base-types Int Bool String Discard ★ FacetName)
|
||||
(define-type-constructor Field #:arity = 1)
|
||||
;; (Behavior τv τi τo τa)
|
||||
;; τv is the type of thing it evaluates to
|
||||
;; τi is the type of patterns used to consume incoming assertions
|
||||
;; τo is the type of assertions made
|
||||
;; τa is the type of spawned actors
|
||||
(define-type-constructor Behavior #:arity = 4)
|
||||
(define-type-constructor Bind #:arity = 1)
|
||||
(define-type-constructor Tuple #:arity >= 0)
|
||||
(define-type-constructor U #:arity >= 0)
|
||||
(define-type-constructor Case #:arity >= 0)
|
||||
(define-type-constructor → #:arity > 0)
|
||||
(define-type-constructor Observe #:arity = 1)
|
||||
(define-type-constructor Inbound #:arity = 1)
|
||||
(define-type-constructor Outbound #:arity = 1)
|
||||
(define-type-constructor Actor #:arity = 1)
|
||||
|
||||
(define-for-syntax (type-eval t)
|
||||
((current-type-eval) t))
|
||||
|
||||
;; this needs to be here until I stop 'compiling' patterns and just have them expand to the right
|
||||
;; thing
|
||||
(begin-for-syntax
|
||||
(current-use-stop-list? #f))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; User Defined Types, aka Constructors
|
||||
|
||||
;; τ.norm in 1st case causes "not valid type" error when file is compiled
|
||||
;; (copied from ext-stlc example)
|
||||
(define-syntax define-type-alias
|
||||
(syntax-parser
|
||||
[(_ alias:id τ:any-type)
|
||||
#'(define-syntax- alias
|
||||
(make-variable-like-transformer #'τ.norm))]
|
||||
[(_ (f:id x:id ...) ty)
|
||||
#'(define-syntax- (f stx)
|
||||
(syntax-parse stx
|
||||
[(_ x ...)
|
||||
#:with τ:any-type #'ty
|
||||
#'τ.norm]))]))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-splicing-syntax-class type-constructor-decl
|
||||
(pattern (~seq #:type-constructor TypeCons:id))
|
||||
(pattern (~seq) #:attr TypeCons #f))
|
||||
|
||||
(struct user-ctor (typed-ctor untyped-ctor)
|
||||
#:property prop:procedure
|
||||
(lambda (v stx)
|
||||
(define transformer (user-ctor-typed-ctor v))
|
||||
(syntax-parse stx
|
||||
[(_ e ...)
|
||||
#`(#,transformer e ...)]))))
|
||||
|
||||
(define-syntax (define-constructor stx)
|
||||
(syntax-parse stx
|
||||
[(_ (Cons:id slot:id ...)
|
||||
ty-cons:type-constructor-decl
|
||||
(~seq #:with
|
||||
Alias AliasBody) ...)
|
||||
#:with TypeCons (or (attribute ty-cons.TypeCons) (format-id stx "~a/t" (syntax-e #'Cons)))
|
||||
#:with MakeTypeCons (format-id #'TypeCons "make-~a" #'TypeCons)
|
||||
#:with GetTypeParams (format-id #'TypeCons "get-~a-type-params" #'TypeCons)
|
||||
#:with TypeConsExpander (format-id #'TypeCons "~~~a" #'TypeCons)
|
||||
#:with TypeConsExtraInfo (format-id #'TypeCons "~a-extra-info" #'TypeCons)
|
||||
#:with (StructName Cons- type-tag) (generate-temporaries #'(Cons Cons Cons))
|
||||
(define arity (stx-length #'(slot ...)))
|
||||
#`(begin-
|
||||
(struct- StructName (slot ...) #:reflection-name 'Cons #:transparent)
|
||||
(define-syntax (TypeConsExtraInfo stx)
|
||||
(syntax-parse stx
|
||||
[(_ X (... ...)) #'('type-tag 'MakeTypeCons 'GetTypeParams)]))
|
||||
(define-type-constructor TypeCons
|
||||
#:arity = #,arity
|
||||
#:extra-info 'TypeConsExtraInfo)
|
||||
(define-syntax (MakeTypeCons stx)
|
||||
(syntax-parse stx
|
||||
[(_ t (... ...))
|
||||
#:fail-unless (= #,arity (stx-length #'(t (... ...)))) "arity mismatch"
|
||||
#'(TypeCons t (... ...))]))
|
||||
(define-syntax (GetTypeParams stx)
|
||||
(syntax-parse stx
|
||||
[(_ (TypeConsExpander t (... ...)))
|
||||
#'(t (... ...))]))
|
||||
(define-syntax Cons
|
||||
(user-ctor #'Cons- #'StructName))
|
||||
(define-typed-syntax (Cons- e (... ...)) ≫
|
||||
#:fail-unless (= #,arity (stx-length #'(e (... ...)))) "arity mismatch"
|
||||
[⊢ e ≫ e- (⇒ : τ)] (... ...)
|
||||
----------------------
|
||||
[⊢ (#%app- StructName e- (... ...)) (⇒ : (TypeCons τ (... ...)))
|
||||
(⇒ :i (U)) (⇒ :o (U)) (⇒ :a (U))])
|
||||
(define-type-alias Alias AliasBody) ...)]))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-syntax ~constructor-extra-info
|
||||
(pattern-expander
|
||||
(syntax-parser
|
||||
[(_ tag mk get)
|
||||
#'(_ (_ tag) (_ mk) (_ get))])))
|
||||
|
||||
(define-syntax ~constructor-type
|
||||
(pattern-expander
|
||||
(syntax-parser
|
||||
[(_ tag . rst)
|
||||
#'(~and it
|
||||
(~fail #:unless (user-defined-type? #'it))
|
||||
(~parse tag (get-type-tag #'it))
|
||||
(~Any _ . rst))])))
|
||||
|
||||
(define-syntax ~constructor-exp
|
||||
(pattern-expander
|
||||
(syntax-parser
|
||||
[(_ cons . rst)
|
||||
#'(~and (cons . rst)
|
||||
(~fail #:unless (ctor-id? #'cons)))])))
|
||||
|
||||
(define (inspect t)
|
||||
(syntax-parse t
|
||||
[(~constructor-type tag t ...)
|
||||
(list (syntax-e #'tag) (stx-map type->str #'(t ...)))]))
|
||||
|
||||
(define (tags-equal? t1 t2)
|
||||
(equal? (syntax-e t1) (syntax-e t2)))
|
||||
|
||||
(define (user-defined-type? t)
|
||||
(get-extra-info (type-eval t)))
|
||||
|
||||
(define (get-type-tag t)
|
||||
(syntax-parse (get-extra-info t)
|
||||
[(~constructor-extra-info tag _ _)
|
||||
(syntax-e #'tag)]))
|
||||
|
||||
(define (get-type-args t)
|
||||
(syntax-parse (get-extra-info t)
|
||||
[(~constructor-extra-info _ _ get)
|
||||
(define f (syntax-local-value #'get))
|
||||
(syntax->list (f #`(get #,t)))]))
|
||||
|
||||
(define (make-cons-type t args)
|
||||
(syntax-parse (get-extra-info t)
|
||||
[(~constructor-extra-info _ mk _)
|
||||
(define f (syntax-local-value #'mk))
|
||||
(type-eval (f #`(mk #,@args)))]))
|
||||
|
||||
(define (ctor-id? stx)
|
||||
(and (identifier? stx)
|
||||
(user-ctor? (syntax-local-value stx (const #f)))))
|
||||
|
||||
(define (untyped-ctor stx)
|
||||
(user-ctor-untyped-ctor (syntax-local-value stx (const #f)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Syntax
|
||||
|
||||
(begin-for-syntax
|
||||
|
||||
#|
|
||||
it's expensive and inflexible to fully parse these, but this is what the language
|
||||
is meant to be
|
||||
(define-syntax-class stmt
|
||||
#:datum-literals (:
|
||||
begin
|
||||
let
|
||||
set!
|
||||
spawn
|
||||
dataspace
|
||||
stop
|
||||
facet
|
||||
unsafe-do
|
||||
fields)
|
||||
(pattern (~or (begin seq:stmt ...)
|
||||
(e1:exp e2:exp)
|
||||
(let [f:id e:exp] let-fun-body:stmt)
|
||||
(set! x:id e:exp)
|
||||
(spawn τ:type s:stmt)
|
||||
(dataspace τ:type nested:stmt ...)
|
||||
(stop x:id s:stmt)
|
||||
(facet x:id (fields [fn:id τf:type ef:exp] ...) ep:endpoint ...+)
|
||||
;; note racket expr, not exp
|
||||
(unsafe-do rkt:expr ...))))
|
||||
|
||||
(define-syntax-class exp
|
||||
#:datum-literals (tuple λ ref)
|
||||
(pattern (~or (o:prim-op es:exp ...)
|
||||
basic-val
|
||||
(k:kons1 e:exp)
|
||||
(tuple es:exp ...)
|
||||
(ref x:id)
|
||||
(λ [p:pat s:stmt] ...))))
|
||||
|#
|
||||
|
||||
;; constructors with arity one
|
||||
(define-syntax-class kons1
|
||||
(pattern (~or (~datum observe)
|
||||
(~datum inbound)
|
||||
(~datum outbound))))
|
||||
|
||||
(define (kons1->constructor stx)
|
||||
(syntax-parse stx
|
||||
#:datum-literals (observe inbound outbound)
|
||||
[observe #'syndicate:observe]
|
||||
[inbound #'syndicate:inbound]
|
||||
[outbound #'syndicate:outbound]))
|
||||
|
||||
(define-syntax-class basic-val
|
||||
(pattern (~or boolean
|
||||
integer
|
||||
string)))
|
||||
|
||||
(define-syntax-class prim-op
|
||||
(pattern (~or (~literal +)
|
||||
(~literal -)
|
||||
(~literal displayln))))
|
||||
|
||||
#;(define-syntax-class endpoint
|
||||
#:datum-literals (on start stop)
|
||||
(pattern (~or (on ed:event-desc s)
|
||||
(assert e:expr))))
|
||||
|
||||
#;(define-syntax-class event-desc
|
||||
#:datum-literals (start stop asserted retracted)
|
||||
(pattern (~or start
|
||||
stop
|
||||
(asserted p:pat)
|
||||
(retracted p:pat))))
|
||||
|
||||
#;(define-syntax-class pat
|
||||
#:datum-literals (tuple _ discard bind)
|
||||
#:attributes (syndicate-pattern match-pattern)
|
||||
(pattern (~or (~and (tuple ps:pat ...)
|
||||
(~bind [syndicate-pattern #'(list 'tuple ps.syndicate-pattern ...)]
|
||||
[match-pattern #'(list 'tuple ps.match-pattern ...)]))
|
||||
(~and (k:kons1 p:pat)
|
||||
(~bind [syndicate-pattern #`(#,(kons1->constructor #'k) p.syndicate-pattern)]
|
||||
[match-pattern #`(#,(kons1->constructor #'k) p.match-pattern)]))
|
||||
(~and (bind ~! x:id τ:type)
|
||||
(~bind [syndicate-pattern #'($ x)]
|
||||
[match-pattern #'x]))
|
||||
(~and discard
|
||||
(~bind [syndicate-pattern #'_]
|
||||
[match-pattern #'_]))
|
||||
(~and x:id
|
||||
(~bind [syndicate-pattern #'x]
|
||||
[match-pattern #'(== x)]))
|
||||
(~and e:expr
|
||||
(~bind [syndicate-pattern #'e]
|
||||
[match-pattern #'(== e)])))))
|
||||
|
||||
(define (compile-pattern pat bind-id-transformer exp-transformer)
|
||||
(let loop ([pat pat])
|
||||
(syntax-parse pat
|
||||
#:datum-literals (tuple discard bind)
|
||||
[(tuple p ...)
|
||||
#`(list 'tuple #,@(stx-map loop #'(p ...)))]
|
||||
[(k:kons1 p)
|
||||
#`(#,(kons1->constructor #'k) #,(loop #'p))]
|
||||
[(bind x:id τ:type)
|
||||
(bind-id-transformer #'x)]
|
||||
[discard
|
||||
#'_]
|
||||
[(~constructor-exp ctor p ...)
|
||||
(define/with-syntax uctor (untyped-ctor #'ctor))
|
||||
#`(uctor #,@(stx-map loop #'(p ...)))]
|
||||
[_
|
||||
(exp-transformer pat)])))
|
||||
|
||||
(define (compile-match-pattern pat)
|
||||
(compile-pattern pat
|
||||
identity
|
||||
(lambda (exp) #`(== #,exp))))
|
||||
|
||||
(define (compile-syndicate-pattern pat)
|
||||
(compile-pattern pat
|
||||
(lambda (id) #`($ #,id))
|
||||
identity)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Subtyping
|
||||
|
||||
;; TODO: subtyping for facets
|
||||
|
||||
;; Type Type -> Bool
|
||||
(define-for-syntax (<: t1 t2)
|
||||
#;(printf "Checking ~a <: ~a\n" (type->str t1) (type->str t2))
|
||||
;; should add a check for type=?
|
||||
(syntax-parse #`(#,t1 #,t2)
|
||||
#;[(τ1 τ2) #:do [(displayln (type->str #'τ1))
|
||||
(displayln (type->str #'τ2))]
|
||||
#:when #f
|
||||
(error "")]
|
||||
[((~U τ1 ...) _)
|
||||
(stx-andmap (lambda (t) (<: t t2)) #'(τ1 ...))]
|
||||
[(_ (~U τ2:type ...))
|
||||
(stx-ormap (lambda (t) (<: t1 t)) #'(τ2 ...))]
|
||||
[((~Actor τ1:type) (~Actor τ2:type))
|
||||
;; should these be .norm? Is the invariant that inputs are always fully
|
||||
;; evalutated/expanded?
|
||||
(and (<: #'τ1 #'τ2)
|
||||
(<: (∩ (strip-? #'τ1) #'τ2) #'τ1))]
|
||||
[((~Tuple τ1:type ...) (~Tuple τ2:type ...))
|
||||
#:when (stx-length=? #'(τ1 ...) #'(τ2 ...))
|
||||
(stx-andmap <: #'(τ1 ...) #'(τ2 ...))]
|
||||
[(_ ~★)
|
||||
(flat-type? t1)]
|
||||
[((~Observe τ1:type) (~Observe τ2:type))
|
||||
(<: #'τ1 #'τ2)]
|
||||
[((~Inbound τ1:type) (~Inbound τ2:type))
|
||||
(<: #'τ1 #'τ2)]
|
||||
[((~Outbound τ1:type) (~Outbound τ2:type))
|
||||
(<: #'τ1 #'τ2)]
|
||||
[((~constructor-type t1 τ1:type ...) (~constructor-type t2 τ2:type ...))
|
||||
#:when (tags-equal? #'t1 #'t2)
|
||||
(and (stx-length=? #'(τ1 ...) #'(τ2 ...))
|
||||
(stx-andmap <: #'(τ1 ...) #'(τ2 ...)))]
|
||||
[((~Behavior τ-v1 τ-i1 τ-o1 τ-a1) (~Behavior τ-v2 τ-i2 τ-o2 τ-a2))
|
||||
(and (<: #'τ-v1 #'τ-v2)
|
||||
;; HMMMMMM. i2 and i1 are types of patterns. TODO
|
||||
;; Want: ∀σ. project-safe(σ, τ-i2) ⇒ project-safe(σ, τ-i1)
|
||||
(<: #'τ-i2 #'τ-i1)
|
||||
(<: #'τ-o1 #'τ-o2)
|
||||
(<: (type-eval #'(Actor τ-a1)) (type-eval #'(Actor τ-a2))))]
|
||||
[((~→ τ-in1 ... τ-out1) (~→ τ-in2 ... τ-out2))
|
||||
#:when (stx-length=? #'(τ-in1 ...) #'(τ-in2 ...))
|
||||
(and (stx-andmap <: #'(τ-in2 ...) #'(τ-in1 ...))
|
||||
(<: #'τ-out1 #'τ-out2))]
|
||||
[((~Field τ1) (~Field τ2))
|
||||
(and (<: #'τ1 #'τ2)
|
||||
(<: #'τ2 #'τ1))]
|
||||
[(~Discard _)
|
||||
#t]
|
||||
[((~Bind τ1) (~Bind τ2))
|
||||
(<: #'τ1 #'τ2)]
|
||||
;; should probably put this first.
|
||||
[_ (type=? t1 t2)]))
|
||||
|
||||
;; Flat-Type Flat-Type -> Type
|
||||
(define-for-syntax (∩ t1 t2)
|
||||
(unless (and (flat-type? t1) (flat-type? t2))
|
||||
(error '∩ "expected two flat-types"))
|
||||
(syntax-parse #`(#,t1 #,t2)
|
||||
[(_ ~★)
|
||||
t1]
|
||||
[(~★ _)
|
||||
t2]
|
||||
[(_ _)
|
||||
#:when (type=? t1 t2)
|
||||
t1]
|
||||
[((~U τ1:type ...) _)
|
||||
(type-eval #`(U #,@(stx-map (lambda (t) (∩ t t2)) #'(τ1 ...))))]
|
||||
[(_ (~U τ2:type ...))
|
||||
(type-eval #`(U #,@(stx-map (lambda (t) (∩ t1 t)) #'(τ2 ...))))]
|
||||
;; all of these fail-when/unless clauses are meant to cause this through to
|
||||
;; the last case and result in ⊥.
|
||||
;; Also, using <: is OK, even though <: refers to ∩, because <:'s use of ∩ is only
|
||||
;; in the Actor case.
|
||||
[((~Tuple τ1:type ...) (~Tuple τ2:type ...))
|
||||
#:fail-unless (stx-length=? #'(τ1 ...) #'(τ2 ...)) #f
|
||||
#:with (τ ...) (stx-map ∩ #'(τ1 ...) #'(τ2 ...))
|
||||
;; I don't think stx-ormap is part of the documented api of turnstile *shrug*
|
||||
#:fail-when (stx-ormap (lambda (t) (<: t (type-eval #'(U)))) #'(τ ...)) #f
|
||||
(type-eval #'(Tuple τ ...))]
|
||||
[((~constructor-type tag1 τ1:type ...) (~constructor-type tag2 τ2:type ...))
|
||||
#:when (tags-equal? #'tag1 #'tag2)
|
||||
#:with (τ ...) (stx-map ∩ #'(τ1 ...) #'(τ2 ...))
|
||||
#:fail-when (stx-ormap (lambda (t) (<: t (type-eval #'(U)))) #'(τ ...)) #f
|
||||
(make-cons-type t1 #'(τ ...))]
|
||||
;; these three are just the same :(
|
||||
[((~Observe τ1:type) (~Observe τ2:type))
|
||||
#:with τ (∩ #'τ1 #'τ2)
|
||||
#:fail-when (<: #'τ (type-eval #'(U))) #f
|
||||
(type-eval #'(Observe τ))]
|
||||
[((~Inbound τ1:type) (~Inbound τ2:type))
|
||||
#:with τ (∩ #'τ1 #'τ2)
|
||||
#:fail-when (<: #'τ (type-eval #'(U))) #f
|
||||
(type-eval #'(Inbound τ))]
|
||||
[((~Outbound τ1:type) (~Outbound τ2:type))
|
||||
#:with τ (∩ #'τ1 #'τ2)
|
||||
#:fail-when (<: #'τ (type-eval #'(U))) #f
|
||||
(type-eval #'(Outbound τ))]
|
||||
[_ (type-eval #'(U))]))
|
||||
|
||||
;; Type Type -> Bool
|
||||
;; first type is the contents of the set
|
||||
;; second type is the type of a pattern
|
||||
(define-for-syntax (project-safe? t1 t2)
|
||||
(syntax-parse #`(#,t1 #,t2)
|
||||
[(_ (~Bind τ2:type))
|
||||
(and (finite? t1) (<: t1 #'τ2))]
|
||||
[(_ ~Discard)
|
||||
#t]
|
||||
[((~U τ1:type ...) _)
|
||||
(stx-andmap (lambda (t) (project-safe? t t2)) #'(τ1 ...))]
|
||||
[(_ (~U τ2:type ...))
|
||||
(stx-andmap (lambda (t) (project-safe? t1 t)) #'(τ2 ...))]
|
||||
[((~Tuple τ1:type ...) (~Tuple τ2:type ...))
|
||||
#:when (overlap? t1 t2)
|
||||
(stx-andmap project-safe? #'(τ1 ...) #'(τ2 ...))]
|
||||
[((~constructor-type t1 τ1:type ...) (~constructor-type t2 τ2:type ...))
|
||||
#:when (tags-equal? #'t1 #'t2)
|
||||
(stx-andmap project-safe? #'(τ1 ...) #'(τ2 ...))]
|
||||
[((~Observe τ1:type) (~Observe τ2:type))
|
||||
(project-safe? #'τ1 #'τ2)]
|
||||
[((~Inbound τ1:type) (~Inbound τ2:type))
|
||||
(project-safe? #'τ1 #'τ2)]
|
||||
[((~Outbound τ1:type) (~Outbound τ2:type))
|
||||
(project-safe? #'τ1 #'τ2)]
|
||||
[_ #t]))
|
||||
|
||||
;; AssertionType PatternType -> Bool
|
||||
;; Is it possible for things of these two types to match each other?
|
||||
;; Flattish-Type = Flat-Types + ★, Bind, Discard (assertion and pattern types)
|
||||
(define-for-syntax (overlap? t1 t2)
|
||||
(syntax-parse #`(#,t1 #,t2)
|
||||
[(~★ _) #t]
|
||||
[(_ (~Bind _)) #t]
|
||||
[(_ ~Discard) #t]
|
||||
[((~U τ1:type ...) _)
|
||||
(stx-ormap (lambda (t) (overlap? t t2)) #'(τ1 ...))]
|
||||
[(_ (~U τ2:type ...))
|
||||
(stx-ormap (lambda (t) (overlap? t1 t)) #'(τ2 ...))]
|
||||
[((~Tuple τ1:type ...) (~Tuple τ2:type ...))
|
||||
(and (stx-length=? #'(τ1 ...) #'(τ2 ...))
|
||||
(stx-andmap overlap? #'(τ1 ...) #'(τ2 ...)))]
|
||||
[((~constructor-type t1 τ1:type ...) (~constructor-type t2 τ2:type ...))
|
||||
(and (tags-equal? #'t1 #'t2)
|
||||
(stx-andmap overlap? #'(τ1 ...) #'(τ2 ...)))]
|
||||
[((~Observe τ1:type) (~Observe τ2:type))
|
||||
(overlap? #'τ1 #'τ2)]
|
||||
[((~Inbound τ1:type) (~Inbound τ2:type))
|
||||
(overlap? #'τ1 #'τ2)]
|
||||
[((~Outbound τ1:type) (~Outbound τ2:type))
|
||||
(overlap? #'τ1 #'τ2)]
|
||||
[_ (<: t1 t2)]))
|
||||
|
||||
|
||||
;; Flattish-Type -> Bool
|
||||
(define-for-syntax (finite? t)
|
||||
(syntax-parse t
|
||||
[~★ #f]
|
||||
[(~U τ:type ...)
|
||||
(stx-andmap finite? #'(τ ...))]
|
||||
[(~Tuple τ:type ...)
|
||||
(stx-andmap finite? #'(τ ...))]
|
||||
[(~constructor-type _ τ:type ...)
|
||||
(stx-andmap finite? #'(τ ...))]
|
||||
[(~Observe τ:type)
|
||||
(finite? #'τ)]
|
||||
[(~Inbound τ:type)
|
||||
(finite? #'τ)]
|
||||
[(~Outbound τ:type)
|
||||
(finite? #'τ)]
|
||||
[_ #t]))
|
||||
|
||||
;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
;; MODIFYING GLOBAL TYPECHECKING STATE!!!!!
|
||||
;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
(begin-for-syntax
|
||||
(current-typecheck-relation <:))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Statements
|
||||
|
||||
;; CONVENTIONS
|
||||
;; The `:` key is for evaluated expressions
|
||||
;; The `:i` key is for input patterns
|
||||
;; The `:o` key is for output assertions
|
||||
;; The `:a` key is for spawned actors
|
||||
|
||||
(define-typed-syntax (set! x:id e:expr) ≫
|
||||
[⊢ e ≫ e- (⇒ : τ)]
|
||||
[⊢ x ≫ x- (⇒ : (~Field τ-x:type))]
|
||||
#:fail-unless (<: #'τ #'τ-x) "Ill-typed field write"
|
||||
----------------------------------------------------
|
||||
[⊢ (x- e-) (⇒ : (U)) (⇒ :i (U)) (⇒ :o (U)) (⇒ :a (U))])
|
||||
|
||||
(define-typed-syntax (stop facet-name:id cont) ≫
|
||||
[⊢ facet-name ≫ facet-name- (⇐ : FacetName)]
|
||||
[⊢ cont ≫ cont- (⇒ :i τ-i) (⇒ :o τ-o) (⇒ :a τ-a)]
|
||||
--------------------------------------------------
|
||||
[⊢ (syndicate:stop-facet facet-name- cont-) (⇒ : (U)) (⇒ :i τ-i) (⇒ :o τ-o) (⇒ :a τ-a)])
|
||||
|
||||
(define-typed-syntax (facet name:id ((~datum fields) [x:id τ:type e:expr] ...) ep ...+) ≫
|
||||
#:fail-unless (stx-andmap flat-type? #'(τ ...)) "keep your uppity data outa my fields"
|
||||
[⊢ e ≫ e- (⇐ : τ)] ...
|
||||
[[name ≫ name- : FacetName] [x ≫ x- : (Field τ)] ...
|
||||
⊢ [ep ≫ ep- (⇒ :i τ-i) (⇒ :o τ-o) (⇒ :a τ-a)] ...]
|
||||
--------------------------------------------------------------
|
||||
;; name NOT name- here because I get an error that way.
|
||||
;; Since name is just an identifier I think it's OK?
|
||||
[⊢ (syndicate:react (let- ([name- (syndicate:current-facet-id)])
|
||||
#,(make-fields #'(x- ...) #'(e- ...))
|
||||
#;(syndicate:field [x- e-] ...)
|
||||
ep- ...))
|
||||
(⇒ : (U)) (⇒ :i (U τ-i ...)) (⇒ :o (U τ-o ...)) (⇒ :a (U τ-a ...))])
|
||||
|
||||
(define-for-syntax (make-fields names inits)
|
||||
(syntax-parse #`(#,names #,inits)
|
||||
[((x:id ...) (e ...))
|
||||
#'(syndicate:field [x e] ...)]))
|
||||
|
||||
(define-typed-syntax (dataspace τ-c:type s ...) ≫
|
||||
;; #:do [(printf "τ-c: ~a\n" (type->str #'τ-c.norm))]
|
||||
#:fail-unless (flat-type? #'τ-c.norm) "Communication type must be first-order"
|
||||
[⊢ s ≫ s- (⇒ :i τ-i:type) (⇒ :o τ-o:type) (⇒ :a τ-s:type)] ...
|
||||
;; #:do [(printf "dataspace types: ~a\n" (stx-map type->str #'(τ-s.norm ...)))
|
||||
;; (printf "dataspace type: ~a\n" (type->str ((current-type-eval) #'(Actor τ-c.norm))))]
|
||||
#:fail-unless (stx-andmap (lambda (t) (<: (type-eval #`(Actor #,t))
|
||||
(type-eval #'(Actor τ-c.norm))))
|
||||
#'(τ-s.norm ...))
|
||||
"Not all actors conform to communication type"
|
||||
#:fail-unless (stx-andmap (lambda (t) (<: t (type-eval #'(U))))
|
||||
#'(τ-i.norm ...)) "dataspace init should only be a spawn"
|
||||
#:fail-unless (stx-andmap (lambda (t) (<: t (type-eval #'(U))))
|
||||
#'(τ-o.norm ...)) "dataspace init should only be a spawn"
|
||||
#:with τ-ds-i (strip-inbound #'τ-c.norm)
|
||||
#:with τ-ds-o (strip-outbound #'τ-c.norm)
|
||||
#:with τ-relay (relay-interests #'τ-c.norm)
|
||||
-----------------------------------------------------------------------------------
|
||||
[⊢ (syndicate:dataspace s- ...) (⇒ : (U)) (⇒ :i (U)) (⇒ :o (U)) (⇒ :a (U τ-ds-i τ-ds-o τ-relay))])
|
||||
|
||||
(define-for-syntax (strip-? t)
|
||||
(type-eval
|
||||
(syntax-parse t
|
||||
;; TODO: probably need to `normalize` the result
|
||||
[(~U τ ...) #`(U #,@(stx-map strip-? #'(τ ...)))]
|
||||
[~★ #'★]
|
||||
[(~Observe τ) #'τ]
|
||||
[_ #'(U)])))
|
||||
|
||||
(define-for-syntax (strip-inbound t)
|
||||
(type-eval
|
||||
(syntax-parse t
|
||||
;; TODO: probably need to `normalize` the result
|
||||
[(~U τ ...) #`(U #,@(stx-map strip-? #'(τ ...)))]
|
||||
[~★ #'★]
|
||||
[(~Inbound τ) #'τ]
|
||||
[_ #'(U)])))
|
||||
|
||||
(define-for-syntax (strip-outbound t)
|
||||
(type-eval
|
||||
(syntax-parse t
|
||||
;; TODO: probably need to `normalize` the result
|
||||
[(~U τ ...) #`(U #,@(stx-map strip-? #'(τ ...)))]
|
||||
[~★ #'★]
|
||||
[(~Outbound τ) #'τ]
|
||||
[_ #'(U)])))
|
||||
|
||||
(define-for-syntax (relay-interests t)
|
||||
(type-eval
|
||||
(syntax-parse t
|
||||
;; TODO: probably need to `normalize` the result
|
||||
[(~U τ ...) #`(U #,@(stx-map strip-? #'(τ ...)))]
|
||||
[~★ #'★]
|
||||
[(~Observe (~Inbound τ)) #'(Observe τ)]
|
||||
[_ #'(U)])))
|
||||
|
||||
(define-typed-syntax (spawn τ-c:type s) ≫
|
||||
#:fail-unless (flat-type? #'τ-c.norm) "Communication type must be first-order"
|
||||
[⊢ s ≫ s- (⇒ :i τ-i:type) (⇒ :o τ-o:type) (⇒ :a τ-a:type)]
|
||||
;; TODO: s shouldn't refer to facets or fields!
|
||||
#:fail-unless (<: #'τ-o.norm #'τ-c.norm)
|
||||
(format "Output ~a not valid in dataspace ~a" (type->str #'τ-o.norm) (type->str #'τ-c.norm))
|
||||
#:fail-unless (<: (type-eval #'(Actor τ-a.norm))
|
||||
(type-eval #'(Actor τ-c.norm))) "Spawned actors not valid in dataspace"
|
||||
#:fail-unless (project-safe? (∩ (strip-? #'τ-o.norm) #'τ-c.norm)
|
||||
#'τ-i.norm) "Not prepared to handle all inputs"
|
||||
;; #:do [(printf "spawning: ~v\n" #'s-)]
|
||||
--------------------------------------------------------------------------------------------
|
||||
[⊢ (syndicate:spawn (syndicate:on-start s-)) (⇒ : (U)) (⇒ :i (U)) (⇒ :o (U)) (⇒ :a τ-c)])
|
||||
|
||||
(define-typed-syntax (let [f:id e:expr] body:expr) ≫
|
||||
[⊢ e ≫ e- (⇒ : τ:type)]
|
||||
#:fail-unless (or (procedure-type? #'τ.norm) (flat-type? #'τ.norm))
|
||||
(format "let doesn't bind actions; got ~a" (type->str #'τ.norm))
|
||||
[[f ≫ f- : τ] ⊢ body ≫ body- (⇒ : τ-body) (⇒ :i τ-body-i) (⇒ :o τ-body-o) (⇒ :a τ-body-a)]
|
||||
------------------------------------------------------------------------
|
||||
[⊢ (let- ([f- e-]) body-) (⇒ : τ-body) (⇒ :i τ-body-i) (⇒ :o τ-body-o) (⇒ :a τ-body-a)])
|
||||
|
||||
(define-for-syntax (procedure-type? τ)
|
||||
(syntax-parse τ
|
||||
[(~→ τ ...+) #t]
|
||||
[_ #f]))
|
||||
|
||||
(define-typed-syntax (begin s ...) ≫
|
||||
[⊢ s ≫ s- (⇒ :i τ1) (⇒ :o τ2) (⇒ :a τ3)] ...
|
||||
------------------------------------------
|
||||
[⊢ (begin- (void-) s- ...) (⇒ : (U)) (⇒ :i (U τ1 ...)) (⇒ :o (U τ2 ...)) (⇒ :a (U τ3 ...))])
|
||||
|
||||
(define-for-syntax (flat-type? τ)
|
||||
(syntax-parse τ
|
||||
[(~→ τ ...) #f]
|
||||
[(~Field _) #f]
|
||||
[(~Behavior _ _ _ _) #f]
|
||||
[_ #t]))
|
||||
|
||||
(define-typed-syntax (unsafe-do rkt:expr ...) ≫
|
||||
------------------------
|
||||
[⊢ (let- () rkt ...) (⇒ : (U)) (⇒ :i (U)) (⇒ :o (U)) (⇒ :a (U))])
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Endpoints
|
||||
|
||||
(begin-for-syntax
|
||||
(define-syntax-class asserted-or-retracted
|
||||
#:datum-literals (asserted retracted)
|
||||
(pattern (~or (~and asserted
|
||||
(~bind [syndicate-kw #'syndicate:asserted]))
|
||||
(~and retracted
|
||||
(~bind [syndicate-kw #'syndicate:retracted]))))))
|
||||
|
||||
(define-typed-syntax on
|
||||
[(on (~literal start) s) ≫
|
||||
[⊢ s ≫ s- (⇒ :i τi) (⇒ :o τ-o) (⇒ :a τ-a)]
|
||||
-----------------------------------
|
||||
[⊢ (syndicate:on-start s-) (⇒ : (U)) (⇒ :i τi) (⇒ :o τ-o) (⇒ :a τ-a)]]
|
||||
[(on (~literal stop) s) ≫
|
||||
[⊢ s ≫ s- (⇒ :i τi) (⇒ :o τ-o) (⇒ :a τ-a)]
|
||||
-----------------------------------
|
||||
[⊢ (syndicate:on-stop s-) (⇒ : (U)) (⇒ :i τi) (⇒ :o τ-o) (⇒ :a τ-a)]]
|
||||
[(on (a/r:asserted-or-retracted p) s) ≫
|
||||
[⊢ p ≫ _ (⇒ : τp)]
|
||||
#:with p- (compile-syndicate-pattern #'p)
|
||||
#:with ([x:id τ:type] ...) (pat-bindings #'p)
|
||||
[[x ≫ x- : τ] ... ⊢ s ≫ s- (⇒ :i τi) (⇒ :o τ-o) (⇒ :a τ-a)]
|
||||
;; the type of subscriptions to draw assertions to the pattern
|
||||
#:with pat-sub (replace-bind-and-discard-with-★ #'τp)
|
||||
-----------------------------------
|
||||
[⊢ (syndicate:on (a/r.syndicate-kw p-)
|
||||
(let- ([x- x] ...) s-))
|
||||
(⇒ : (U))
|
||||
(⇒ :i (U τi τp))
|
||||
(⇒ :o (U (Observe pat-sub) τ-o))
|
||||
(⇒ :a τ-a)]])
|
||||
|
||||
;; FlattishType -> FlattishType
|
||||
(define-for-syntax (replace-bind-and-discard-with-★ t)
|
||||
(syntax-parse t
|
||||
[(~Bind _)
|
||||
(type-eval #'★)]
|
||||
[~Discard
|
||||
(type-eval #'★)]
|
||||
[(~U τ ...)
|
||||
(type-eval #`(U #,@(stx-map replace-bind-and-discard-with-★ #'(τ ...))))]
|
||||
[(~Tuple τ ...)
|
||||
(type-eval #`(Tuple #,@(stx-map replace-bind-and-discard-with-★ #'(τ ...))))]
|
||||
[(~Observe τ)
|
||||
(type-eval #`(Observe #,(replace-bind-and-discard-with-★ #'τ)))]
|
||||
[(~Inbound τ)
|
||||
(type-eval #`(Inbound #,(replace-bind-and-discard-with-★ #'τ)))]
|
||||
[(~Outbound τ)
|
||||
(type-eval #`(Outbound #,(replace-bind-and-discard-with-★ #'τ)))]
|
||||
[(~constructor-type _ τ ...)
|
||||
(make-cons-type t (stx-map replace-bind-and-discard-with-★ #'(τ ...)))]
|
||||
[_ t]))
|
||||
|
||||
(define-typed-syntax (assert e:expr) ≫
|
||||
[⊢ e ≫ e- (⇒ : τ:type)]
|
||||
#:with τ-in (strip-? #'τ.norm)
|
||||
-------------------------------------
|
||||
[⊢ (syndicate:assert e-) (⇒ : (U)) (⇒ :i τ-in) (⇒ :o τ) (⇒ :a (U))])
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Expressions
|
||||
|
||||
(define-typed-syntax (tuple e:expr ...) ≫
|
||||
[⊢ e ≫ e- (⇒ : τ)] ...
|
||||
-----------------------
|
||||
[⊢ (list 'tuple e- ...) (⇒ : (Tuple τ ...)) (⇒ :i (U)) (⇒ :o (U)) (⇒ :a (U))])
|
||||
|
||||
(define-typed-syntax (ref x:id) ≫
|
||||
[⊢ x ≫ x- ⇒ (~Field τ)]
|
||||
------------------------
|
||||
[⊢ (x-) (⇒ : τ) (⇒ :i (U)) (⇒ :o (U)) (⇒ :a (U))])
|
||||
|
||||
(define-typed-syntax (λ [p s] ...) ≫
|
||||
#:with (([x:id τ:type] ...) ...) (stx-map pat-bindings #'(p ...))
|
||||
[[x ≫ x- : τ] ... ⊢ s ≫ s- (⇒ : τv) (⇒ :i τ1) (⇒ :o τ2) (⇒ :a τ3)] ...
|
||||
;; REALLY not sure how to handle p/p-/p.match-pattern,
|
||||
;; particularly w.r.t. typed terms that appear in p.match-pattern
|
||||
[⊢ p ≫ _ ⇒ τ-p] ...
|
||||
#:with (p- ...) (stx-map compile-match-pattern #'(p ...))
|
||||
#:with (τ-in ...) (stx-map lower-pattern-type #'(τ-p ...))
|
||||
--------------------------------------------------------------
|
||||
;; TODO: add a catch-all error clause
|
||||
[⊢ (match-lambda- [p- (let- ([x- x] ...) s-)] ...)
|
||||
(⇒ : (→ (U τ-p ...) (Behavior (U τv ...) (U τ1 ...) (U τ2 ...) (U τ3 ...))))
|
||||
(⇒ :i (U))
|
||||
(⇒ :o (U))
|
||||
(⇒ :a (U))])
|
||||
|
||||
;; FlattishType -> FlattishType
|
||||
;; replaces (Bind τ) with τ and Discard with ★
|
||||
(define-for-syntax (lower-pattern-type t)
|
||||
(syntax-parse t
|
||||
[(~Bind τ)
|
||||
#'τ]
|
||||
[~Discard
|
||||
(type-eval #'★)]
|
||||
[(~U τ ...)
|
||||
(type-eval #`(U #,@(stx-map lower-pattern-type #'(τ ...))))]
|
||||
[(~Tuple τ ...)
|
||||
(type-eval #`(Tuple #,@(stx-map lower-pattern-type #'(τ ...))))]
|
||||
[(~Observe τ)
|
||||
(type-eval #`(Observe #,(lower-pattern-type #'τ)))]
|
||||
[(~Inbound τ)
|
||||
(type-eval #`(Inbound #,(lower-pattern-type #'τ)))]
|
||||
[(~Outbound τ)
|
||||
(type-eval #`(Outbound #,(lower-pattern-type #'τ)))]
|
||||
[(~constructor-type _ τ ...)
|
||||
(make-cons-type t (stx-map lower-pattern-type #'(τ ...)))]
|
||||
[_ t]))
|
||||
|
||||
(define-typed-syntax (typed-app e_fn e_arg ...) ≫
|
||||
[⊢ e_fn ≫ e_fn- (⇒ : (~→ τ_in:type ... (~Behavior τ-v τ-i τ-o τ-a)))]
|
||||
#:fail-unless (stx-length=? #'[τ_in ...] #'[e_arg ...])
|
||||
(num-args-fail-msg #'e_fn #'[τ_in ...] #'[e_arg ...])
|
||||
[⊢ e_arg ≫ e_arg- (⇒ : τ_arg:type)] ...
|
||||
;; #:do [(printf "~a\n" (stx-map type->str #'(τ_arg.norm ...)))
|
||||
;; (printf "~a\n" (stx-map type->str #'(τ_in.norm ...) #;(stx-map lower-pattern-type #'(τ_in.norm ...))))]
|
||||
#:fail-unless (stx-andmap <: #'(τ_arg.norm ...) (stx-map lower-pattern-type #'(τ_in.norm ...)))
|
||||
"argument mismatch"
|
||||
#:fail-unless (stx-andmap project-safe? #'(τ_arg.norm ...) #'(τ_in.norm ...))
|
||||
"match error"
|
||||
------------------------------------------------------------------------
|
||||
[⊢ (#%app- e_fn- e_arg- ...) (⇒ : τ-v) (⇒ :i τ-i) (⇒ :o τ-o) (⇒ :a τ-a)])
|
||||
|
||||
;; it would be nice to abstract over these three
|
||||
(define-typed-syntax (observe e:expr) ≫
|
||||
[⊢ e ≫ e- (⇒ : τ)]
|
||||
---------------------------------------------------------------------------
|
||||
[⊢ (syndicate:observe e-) (⇒ : (Observe τ)) (⇒ :i (U)) (⇒ :o (U)) (⇒ :a (U))])
|
||||
|
||||
(define-typed-syntax (inbound e:expr) ≫
|
||||
[⊢ e ≫ e- ⇒ τ]
|
||||
---------------------------------------------------------------------------
|
||||
[⊢ (syndicate:inbound e-) (⇒ : (Inbound τ)) (⇒ :i (U)) (⇒ :o (U)) (⇒ :a (U))])
|
||||
|
||||
(define-typed-syntax (outbound e:expr) ≫
|
||||
[⊢ e ≫ e- ⇒ τ]
|
||||
---------------------------------------------------------------------------
|
||||
[⊢ (syndicate:outbound e-) (⇒ : (Outbound τ)) (⇒ :i (U)) (⇒ :o (U)) (⇒ :a (U))])
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Patterns
|
||||
|
||||
(define-typed-syntax (bind x:id τ:type) ≫
|
||||
----------------------------------------
|
||||
;; TODO: at some point put $ back in
|
||||
[⊢ (void-) (⇒ : (Bind τ)) (⇒ :i (U)) (⇒ :o (U)) (⇒ :a (U))])
|
||||
|
||||
(define-typed-syntax discard
|
||||
[_ ≫
|
||||
--------------------
|
||||
;; TODO: change void to _
|
||||
[⊢ (void-) (⇒ : Discard) (⇒ :i (U)) (⇒ :o (U)) (⇒ :a (U))]])
|
||||
|
||||
;; pat -> ([Id Type] ...)
|
||||
(define-for-syntax (pat-bindings stx)
|
||||
(syntax-parse stx
|
||||
#:datum-literals (bind tuple)
|
||||
[(bind x:id τ:type)
|
||||
#'([x τ])]
|
||||
[(tuple p ...)
|
||||
#:with (([x:id τ:type] ...) ...) (stx-map pat-bindings #'(p ...))
|
||||
#'([x τ] ... ...)]
|
||||
[(k:kons1 p)
|
||||
(pat-bindings #'p)]
|
||||
[(~constructor-exp cons p ...)
|
||||
#:with (([x:id τ:type] ...) ...) (stx-map pat-bindings #'(p ...))
|
||||
#'([x τ] ... ...)]
|
||||
[_
|
||||
#'()]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Primitives
|
||||
|
||||
;; hmmm
|
||||
(define-primop + (→ Int Int (Behavior Int (U) (U) (U))))
|
||||
(define-primop - (→ Int Int (Behavior Int (U) (U) (U))))
|
||||
(define-primop * (→ Int Int (Behavior Int (U) (U) (U))))
|
||||
#;(define-primop and (→ Bool Bool (Behavior Bool (U) (U) (U))))
|
||||
(define-primop or (→ Bool Bool (Behavior Bool (U) (U) (U))))
|
||||
(define-primop not (→ Bool (Behavior Bool (U) (U) (U))))
|
||||
(define-primop < (→ Int Int (Behavior Bool (U) (U) (U))))
|
||||
(define-primop > (→ Int Int (Behavior Bool (U) (U) (U))))
|
||||
(define-primop <= (→ Int Int (Behavior Bool (U) (U) (U))))
|
||||
(define-primop >= (→ Int Int (Behavior Bool (U) (U) (U))))
|
||||
(define-primop = (→ Int Int (Behavior Bool (U) (U) (U))))
|
||||
|
||||
(define-typed-syntax (/ e1 e2) ≫
|
||||
[⊢ e1 ≫ e1- (⇐ : Int)]
|
||||
[⊢ e2 ≫ e2- (⇐ : Int)]
|
||||
------------------------
|
||||
[⊢ (exact-truncate- (/- e1- e2-)) (⇒ : Int) (⇒ :i (U)) (⇒ :o (U)) (⇒ :a (U))])
|
||||
|
||||
;; for some reason defining `and` as a prim op doesn't work
|
||||
(define-typed-syntax (and e ...) ≫
|
||||
[⊢ e ≫ e- (⇐ : Bool)] ...
|
||||
------------------------
|
||||
[⊢ (and- e- ...) (⇒ : Bool) (⇒ :i (U)) (⇒ :o (U)) (⇒ :a (U))])
|
||||
|
||||
(define-typed-syntax (equal? e1:expr e2:expr) ≫
|
||||
[⊢ e1 ≫ e1- (⇒ : τ1:type)]
|
||||
#:fail-unless (flat-type? #'τ1.norm)
|
||||
(format "equality only available on flat data; got ~a" (type->str #'τ1))
|
||||
[⊢ e2 ≫ e2- (⇐ : τ1)]
|
||||
---------------------------------------------------------------------------
|
||||
[⊢ (equal?- e1- e2-) (⇒ : Bool) (⇒ :i (U)) (⇒ :o (U)) (⇒ :a (U))])
|
||||
|
||||
(define-typed-syntax (displayln e:expr) ≫
|
||||
[⊢ e ≫ e- ⇒ τ]
|
||||
---------------
|
||||
[⊢ (displayln- e-) (⇒ : (U)) (⇒ :i (U)) (⇒ :o (U)) (⇒ :a (U))])
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Basic Values
|
||||
|
||||
(define-typed-syntax #%datum
|
||||
[(_ . n:integer) ≫
|
||||
----------------
|
||||
[⊢ (#%datum- . n) (⇒ : Int) (⇒ :i (U)) (⇒ :o (U)) (⇒ :a (U))]]
|
||||
[(_ . b:boolean) ≫
|
||||
----------------
|
||||
[⊢ (#%datum- . b) (⇒ : Bool) (⇒ :i (U)) (⇒ :o (U)) (⇒ :a (U))]]
|
||||
[(_ . s:string) ≫
|
||||
----------------
|
||||
[⊢ (#%datum- . s) (⇒ : String) (⇒ :i (U)) (⇒ :o (U)) (⇒ :a (U))]])
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Utilities
|
||||
|
||||
#;(define-syntax (begin/void-default stx)
|
||||
(syntax-parse stx
|
||||
[(_)
|
||||
(syntax/loc stx (void))]
|
||||
[(_ expr0 expr ...)
|
||||
(syntax/loc stx (begin- expr0 expr ...))]))
|
||||
|
||||
|
||||
|
||||
(define-typed-syntax (print-type e) ≫
|
||||
[⊢ e ≫ e- ⇒ τ]
|
||||
#:do [(displayln (type->str #'τ))]
|
||||
----------------------------------
|
||||
[⊢ e- ⇒ τ])
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Extensions
|
||||
|
||||
(define-syntax (match stx)
|
||||
(syntax-parse stx
|
||||
[(match e [pat body] ...+)
|
||||
(syntax/loc stx
|
||||
(typed-app (λ [pat body] ...) e))]))
|
||||
|
||||
(define-syntax (if stx)
|
||||
(syntax-parse stx
|
||||
[(if e1 e2 e3)
|
||||
(syntax/loc stx
|
||||
(typed-app (λ [#f e3] [discard e2]) e1))]))
|
||||
|
||||
(define-typed-syntax (cond [pred:expr s] ...+) ≫
|
||||
[⊢ pred ≫ pred- (⇐ : Bool)] ...
|
||||
[⊢ s ≫ s- (⇒ :i τ-i) (⇒ :o τ-o) (⇒ :a τ-a)] ...
|
||||
------------------------------------------------
|
||||
[⊢ (cond- [pred- s-] ...) (⇒ : (U)) (⇒ :i (U τ-i ...)) (⇒ :o (U τ-o ...)) (⇒ :a (U τ-a ...))])
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Tests
|
||||
|
||||
;; WANTED UNIT TESTS
|
||||
;; (check-true (<: #'(U String) #'String))
|
||||
;; (check-true (<: #'(U (U)) #'String))
|
||||
;; (check-true (<: #'(Actor (U (U))) #'(Actor String))
|
||||
;; (check-true (<: #'(Actor (U (U))) #'(Actor (U (Observe ★) String)))
|
||||
;; (check-true (<: ((current-type-eval) #'(U (U) (U))) ((current-type-eval) #'(U))))
|
||||
;; (check-false (<: ((current-type-eval) #'(Actor (U (Observe ★) String Int)))
|
||||
;; ((current-type-eval) #'(Actor (U (Observe ★) String)))))
|
||||
;; (check-true (<: (Actor (U (Observe ★) String)) (Actor (U (Observe ★) String)))
|
||||
|
||||
(module+ test
|
||||
(check-type 1 : Int)
|
||||
|
||||
(check-type (tuple 1 2 3) : (Tuple Int Int Int))
|
||||
|
||||
(check-type (tuple discard 1 (bind x Int)) : (Tuple Discard Int (Bind Int)))
|
||||
|
||||
#;(check-type (λ [(bind x Int) (begin)]) : (Case [→ (Bind Int) (Facet (U) (U) (U))]))
|
||||
#;(check-true (void? ((λ [(bind x Int) (begin)]) 1))))
|
||||
|
||||
(define-syntax (test-syntax-class stx)
|
||||
(syntax-parse stx
|
||||
[(_ e class:id)
|
||||
#`(let ()
|
||||
(define-syntax (test-result stx)
|
||||
(syntax-parse e
|
||||
[(~var _ class) #'#t]
|
||||
[_ #'#f]))
|
||||
(test-result))]))
|
|
@ -1,257 +0,0 @@
|
|||
#lang turnstile
|
||||
|
||||
(provide for/fold
|
||||
for
|
||||
for/list
|
||||
for/set
|
||||
for/sum
|
||||
for/first)
|
||||
|
||||
(require "core-types.rkt")
|
||||
(require "sequence.rkt")
|
||||
(require (only-in "list.rkt" List ~List))
|
||||
(require (only-in "set.rkt" Set ~Set))
|
||||
(require (only-in "hash.rkt" Hash ~Hash))
|
||||
(require (only-in "prim.rkt" Bool + #%datum))
|
||||
(require (only-in "core-expressions.rkt" let unit tuple-select mk-tuple))
|
||||
(require "maybe.rkt")
|
||||
|
||||
(require (postfix-in - (only-in racket/set
|
||||
for/set
|
||||
in-set)))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-splicing-syntax-class iter-clause
|
||||
#:attributes (parend)
|
||||
#:datum-literals (:)
|
||||
(pattern [x:id seq:expr]
|
||||
#:attr parend #'[x seq])
|
||||
(pattern [x:id : τ:type seq:expr]
|
||||
#:attr parend #'[x : τ seq])
|
||||
(pattern [(k:id v:id) hash-seq:expr]
|
||||
#:attr parend #'[(k v) hash-seq])
|
||||
(pattern (~seq #:when pred:expr)
|
||||
#:attr parend #'(#:when pred))
|
||||
(pattern (~seq #:unless pred:expr)
|
||||
#:attr parend #'(#:unless pred))
|
||||
(pattern (~seq #:break pred:expr)
|
||||
#:attr parend #'(#:break pred))))
|
||||
|
||||
;; a Binding is a (SyntaxList Id Id Type), i.e. #'(x x- τ-x)
|
||||
(begin-for-syntax
|
||||
(struct loop-clause (exp bindings) #:transparent)
|
||||
(struct directive (kw exp) #:transparent))
|
||||
|
||||
|
||||
;; (SyntaxListOf LoopClause) -> (Syntax LoopClause- (Binding ...))
|
||||
(define-for-syntax (analyze-for-clauses clauses)
|
||||
(define-values (br binds)
|
||||
(for/fold ([body-rev '()]
|
||||
[bindings '()])
|
||||
([clause (in-syntax clauses)])
|
||||
(match (analyze-for-clause clause bindings)
|
||||
[(loop-clause exp bs)
|
||||
(values (cons exp body-rev)
|
||||
(append bindings bs))]
|
||||
[(directive kw exp)
|
||||
(values (list* exp kw body-rev)
|
||||
bindings)])))
|
||||
#`(#,(reverse br)
|
||||
#,binds))
|
||||
|
||||
;; iter-clause (Listof Binding) -> (U iter-clause directive)
|
||||
(define-for-syntax (analyze-for-clause clause ctx)
|
||||
(define/with-syntax ([y y- τ-y] ...) ctx)
|
||||
(syntax-parse clause
|
||||
#:datum-literals (:)
|
||||
[[x:id seq:expr]
|
||||
#:and (~typecheck
|
||||
[[y ≫ y-- : τ-y] ... ⊢ seq ≫ seq- (⇒ : τ-seq)])
|
||||
#:fail-unless (pure? #'seq-) "pure"
|
||||
#:with x- (generate-temporary #'x)
|
||||
#:do [(define-values (seq-- τ-elems) (make-sequence #'seq- #'τ-seq))]
|
||||
(loop-clause (substs #'(y- ...) #'(y-- ...)
|
||||
#`[x- #,seq--]
|
||||
free-identifier=?)
|
||||
(list #`(x x- #,τ-elems)))]
|
||||
[[x:id : τ:type seq:expr]
|
||||
#:with seq+ (add-expected-type #'seq #'τ.norm)
|
||||
#:do [(match-define (list seq- (list (list x- τ-elems)))
|
||||
(analyze-for-clause (syntax/loc clause [x seq+])))]
|
||||
#:fail-unless (<: τ-elems #'τ.norm) "unexpected type"
|
||||
(loop-clause #`[#,x- #,seq-]
|
||||
(list #`(x #,x- τ.norm)))]
|
||||
[[(k:id v:id) hash-seq:expr]
|
||||
#:and (~typecheck
|
||||
[[y ≫ y-- : τ-y] ... ⊢ hash-seq ≫ hash-seq- (⇒ : (~Hash K V))])
|
||||
#:fail-unless (pure? #'hash-seq-) "pure"
|
||||
#:with (k- v-) (generate-temporaries #'(k v))
|
||||
(loop-clause (substs #'(y- ...) #'(y-- ...)
|
||||
#`[(k- v-) (in-hash- hash-seq-)]
|
||||
free-identifier=?)
|
||||
(list #'(k k- K) #'(v v- V)))]
|
||||
[(dir:keyword pred)
|
||||
#:and (~typecheck
|
||||
[[y ≫ y-- : τ-y] ... ⊢ pred ≫ pred- (⇐ : Bool)])
|
||||
#:fail-unless (pure? #'pred-) "pure"
|
||||
(directive #'dir (substs #'(y- ...) #'(y-- ...)
|
||||
#'pred-
|
||||
free-identifier=?))]))
|
||||
|
||||
;; Expression Type -> (Values Expression Type)
|
||||
;; Determine what kind of sequence we're dealing with;
|
||||
;; if it's not already in Sequence form, wrap the expression in the appropriate in-* form
|
||||
;; also figure out what the type of elements are to associate with the loop variable
|
||||
;; hashes handled separately
|
||||
(define-for-syntax (make-sequence e τ)
|
||||
(syntax-parse τ
|
||||
[(~Sequence t)
|
||||
(values e #'t)]
|
||||
[(~List t)
|
||||
(values #`(in-list- #,e) #'t)]
|
||||
[(~Set t)
|
||||
(values #`(in-set- #,e) #'t)]
|
||||
[_
|
||||
(type-error #:src e
|
||||
#:msg "not an iterable type: ~a" τ)]))
|
||||
|
||||
(define-for-syntax (bind-renames renames body)
|
||||
(syntax-parse renames
|
||||
[([x:id x-:id] ...)
|
||||
#:with (x-- ...) (map syntax-local-identifier-as-binding (syntax->list #'(x- ...)))
|
||||
(quasisyntax/loc body
|
||||
(let- ()
|
||||
(define-syntax x (make-variable-like-transformer #'x--)) ...
|
||||
#,body))]))
|
||||
|
||||
(define-typed-syntax for/fold
|
||||
[(for/fold ([acc:id (~optional (~datum :)) τ-acc init] ...+)
|
||||
(clause:iter-clause
|
||||
...)
|
||||
e-body ...+) ≫
|
||||
[⊢ init ≫ init- (⇐ : τ-acc)] ...
|
||||
#:fail-unless (all-pure? #'(init- ...)) "expression must be pure"
|
||||
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
||||
#:do [(define num-accs (length (syntax->list #'(τ-acc ...))))]
|
||||
#:with body-ty (if (= 1 num-accs)
|
||||
(first (syntax->list #'(τ-acc ...)))
|
||||
(type-eval #'(Tuple (~@ τ-acc ...))))
|
||||
[[[x ≫ x-- : τ] ...]
|
||||
[[acc ≫ acc- : τ-acc] ...] ⊢ (block e-body ...) ≫ e-body-
|
||||
(⇐ : body-ty)
|
||||
(⇒ ν-ep (~effs τ-ep ...))
|
||||
(⇒ ν-s (~effs τ-s ...))
|
||||
(⇒ ν-f (~effs τ-f ...))]
|
||||
-------------------------------------------------------
|
||||
[⊢ (values->tuple #,num-accs
|
||||
(for/fold- ([acc- init-] ...)
|
||||
clauses-
|
||||
#,(bind-renames #'([x-- x-] ...) #`(tuple->values #,num-accs e-body-))))
|
||||
(⇒ : body-ty)
|
||||
(⇒ ν-ep (τ-ep ...))
|
||||
(⇒ ν-s (τ-s ...))
|
||||
(⇒ ν-f (τ-f ...))]]
|
||||
[(for/fold (accs ... [acc:id init] more-accs ...)
|
||||
clauses
|
||||
e-body ...+) ≫
|
||||
[⊢ init ≫ _ (⇒ : τ-acc)]
|
||||
---------------------------------------------------
|
||||
[≻ (for/fold (accs ... [acc τ-acc init] more-accs ...)
|
||||
clauses
|
||||
e-body ...)]])
|
||||
|
||||
(define-syntax-parser tuple->values
|
||||
[(_ n:nat e:expr)
|
||||
(define arity (syntax-e #'n))
|
||||
(cond
|
||||
[(= 1 arity)
|
||||
#'e]
|
||||
[else
|
||||
(define/with-syntax tmp (generate-temporary 'tup))
|
||||
(define projections
|
||||
(for/list ([i (in-range arity)])
|
||||
#`(#%app- tuple-select #,i tmp)))
|
||||
#`(let- ([tmp e])
|
||||
(#%app- values- #,@projections))])])
|
||||
|
||||
#;(tuple->values 1 (tuple 0))
|
||||
|
||||
(define-syntax-parser values->tuple
|
||||
[(_ n:nat e:expr)
|
||||
(define arity (syntax-e #'n))
|
||||
(cond
|
||||
[(= 1 arity)
|
||||
#'e]
|
||||
[else
|
||||
(define/with-syntax (tmp ...) (generate-temporaries (make-list arity 'values->tuple)))
|
||||
#`(let-values- ([(tmp ...) e])
|
||||
(#%app- mk-tuple (#%app- list- tmp ...)))])])
|
||||
|
||||
(define-typed-syntax (for/list (clause:iter-clause ...)
|
||||
e-body ...+) ≫
|
||||
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
||||
[[x ≫ x-- : τ] ... ⊢ (block e-body ...) ≫ e-body-
|
||||
(⇒ : τ-body)
|
||||
(⇒ ν-ep (~effs τ-ep ...))
|
||||
(⇒ ν-s (~effs τ-s ...))
|
||||
(⇒ ν-f (~effs τ-f ...))]
|
||||
----------------------------------------------------------------------
|
||||
[⊢ (for/list- clauses-
|
||||
#,(bind-renames #'([x-- x-] ...) #'e-body-))
|
||||
(⇒ : (List τ-body))
|
||||
(⇒ ν-ep (τ-ep ...))
|
||||
(⇒ ν-s (τ-s ...))
|
||||
(⇒ ν-f (τ-f ...))])
|
||||
|
||||
(define-typed-syntax (for/set (clause:iter-clause ...)
|
||||
e-body ...+) ≫
|
||||
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
||||
[[x ≫ x-- : τ] ... ⊢ (block e-body ...) ≫ e-body-
|
||||
(⇒ : τ-body)
|
||||
(⇒ ν-ep (~effs τ-ep ...))
|
||||
(⇒ ν-s (~effs τ-s ...))
|
||||
(⇒ ν-f (~effs τ-f ...))]
|
||||
----------------------------------------------------------------------
|
||||
[⊢ (for/set- clauses-
|
||||
#,(bind-renames #'([x-- x-] ...) #'e-body-))
|
||||
(⇒ : (Set τ-body))
|
||||
(⇒ ν-ep (τ-ep ...))
|
||||
(⇒ ν-s (τ-s ...))
|
||||
(⇒ ν-f (τ-f ...))])
|
||||
|
||||
(define-typed-syntax (for/sum (clause ...)
|
||||
e-body ...+) ≫
|
||||
----------------------------------------------------------------------
|
||||
[≻ (for/fold ([acc 0])
|
||||
(clause ...)
|
||||
(+ acc (let () e-body ...)))])
|
||||
|
||||
(define-typed-syntax (for (clause ...)
|
||||
e-body ...+) ≫
|
||||
----------------------------------------------------------------------
|
||||
[≻ (for/fold ([acc unit])
|
||||
(clause ...)
|
||||
e-body ...
|
||||
acc)])
|
||||
|
||||
(define-typed-syntax (for/first (clause:iter-clause ...)
|
||||
e-body ...+) ≫
|
||||
#:with (clauses- ([x x- τ] ...)) (analyze-for-clauses #'(clause.parend ...))
|
||||
[[x ≫ x-- : τ] ... ⊢ (block e-body ...) ≫ e-body-
|
||||
(⇒ : τ-body)
|
||||
(⇒ ν-ep (~effs τ-ep ...))
|
||||
(⇒ ν-s (~effs τ-s ...))
|
||||
(⇒ ν-f (~effs τ-f ...))]
|
||||
[[res ≫ _ : τ-body] ⊢ res ≫ res- (⇒ : _)]
|
||||
----------------------------------------------------------------------
|
||||
[⊢ (let- ()
|
||||
(define- res-
|
||||
(for/first- clauses-
|
||||
#,(bind-renames #'([x-- x-] ...) #'e-body-)))
|
||||
(if- res-
|
||||
(some res-)
|
||||
none))
|
||||
(⇒ : (Maybe τ-body))
|
||||
(⇒ ν-ep (τ-ep ...))
|
||||
(⇒ ν-s (τ-s ...))
|
||||
(⇒ ν-f (τ-f ...))])
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue