2015-03-02 16:10:11 +00:00
|
|
|
|
#lang racket/base
|
2016-07-30 17:02:07 +00:00
|
|
|
|
;; Core structures and utilities for implementation of Incremental Syndicate.
|
2015-03-02 16:10:11 +00:00
|
|
|
|
|
2015-03-05 14:54:12 +00:00
|
|
|
|
(provide (struct-out message)
|
2015-03-06 11:21:50 +00:00
|
|
|
|
(except-out (struct-out quit) quit)
|
|
|
|
|
(rename-out [quit <quit>])
|
2017-02-15 23:18:19 +00:00
|
|
|
|
(except-out (struct-out actor) actor)
|
|
|
|
|
(rename-out [actor <actor>])
|
2016-07-30 17:02:07 +00:00
|
|
|
|
(struct-out quit-dataspace)
|
2015-03-05 14:54:12 +00:00
|
|
|
|
(struct-out transition)
|
|
|
|
|
|
2016-07-30 17:36:03 +00:00
|
|
|
|
(struct-out process)
|
|
|
|
|
|
2017-09-13 18:08:01 +00:00
|
|
|
|
assertion-struct
|
|
|
|
|
message-struct
|
|
|
|
|
|
2015-09-07 20:05:06 +00:00
|
|
|
|
(struct-out seal)
|
2016-05-06 21:35:15 +00:00
|
|
|
|
sealof
|
2015-09-07 20:05:06 +00:00
|
|
|
|
|
2015-03-05 14:54:12 +00:00
|
|
|
|
(all-from-out "patch.rkt")
|
|
|
|
|
|
2016-03-12 16:54:31 +00:00
|
|
|
|
;; imported from trie.rkt:
|
2015-03-05 14:54:12 +00:00
|
|
|
|
?
|
|
|
|
|
wildcard?
|
|
|
|
|
?!
|
|
|
|
|
(struct-out capture)
|
2016-01-22 02:55:41 +00:00
|
|
|
|
pretty-print-trie
|
|
|
|
|
trie->pretty-string
|
|
|
|
|
trie-non-empty?
|
|
|
|
|
trie-empty?
|
|
|
|
|
trie-empty
|
2015-03-05 14:54:12 +00:00
|
|
|
|
projection->pattern
|
2016-03-12 16:54:31 +00:00
|
|
|
|
projection-arity
|
2016-01-22 02:55:41 +00:00
|
|
|
|
trie-project
|
|
|
|
|
trie-project/set
|
|
|
|
|
trie-project/set/single
|
2016-01-18 22:33:26 +00:00
|
|
|
|
project-assertions
|
2015-03-05 14:54:12 +00:00
|
|
|
|
|
|
|
|
|
event?
|
|
|
|
|
action?
|
2016-03-01 21:45:29 +00:00
|
|
|
|
match-event
|
2015-03-05 14:54:12 +00:00
|
|
|
|
|
|
|
|
|
meta-label?
|
|
|
|
|
|
|
|
|
|
assert
|
|
|
|
|
retract
|
|
|
|
|
sub
|
|
|
|
|
unsub
|
2017-08-22 20:53:57 +00:00
|
|
|
|
patch->initial-assertions
|
2015-03-05 14:54:12 +00:00
|
|
|
|
|
2015-03-06 11:21:50 +00:00
|
|
|
|
(rename-out [make-quit quit])
|
2017-02-15 23:18:19 +00:00
|
|
|
|
make-actor
|
|
|
|
|
(rename-out [boot-process actor])
|
|
|
|
|
actor/stateless
|
2015-03-05 14:54:12 +00:00
|
|
|
|
|
2016-07-21 02:13:43 +00:00
|
|
|
|
general-transition?
|
2016-07-30 17:02:07 +00:00
|
|
|
|
ensure-transition
|
2016-07-21 02:13:43 +00:00
|
|
|
|
|
2015-03-06 15:49:39 +00:00
|
|
|
|
transition-bind
|
|
|
|
|
sequence-transitions
|
2015-12-11 02:16:06 +00:00
|
|
|
|
sequence-transitions*
|
|
|
|
|
sequence-transitions0
|
|
|
|
|
sequence-transitions0*
|
2015-03-06 15:49:39 +00:00
|
|
|
|
|
2016-07-30 17:02:07 +00:00
|
|
|
|
clean-actions
|
2016-07-30 17:36:03 +00:00
|
|
|
|
clean-transition
|
|
|
|
|
|
2016-07-30 17:48:42 +00:00
|
|
|
|
update-process-state
|
2017-08-05 23:36:15 +00:00
|
|
|
|
boot->process+transition
|
|
|
|
|
actor->process+transition/assertions)
|
2015-03-16 14:38:32 +00:00
|
|
|
|
|
2017-08-10 19:04:45 +00:00
|
|
|
|
(module reader syntax/module-reader
|
|
|
|
|
syndicate/core-lang)
|
|
|
|
|
|
2015-03-02 16:10:11 +00:00
|
|
|
|
(require racket/match)
|
|
|
|
|
(require (only-in racket/list flatten))
|
2016-03-12 16:54:31 +00:00
|
|
|
|
(require "trie.rkt")
|
2015-03-02 16:10:11 +00:00
|
|
|
|
(require "patch.rkt")
|
2015-03-16 14:38:32 +00:00
|
|
|
|
(require "mux.rkt")
|
2017-07-12 14:29:26 +00:00
|
|
|
|
(require "pretty.rkt")
|
2015-03-02 16:10:11 +00:00
|
|
|
|
|
2017-08-05 23:36:15 +00:00
|
|
|
|
(require (for-syntax racket/base))
|
|
|
|
|
(require (for-syntax syntax/parse))
|
|
|
|
|
(require (for-syntax syntax/srcloc))
|
|
|
|
|
(require "syntax-classes.rkt")
|
|
|
|
|
|
2015-03-04 16:16:18 +00:00
|
|
|
|
;; Events = Patches ∪ Messages
|
|
|
|
|
(struct message (body) #:prefab)
|
|
|
|
|
|
2015-03-02 16:10:11 +00:00
|
|
|
|
;; Actions ⊃ Events
|
2017-08-05 23:36:15 +00:00
|
|
|
|
(struct actor (boot initial-assertions) #:prefab)
|
2016-04-07 07:42:54 +00:00
|
|
|
|
(struct quit-dataspace () #:prefab) ;; NB. An action. Compare (quit), a Transition.
|
2015-03-02 16:10:11 +00:00
|
|
|
|
|
|
|
|
|
;; A Behavior is a ((Option Event) Any -> Transition): a function
|
|
|
|
|
;; mapping an Event (or, in the #f case, a poll signal) and a
|
|
|
|
|
;; Process's current state to a Transition.
|
|
|
|
|
;;
|
|
|
|
|
;; A Transition is either
|
|
|
|
|
;; - #f, a signal from a Process that it is inert and need not be
|
|
|
|
|
;; scheduled until some Event relevant to it arrives; or,
|
|
|
|
|
;; - a (transition Any (Constreeof Action)), a new Process state to
|
2016-04-07 07:42:54 +00:00
|
|
|
|
;; be held by its Dataspace and a sequence of Actions for the Dataspace
|
2015-03-02 16:10:11 +00:00
|
|
|
|
;; to take on the transitioning Process's behalf.
|
2015-11-17 19:01:04 +00:00
|
|
|
|
;; - a (quit (Option Exn) (Constreeof Action)), signalling that the
|
|
|
|
|
;; Process should never again be handed an event, and that any
|
|
|
|
|
;; queued actions should be performed, followed by the sequence
|
|
|
|
|
;; of Actions given, and then the process should be
|
|
|
|
|
;; garbage-collected. The optional Exn is only used for
|
|
|
|
|
;; debugging purposes; #f means normal termination.
|
2015-03-02 16:10:11 +00:00
|
|
|
|
(struct transition (state actions) #:transparent)
|
2015-11-17 19:01:04 +00:00
|
|
|
|
(struct quit (exn actions) #:prefab)
|
2015-03-02 16:10:11 +00:00
|
|
|
|
|
2016-07-30 17:36:03 +00:00
|
|
|
|
;; A Process is per-process data: (process Any Behavior Any)
|
2017-07-12 14:29:26 +00:00
|
|
|
|
(struct process (name behavior state) #:transparent
|
|
|
|
|
#:methods gen:syndicate-pretty-printable
|
|
|
|
|
[(define (syndicate-pretty-print proc [p (current-output-port)])
|
|
|
|
|
(pretty-print-process proc p))])
|
2016-07-30 17:36:03 +00:00
|
|
|
|
|
2015-03-02 16:10:11 +00:00
|
|
|
|
;; A PID is a Nat.
|
|
|
|
|
;; A Label is a PID or 'meta.
|
|
|
|
|
|
2017-09-13 18:08:01 +00:00
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
;; Thin veneers over `struct` for declaring intent.
|
|
|
|
|
|
|
|
|
|
(define-syntax-rule (assertion-struct item ...) (struct item ... #:prefab))
|
|
|
|
|
(define-syntax-rule (message-struct item ...) (struct item ... #:prefab))
|
|
|
|
|
|
2015-09-07 20:05:06 +00:00
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
;; Seals are used by protocols to prevent the routing tries from
|
|
|
|
|
;; examining internal structure of values.
|
|
|
|
|
|
2017-12-05 17:22:13 +00:00
|
|
|
|
(struct seal (contents) ;; NB. Neither transparent nor prefab
|
|
|
|
|
#:methods gen:custom-write
|
|
|
|
|
[(define (write-proc s port mode)
|
|
|
|
|
(fprintf port "#{~v}" (seal-contents s)))])
|
2015-09-07 20:05:06 +00:00
|
|
|
|
|
2016-05-06 21:35:15 +00:00
|
|
|
|
;; contract -> contract
|
|
|
|
|
(define ((sealof c) x)
|
|
|
|
|
(and (seal? x) (c (seal-contents x))))
|
|
|
|
|
|
2015-03-02 16:10:11 +00:00
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
2015-03-04 16:16:18 +00:00
|
|
|
|
(define (event? x) (or (patch? x) (message? x)))
|
2017-02-15 23:18:19 +00:00
|
|
|
|
(define (action? x) (or (event? x) (actor? x) (quit-dataspace? x)))
|
2015-03-02 16:10:11 +00:00
|
|
|
|
|
2016-03-01 21:45:29 +00:00
|
|
|
|
(define-syntax-rule (match-event e clause ...)
|
|
|
|
|
(match e
|
|
|
|
|
clause ...
|
|
|
|
|
[_ #f]))
|
|
|
|
|
|
2016-07-30 17:02:07 +00:00
|
|
|
|
(define (assert pattern)
|
|
|
|
|
(patch (pattern->trie '<assert> pattern) trie-empty))
|
|
|
|
|
(define (retract pattern)
|
|
|
|
|
(patch trie-empty (pattern->trie '<retract> pattern)))
|
2015-03-05 14:54:12 +00:00
|
|
|
|
|
2016-07-30 17:02:07 +00:00
|
|
|
|
(define (sub pattern)
|
|
|
|
|
(patch (pattern->trie '<sub> (observe pattern)) trie-empty))
|
|
|
|
|
(define (unsub pattern)
|
|
|
|
|
(patch trie-empty (pattern->trie '<unsub> (observe pattern))))
|
2015-03-05 14:54:12 +00:00
|
|
|
|
|
2017-08-22 20:53:57 +00:00
|
|
|
|
(define (patch->initial-assertions p)
|
|
|
|
|
(when (not (trie-empty? (patch-removed p)))
|
|
|
|
|
(error 'patch->initial-assertions "Non-empty removed set in initial assertion patch: ~v" p))
|
|
|
|
|
(patch-added p))
|
|
|
|
|
|
2015-03-02 16:10:11 +00:00
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
2015-12-03 20:53:07 +00:00
|
|
|
|
(define (general-transition? v)
|
2016-03-01 21:45:29 +00:00
|
|
|
|
(or (not v) (transition? v) (quit? v) (void? v)))
|
2015-12-03 20:53:07 +00:00
|
|
|
|
|
2015-03-02 16:10:11 +00:00
|
|
|
|
(define (ensure-transition v)
|
2015-12-03 20:53:07 +00:00
|
|
|
|
(if (general-transition? v)
|
2015-03-02 16:10:11 +00:00
|
|
|
|
v
|
2016-03-01 21:45:29 +00:00
|
|
|
|
(raise (exn:fail:contract (format "Expected transition, quit, #f or (void); got ~v" v)
|
2015-03-02 16:10:11 +00:00
|
|
|
|
(current-continuation-marks)))))
|
|
|
|
|
|
|
|
|
|
(define (clean-transition t)
|
2015-03-06 11:21:50 +00:00
|
|
|
|
(match t
|
|
|
|
|
[#f #f]
|
2015-11-17 19:01:04 +00:00
|
|
|
|
[(quit exn actions) (quit exn (clean-actions actions))]
|
2016-03-01 21:45:29 +00:00
|
|
|
|
[(transition state actions) (transition state (clean-actions actions))]
|
|
|
|
|
[(? void?) #f]))
|
2015-03-02 16:10:11 +00:00
|
|
|
|
|
|
|
|
|
(define (clean-actions actions)
|
2015-03-05 14:54:12 +00:00
|
|
|
|
(filter (lambda (x) (and (action? x) (not (patch-empty? x)))) (flatten actions)))
|
2015-03-02 16:10:11 +00:00
|
|
|
|
|
2016-07-30 17:36:03 +00:00
|
|
|
|
(define (update-process-state i new-state)
|
|
|
|
|
(struct-copy process i [state new-state]))
|
|
|
|
|
|
2017-08-05 23:36:15 +00:00
|
|
|
|
(define (boot->process+transition boot-proc)
|
|
|
|
|
(match-define (list beh t name) (boot-proc))
|
2016-07-30 17:48:42 +00:00
|
|
|
|
(values (process name beh 'undefined-initial-state) t))
|
|
|
|
|
|
2017-08-05 23:36:15 +00:00
|
|
|
|
(define (actor->process+transition/assertions s)
|
|
|
|
|
(define-values (proc t) (boot->process+transition (actor-boot s)))
|
|
|
|
|
(values proc t (actor-initial-assertions s)))
|
|
|
|
|
|
2015-11-17 19:01:04 +00:00
|
|
|
|
(define (make-quit #:exception [exn #f] . actions)
|
|
|
|
|
(quit exn actions))
|
2015-03-06 11:21:50 +00:00
|
|
|
|
|
2017-08-05 23:36:15 +00:00
|
|
|
|
(define (make-actor actor-producing-thunk initial-assertions)
|
2017-02-15 23:18:19 +00:00
|
|
|
|
(actor (let ((parameterization (current-parameterization)))
|
2016-07-31 21:24:48 +00:00
|
|
|
|
(lambda ()
|
|
|
|
|
(call-with-parameterization
|
|
|
|
|
parameterization
|
|
|
|
|
(lambda ()
|
2017-02-15 23:18:19 +00:00
|
|
|
|
(match (actor-producing-thunk)
|
2016-07-31 21:24:48 +00:00
|
|
|
|
[(list (? procedure? raw-beh) (? general-transition? txn) name)
|
|
|
|
|
(list (lambda (e s)
|
|
|
|
|
(call-with-parameterization parameterization (lambda () (raw-beh e s))))
|
|
|
|
|
txn
|
|
|
|
|
name)]
|
2017-08-05 23:36:15 +00:00
|
|
|
|
[other other]))))) ;; punt on error checking to dataspace boot code
|
|
|
|
|
initial-assertions))
|
|
|
|
|
|
|
|
|
|
(define-syntax (boot-process stx)
|
|
|
|
|
(syntax-parse stx
|
|
|
|
|
[(_ name:name assertions:assertions behavior-exp initial-state-exp initial-action-tree-exp)
|
|
|
|
|
#'(make-actor (lambda ()
|
|
|
|
|
(list behavior-exp
|
|
|
|
|
(transition initial-state-exp initial-action-tree-exp)
|
|
|
|
|
name.N))
|
|
|
|
|
assertions.P)]))
|
|
|
|
|
|
|
|
|
|
(define-syntax (actor/stateless stx)
|
|
|
|
|
(syntax-parse stx
|
|
|
|
|
[(_ name:name assertions:assertions behavior-exp initial-action-tree-exp)
|
|
|
|
|
#'(boot-process #:name name.N
|
|
|
|
|
#:assertions* assertions.P
|
|
|
|
|
(stateless-behavior-wrap behavior-exp)
|
|
|
|
|
(void)
|
|
|
|
|
initial-action-tree-exp)]))
|
2015-03-06 13:23:36 +00:00
|
|
|
|
|
|
|
|
|
(define ((stateless-behavior-wrap b) e state)
|
|
|
|
|
(match (b e)
|
|
|
|
|
[#f #f]
|
|
|
|
|
[(? quit? q) q]
|
|
|
|
|
[actions (transition state actions)]))
|
|
|
|
|
|
2015-03-02 16:10:11 +00:00
|
|
|
|
(define (transition-bind k t0)
|
2015-03-06 11:21:50 +00:00
|
|
|
|
(match t0
|
|
|
|
|
[#f (error 'transition-bind "Cannot bind from transition #f with continuation ~v" k)]
|
2015-11-17 19:01:04 +00:00
|
|
|
|
[(quit _ _) t0]
|
2015-03-06 11:21:50 +00:00
|
|
|
|
[(transition state0 actions0)
|
|
|
|
|
(match (k state0)
|
|
|
|
|
[#f t0]
|
2015-11-17 19:01:04 +00:00
|
|
|
|
[(quit exn actions1) (quit exn (cons actions0 actions1))]
|
2015-03-06 11:21:50 +00:00
|
|
|
|
[(transition state1 actions1) (transition state1 (cons actions0 actions1))])]))
|
2015-03-02 16:10:11 +00:00
|
|
|
|
|
|
|
|
|
(define (sequence-transitions t0 . steps)
|
2015-12-09 23:59:33 +00:00
|
|
|
|
(sequence-transitions* t0 steps))
|
|
|
|
|
|
|
|
|
|
(define (sequence-transitions* t0 steps)
|
2015-03-02 16:10:11 +00:00
|
|
|
|
(foldl transition-bind t0 steps))
|
|
|
|
|
|
2015-12-09 23:59:33 +00:00
|
|
|
|
(define (sequence-transitions0 state0 . steps)
|
|
|
|
|
(sequence-transitions0* state0 steps))
|
|
|
|
|
|
|
|
|
|
(define (sequence-transitions0* state0 steps)
|
|
|
|
|
(match steps
|
|
|
|
|
['() #f]
|
|
|
|
|
[(cons step rest)
|
|
|
|
|
(match (step state0)
|
|
|
|
|
[#f (sequence-transitions0* state0 rest)]
|
|
|
|
|
[(? quit? q) q]
|
|
|
|
|
[(? transition? t) (sequence-transitions* t rest)])]))
|
|
|
|
|
|
2015-03-04 14:45:16 +00:00
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
2017-07-12 14:29:26 +00:00
|
|
|
|
(define (pretty-print-process proc p)
|
|
|
|
|
(match-define (process name behavior state) proc)
|
|
|
|
|
(fprintf p "PROCESS:\n")
|
|
|
|
|
(fprintf p " - Name: ~v\n" name)
|
|
|
|
|
(fprintf p " - Behavior: ~v\n" behavior)
|
|
|
|
|
(fprintf p " - ")
|
|
|
|
|
(display (indented-port-output 3 (lambda (p) (syndicate-pretty-print state p)) #:first-line? #f) p)
|
|
|
|
|
(newline p))
|
|
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
2016-04-07 08:06:59 +00:00
|
|
|
|
;;; Local Variables:
|
|
|
|
|
;;; eval: (put 'match-event 'scheme-indent-function 1)
|
|
|
|
|
;;; eval: (put 'match-event 'racket-indent-function 1)
|
|
|
|
|
;;; End:
|