From 4b1b2a9635dc7f2b9311e92d4c8b6c8ffdd1bf3a Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Thu, 3 Jun 2021 15:59:17 +0200 Subject: [PATCH] Proper skeleton-based dataspace --- OLD-syndicate/skeleton.rkt | 395 ------------------------------------- syndicate/dataspace.rkt | 65 +++--- syndicate/skeleton.rkt | 335 +++++++++++++++++++++++++++++++ 3 files changed, 363 insertions(+), 432 deletions(-) delete mode 100644 OLD-syndicate/skeleton.rkt create mode 100644 syndicate/skeleton.rkt diff --git a/OLD-syndicate/skeleton.rkt b/OLD-syndicate/skeleton.rkt deleted file mode 100644 index 68b8a6e..0000000 --- a/OLD-syndicate/skeleton.rkt +++ /dev/null @@ -1,395 +0,0 @@ -#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) - (struct-out visibility-restriction) - make-empty-skeleton - add-interest! - remove-interest! - add-assertion! - remove-assertion! - send-assertion!) - -(module+ for-test - (provide make-empty-skeleton/cache - extend-skeleton! - path-cmp)) - -(require racket/match) -(require racket/hash) -(require racket/list) - -(require "support/struct.rkt") -(require "bag.rkt") -(require "pattern.rkt") -(require "assertions.rkt") - -;; A VisibilityRestriction describes ... TODO -;; (visibility-restriction SkProj Assertion) -(struct visibility-restriction (proj term) #:transparent) - -;; A ScopedAssertion is a VisibilityRestriction or an Assertion. -;; (Corollary: Instances of `visibility-restriction` can never be assertions.) - -;; 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) | (vector-type Nat) -;; -(struct skeleton-node (continuation [edges #:mutable]) #:transparent) -(struct skeleton-selector (pop-count index) #:transparent) -(struct list-type (arity) #:transparent) -(struct vector-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 ScopedAssertion) -;; (MutableHash SkProj (MutableHash SkKey SkConst))) -;; SkConst = (skeleton-matched-constant -;; (MutableSet ScopedAssertion) -;; (MutableHash SkProj SkAcc)) -;; SkAcc = (skeleton-accumulator -;; (MutableBag SkKey) -;; (MutableSeteq (... -> 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) -;; (Option ((MutableBag SkKey) -> 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 - cleanup - ) #:transparent) - -;;--------------------------------------------------------------------------- - -(define (make-empty-skeleton/cache cache) - (skeleton-node (skeleton-continuation cache - (make-hash)) - '())) - -(define (make-empty-skeleton) - (make-empty-skeleton/cache (make-hash))) - -(define (make-empty-matched-constant) - (skeleton-matched-constant (make-hash) (make-hash))) - -(define (skcont-add! c i) - (match-define (skeleton-interest _desc cs cv vs h _cleanup) i) - (define (classify-assertions) - (define cvt (make-hash)) - (hash-for-each (skeleton-continuation-cache c) - (lambda (a _) - (define avs (apply-projection (unscope-assertion a) cs)) - (define sc (hash-ref! cvt avs make-empty-matched-constant)) - (hash-set! (skeleton-matched-constant-cache sc) a #t))) - cvt) - (define cvt (hash-ref! (skeleton-continuation-table c) cs classify-assertions)) - (define sc (hash-ref! cvt cv make-empty-matched-constant)) - (define (make-accumulator) - (define cache (make-bag)) - (hash-for-each (skeleton-matched-constant-cache sc) - (lambda (a _) - (unpack-scoped-assertion [restriction-path term] a) - (when (unrestricted? vs restriction-path) - (bag-change! cache (apply-projection term vs) 1)))) - (skeleton-accumulator cache (make-hasheq))) - (define acc (hash-ref! (skeleton-matched-constant-table sc) vs make-accumulator)) - (hash-set! (skeleton-accumulator-handlers acc) h #t) - (for [(vars (in-bag (skeleton-accumulator-cache acc)))] (apply h '+ vars))) - -(define (skeleton-matched-constant-empty? sc) - (match-define (skeleton-matched-constant cache table) sc) - (and (hash-empty? cache) (hash-empty? table))) - -(define (skcont-remove! c i) - (match-define (skeleton-interest _desc cs cv vs h cleanup) 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 - (when (and cleanup (hash-has-key? (skeleton-accumulator-handlers acc) h)) - (cleanup (skeleton-accumulator-cache acc))) - (hash-remove! (skeleton-accumulator-handlers acc) h) - (when (hash-empty? (skeleton-accumulator-handlers acc)) - (hash-remove! (skeleton-matched-constant-table sc) vs))) - (when (skeleton-matched-constant-empty? 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)))] - [(vector-type? class) (and (vector? term) (= (vector-length term) (vector-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 (unscope-assertion term) path) class)) - -(define (unscope-assertion scoped-assertion) - (match scoped-assertion - [(visibility-restriction _ term) term] - [term term])) - -(define-syntax-rule (unpack-scoped-assertion [path term] expr) - (define-values (path term) - (match expr - [(visibility-restriction p t) (values p t)] - [other (values #f other)]))) - -(define (path-cmp a b) - (match* (a b) - [('() '()) '=] - [('() _) '<] - [(_ '()) '>] - [((cons av a) (cons bv b)) - (cond [(< av bv) '<] - [(> av bv) '>] - [else (path-cmp a b)])])) - -(define (unrestricted? capture-paths restriction-paths) - ;; We are "unrestricted" if Set(capture-paths) ⊆ Set(restriction-paths). Since both variables - ;; really hold lists, we operate with awareness of the order the lists are built here. We - ;; know that the lists are built in fringe order; that is, they are sorted wrt `path-cmp`. - (or (not restriction-paths) - (let outer ((cs capture-paths) (rs restriction-paths)) - (match cs - ['() #t] - [(cons c cs) - (let inner ((rs rs)) - (match rs - ['() #f] ;; `c` does not exist in `restriction-paths` ∴ restricted. - [(cons r rs) - (match (path-cmp c r) - ['< #f] ;; `c` < `r` ==> `c` not in `restriction-paths` ∴ restricted. - ['= (outer cs rs)] - ['> (inner rs)])]))])))) - -(define (extend-skeleton! sk desc) - (define (walk-node! rev-path sk pop-count index desc) - (match desc - [(list class-desc pieces ...) - (define class - (cond [(struct-type? class-desc) class-desc] - [(eq? class-desc 'list) (list-type (length pieces))] - [(eq? class-desc 'vector) (vector-type (length pieces))] - [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))) - (define filtered (make-hash)) - (define path (reverse rev-path)) - (hash-for-each unfiltered - (lambda (a _) - (when (subterm-matches-class? a path class) - (hash-set! filtered a #t)))) - (make-empty-skeleton/cache filtered)) - (define next (hash-ref! table class make-skeleton-node-with-cache)) - (walk-edge! (cons 0 rev-path) next 0 0 pieces)] - [_ - (values pop-count sk)])) - (define (walk-edge! rev-path sk pop-count index pieces) - (match pieces - ['() - (values (+ pop-count 1) sk)] - [(cons p pieces) - (let-values (((pop-count sk) (walk-node! rev-path sk pop-count index p))) - (walk-edge! (cons (+ index 1) (cdr rev-path)) sk pop-count (+ index 1) pieces))])) - (let-values (((_pop-count sk) (walk-node! '() sk 0 0 desc))) - sk)) - -(define (add-interest! sk i) - (let ((sk (extend-skeleton! sk (skeleton-interest-desc i)))) - (skcont-add! (skeleton-node-continuation sk) i))) - -(define (remove-interest! sk i) - (let ((sk (extend-skeleton! sk (skeleton-interest-desc i)))) - (skcont-remove! (skeleton-node-continuation sk) i))) - -(define (skeleton-modify! sk term0 modify-skcont! on-missing-skconst modify-skconst! modify-skacc!) - (unpack-scoped-assertion [restriction-path term0-term] term0) - - (define (walk-node! sk term-stack) - (match-define (skeleton-node continuation edges) sk) - - (modify-skcont! continuation term0) - (let ((sct (skeleton-continuation-table continuation)) - (constant-projections-to-remove '())) - (hash-for-each sct - (lambda (constant-proj key-proj-handler) - (define constants (apply-projection term0-term constant-proj)) - (define proj-handler - (hash-ref key-proj-handler - constants - (lambda () (on-missing-skconst key-proj-handler constants)))) - (when proj-handler - (when (eq? (modify-skconst! proj-handler term0) 'remove-check) - (when (skeleton-matched-constant-empty? proj-handler) - (hash-remove! key-proj-handler constants) - (when (hash-empty? key-proj-handler) - (set! constant-projections-to-remove - (cons constant-proj constant-projections-to-remove))))) - (hash-for-each (skeleton-matched-constant-table proj-handler) - (lambda (variable-proj acc) - (when (unrestricted? variable-proj restriction-path) - (define vars (apply-projection term0-term variable-proj)) - (modify-skacc! acc vars term0))))))) - (for-each (lambda (constant-proj) (hash-remove! sct constant-proj)) - constant-projections-to-remove)) - - (for [(edge (in-list edges))] - (match-define (cons (skeleton-selector pop-count index) table) edge) - (define popped-stack (drop term-stack pop-count)) - (define old-top (car popped-stack)) - (define new-top - (cond [(non-object-struct? old-top) (vector-ref (struct->vector old-top) (+ index 1))] - [(list? old-top) (list-ref old-top index)] - [(vector? old-top) (vector-ref old-top index)])) - (define entry (hash-ref table - (cond [(non-object-struct? new-top) (struct->struct-type new-top)] - [(list? new-top) (list-type (length new-top))] - [(vector? new-top) (vector-type (vector-length new-top))] - [else #f]) - #f)) - (when entry (walk-node! entry (cons new-top popped-stack))))) - - (walk-node! sk (list (list term0-term)))) - -(define (add-term-to-skcont! skcont term) - (hash-set! (skeleton-continuation-cache skcont) term #t)) -(define (add-term-to-skconst! skconst term) - (hash-set! (skeleton-matched-constant-cache skconst) term #t)) -(define (add-term-to-skacc! skacc vars _term) - ;; (log-info ">>>>>> At addition time for ~v, cache has ~v" - ;; _term - ;; (hash-ref (skeleton-accumulator-cache skacc) vars 0)) - (match (bag-change! (skeleton-accumulator-cache skacc) vars 1) - ['absent->present - (hash-for-each (skeleton-accumulator-handlers skacc) - (lambda (handler _) (apply handler '+ vars)))] - ;; 'present->absent and 'absent->absent absurd - ['present->present - (void)])) - -(define (add-assertion! sk term) - (skeleton-modify! sk - term - add-term-to-skcont! - (lambda (cv-table cv) - (let ((sc (make-empty-matched-constant))) - (hash-set! cv-table cv sc) - sc)) - add-term-to-skconst! - add-term-to-skacc!)) - -(define (remove-term-from-skcont! skcont term) - (hash-remove! (skeleton-continuation-cache skcont) term)) -(define (remove-term-from-skconst! skconst term) - (hash-remove! (skeleton-matched-constant-cache skconst) term) - 'remove-check) -(define (remove-term-from-skacc! skacc vars _term) - (define cache (skeleton-accumulator-cache skacc)) - ;; (log-info ">>>>>> At removal time for ~v, cache has ~v" _term (hash-ref cache vars 0)) - (if (bag-member? cache vars) - (match (bag-change! cache vars -1) - ['present->absent - (hash-for-each (skeleton-accumulator-handlers skacc) - (lambda (handler _) (apply handler '- vars)))] - ;; 'absent->absent and 'absent->present absurd - ['present->present - (void)]) - (log-warning "Removing assertion not previously added: ~v" _term))) - -(define (remove-assertion! sk term) - (skeleton-modify! sk - term - remove-term-from-skcont! - (lambda (_cv-table _cv) #f) - remove-term-from-skconst! - remove-term-from-skacc!)) - -(define (send-assertion! sk term) - (skeleton-modify! sk - term - void - (lambda (_cv-table _cv) #f) - void - (lambda (skacc vars _term) - (hash-for-each (skeleton-accumulator-handlers skacc) - (lambda (handler _) (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 (in-list proj))] - (apply-projection-path term path))) - -(define (apply-projection-path term path) - (for/fold [(term term)] [(index (in-list path))] - (cond [(non-object-struct? term) (vector-ref (struct->vector term) (+ index 1))] - [(list? term) (list-ref term index)] - [(vector? term) (vector-ref term index)] - [else (error 'apply-projection "Term representation not supported: ~v" term)]))) diff --git a/syndicate/dataspace.rkt b/syndicate/dataspace.rkt index 3f5d8ed..cb8857e 100644 --- a/syndicate/dataspace.rkt +++ b/syndicate/dataspace.rkt @@ -12,49 +12,40 @@ (require "bag.rkt") (require "main.rkt") +(require "skeleton.rkt") (require "schemas/gen/dataspace.rkt") (require "schemas/gen/dataspace-patterns.rkt") (require "schemas/gen/dataspace-patterns.meta.rkt") +(define-logger syndicate/dataspace) + (define (dataspace) (define handles (make-hash)) (define assertions (make-bag)) - (define subscriptions (make-hash)) - (entity #:assert (action (rec handle) - (log-info "+ ~v ~v" handle rec) - (when (record? rec) - (hash-set! handles handle rec) - (when (eq? (bag-change! assertions rec +1) 'absent->present) - (match (parse-Observe rec) + (define skeleton (make-empty-skeleton)) + (define ds-e + (entity #:assert (action (value handle) + (log-syndicate/dataspace-debug "~v + ~v ~v" ds-e handle value) + (define maybe-observe (parse-Observe value)) + (hash-set! handles handle (cons value maybe-observe)) + (when (eq? (bag-change! assertions value +1) 'absent->present) + (match maybe-observe [(? eof-object?) (void)] - [(Observe label observer) - (define seen (make-hash)) - (hash-set! (hash-ref! subscriptions label make-hasheq) observer seen) - (for [(existing (in-bag assertions))] - (when (preserve=? (record-label existing) label) - (hash-set! seen existing (turn-assert! this-turn observer existing))))]) - (for [((observer seen) (in-hash (hash-ref subscriptions (record-label rec) '#hash())))] - (unless (hash-has-key? seen rec) - (hash-set! seen rec (turn-assert! this-turn observer rec))))))) - #:retract (action (upstream-handle) - (define rec (hash-ref handles upstream-handle #f)) - (log-info "- ~v ~v" upstream-handle rec) - (when rec - (hash-remove! handles upstream-handle) - (when (eq? (bag-change! assertions rec -1) 'present->absent) - (for [(seen (in-hash-values (hash-ref subscriptions (record-label rec) '#hash())))] - (turn-retract! this-turn (hash-ref seen rec)) - (hash-remove! seen rec)) - (match (parse-Observe rec) - [(? eof-object?) (void)] - [(Observe label observer) - (let ((subscribers (hash-ref subscriptions label))) - (hash-remove! subscribers observer) - (when (hash-empty? subscribers) - (hash-remove! subscriptions label)))])))) - #:message (action (message) - (log-info "! ~v" message) - (when (record? message) - (for [(peer (in-hash-keys (hash-ref subscriptions (record-label message) '#hash())))] - (turn-message! this-turn peer message)))))) + [(Observe pat ref) (add-interest! this-turn skeleton pat ref)]) + (add-assertion! this-turn skeleton value))) + #:retract (action (upstream-handle) + (match (hash-ref handles upstream-handle #f) + [#f (error 'dataspace "Peer retracted unknown handle ~v" upstream-handle)] + [(cons value maybe-observe) + (log-syndicate/dataspace-debug "~v - ~v ~v" ds-e upstream-handle value) + (hash-remove! handles upstream-handle) + (when (eq? (bag-change! assertions value -1) 'present->absent) + (remove-assertion! this-turn skeleton value) + (match maybe-observe + [(? eof-object?) (void)] + [(Observe pat ref) (remove-interest! this-turn skeleton pat ref)]))])) + #:message (action (message) + (log-syndicate/dataspace-debug "~v ! ~v" ds-e message) + (send-assertion! this-turn skeleton message)))) + ds-e) diff --git a/syndicate/skeleton.rkt b/syndicate/skeleton.rkt new file mode 100644 index 0000000..69fc638 --- /dev/null +++ b/syndicate/skeleton.rkt @@ -0,0 +1,335 @@ +#lang racket/base +;; "Skeletons" describe the indexed structure of a dataspace. +;; In particular, they efficiently connect assertions to matching interests. + +(provide make-empty-skeleton + add-interest! + remove-interest! + add-assertion! + remove-assertion! + send-assertion!) + +(module+ for-test + (provide make-empty-skeleton/cache + extend-skeleton!)) + +(require racket/match) +(require racket/hash) +(require racket/list) + +(require preserves) + +(require "support/struct.rkt") +(require "bag.rkt") +(require "pattern.rkt") +(require "actor.rkt") + +;; 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 ConstructorSpec Skeleton))) +;; SkSelector = (skeleton-selector Nat Any) +;; +;; A `ConstructorSpec` specifies a record label with arity, or a list +;; arity, or a dictionary. +;; +;; ConstructorSpec = (U CRec CArr CDict) ;; from dataspace-patterns.prs +;; +(struct skeleton-node (continuation [edges #:mutable]) #:transparent) +(struct skeleton-selector (pop-count key) #:transparent) +;; +;; A `Pattern` is a pattern over assertions, following the schema of +;; the same name in schemas/dataspace-patterns.prs. Instances of +;; `Pattern` are usually produced by the `:pattern` macro and related +;; tooling. +;; +;; 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 +;; (MutableHash Assertion #t) +;; (MutableHash SkProj (MutableHash SkKey SkConst))) +;; SkConst = (skeleton-matched-constant +;; (MutableHash Assertion #t) +;; (MutableHash SkProj SkAcc)) +;; SkAcc = (skeleton-accumulator +;; (MutableBag SkKey) +;; (MutableHasheq EntityRef (MutableHash SkKey Handle))) +;; +(struct skeleton-continuation (cache table) #:transparent) +(struct skeleton-matched-constant (cache table) #:transparent) +(struct skeleton-accumulator (cache peers) #: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 Any)) +;; +;; The outer list specifies elements of the flat list; the inner lists +;; specify paths via 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 entity-refs in +;; the associated `SkAcc`. + +;;--------------------------------------------------------------------------- + +(define (make-empty-skeleton/cache cache) + (skeleton-node (skeleton-continuation cache + (make-hash)) + '())) + +(define (make-empty-skeleton) + (make-empty-skeleton/cache (make-hash))) + +(define (make-empty-matched-constant) + (skeleton-matched-constant (make-hash) (make-hash))) + +(define (skcont-add! turn c pat ref) + (define cs (pattern->constant-paths pat)) + (define (classify-assertions) + (define cvt (make-hash)) + (hash-for-each (skeleton-continuation-cache c) + (lambda (a _) + (define avs (apply-projection a cs)) + (define sc (hash-ref! cvt avs make-empty-matched-constant)) + (hash-set! (skeleton-matched-constant-cache sc) a #t))) + cvt) + (define cvt (hash-ref! (skeleton-continuation-table c) cs classify-assertions)) + (define sc (hash-ref! cvt (pattern->constant-values pat) make-empty-matched-constant)) + (define vs (pattern->capture-paths pat)) + (define (make-accumulator) + (define cache (make-bag)) + (hash-for-each (skeleton-matched-constant-cache sc) + (lambda (term _) (bag-change! cache (apply-projection term vs) 1))) + (skeleton-accumulator cache (make-hasheq))) + (define acc (hash-ref! (skeleton-matched-constant-table sc) vs make-accumulator)) + (define peer-entry (make-hash)) + (hash-set! (skeleton-accumulator-peers acc) ref peer-entry) + (for [(vars (in-bag (skeleton-accumulator-cache acc)))] + (hash-set! peer-entry vars (turn-assert! turn ref vars)))) + +(define (skeleton-matched-constant-empty? sc) + (match-define (skeleton-matched-constant cache table) sc) + (and (hash-empty? cache) (hash-empty? table))) + +(define (skcont-remove! turn c pat ref) + (define cs (pattern->constant-paths pat)) + (define cvt (hash-ref (skeleton-continuation-table c) cs #f)) + (when cvt + (define cv (pattern->constant-values pat)) + (define sc (hash-ref cvt cv #f)) + (when sc + (define vs (pattern->capture-paths pat)) + (define acc (hash-ref (skeleton-matched-constant-table sc) vs #f)) + (when acc + (for [(handle (in-hash-values (hash-ref (skeleton-accumulator-peers acc) ref)))] + (turn-retract! turn handle)) + (hash-remove! (skeleton-accumulator-peers acc) ref) + (when (hash-empty? (skeleton-accumulator-peers acc)) + (hash-remove! (skeleton-matched-constant-table sc) vs))) + (when (skeleton-matched-constant-empty? sc) + (hash-remove! cvt cv))) + (when (hash-empty? cvt) + (hash-remove! (skeleton-continuation-table c) cs)))) + +(define (term-matches-ctor-spec? term ctor-spec) + (match ctor-spec + [(CArr arity) + (and (list? term) (= (length term) arity))] + [(CRec label arity) + (and (non-object-struct? term) + (let ((t (struct->struct-type term))) + (and (equal? (struct-type-name t) label) + (= (struct-type-constructor-arity t) arity))))] + [(CDict) + (hash? term)])) + +(define (subterm-matches-ctor-spec? term path ctor-spec) + (term-matches-ctor-spec? (apply-projection-path term path) ctor-spec)) + +(define (extend-skeleton! sk pat) + (define (walk-node! rev-path sk pop-count key pat) + (match pat + [(Pattern-DCompound (or (DCompound-rec ctor-spec members) + (DCompound-arr ctor-spec members) + (DCompound-dict ctor-spec members))) + (define selector (skeleton-selector pop-count key)) + (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))) + (define filtered (make-hash)) + (define path (reverse rev-path)) + (hash-for-each unfiltered + (lambda (a _) + (when (subterm-matches-ctor-spec? a path ctor-spec) + (hash-set! filtered a #t)))) + (make-empty-skeleton/cache filtered)) + (define next (hash-ref! table ctor-spec make-skeleton-node-with-cache)) + (let-values (((pop-count sk) + (for/fold [(pop-count 0) (sk next)] + [((key subpat) (in-hash members))] + (walk-node! (cons key rev-path) sk pop-count key subpat)))) + (values (+ pop-count 1) sk))] + [_ + (values pop-count sk)])) + (let-values (((_pop-count sk) (walk-node! '() sk 0 0 pat))) + sk)) + +(define (add-interest! turn sk pat ref) + (skcont-add! turn (skeleton-node-continuation (extend-skeleton! sk pat)) pat ref)) + +(define (remove-interest! turn sk pat ref) + (skcont-remove! turn (skeleton-node-continuation (extend-skeleton! sk pat)) pat ref)) + +(define (skeleton-modify! turn sk term0 modify-skcont! on-missing-skconst modify-skconst! modify-skacc!) + (let walk-node! ((sk sk) (term-stack (list (list term0)))) + (match-define (skeleton-node continuation edges) sk) + (modify-skcont! continuation term0) + (let ((sct (skeleton-continuation-table continuation)) + (constant-projections-to-remove '())) + (hash-for-each sct + (lambda (constant-proj key-proj-handler) + (define constants (apply-projection term0 constant-proj)) + (define proj-handler + (hash-ref key-proj-handler + constants + (lambda () (on-missing-skconst key-proj-handler constants)))) + (when proj-handler + (when (eq? (modify-skconst! proj-handler term0) 'remove-check) + (when (skeleton-matched-constant-empty? proj-handler) + (hash-remove! key-proj-handler constants) + (when (hash-empty? key-proj-handler) + (set! constant-projections-to-remove + (cons constant-proj constant-projections-to-remove))))) + (hash-for-each (skeleton-matched-constant-table proj-handler) + (lambda (variable-proj acc) + (define vars (apply-projection term0 variable-proj)) + (modify-skacc! turn acc vars term0)))))) + (for-each (lambda (constant-proj) (hash-remove! sct constant-proj)) + constant-projections-to-remove)) + + (for [(edge (in-list edges))] + (match-define (cons (skeleton-selector pop-count key) table) edge) + (define popped-stack (drop term-stack pop-count)) + (define old-top (car popped-stack)) + (define new-top (step-term old-top key)) + (define entry (hash-ref table + (cond [(non-object-struct? new-top) + (define t (struct->struct-type new-top)) + (CRec (struct-type-name t) (struct-type-constructor-arity t))] + [(list? new-top) + (CArr (length new-top))] + [(hash? new-top) + (CDict)] + [else #f]) + #f)) + (when entry (walk-node! entry (cons new-top popped-stack)))))) + +(define (add-term-to-skcont! skcont term) + (hash-set! (skeleton-continuation-cache skcont) term #t)) +(define (add-term-to-skconst! skconst term) + (hash-set! (skeleton-matched-constant-cache skconst) term #t)) +(define (add-term-to-skacc! turn skacc vars _term) + ;; (log-info ">>>>>> At addition time for ~v, cache has ~v" + ;; _term + ;; (hash-ref (skeleton-accumulator-cache skacc) vars 0)) + (match (bag-change! (skeleton-accumulator-cache skacc) vars 1) + ['absent->present + (hash-for-each (skeleton-accumulator-peers skacc) + (lambda (ref peer-entry) + (hash-set! peer-entry vars (turn-assert! turn ref vars))))] + ;; 'present->absent and 'absent->absent absurd + ['present->present + (void)])) + +(define (add-assertion! turn sk term) + (skeleton-modify! turn + sk + term + add-term-to-skcont! + (lambda (cv-table cv) + (let ((sc (make-empty-matched-constant))) + (hash-set! cv-table cv sc) + sc)) + add-term-to-skconst! + add-term-to-skacc!)) + +(define (remove-term-from-skcont! skcont term) + (hash-remove! (skeleton-continuation-cache skcont) term)) +(define (remove-term-from-skconst! skconst term) + (hash-remove! (skeleton-matched-constant-cache skconst) term) + 'remove-check) +(define (remove-term-from-skacc! turn skacc vars _term) + (define cache (skeleton-accumulator-cache skacc)) + ;; (log-info ">>>>>> At removal time for ~v, cache has ~v" _term (hash-ref cache vars 0)) + (match (bag-change! cache vars -1) + ['present->absent + (hash-for-each (skeleton-accumulator-peers skacc) + (lambda (_ref peer-entry) + (turn-retract! turn (hash-ref peer-entry vars)) + (hash-remove! peer-entry vars)))] + ['present->present + (void)] + ;; 'absent->absent absurd + ['absent->present + ;; 'absent->present should be absurd, but may be a programming error + (bag-change! cache vars 1) ;; undo the change + (log-warning "Removing assertion not previously added: ~v" _term)])) + +(define (remove-assertion! turn sk term) + (skeleton-modify! turn + sk + term + remove-term-from-skcont! + (lambda (_cv-table _cv) #f) + remove-term-from-skconst! + remove-term-from-skacc!)) + +(define (send-assertion! turn sk term) + (skeleton-modify! turn + sk + term + void + (lambda (_cv-table _cv) #f) + void + (lambda (turn skacc vars _term) + (hash-for-each (skeleton-accumulator-peers skacc) + (lambda (ref _peer-entry) (turn-message! turn ref vars)))))) + +;; TODO: avoid repeated descent into `term` by factoring out prefixes of paths in `proj` +(define (apply-projection term proj) + (for/list [(path (in-list proj))] + (apply-projection-path term path))) + +(define (apply-projection-path term path) + (for/fold [(term term)] + [(key (in-list path))] + (step-term term key))) + +(define (step-term term key) + (cond [(non-object-struct? term) (vector-ref (struct->vector term) (+ key 1))] + [(list? term) (list-ref term key)] + [(hash? term) (hash-ref term key (void))] + [else (error 'apply-projection "Term representation not supported: ~v" term)]))