POC imperative dataspace implementation, with set-box example
This commit is contained in:
Tony Garnock-Jones
parent
25997cc778
commit
2e67feee6d
|
|
@ -0,0 +1,32 @@
|
|||
#lang racket/base
|
||||
;; Bags and Deltas (which are Bags where item-counts can be negative).
|
||||
|
||||
(provide make-bag
|
||||
bag-change!
|
||||
bag-ref
|
||||
bag-clear!
|
||||
in-bag)
|
||||
|
||||
;; A `(Bagof X)` is a `(MutableHash X Nat)`, where the `Nat` against
|
||||
;; an `X` is its replication count in the bag.
|
||||
;;
|
||||
;; A `(Deltaof X)` is a `(MutableHash X Int)`, just like a `(Bagof X)`
|
||||
;; except the replication counts can be negative.
|
||||
|
||||
(define make-bag make-hash)
|
||||
|
||||
(define (bag-change! b x delta)
|
||||
(define old-count (bag-ref b x))
|
||||
(define new-count (+ old-count delta))
|
||||
(if (zero? new-count)
|
||||
(begin (hash-remove! b x)
|
||||
(if (zero? old-count) 'absent->absent 'present->absent))
|
||||
(begin (hash-set! b x new-count)
|
||||
(if (zero? old-count) 'absent->present 'present->present))))
|
||||
|
||||
(define (bag-ref b x)
|
||||
(hash-ref b x 0))
|
||||
|
||||
(define bag-clear! hash-clear!)
|
||||
|
||||
(define-syntax-rule (in-bag piece ...) (in-hash piece ...))
|
||||
|
|
@ -0,0 +1,448 @@
|
|||
#lang racket/base
|
||||
|
||||
(require syndicate/functional-queue)
|
||||
(require syndicate/dataflow)
|
||||
(require racket/match)
|
||||
(require racket/set)
|
||||
|
||||
(module+ test (require rackunit))
|
||||
|
||||
(require "skeleton.rkt")
|
||||
(require "pattern.rkt")
|
||||
(require "bag.rkt")
|
||||
|
||||
;; A `FID` is a Facet ID, uniquely identifying both a facet and its
|
||||
;; ancestry in a `Dataspace`.
|
||||
;;
|
||||
;; FID = (Listof Nat)
|
||||
;;
|
||||
;; The first `Nat` in the list is the unique identifier for this
|
||||
;; facet; the `cdr` of the list is the FID of its parent facet. No two
|
||||
;; `FID`s in a `Dataspace` have the same first `Nat`.
|
||||
|
||||
;; A `Dataspace` is a ... TODO
|
||||
|
||||
;; An `Action` is either `(patch (Deltaof Assertion))` or `(message
|
||||
;; Assertion)` or `(spawn BootProc)`.
|
||||
(struct patch (changes) #:prefab)
|
||||
(struct message (body) #:prefab)
|
||||
(struct spawn (boot-proc) #:prefab)
|
||||
|
||||
(struct dataspace ([next-id #:mutable] ;; Nat
|
||||
routing-table ;; Skeleton
|
||||
facets ;; (MutableHash FID Facet)
|
||||
actors ;; (MutableSetof FID)
|
||||
assertions ;; (Bagof Assertion)
|
||||
dataflow ;; DataflowGraph
|
||||
pending-scripts ;; (MutableVectorof (Queueof (-> Any)))
|
||||
[pending-actions #:mutable] ;; (Queueof Action)
|
||||
)
|
||||
#:transparent)
|
||||
|
||||
(struct facet (id ;; FID
|
||||
endpoints ;; (MutableHash EID Endpoint)
|
||||
[stop-scripts #:mutable] ;; (Listof Script) -- IN REVERSE ORDER
|
||||
[children #:mutable] ;; (Setof FID)
|
||||
)
|
||||
#:transparent)
|
||||
|
||||
(struct endpoint (id ;; EID
|
||||
[assertion #:mutable] ;; Assertion
|
||||
assertion-fn ;; (-> Assertion)
|
||||
handler ;; (Option SkInterest)
|
||||
)
|
||||
#:transparent)
|
||||
|
||||
;; TODO: field ownership: record actor (root facet) ID in field, check
|
||||
;; it on access.
|
||||
(struct field-handle (name ;; Symbol
|
||||
id ;; Nat
|
||||
owner ;; FID
|
||||
[value #:mutable] ;; Any
|
||||
)
|
||||
#:methods gen:custom-write
|
||||
[(define (write-proc f port mode)
|
||||
(fprintf port "#<field-handle:~a:~a>" (field-handle-name f) (field-handle-id f)))]
|
||||
#:property prop:procedure
|
||||
(case-lambda
|
||||
[(f)
|
||||
(dataflow-record-observation! (dataspace-dataflow (current-dataspace)) f)
|
||||
(field-handle-value f)]
|
||||
[(f v)
|
||||
(dataflow-record-damage! (dataspace-dataflow (current-dataspace)) f)
|
||||
(set-field-handle-value! f v)]))
|
||||
|
||||
;; Parameterof Dataspace
|
||||
(define current-dataspace (make-parameter #f))
|
||||
|
||||
;; Parameterof FID
|
||||
(define current-actor (make-parameter #f))
|
||||
|
||||
;; Parameterof FID
|
||||
(define current-facet-id (make-parameter #f))
|
||||
|
||||
;; Parameterof Facet
|
||||
(define current-facet (make-parameter #f))
|
||||
|
||||
;; Parameterof Boolean
|
||||
(define in-script? (make-parameter #t))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
;; Script priorities. These are used to ensure that the results of
|
||||
;; some *side effects* are visible to certain pieces of code.
|
||||
|
||||
(module priorities racket/base
|
||||
(require (for-syntax racket/base))
|
||||
|
||||
(define-syntax (define-priority-levels stx)
|
||||
(let loop ((counter 0) (stx (syntax-case stx ()
|
||||
[(_ level ...) #'(level ...)])))
|
||||
(syntax-case stx ()
|
||||
[()
|
||||
#'(void)]
|
||||
[(#:count c)
|
||||
#`(begin (define c #,counter)
|
||||
(provide c))]
|
||||
[(this-level more ...)
|
||||
#`(begin (define this-level #,counter)
|
||||
(provide this-level)
|
||||
#,(loop (+ counter 1) #'(more ...)))])))
|
||||
|
||||
(define-priority-levels ;; highest-priority to lowest-priority
|
||||
*query-priority-high*
|
||||
*query-priority*
|
||||
*query-handler-priority*
|
||||
*normal-priority*
|
||||
*gc-priority*
|
||||
*idle-priority*
|
||||
#:count priority-count))
|
||||
|
||||
(require (submod "." priorities))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (make-dataspace)
|
||||
(dataspace 0
|
||||
(make-empty-skeleton)
|
||||
(make-hash)
|
||||
(mutable-set)
|
||||
(make-bag)
|
||||
(make-dataflow-graph)
|
||||
(make-vector priority-count (make-queue))
|
||||
(make-queue)))
|
||||
|
||||
(define (generate-id! ds)
|
||||
(let ((id (dataspace-next-id ds)))
|
||||
(set-dataspace-next-id! ds (+ id 1))
|
||||
id))
|
||||
|
||||
(define (fid-parent fid)
|
||||
(cdr fid))
|
||||
|
||||
(define (generate-fid! ds parent-fid)
|
||||
(cons (generate-id! ds) parent-fid))
|
||||
|
||||
(define (actor-fid? fid)
|
||||
(null? (fid-parent fid)))
|
||||
|
||||
(define (add-actor! ds boot-proc)
|
||||
(define actor-fid (generate-fid! ds '()))
|
||||
(set-add! (dataspace-actors ds) actor-fid)
|
||||
(add-facet! ds actor-fid actor-fid boot-proc))
|
||||
|
||||
(define (lookup-facet ds fid)
|
||||
(hash-ref (dataspace-facets ds) fid #f))
|
||||
|
||||
(define-syntax-rule (with-current-facet [ds actor-fid fid f script?] body ...)
|
||||
(parameterize ((current-dataspace ds)
|
||||
(current-actor actor-fid)
|
||||
(current-facet-id fid)
|
||||
(current-facet f)
|
||||
(in-script? script?))
|
||||
body ...))
|
||||
|
||||
(define (capture-facet-context proc)
|
||||
(let ((ds (current-dataspace))
|
||||
(actor-fid (current-actor))
|
||||
(fid (current-facet-id))
|
||||
(f (current-facet)))
|
||||
(lambda args
|
||||
(with-current-facet [ds actor-fid fid f #t]
|
||||
(apply proc args)))))
|
||||
|
||||
(define (pop-next-script! ds)
|
||||
(define priority-levels (dataspace-pending-scripts ds))
|
||||
(let loop ((level 0))
|
||||
(and (< level (vector-length priority-levels))
|
||||
(let ((q (vector-ref priority-levels level)))
|
||||
(if (queue-empty? q)
|
||||
(loop (+ level 1))
|
||||
(let-values (((script q) (dequeue q)))
|
||||
(vector-set! priority-levels level q)
|
||||
script))))))
|
||||
|
||||
(define (run-all-pending-scripts! ds)
|
||||
(define script (pop-next-script! ds))
|
||||
(and script
|
||||
(begin (script)
|
||||
(dataflow-repair-damage! (dataspace-dataflow ds)
|
||||
(lambda (subject-id)
|
||||
(match-define (list fid eid) subject-id)
|
||||
(define f (lookup-facet ds fid))
|
||||
(when f
|
||||
(define ep (hash-ref (facet-endpoints f) eid))
|
||||
(define old-assertion (endpoint-assertion ep))
|
||||
(define new-assertion ((endpoint-assertion-fn ep)))
|
||||
(when (not (equal? old-assertion new-assertion))
|
||||
(set-endpoint-assertion! ep new-assertion)
|
||||
(dataspace-retract! ds old-assertion)
|
||||
(dataspace-assert! ds new-assertion)
|
||||
(define h (endpoint-handler ep))
|
||||
(when h
|
||||
(dataspace-unsubscribe! ds h)
|
||||
(dataspace-subscribe! ds h))))))
|
||||
(run-all-pending-scripts! ds))))
|
||||
|
||||
(define (perform-pending-actions! ds)
|
||||
(define actions (queue->list (dataspace-pending-actions ds)))
|
||||
(set-dataspace-pending-actions! ds (make-queue))
|
||||
(for [(action actions)]
|
||||
(match action
|
||||
[(patch delta)
|
||||
(for [((a count) (in-bag delta))]
|
||||
(match (bag-change! (dataspace-assertions ds) a count)
|
||||
['present->absent (remove-assertion! (dataspace-routing-table ds) a)]
|
||||
['absent->present (add-assertion! (dataspace-routing-table ds) a)]
|
||||
;; 'absent->absent absurd
|
||||
['present->present (void)]))] ;; i.e. no visible change
|
||||
[(message body)
|
||||
(send-assertion! (dataspace-routing-table ds) body)]
|
||||
[(spawn boot-proc)
|
||||
(add-actor! ds boot-proc)]))
|
||||
(not (null? actions)))
|
||||
|
||||
(define (run-scripts! ds)
|
||||
(define ran-a-script (run-all-pending-scripts! ds))
|
||||
(define performed-an-action (perform-pending-actions! ds))
|
||||
;; TODO: figure out when a dataspace should quit itself. Given the
|
||||
;; mutable nature of the implementation, maybe never? It might be
|
||||
;; being held elsewhere!
|
||||
(or ran-a-script performed-an-action))
|
||||
|
||||
(define (add-facet! ds actor-fid fid boot-proc)
|
||||
(define parent-fid (fid-parent fid))
|
||||
(define f (facet fid
|
||||
(make-hash)
|
||||
'()
|
||||
(set)))
|
||||
(hash-set! (dataspace-facets ds) fid f)
|
||||
(when (pair? parent-fid)
|
||||
(define pf (lookup-facet ds parent-fid))
|
||||
(when pf (set-facet-children! pf (set-add (facet-children pf) fid))))
|
||||
(with-current-facet [ds actor-fid fid f #f]
|
||||
(boot-proc))
|
||||
(schedule-script! ds (lambda ()
|
||||
(when (and (facet-live? ds fid)
|
||||
(or (and (pair? parent-fid) (not (facet-live? ds parent-fid)))
|
||||
(facet-live-but-inert? ds fid)))
|
||||
(terminate-facet! ds actor-fid fid)))))
|
||||
|
||||
(define (facet-live? ds fid)
|
||||
(hash-has-key? (dataspace-facets ds) fid))
|
||||
|
||||
(define (facet-live-but-inert? ds fid)
|
||||
(define f (lookup-facet ds fid))
|
||||
(and f
|
||||
(hash-empty? (facet-endpoints f))
|
||||
(set-empty? (facet-children f))))
|
||||
|
||||
(define (schedule-script! #:priority [priority *normal-priority*] ds thunk)
|
||||
(define v (dataspace-pending-scripts ds))
|
||||
(vector-set! v priority (enqueue (vector-ref v priority) thunk)))
|
||||
|
||||
(define (terminate-facet! ds actor-fid fid)
|
||||
(define f (lookup-facet ds fid))
|
||||
(when f
|
||||
(define parent-fid (fid-parent fid))
|
||||
|
||||
(when (pair? parent-fid)
|
||||
(define pf (lookup-facet ds parent-fid))
|
||||
(when pf (set-facet-children! (set-remove (facet-children pf) fid))))
|
||||
|
||||
(hash-remove! (dataspace-facets ds) fid)
|
||||
|
||||
(for [(child-fid (in-set (facet-children f)))]
|
||||
(terminate-facet! ds actor-fid child-fid))
|
||||
|
||||
;; Run stop-scripts after terminating children. This means that
|
||||
;; children's stop-scripts run before ours.
|
||||
(for [(script (reverse (facet-stop-scripts f)))]
|
||||
(schedule-script! ds script))
|
||||
|
||||
(schedule-script!
|
||||
ds
|
||||
(lambda ()
|
||||
(for [((eid ep) (in-hash (facet-endpoints f)))]
|
||||
(dataflow-forget-subject! (dataspace-dataflow ds) (list fid eid))
|
||||
(dataspace-retract! ds (endpoint-assertion ep))
|
||||
(define h (endpoint-handler ep))
|
||||
(when h (dataspace-unsubscribe! ds h)))))
|
||||
|
||||
(schedule-script!
|
||||
#:priority *gc-priority*
|
||||
ds
|
||||
(lambda ()
|
||||
(when (and (pair? parent-fid) (facet-live-but-inert? ds parent-fid))
|
||||
(log-info "terminating ~v because it's dead and child ~v terminated" parent-fid fid)
|
||||
(terminate-facet! ds actor-fid parent-fid))))))
|
||||
|
||||
(define (add-endpoint! ds where assertion-fn handler)
|
||||
(when (in-script?)
|
||||
(error 'add-endpoint!
|
||||
"~a: Cannot add endpoint in script; are you missing a (react ...)?"
|
||||
where))
|
||||
(define eid (generate-id! ds))
|
||||
(define assertion
|
||||
(parameterize ((current-dataflow-subject-id (list (current-facet-id) eid)))
|
||||
(assertion-fn)))
|
||||
(define ep (endpoint eid assertion assertion-fn handler))
|
||||
(dataspace-assert! ds assertion)
|
||||
(when handler (dataspace-subscribe! ds handler))
|
||||
(hash-set! (facet-endpoints (current-facet)) eid ep))
|
||||
|
||||
(define (ensure-patch-action! ds)
|
||||
(define old-q (dataspace-pending-actions ds))
|
||||
(when (or (queue-empty? old-q) (not (patch? (queue-last old-q))))
|
||||
(set-dataspace-pending-actions! ds (enqueue old-q (patch (make-bag)))))
|
||||
(patch-changes (queue-last (dataspace-pending-actions ds))))
|
||||
|
||||
(define (dataspace-retract! ds assertion)
|
||||
(when (not (void? assertion))
|
||||
(bag-change! (ensure-patch-action! ds) assertion -1)))
|
||||
|
||||
(define (dataspace-assert! ds assertion)
|
||||
(when (not (void? assertion))
|
||||
(bag-change! (ensure-patch-action! ds) assertion +1)))
|
||||
|
||||
(define (dataspace-unsubscribe! ds h)
|
||||
(remove-interest! (dataspace-routing-table ds) h))
|
||||
|
||||
(define (dataspace-subscribe! ds h)
|
||||
(add-interest! (dataspace-routing-table ds) h))
|
||||
|
||||
(define (dataspace-send! ds body)
|
||||
(set-dataspace-pending-actions! ds (enqueue (dataspace-pending-actions ds) (message body))))
|
||||
|
||||
(module+ test
|
||||
;; TODO: move somewhere sensible
|
||||
;; 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))
|
||||
|
||||
(message-struct set-box (new-value))
|
||||
(assertion-struct box-state (value))
|
||||
|
||||
;; TODO: move somewhere sensible
|
||||
(assertion-struct observe (specification))
|
||||
|
||||
(define ds (make-dataspace))
|
||||
(add-actor! ds
|
||||
(lambda ()
|
||||
(define current-value (field-handle 'current-value
|
||||
(generate-id! (current-dataspace))
|
||||
(current-facet-id)
|
||||
0))
|
||||
(add-endpoint! (current-dataspace)
|
||||
'stop-when-ten
|
||||
(capture-facet-context
|
||||
(lambda ()
|
||||
(when (= (current-value) 10)
|
||||
(schedule-script! (current-dataspace)
|
||||
(capture-facet-context
|
||||
(lambda ()
|
||||
(schedule-script!
|
||||
(current-dataspace)
|
||||
(capture-facet-context
|
||||
(lambda ()
|
||||
(printf "box: terminating\n"))))
|
||||
(terminate-facet! (current-dataspace)
|
||||
(current-actor)
|
||||
(current-facet-id))))))
|
||||
(void)))
|
||||
#f)
|
||||
(add-endpoint! (current-dataspace)
|
||||
'assert-box-state
|
||||
(capture-facet-context
|
||||
(lambda () (box-state (current-value))))
|
||||
#f)
|
||||
(add-endpoint! (current-dataspace)
|
||||
'on-message-set-box
|
||||
(capture-facet-context
|
||||
(lambda () (observe (set-box (capture (discard))))))
|
||||
(skeleton-interest (list struct:set-box #f)
|
||||
'()
|
||||
'()
|
||||
'((0 0))
|
||||
(capture-facet-context
|
||||
(lambda (op new-value)
|
||||
(when (eq? '! op)
|
||||
(schedule-script!
|
||||
(current-dataspace)
|
||||
(capture-facet-context
|
||||
(lambda ()
|
||||
(printf "new-value ~a ~v\n" op new-value)
|
||||
(current-value new-value)))))))))))
|
||||
(add-actor! ds
|
||||
(lambda ()
|
||||
(add-endpoint! (current-dataspace)
|
||||
'stop-when-retracted-observe-set-box
|
||||
(capture-facet-context
|
||||
(lambda () (observe (observe (set-box (discard))))))
|
||||
(skeleton-interest (list struct:observe (list struct:set-box #f))
|
||||
'()
|
||||
'()
|
||||
'()
|
||||
(capture-facet-context
|
||||
(lambda (op)
|
||||
(when (eq? '- op)
|
||||
(schedule-script!
|
||||
(current-dataspace)
|
||||
(capture-facet-context
|
||||
(lambda ()
|
||||
(schedule-script!
|
||||
(current-dataspace)
|
||||
(capture-facet-context
|
||||
(lambda ()
|
||||
(printf "client: box has gone\n"))))
|
||||
(terminate-facet! (current-dataspace)
|
||||
(current-actor)
|
||||
(current-facet-id))))))))))
|
||||
(add-endpoint! (current-dataspace)
|
||||
'on-asserted-box-state
|
||||
(capture-facet-context
|
||||
(lambda () (observe (box-state (capture (discard))))))
|
||||
(skeleton-interest (list struct:box-state #f)
|
||||
'()
|
||||
'()
|
||||
'((0 0))
|
||||
(capture-facet-context
|
||||
(lambda (op v)
|
||||
(when (eq? '+ op)
|
||||
(schedule-script!
|
||||
(current-dataspace)
|
||||
(capture-facet-context
|
||||
(lambda ()
|
||||
(printf "v ~a ~v\n" op v)
|
||||
(dataspace-send! (current-dataspace)
|
||||
(set-box (+ v 1)))))))))))))
|
||||
|
||||
(require racket/pretty)
|
||||
(pretty-print ds)
|
||||
(let loop ((i 0))
|
||||
(printf "--- i = ~v\n" i)
|
||||
(when (run-scripts! ds)
|
||||
(pretty-print ds)
|
||||
(loop (+ i 1))))
|
||||
(pretty-print ds)
|
||||
)
|
||||
|
|
@ -1,6 +1,8 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide analyse-pattern
|
||||
(provide (struct-out discard)
|
||||
(struct-out capture)
|
||||
analyse-pattern
|
||||
desc->key
|
||||
desc->skeleton-proj
|
||||
desc->capture-proj
|
||||
|
|
@ -11,9 +13,8 @@
|
|||
(require racket/struct-info)
|
||||
(require syntax/stx)
|
||||
|
||||
(struct wildcard () #:prefab)
|
||||
|
||||
(define ? (wildcard))
|
||||
(struct discard () #:prefab)
|
||||
(struct capture (detail) #:prefab)
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; ## Analysing patterns
|
||||
|
|
@ -119,6 +120,6 @@
|
|||
#`(list #,@(map desc->assertion-stx pieces))]
|
||||
[`(compound (,_struct-type ,ctor ,_pred ,_getters ,_setters ,_super) ,pieces ...)
|
||||
#`(#,ctor #,@(map desc->assertion-stx pieces))]
|
||||
[`(capture ,_ ,p) (desc->assertion-stx p)]
|
||||
[`(discard) #'?]
|
||||
[`(capture ,_ ,p) #`(capture #,(desc->assertion-stx p))]
|
||||
[`(discard) #'(discard)]
|
||||
[`(atom ,v) v]))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,355 @@
|
|||
#lang racket/base
|
||||
;; "Skeletons" describe the indexed structure of a dataspace.
|
||||
;; In particular, they efficiently connect assertions to matching interests.
|
||||
|
||||
(provide (struct-out skeleton-interest)
|
||||
make-empty-skeleton
|
||||
add-interest!
|
||||
remove-interest!
|
||||
add-assertion!
|
||||
remove-assertion!
|
||||
send-assertion!
|
||||
apply-projection
|
||||
apply-projection-path)
|
||||
|
||||
(require syndicate/support/struct)
|
||||
(require racket/match)
|
||||
(require racket/set)
|
||||
(require racket/hash)
|
||||
(require racket/list)
|
||||
|
||||
(module+ test (require rackunit))
|
||||
|
||||
;; A `Skeleton` is a structural guard on an assertion: essentially,
|
||||
;; specification of (the outline of) its shape; its silhouette.
|
||||
;; Following a skeleton's structure leads to zero or more `SkCont`s.
|
||||
;;
|
||||
;; Skeleton = (skeleton-node SkCont (AListof SkSelector (MutableHash SkClass SkNode)))
|
||||
;; SkSelector = (skeleton-selector Nat Nat)
|
||||
;; SkClass = StructType | (list-type Nat)
|
||||
;;
|
||||
(struct skeleton-node (continuation [edges #:mutable]) #:transparent)
|
||||
(struct skeleton-selector (pop-count index) #:transparent)
|
||||
(struct list-type (arity) #:transparent)
|
||||
;;
|
||||
;; A `SkDesc` is a single assertion silhouette, usually the
|
||||
;; evaluation-result of `desc->skeleton-stx` from `pattern.rkt`.
|
||||
;;
|
||||
;; A `SkCont` is a *skeleton continuation*, a collection of "next
|
||||
;; steps" after a `Skeleton` has matched the general outline of an
|
||||
;; assertion.
|
||||
;;
|
||||
;; INVARIANT: At each level, the caches correspond to the
|
||||
;; appropriately filtered and projected contents of the dataspace
|
||||
;; containing the structures.
|
||||
;;
|
||||
;; SkCont = (skeleton-continuation
|
||||
;; (MutableSet Assertion)
|
||||
;; (MutableHash SkProj (MutableHash SkKey SkConst)))
|
||||
;; SkConst = (skeleton-matched-constant
|
||||
;; (MutableSet Assertion)
|
||||
;; (MutableHash SkProj SkAcc))
|
||||
;; SkAcc = (skeleton-accumulator
|
||||
;; (MutableSet SkKey)
|
||||
;; (MutableSet (... -> Any)))
|
||||
;;
|
||||
(struct skeleton-continuation (cache table) #:transparent)
|
||||
(struct skeleton-matched-constant (cache table) #:transparent)
|
||||
(struct skeleton-accumulator (cache handlers) #:transparent)
|
||||
;;
|
||||
;; A `SkProj` is a *skeleton projection*, a specification of loci
|
||||
;; within a tree-shaped assertion to collect into a flat list.
|
||||
;;
|
||||
;; SkProj = (Listof (Listof Nat))
|
||||
;;
|
||||
;; The outer list specifies elements of the flat list; the inner lists
|
||||
;; specify paths via zero-indexed links to child nodes in the
|
||||
;; tree-shaped assertion being examined. A precondition for use of a
|
||||
;; `SkProj` is that the assertion being examined has been checked for
|
||||
;; conformance to the skeleton being projected.
|
||||
;;
|
||||
;; A `SkKey` is the result of running a `SkProj` over a term,
|
||||
;; extracting the values at the denoted locations.
|
||||
;;
|
||||
;; SkKey = (Listof Any)
|
||||
;;
|
||||
;; Each `SkProj` in `SkCont` selects *constant* portions of the term
|
||||
;; for more matching against the `SkKey`s in the table associated with
|
||||
;; the `SkProj`. Each `SkProj` in `SkConst`, if any, selects
|
||||
;; *variable* portions of the term to be given to the handler
|
||||
;; functions in the associated `SkAcc`.
|
||||
|
||||
;; A `SkInterest` is a specification for an addition to or removal
|
||||
;; from an existing `Skeleton`.
|
||||
;;
|
||||
;; SkInterest = (skeleton-interest SkDesc SkProj SkKey SkProj (... -> Any))
|
||||
;;
|
||||
;; The `SkDesc` gives the silhouette. The first `SkProj` is the
|
||||
;; constant-portion selector, to be matched against the `SkKey`. The
|
||||
;; second `SkProj` is used on matching assertions to extract the
|
||||
;; variable portions, to be passed to the handler function.
|
||||
;;
|
||||
(struct skeleton-interest (desc const-selector const-value var-selector handler) #:transparent)
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(define (make-empty-skeleton/cache cache)
|
||||
(skeleton-node (skeleton-continuation cache
|
||||
(make-hash))
|
||||
'()))
|
||||
|
||||
(define (make-empty-skeleton)
|
||||
(make-empty-skeleton/cache (mutable-set)))
|
||||
|
||||
(define (skcont-add! c i apply-handler!)
|
||||
(match-define (skeleton-interest _desc cs cv vs h) i)
|
||||
(define (make-matched-constant)
|
||||
(skeleton-matched-constant (for/mutable-set [(a (skeleton-continuation-cache c))
|
||||
#:when (equal? (apply-projection a cs) cv)]
|
||||
a)
|
||||
(make-hash)))
|
||||
(define cvt (hash-ref! (skeleton-continuation-table c) cs make-hash))
|
||||
(define sc (hash-ref! cvt cv make-matched-constant))
|
||||
(define (make-accumulator)
|
||||
(skeleton-accumulator (for/mutable-set [(a (skeleton-matched-constant-cache sc))]
|
||||
(apply-projection a vs))
|
||||
(mutable-set)))
|
||||
(define acc (hash-ref! (skeleton-matched-constant-table sc) vs make-accumulator))
|
||||
(set-add! (skeleton-accumulator-handlers acc) h)
|
||||
(for [(vars (skeleton-accumulator-cache acc))] (apply-handler! h vars)))
|
||||
|
||||
(define (skcont-remove! c i apply-handler!)
|
||||
(match-define (skeleton-interest _desc cs cv vs h) i)
|
||||
(define cvt (hash-ref (skeleton-continuation-table c) cs #f))
|
||||
(when cvt
|
||||
(define sc (hash-ref cvt cv #f))
|
||||
(when sc
|
||||
(define acc (hash-ref (skeleton-matched-constant-table sc) vs #f))
|
||||
(when acc
|
||||
(for [(vars (skeleton-accumulator-cache acc))] (apply-handler! h vars))
|
||||
(set-remove! (skeleton-accumulator-handlers acc) h)
|
||||
(when (set-empty? (skeleton-accumulator-handlers acc))
|
||||
(hash-remove! (skeleton-matched-constant-table sc) vs)))
|
||||
(when (hash-empty? (skeleton-matched-constant-table sc))
|
||||
(hash-remove! cvt cv)))
|
||||
(when (hash-empty? cvt)
|
||||
(hash-remove! (skeleton-continuation-table c) cs))))
|
||||
|
||||
(define (term-matches-class? term class)
|
||||
(cond
|
||||
[(list-type? class) (and (list? term) (= (length term) (list-type-arity class)))]
|
||||
[(struct-type? class) (and (non-object-struct? term) (eq? (struct->struct-type term) class))]
|
||||
[else (error 'term-matches-class? "Invalid class: ~v" class)]))
|
||||
|
||||
(define (subterm-matches-class? term path class)
|
||||
(term-matches-class? (apply-projection-path term path) class))
|
||||
|
||||
(define (update-path path pop-count index)
|
||||
(append (drop-right path pop-count) (list index)))
|
||||
|
||||
(define (extend-skeleton! sk desc)
|
||||
(define (walk-node! path sk pop-count index desc)
|
||||
(match desc
|
||||
[(list class-desc pieces ...)
|
||||
(define class
|
||||
(cond [(eq? class-desc 'list) (list-type (length pieces))]
|
||||
[(struct-type? class-desc) class-desc]
|
||||
[else (error 'extend-skeleton! "Invalid class-desc: ~v" class-desc)]))
|
||||
(define selector (skeleton-selector pop-count index))
|
||||
(define table
|
||||
(match (assoc selector (skeleton-node-edges sk))
|
||||
[#f (let ((table (make-hash)))
|
||||
(set-skeleton-node-edges! sk (cons (cons selector table) (skeleton-node-edges sk)))
|
||||
table)]
|
||||
[(cons _selector table) table]))
|
||||
(define (make-skeleton-node-with-cache)
|
||||
(define unfiltered (skeleton-continuation-cache (skeleton-node-continuation sk)))
|
||||
(make-empty-skeleton/cache
|
||||
(for/mutable-set [(a unfiltered) #:when (subterm-matches-class? a path class)] a)))
|
||||
(define next (hash-ref! table class make-skeleton-node-with-cache))
|
||||
(walk-edge! (update-path path pop-count 0) next 0 0 pieces)]
|
||||
[_
|
||||
(values pop-count sk)]))
|
||||
(define (walk-edge! path sk pop-count index pieces)
|
||||
(match pieces
|
||||
['()
|
||||
(values (+ pop-count 1) sk)]
|
||||
[(cons p pieces)
|
||||
(let-values (((pop-count sk) (walk-node! path sk pop-count index p)))
|
||||
(walk-edge! (update-path path 1 (+ index 1)) sk pop-count (+ index 1) pieces))]))
|
||||
(let-values (((_pop-count sk) (walk-edge! '(0) sk 0 0 (list desc))))
|
||||
sk))
|
||||
|
||||
(define (add-interest! sk i)
|
||||
(let ((sk (extend-skeleton! sk (skeleton-interest-desc i))))
|
||||
(skcont-add! (skeleton-node-continuation sk)
|
||||
i
|
||||
(lambda (h vars) (apply h '+ vars)))))
|
||||
|
||||
(define (remove-interest! sk i)
|
||||
(let ((sk (extend-skeleton! sk (skeleton-interest-desc i))))
|
||||
(skcont-remove! (skeleton-node-continuation sk)
|
||||
i
|
||||
(lambda (h vars) (apply h '- vars)))))
|
||||
|
||||
(define (skeleton-modify! sk term0 modify-skcont! modify-skconst! modify-skacc!)
|
||||
(define (walk-node! sk term-stack)
|
||||
(match-define (skeleton-node continuation edges) sk)
|
||||
|
||||
(modify-skcont! continuation term0)
|
||||
(for [((constant-proj key-proj-handler) (in-hash (skeleton-continuation-table continuation)))]
|
||||
(define constants (apply-projection term0 constant-proj))
|
||||
(define proj-handler (hash-ref key-proj-handler constants #f))
|
||||
(when proj-handler
|
||||
(modify-skconst! proj-handler term0)
|
||||
(for [((variable-proj acc) (in-hash (skeleton-matched-constant-table proj-handler)))]
|
||||
(define variables (apply-projection term0 variable-proj))
|
||||
(modify-skacc! acc variables term0))))
|
||||
|
||||
(for [(edge edges)]
|
||||
(match-define (cons (skeleton-selector pop-count index) table) edge)
|
||||
(define popped-stack (drop term-stack pop-count))
|
||||
(define pieces (car popped-stack))
|
||||
(define term (vector-ref pieces (+ index 1))) ;; adjust for struct identifier at beginning
|
||||
(define entry (hash-ref table
|
||||
(cond [(list? term) (list-type (length term))]
|
||||
[(non-object-struct? term) (struct->struct-type term)]
|
||||
[else #f])
|
||||
#f))
|
||||
(when entry
|
||||
(define new-pieces
|
||||
(cond [(list? term) (list->vector (cons 'list term))]
|
||||
[(non-object-struct? term) (struct->vector term)]))
|
||||
(walk-node! entry (cons new-pieces term-stack)))))
|
||||
|
||||
(walk-node! sk (list (vector 'list term0))))
|
||||
|
||||
(define (add-term-to-skcont! skcont term)
|
||||
(set-add! (skeleton-continuation-cache skcont) term))
|
||||
(define (add-term-to-skconst! skconst term)
|
||||
(set-add! (skeleton-matched-constant-cache skconst) term))
|
||||
(define (add-term-to-skacc! skacc vars _term)
|
||||
(define cache (skeleton-accumulator-cache skacc))
|
||||
(set-add! cache vars)
|
||||
(for [(handler (skeleton-accumulator-handlers skacc))]
|
||||
(apply handler '+ vars)))
|
||||
|
||||
(define (add-assertion! sk term)
|
||||
(skeleton-modify! sk
|
||||
term
|
||||
add-term-to-skcont!
|
||||
add-term-to-skconst!
|
||||
add-term-to-skacc!))
|
||||
|
||||
(define (remove-term-from-skcont! skcont term)
|
||||
(set-remove! (skeleton-continuation-cache skcont) term))
|
||||
(define (remove-term-from-skconst! skconst term)
|
||||
(set-remove! (skeleton-matched-constant-cache skconst) term))
|
||||
(define (remove-term-from-skacc! skacc vars _term)
|
||||
(define cache (skeleton-accumulator-cache skacc))
|
||||
(set-remove! cache vars)
|
||||
(for [(handler (skeleton-accumulator-handlers skacc))]
|
||||
(apply handler '- vars)))
|
||||
|
||||
(define (remove-assertion! sk term)
|
||||
(skeleton-modify! sk
|
||||
term
|
||||
remove-term-from-skcont!
|
||||
remove-term-from-skconst!
|
||||
remove-term-from-skacc!))
|
||||
|
||||
(define (send-assertion! sk term)
|
||||
(skeleton-modify! sk
|
||||
term
|
||||
void
|
||||
void
|
||||
(lambda (skacc vars _term)
|
||||
(for [(handler (skeleton-accumulator-handlers skacc))]
|
||||
(apply handler '! vars)))))
|
||||
|
||||
;; TODO: avoid repeated descent into `term` by factoring out prefixes of paths in `proj`
|
||||
(define (apply-projection term proj)
|
||||
(for/list [(path proj)]
|
||||
(apply-projection-path term path)))
|
||||
|
||||
(define (apply-projection-path term path)
|
||||
(for/fold [(term (list term))] [(index path)]
|
||||
(cond [(list? term) (list-ref term index)]
|
||||
[(non-object-struct? term) (vector-ref (struct->vector term) (+ index 1))]
|
||||
[else (error 'apply-projection "Term representation not supported: ~v" term)])))
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
||||
(module+ test
|
||||
(struct a (x y) #:transparent)
|
||||
(struct b (v) #:transparent)
|
||||
(struct c (v) #:transparent)
|
||||
(struct d (x y z) #:transparent)
|
||||
|
||||
(define sk
|
||||
(make-empty-skeleton/cache (mutable-set (a (b 'bee) (b 'cat))
|
||||
(a (b 'foo) (c 'bar))
|
||||
(a (b 'foo) (c 'BAR))
|
||||
(a (c 'bar) (b 'foo))
|
||||
(a (c 'dog) (c 'fox))
|
||||
(d (b 'DBX) (b 'DBY) (b 'DBZ))
|
||||
(d (c 'DCX) (c 'DCY) (c 'DCZ))
|
||||
(b 'zot)
|
||||
123)))
|
||||
|
||||
(add-interest! sk
|
||||
(skeleton-interest (list struct:a (list struct:b #f) #f)
|
||||
'((0 0 0))
|
||||
'(foo)
|
||||
'((0 1))
|
||||
(lambda (op . bindings)
|
||||
(printf "xAB HANDLER: ~v ~v\n" op bindings))))
|
||||
|
||||
(void (extend-skeleton! sk (list struct:a (list struct:b #f) #f)))
|
||||
(void (extend-skeleton! sk (list struct:a #f (list struct:c #f))))
|
||||
(void (extend-skeleton! sk (list struct:a #f (list struct:c (list struct:b #f)))))
|
||||
(void (extend-skeleton! sk (list struct:a #f #f)))
|
||||
(void (extend-skeleton! sk (list struct:c #f)))
|
||||
(void (extend-skeleton! sk (list struct:b #f)))
|
||||
(void (extend-skeleton! sk (list struct:d (list struct:b #f) #f (list struct:b #f))))
|
||||
(void (extend-skeleton! sk (list struct:d (list struct:b #f) #f (list struct:c #f))))
|
||||
(void (extend-skeleton! sk (list struct:d (list struct:c #f) #f (list struct:b #f))))
|
||||
(void (extend-skeleton! sk (list struct:d (list struct:c #f) #f (list struct:c #f))))
|
||||
(check-eq? sk (extend-skeleton! sk #f))
|
||||
|
||||
(add-interest! sk
|
||||
(skeleton-interest (list struct:d (list struct:b #f) #f (list struct:c #f))
|
||||
'((0 2 0))
|
||||
'(DCZ)
|
||||
'((0) (0 0) (0 0 0) (0 1))
|
||||
(lambda (op . bindings)
|
||||
(printf "DBC HANDLER: ~v ~v\n" op bindings))))
|
||||
|
||||
(remove-assertion! sk (a (b 'foo) (c 'bar)))
|
||||
(remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ)))
|
||||
(add-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ)))
|
||||
(add-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ)))
|
||||
(add-assertion! sk (d (b 'B1) (b 'DBY) (c 'CX)))
|
||||
(add-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ)))
|
||||
(add-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ)))
|
||||
(add-assertion! sk (d (b 'B1) (b 'DBY) (c 'CX)))
|
||||
|
||||
(add-interest! sk
|
||||
(skeleton-interest (list struct:d #f (list struct:b #f) #f)
|
||||
'((0 1 0))
|
||||
'(DBY)
|
||||
'((0 0) (0 2))
|
||||
(lambda (op . bindings)
|
||||
(printf "xDB HANDLER: ~v ~v\n" op bindings))))
|
||||
|
||||
(send-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ)))
|
||||
(send-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ)))
|
||||
|
||||
(remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ)))
|
||||
(remove-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ)))
|
||||
(remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'CX)))
|
||||
(remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'DCZ)))
|
||||
(remove-assertion! sk (d (b 'BX) (b 'DBY) (c 'DCZ)))
|
||||
(remove-assertion! sk (d (b 'B1) (b 'DBY) (c 'CX)))
|
||||
;; sk
|
||||
)
|
||||
Loading…
Reference in New Issue