From 23bee726b1fba5c88b3c14fd83b58b827e73dada Mon Sep 17 00:00:00 2001 From: Sam Caldwell Date: Fri, 24 May 2019 15:06:55 -0400 Subject: [PATCH] priorities for query handlers, on-add, on-remove --- .../examples/roles/simple-query-hash.rkt | 15 +++- racket/typed/roles.rkt | 81 ++++++++++++++++--- 2 files changed, 83 insertions(+), 13 deletions(-) diff --git a/racket/typed/examples/roles/simple-query-hash.rkt b/racket/typed/examples/roles/simple-query-hash.rkt index ffca473..bb25fe3 100644 --- a/racket/typed/examples/roles/simple-query-hash.rkt +++ b/racket/typed/examples/roles/simple-query-hash.rkt @@ -1,8 +1,12 @@ #lang typed/syndicate/roles ;; Expected Output +;; adding key2 -> 88 +;; adding key1 -> 18 ;; size: 0 ;; size: 2 +;; removing key2 +;; adding key2 -> 99 (assertion-struct output : Output (v)) @@ -14,12 +18,19 @@ (run-ground-dataspace ds-type (spawn ds-type (start-facet querier - (define/query-hash key# (tuple (bind k String) (bind v Int)) k v) + (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)) - (assert (tuple "key2" 88)) + (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)))))) diff --git a/racket/typed/roles.rkt b/racket/typed/roles.rkt index e3880fd..7bb383d 100644 --- a/racket/typed/roles.rkt +++ b/racket/typed/roles.rkt @@ -75,6 +75,7 @@ (require "either.rkt") (require (prefix-in syndicate: syndicate/actor-lang)) +(require (submod syndicate/actor priorities)) (require (for-meta 2 macrotypes/stx-utils racket/list syntax/stx syntax/parse racket/base)) (require macrotypes/postfix-in) @@ -190,7 +191,28 @@ [react-con #'¬Know])) (~and message (~bind [syndicate-kw #'syndicate:message] - [react-con #'Message])))))) + [react-con #'Message]))))) + (define-syntax-class priority-level + #:literals (*query-priority-high* + *query-priority* + *query-handler-priority* + *normal-priority* + *gc-priority* + *idle-priority*) + (pattern (~and level + (~or *query-priority-high* + *query-priority* + *query-handler-priority* + *normal-priority* + *gc-priority* + *idle-priority*)))) + (define-splicing-syntax-class priority + #:attributes (level) + (pattern (~seq #:priority l:priority-level) + #:attr level #'l.level) + (pattern (~seq) + #:attr level #'*normal-priority*)) + ) (define-typed-syntax on [(on (~literal start) s ...) ≫ @@ -209,7 +231,9 @@ ----------------------------------- [⊢ (syndicate:on-stop s-) (⇒ : ★/t) (⇒ ν-ep (τ-r))]] - [(on (a/r/m:asserted/retracted/message p) s ...) ≫ + [(on (a/r/m:asserted/retracted/message p) + priority:priority + s ...) ≫ #:with p/e (elaborate-pattern/with-com-ty #'p) [⊢ p/e ≫ p-- (⇒ : τp)] #:fail-unless (pure? #'p--) "pattern not allowed to have effects" @@ -222,6 +246,7 @@ #:with τ-r (type-eval #'(Reacts (a/r/m.react-con τp) τ-f ... τ-s ...)) ----------------------------------- [⊢ (syndicate:on (a/r/m.syndicate-kw p-) + #:priority priority.level s-) (⇒ : ★/t) (⇒ ν-ep (τ-r))]]) @@ -330,18 +355,42 @@ [_ pat]))) -(define-typed-syntax (define/query-value x:id e0 p e) ≫ +(begin-for-syntax + (define-splicing-syntax-class on-add + #:attributes (expr) + (pattern (~seq #:on-add add-e) + #:attr expr #'add-e) + (pattern (~seq) + #:attr expr #'#f)) + + (define-splicing-syntax-class on-remove + #:attributes (expr) + (pattern (~seq #:on-remove remove-e) + #:attr expr #'remove-e) + (pattern (~seq) + #:attr expr #'#f))) + + +(define-typed-syntax (define/query-value x:id e0 p e + (~optional add:on-add) + (~optional remove:on-remove)) ≫ [⊢ e0 ≫ e0- (⇒ : τ)] #:fail-unless (pure? #'e0-) "expression must be pure" ---------------------------------------- [≻ (begin (field [x τ e0-]) (on (asserted p) - (set! x e)) + #:priority *query-priority* + (set! x e) + add.expr) (on (retracted p) - (set! x e0-)))]) + #:priority *query-priority-high* + (set! x e0-) + remove.expr))]) ;; TODO: #:on-add -(define-typed-syntax (define/query-set x:id p e) ≫ +(define-typed-syntax (define/query-set x:id p e + (~optional add:on-add) + (~optional remove:on-remove)) ≫ #:with p+ (elaborate-pattern/with-com-ty #'p) #:with ([y τ] ...) (pat-bindings #'p+) ;; e will be re-expanded :/ @@ -349,11 +398,17 @@ ---------------------------------------- [≻ (begin (field [x (Set τ-e) (set)]) (on (asserted p+) - (set! x (set-add (ref x) e))) + #:priority *query-priority* + (set! x (set-add (ref x) e)) + add.expr) (on (retracted p+) - (set! x (set-remove (ref x) e))))]) + #:priority *query-priority-high* + (set! x (set-remove (ref x) e)) + remove.expr))]) -(define-typed-syntax (define/query-hash x:id p e-key e-value) ≫ +(define-typed-syntax (define/query-hash x:id p e-key e-value + (~optional add:on-add) + (~optional remove:on-remove)) ≫ #:with p+ (elaborate-pattern/with-com-ty #'p) #:with ([y τ] ...) (pat-bindings #'p+) ;; e-key and e-value will be re-expanded :/ @@ -368,9 +423,13 @@ ---------------------------------------- [≻ (begin (field [x (Hash τ-key τ-value) (hash)]) (on (asserted p+) - (set! x (hash-set (ref x) e-key e-value))) + #:priority *query-priority* + (set! x (hash-set (ref x) e-key e-value)) + add.expr) (on (retracted p+) - (set! x (hash-remove (ref x) e-key))))]) + #:priority *query-priority-high* + (set! x (hash-remove (ref x) e-key)) + remove.expr))]) (define-typed-syntax (stop-when E script ...) ≫ [[forged-name ≫ _ : FacetName] ⊢ forged-name ≫ forged-name-]