From 7a9f52b97c2d8d52c7d7e3e68e1d08deb0e2749f Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 2 Jun 2021 13:41:30 +0200 Subject: [PATCH] Add missing layer in pattern generation --- syndicate/go.rkt | 6 +++++- syndicate/pattern.rkt | 40 ++++++++++++++++++----------------- syndicate/schema-compiler.rkt | 40 ++++++++++++++++++----------------- 3 files changed, 47 insertions(+), 39 deletions(-) diff --git a/syndicate/go.rkt b/syndicate/go.rkt index bf64bfb..92df533 100644 --- a/syndicate/go.rkt +++ b/syndicate/go.rkt @@ -9,6 +9,7 @@ (require "schemas/gen/dataspace.rkt") (require "syntax.rkt") +(require (only-in "pattern.rkt" :pattern)) (define box (action (ds LIMIT REPORT_EVERY) @@ -43,7 +44,7 @@ ;; (when (zero? count) ;; (log-info "Client detected box termination") ;; (stop-facet root-facet)))) - (assert (Observe 'BoxState + (assert (Observe (:pattern (BoxState _)) (ref (entity #:assert (action (_v _h) (set! count (+ count 1))) @@ -63,6 +64,7 @@ (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) @@ -79,6 +81,7 @@ (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) @@ -93,6 +96,7 @@ (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)))))) diff --git a/syndicate/pattern.rkt b/syndicate/pattern.rkt index b0cfc64..73fcc92 100644 --- a/syndicate/pattern.rkt +++ b/syndicate/pattern.rkt @@ -80,8 +80,8 @@ (define (member-entry key-stx pat-stx) (define analysed (analyse-pattern pat-stx)) - (syntax-case analysed (DDiscard) - [(DDiscard) (list)] + (syntax-case analysed (Pattern-DDiscard DDiscard) + [(Pattern-DDiscard (DDiscard)) (list)] [_ (list key-stx analysed)])) (define (struct-label-and-arity id-stx actual-count) @@ -113,40 +113,42 @@ ;; Extremely limited support for quasiquoting and quoting [(quasiquote (unquote p)) (analyse-pattern #'p)] [(quasiquote (p ...)) (analyse-pattern #'(list (quasiquote p) ...))] - [(quasiquote p) #`(DLit 'p)] - [(quote p) #`(DLit 'p)] + [(quasiquote p) #`(Pattern-DLit (DLit 'p))] + [(quote p) #`(Pattern-DLit (DLit 'p))] [(ctor piece ...) (struct-info? (id-value #'ctor)) (let-values (((label arity) (struct-label-and-arity #'ctor))) - #`(DCompound-rec '#,label - #,arity - (hasheqv #,@(append* - (for/list [(n (in-naturals)) - (piece (in-list (syntax->list #'(piece ...))))] - (member-entry n piece))))))] + #`(Pattern-DCompound + (DCompound-rec '#,label + #,arity + (hasheqv #,@(append* + (for/list [(n (in-naturals)) + (piece (in-list (syntax->list #'(piece ...))))] + (member-entry n piece)))))))] [(list-stx piece ...) (list-id? #'list-stx) - #`(DCompound-arr #,(length (syntax->list #'(piece ...))) - (hasheqv #,@(append* - (for/list [(n (in-naturals)) - (piece (in-list (syntax->list #'(piece ...))))] - (member-entry n piece)))))] + #`(Pattern-DCompound + (DCompound-arr #,(length (syntax->list #'(piece ...))) + (hasheqv #,@(append* + (for/list [(n (in-naturals)) + (piece (in-list (syntax->list #'(piece ...))))] + (member-entry n piece))))))] [id (dollar-id? #'id) - #`(DBind '#,(undollar #'id) (DDiscard))] + #`(Pattern-DBind (DBind '#,(undollar #'id) (Pattern-DDiscard (DDiscard))))] [($ id p) - #`(DBind 'id #,(analyse-pattern #'p))] + #`(Pattern-DBind (DBind 'id #,(analyse-pattern #'p)))] [id (discard-id? #'id) - #`(DDiscard)] + #`(Pattern-DDiscard (DDiscard))] [other - #`(DLit other)])) + #`(Pattern-DLit (DLit other))])) (define (analyse-pattern-bindings stx) (define disarmed-stx (syntax-disarm stx orig-insp)) diff --git a/syndicate/schema-compiler.rkt b/syndicate/schema-compiler.rkt index ae6e6b9..4b7c462 100644 --- a/syndicate/schema-compiler.rkt +++ b/syndicate/schema-compiler.rkt @@ -25,7 +25,7 @@ (format-symbol ":pat:~a" sym))) (define (def-pattern name def) - (define discard `(,(N 'DDiscard))) + (define discard `(,(N 'Pattern-DDiscard) (,(N 'DDiscard)))) (define (pat-pattern p) (match (unwrap p) @@ -34,7 +34,7 @@ [(SimplePattern-any) discard] [(SimplePattern-atom _atomKind) discard] [(SimplePattern-embedded _interface) discard] - [(SimplePattern-lit value) `(,(N 'DLit) ',value)] + [(SimplePattern-lit value) `(,(N 'Pattern-DLit) (,(N 'DLit) ',value))] [(SimplePattern-seqof pat) discard] [(SimplePattern-setof pat) discard] [(SimplePattern-dictof key-pat value-pat) discard] @@ -43,25 +43,27 @@ [(CompoundPattern-rec label-pat fields-pat) (match* ((unwrap label-pat) (unwrap fields-pat)) [((SimplePattern-lit label) (CompoundPattern-tuple field-pats)) - `(,(N 'DCompound-rec) - ',label - ,(length field-pats) - (hasheqv ,@(append* (for/list [(i (in-naturals)) - (p (in-list field-pats))] - (define s (pat-pattern p)) - (if (equal? s discard) - `() - `(,i ,s))))))] + `(,(N 'Pattern-DCompound) + (,(N 'DCompound-rec) + ',label + ,(length field-pats) + (hasheqv ,@(append* (for/list [(i (in-naturals)) + (p (in-list field-pats))] + (define s (pat-pattern p)) + (if (equal? s discard) + `() + `(,i ,s)))))))] [(_ _) `#,(raise-syntax-error ',name "Record schema cannot be used as a pattern")])] [(CompoundPattern-tuple pats) - `(,(N 'DCompound-arr) - ,(length pats) - (hasheqv ,@(append* (for/list [(i (in-naturals)) - (p (in-list pats))] - (define s (pat-pattern p)) - (if (equal? s discard) - `() - `(,i ,p))))))] + `(,(N 'Pattern-DCompound) + (,(N 'DCompound-arr) + ,(length pats) + (hasheqv ,@(append* (for/list [(i (in-naturals)) + (p (in-list pats))] + (define s (pat-pattern p)) + (if (equal? s discard) + `() + `(,i ,p)))))))] [other (error 'pat-pattern "Unimplemented: ~v" other)])) (define fields (match (definition-ty def)