syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Add missing layer in pattern generation

This commit is contained in:
Tony Garnock-Jones 2021-06-02 13:41:30 +02:00
parent b77fe3efbc
commit 7a9f52b97c
3 changed files with 47 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
syndicate/go.rkt
View File

@ -9,6 +9,7 @@
(require "schemas/gen/dataspace.rkt") (require "schemas/gen/dataspace.rkt")
(require "syntax.rkt") (require "syntax.rkt")
(require (only-in "pattern.rkt" :pattern))
(define box (define box
(action (ds LIMIT REPORT_EVERY) (action (ds LIMIT REPORT_EVERY)
@ -43,7 +44,7 @@
;; (when (zero? count) ;; (when (zero? count)
;; (log-info "Client detected box termination") ;; (log-info "Client detected box termination")
;; (stop-facet root-facet)))) ;; (stop-facet root-facet))))
(assert (Observe 'BoxState (assert (Observe (:pattern (BoxState _))
(ref (entity #:assert (ref (entity #:assert
(action (_v _h) (action (_v _h)
(set! count (+ count 1))) (set! count (+ count 1)))
@ -63,6 +64,7 @@
(define assertions (make-bag)) (define assertions (make-bag))
(define subscriptions (make-hash)) (define subscriptions (make-hash))
(entity #:assert (action (rec handle) (entity #:assert (action (rec handle)
(log-info "+ ~v ~v" handle rec)
(when (record? rec) (when (record? rec)
(hash-set! handles handle rec) (hash-set! handles handle rec)
(when (eq? (bag-change! assertions rec +1) 'absent->present) (when (eq? (bag-change! assertions rec +1) 'absent->present)
@ -79,6 +81,7 @@
(hash-set! seen rec (turn-assert! this-turn observer rec))))))) (hash-set! seen rec (turn-assert! this-turn observer rec)))))))
#:retract (action (upstream-handle) #:retract (action (upstream-handle)
(define rec (hash-ref handles upstream-handle #f)) (define rec (hash-ref handles upstream-handle #f))
(log-info "- ~v ~v" upstream-handle rec)
(when rec (when rec
(hash-remove! handles upstream-handle) (hash-remove! handles upstream-handle)
(when (eq? (bag-change! assertions rec -1) 'present->absent) (when (eq? (bag-change! assertions rec -1) 'present->absent)
@ -93,6 +96,7 @@
(when (hash-empty? subscribers) (when (hash-empty? subscribers)
(hash-remove! subscriptions label)))])))) (hash-remove! subscriptions label)))]))))
#:message (action (message) #:message (action (message)
(log-info "! ~v" message)
(when (record? message) (when (record? message)
(for [(peer (in-hash-keys (hash-ref subscriptions (record-label message) '#hash())))] (for [(peer (in-hash-keys (hash-ref subscriptions (record-label message) '#hash())))]
(turn-message! this-turn peer message)))))) (turn-message! this-turn peer message))))))

40
syndicate/pattern.rkt
View File

@ -80,8 +80,8 @@
(define (member-entry key-stx pat-stx) (define (member-entry key-stx pat-stx)
(define analysed (analyse-pattern pat-stx)) (define analysed (analyse-pattern pat-stx))
(syntax-case analysed (DDiscard) (syntax-case analysed (Pattern-DDiscard DDiscard)
[(DDiscard) (list)] [(Pattern-DDiscard (DDiscard)) (list)]
[_ (list key-stx analysed)])) [_ (list key-stx analysed)]))
(define (struct-label-and-arity id-stx actual-count) (define (struct-label-and-arity id-stx actual-count)
@ -113,40 +113,42 @@
;; Extremely limited support for quasiquoting and quoting ;; Extremely limited support for quasiquoting and quoting
[(quasiquote (unquote p)) (analyse-pattern #'p)] [(quasiquote (unquote p)) (analyse-pattern #'p)]
[(quasiquote (p ...)) (analyse-pattern #'(list (quasiquote p) ...))] [(quasiquote (p ...)) (analyse-pattern #'(list (quasiquote p) ...))]
[(quasiquote p) #`(DLit 'p)] [(quasiquote p) #`(Pattern-DLit (DLit 'p))]
[(quote p) #`(DLit 'p)] [(quote p) #`(Pattern-DLit (DLit 'p))]
[(ctor piece ...) [(ctor piece ...)
(struct-info? (id-value #'ctor)) (struct-info? (id-value #'ctor))
(let-values (((label arity) (struct-label-and-arity #'ctor))) (let-values (((label arity) (struct-label-and-arity #'ctor)))
#`(DCompound-rec '#,label #`(Pattern-DCompound
#,arity (DCompound-rec '#,label
(hasheqv #,@(append* #,arity
(for/list [(n (in-naturals)) (hasheqv #,@(append*
(piece (in-list (syntax->list #'(piece ...))))] (for/list [(n (in-naturals))
(member-entry n piece))))))] (piece (in-list (syntax->list #'(piece ...))))]
(member-entry n piece)))))))]
[(list-stx piece ...) [(list-stx piece ...)
(list-id? #'list-stx) (list-id? #'list-stx)
#`(DCompound-arr #,(length (syntax->list #'(piece ...))) #`(Pattern-DCompound
(hasheqv #,@(append* (DCompound-arr #,(length (syntax->list #'(piece ...)))
(for/list [(n (in-naturals)) (hasheqv #,@(append*
(piece (in-list (syntax->list #'(piece ...))))] (for/list [(n (in-naturals))
(member-entry n piece)))))] (piece (in-list (syntax->list #'(piece ...))))]
(member-entry n piece))))))]
[id [id
(dollar-id? #'id) (dollar-id? #'id)
#`(DBind '#,(undollar #'id) (DDiscard))] #`(Pattern-DBind (DBind '#,(undollar #'id) (Pattern-DDiscard (DDiscard))))]
[($ id p) [($ id p)
#`(DBind 'id #,(analyse-pattern #'p))] #`(Pattern-DBind (DBind 'id #,(analyse-pattern #'p)))]
[id [id
(discard-id? #'id) (discard-id? #'id)
#`(DDiscard)] #`(Pattern-DDiscard (DDiscard))]
[other [other
#`(DLit other)])) #`(Pattern-DLit (DLit other))]))
(define (analyse-pattern-bindings stx) (define (analyse-pattern-bindings stx)
(define disarmed-stx (syntax-disarm stx orig-insp)) (define disarmed-stx (syntax-disarm stx orig-insp))

40
syndicate/schema-compiler.rkt
View File

@ -25,7 +25,7 @@
(format-symbol ":pat:~a" sym))) (format-symbol ":pat:~a" sym)))
(define (def-pattern name def) (define (def-pattern name def)
(define discard `(,(N 'DDiscard))) (define discard `(,(N 'Pattern-DDiscard) (,(N 'DDiscard))))
(define (pat-pattern p) (define (pat-pattern p)
(match (unwrap p) (match (unwrap p)
@ -34,7 +34,7 @@
[(SimplePattern-any) discard] [(SimplePattern-any) discard]
[(SimplePattern-atom _atomKind) discard] [(SimplePattern-atom _atomKind) discard]
[(SimplePattern-embedded _interface) 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-seqof pat) discard]
[(SimplePattern-setof pat) discard] [(SimplePattern-setof pat) discard]
[(SimplePattern-dictof key-pat value-pat) discard] [(SimplePattern-dictof key-pat value-pat) discard]
@ -43,25 +43,27 @@
[(CompoundPattern-rec label-pat fields-pat) [(CompoundPattern-rec label-pat fields-pat)
(match* ((unwrap label-pat) (unwrap fields-pat)) (match* ((unwrap label-pat) (unwrap fields-pat))
[((SimplePattern-lit label) (CompoundPattern-tuple field-pats)) [((SimplePattern-lit label) (CompoundPattern-tuple field-pats))
`(,(N 'DCompound-rec) `(,(N 'Pattern-DCompound)
',label (,(N 'DCompound-rec)
,(length field-pats) ',label
(hasheqv ,@(append* (for/list [(i (in-naturals)) ,(length field-pats)
(p (in-list field-pats))] (hasheqv ,@(append* (for/list [(i (in-naturals))
(define s (pat-pattern p)) (p (in-list field-pats))]
(if (equal? s discard) (define s (pat-pattern p))
`() (if (equal? s discard)
`(,i ,s))))))] `()
`(,i ,s)))))))]
[(_ _) `#,(raise-syntax-error ',name "Record schema cannot be used as a pattern")])] [(_ _) `#,(raise-syntax-error ',name "Record schema cannot be used as a pattern")])]
[(CompoundPattern-tuple pats) [(CompoundPattern-tuple pats)
`(,(N 'DCompound-arr) `(,(N 'Pattern-DCompound)
,(length pats) (,(N 'DCompound-arr)
(hasheqv ,@(append* (for/list [(i (in-naturals)) ,(length pats)
(p (in-list pats))] (hasheqv ,@(append* (for/list [(i (in-naturals))
(define s (pat-pattern p)) (p (in-list pats))]
(if (equal? s discard) (define s (pat-pattern p))
`() (if (equal? s discard)
`(,i ,p))))))] `()
`(,i ,p)))))))]
[other (error 'pat-pattern "Unimplemented: ~v" other)])) [other (error 'pat-pattern "Unimplemented: ~v" other)]))
(define fields (match (definition-ty def) (define fields (match (definition-ty def)