Update code to match latest schema changes
This commit is contained in:
parent
8d0a88e4c2
commit
1b9eddc0b6
|
@ -53,8 +53,13 @@
|
|||
(hash-set! handles handle (cons value maybe-observe))
|
||||
(when (eq? (bag-change! assertions value +1) 'absent->present)
|
||||
(match maybe-observe
|
||||
[(? eof-object?) (void)]
|
||||
[(Observe pat ref) (add-interest! this-turn skeleton pat ref)])
|
||||
[(? eof-object?)
|
||||
(log-syndicate/dataspace-debug "Not an observer:~a" (pretty-assertion 4 value))
|
||||
(void)]
|
||||
[(Observe pat ref)
|
||||
(add-interest! this-turn skeleton pat ref)
|
||||
(log-syndicate/dataspace-debug "Updated index:~a" (pretty-assertion 4 skeleton))
|
||||
])
|
||||
(add-assertion! this-turn skeleton value)))
|
||||
#:retract (lambda (upstream-handle)
|
||||
(match (hash-ref handles upstream-handle #f)
|
||||
|
|
|
@ -23,7 +23,7 @@
|
|||
(with-services [syndicate/drivers/stream]
|
||||
(at ds
|
||||
(during/spawn
|
||||
(Observe (:pattern (StreamConnection ,_ ,_ ,(DLit (TcpLocal $host $port)))) _)
|
||||
(Observe (:pattern (StreamConnection ,_ ,_ (TcpLocal ,(DLit $host) ,(DLit $port)))) _)
|
||||
#:name (TcpLocal host port)
|
||||
(run-listener ds host port))
|
||||
|
||||
|
|
|
@ -16,9 +16,6 @@
|
|||
pattern->constant-paths
|
||||
pattern->capture-paths
|
||||
|
||||
pattern->constant
|
||||
;; quote-pattern
|
||||
|
||||
!dump-registered-preserves-patterns!
|
||||
|
||||
(all-from-out "schemas/dataspacePatterns.rkt"))
|
||||
|
@ -97,7 +94,7 @@
|
|||
(define (constructor-registered? stx)
|
||||
(free-id-table-ref preserves-pattern-registry stx #f))
|
||||
|
||||
(define (struct-label-and-arity id-stx actual-count)
|
||||
(define (struct-label/arity-check id-stx actual-count)
|
||||
(match-define (list _type-stx ctor-stx pred-stx accessor-stxs _mutator-stxs _super)
|
||||
(extract-struct-info (id-value id-stx)))
|
||||
(define expected-count (length accessor-stxs))
|
||||
|
@ -107,8 +104,7 @@
|
|||
expected-count
|
||||
ctor-stx
|
||||
actual-count)))
|
||||
(values (syntax-e ctor-stx)
|
||||
expected-count))
|
||||
(syntax-e ctor-stx))
|
||||
|
||||
(define (append-map-pairs f xs)
|
||||
(match xs
|
||||
|
@ -119,13 +115,10 @@
|
|||
(define (analyse-pattern stx
|
||||
[check-destructuring (lambda (stx) stx)]
|
||||
[wrap-literal (lambda (stx) stx)])
|
||||
(define (member-entry key-stx pat-stx)
|
||||
(define analysed (analyse-pattern pat-stx check-destructuring wrap-literal))
|
||||
(syntax-case analysed (Pattern-DDiscard DDiscard)
|
||||
[(Pattern-DDiscard (DDiscard)) (list)]
|
||||
[_ (list key-stx analysed)]))
|
||||
(define (walk-hash pieces-stx)
|
||||
(append-map-pairs member-entry (syntax->list pieces-stx)))
|
||||
(append-map-pairs (lambda (key-stx pat-stx)
|
||||
(list key-stx (analyse-pattern pat-stx check-destructuring wrap-literal)))
|
||||
(syntax->list pieces-stx)))
|
||||
(let walk ((stx stx))
|
||||
(define disarmed-stx (syntax-disarm stx orig-insp))
|
||||
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
||||
|
@ -136,40 +129,28 @@
|
|||
|
||||
[(ctor args ...)
|
||||
(constructor-registered? #'ctor)
|
||||
(check-destructuring
|
||||
((free-id-table-ref preserves-pattern-registry #'ctor) 'pattern disarmed-stx))]
|
||||
((free-id-table-ref preserves-pattern-registry #'ctor) 'pattern disarmed-stx)]
|
||||
|
||||
;; Extremely limited support for quasiquoting and quoting
|
||||
[(quasiquote (unquote p)) (walk #'p)]
|
||||
[(quasiquote (p ...)) (walk #'(list (quasiquote p) ...))]
|
||||
[(quasiquote p) #`(Pattern-DLit (DLit #,(wrap-literal #''p)))]
|
||||
[(quote p) #`(Pattern-DLit (DLit #,(wrap-literal #''p)))]
|
||||
[(quasiquote p) #`(literal->literal-pattern #,(wrap-literal #''p))]
|
||||
[(quote p) #`(literal->literal-pattern #,(wrap-literal #''p))]
|
||||
|
||||
[(unquote p) #'p]
|
||||
|
||||
[(ctor piece ...)
|
||||
(struct-info? (id-value #'ctor))
|
||||
(let-values (((label arity) (struct-label-and-arity #'ctor (length (syntax->list #'(piece ...))))))
|
||||
(check-destructuring
|
||||
#`(make-rec-pattern '#,label #,arity
|
||||
(hasheqv #,@(append*
|
||||
(for/list [(n (in-naturals))
|
||||
(piece (in-list (syntax->list #'(piece ...))))]
|
||||
(member-entry n piece)))))))]
|
||||
(let ((label (struct-label/arity-check #'ctor (length (syntax->list #'(piece ...))))))
|
||||
(check-destructuring #`(rec '#,label (list #,@(map walk (syntax->list #'(piece ...)))))))]
|
||||
|
||||
[(list-stx piece ...)
|
||||
(list-id? #'list-stx)
|
||||
(check-destructuring
|
||||
#`(make-arr-pattern #,(length (syntax->list #'(piece ...)))
|
||||
(hasheqv #,@(append*
|
||||
(for/list [(n (in-naturals))
|
||||
(piece (in-list (syntax->list #'(piece ...))))]
|
||||
(member-entry n piece))))))]
|
||||
(check-destructuring #`(arr (list #,@(map walk (syntax->list #'(piece ...))))))]
|
||||
|
||||
[(hash-stx piece ...)
|
||||
(hash-or-hasheqv-id? #'hash-stx)
|
||||
(check-destructuring
|
||||
#`(make-dict-pattern (hash #,@(walk-hash #'(piece ...)))))]
|
||||
(check-destructuring #`(dict (hash #,@(walk-hash #'(piece ...)))))]
|
||||
|
||||
[id
|
||||
(dollar-id? #'id)
|
||||
|
@ -185,23 +166,22 @@
|
|||
(discard-id? #'id)
|
||||
#`(Pattern-DDiscard (DDiscard))]
|
||||
|
||||
[(c l a (hash-stx piece ...))
|
||||
(and (id=? #'make-rec-pattern #'c)
|
||||
(hash-or-hasheqv-id? #'hash-stx))
|
||||
#`(make-rec-pattern* l a (hash-stx #,@(walk-hash #'(piece ...))))]
|
||||
[(c l (list-stx piece ...))
|
||||
(and (id=? #'rec #'c)
|
||||
(list-id? #'list-stx))
|
||||
#`(rec* l (list #,@(map walk (syntax->list #'(piece ...)))))]
|
||||
|
||||
[(c a (hash-stx piece ...))
|
||||
(and (id=? #'make-arr-pattern #'c)
|
||||
(hash-or-hasheqv-id? #'hash-stx))
|
||||
#`(make-arr-pattern* a (hash-stx #,@(walk-hash #'(piece ...))))]
|
||||
[(c (list-stx piece ...))
|
||||
(and (id=? #'arr #'c)
|
||||
(list-id? #'list-stx))
|
||||
#`(arr* (list #,@(map walk (syntax->list #'(piece ...)))))]
|
||||
|
||||
[(c (hash-stx piece ...))
|
||||
(and (id=? #'make-dict-pattern #'c)
|
||||
(and (id=? #'dict #'c)
|
||||
(hash-or-hasheqv-id? #'hash-stx))
|
||||
#`(make-dict-pattern* (hash-stx #,@(walk-hash #'(piece ...))))]
|
||||
#`(dict* (hash-stx #,@(walk-hash #'(piece ...))))]
|
||||
|
||||
[other
|
||||
#`(Pattern-DLit (DLit #,(wrap-literal #'other)))])))
|
||||
[other #`(literal->literal-pattern #,(wrap-literal #'other))])))
|
||||
|
||||
(define (analyse-pattern-bindings stx)
|
||||
(let walk ((stx stx))
|
||||
|
@ -245,23 +225,22 @@
|
|||
(discard-id? #'id)
|
||||
'()]
|
||||
|
||||
[(c l a (hash-stx piece ...))
|
||||
(and (id=? #'make-rec-pattern #'c)
|
||||
(hash-or-hasheqv-id? #'hash-stx))
|
||||
(append-map-pairs (lambda (_k v) (walk v)) (syntax->list #'(piece ...)))]
|
||||
[(c l (list-stx piece ...))
|
||||
(and (id=? #'rec #'c)
|
||||
(list-id? #'list-stx))
|
||||
(append-map walk (syntax->list #'(piece ...)))]
|
||||
|
||||
[(c a (hash-stx piece ...))
|
||||
(and (id=? #'make-arr-pattern #'c)
|
||||
(hash-or-hasheqv-id? #'hash-stx))
|
||||
(append-map-pairs (lambda (_k v) (walk v)) (syntax->list #'(piece ...)))]
|
||||
[(c (list-stx piece ...))
|
||||
(and (id=? #'arr #'c)
|
||||
(list-id? #'list-stx))
|
||||
(append-map walk (syntax->list #'(piece ...)))]
|
||||
|
||||
[(c (hash-stx piece ...))
|
||||
(and (id=? #'make-dict-pattern #'c)
|
||||
(and (id=? #'dict #'c)
|
||||
(hash-or-hasheqv-id? #'hash-stx))
|
||||
(append-map-pairs (lambda (_k v) (walk v)) (syntax->list #'(piece ...)))]
|
||||
|
||||
[other
|
||||
'()])))
|
||||
[other '()])))
|
||||
|
||||
(define (analyse-match-pattern stx)
|
||||
(let walk ((stx stx))
|
||||
|
@ -342,17 +321,19 @@
|
|||
(define (select-pattern-leaves desc capture-fn lit-fn)
|
||||
(let walk-node ((key-rev '()) (desc desc))
|
||||
(match desc
|
||||
[(Pattern-DCompound (or (DCompound-rec _ members)
|
||||
(DCompound-arr _ members)
|
||||
(DCompound-dict _ members)))
|
||||
(append* (for/list [((key subdesc) (in-hash members))]
|
||||
[(Pattern-DCompound (or (DCompound-rec _ fields)
|
||||
(DCompound-arr fields)))
|
||||
(append* (for/list [(key (in-naturals)) (subdesc (in-list fields))]
|
||||
(walk-node (cons key key-rev) subdesc)))]
|
||||
[(Pattern-DCompound (DCompound-dict entries))
|
||||
(append* (for/list [((key subdesc) (in-hash entries))]
|
||||
(walk-node (cons key key-rev) subdesc)))]
|
||||
[(Pattern-DBind (DBind subdesc))
|
||||
(append (capture-fn key-rev) (walk-node key-rev subdesc))]
|
||||
[(Pattern-DDiscard (DDiscard))
|
||||
'()]
|
||||
[(Pattern-DLit (DLit value))
|
||||
(lit-fn key-rev value)])))
|
||||
(lit-fn key-rev (->preserve value))])))
|
||||
|
||||
(define (pattern->constant-values desc)
|
||||
(select-pattern-leaves desc
|
||||
|
@ -369,81 +350,6 @@
|
|||
(lambda (key-rev) (list (reverse key-rev)))
|
||||
(lambda (key-rev value) (list))))
|
||||
|
||||
(define (pattern->constant desc [env (lambda (index) (void))])
|
||||
(define next-binding-index 0)
|
||||
(define (walk p k)
|
||||
(match p
|
||||
[(Pattern-DDiscard (DDiscard)) (void)]
|
||||
[(Pattern-DBind (DBind pat))
|
||||
(let ((v (env next-binding-index)))
|
||||
(set! next-binding-index (+ next-binding-index 1))
|
||||
(let ((inner (walk pat values)))
|
||||
(k (if (void? v) inner v))))]
|
||||
[(Pattern-DLit (DLit value)) (k value)]
|
||||
[(Pattern-DCompound (DCompound-rec (CRec label arity) members))
|
||||
(let loop ((fields-rev '()) (i 0))
|
||||
(if (= i arity)
|
||||
(k (record label (reverse fields-rev)))
|
||||
(let ((vpat (hash-ref members i #f)))
|
||||
(if vpat
|
||||
(walk vpat (lambda (v) (loop (cons v fields-rev) (+ i 1))))
|
||||
(void)))))]
|
||||
[(Pattern-DCompound (DCompound-arr (CArr arity) members))
|
||||
(let loop ((items-rev '()) (i 0))
|
||||
(if (= i arity)
|
||||
(k (reverse items-rev))
|
||||
(let ((vpat (hash-ref members i #f)))
|
||||
(if vpat
|
||||
(walk vpat (lambda (v) (loop (cons v items-rev) (+ i 1))))
|
||||
(void)))))]
|
||||
[(Pattern-DCompound (DCompound-dict (CDict) members))
|
||||
(let loop ((items (hash)) (entries (hash->list members)))
|
||||
(match entries
|
||||
['() (k items)]
|
||||
[(cons (cons key vpat) more)
|
||||
(walk vpat (lambda (v) (loop (hash-set items key v) more)))]))]))
|
||||
(walk (parse-Pattern desc) values))
|
||||
|
||||
;; (define (quote-pattern p)
|
||||
;; (match p
|
||||
;; [(Pattern-DDiscard (DDiscard))
|
||||
;; (Pattern-DCompound (DCompound-rec (CRec '_ 0) (hash)))]
|
||||
;; [(Pattern-DBind (DBind pat))
|
||||
;; (Pattern-DCompound (DCompound-rec (CRec 'bind 1)
|
||||
;; (hash 0 (quote-pattern pat))))]
|
||||
;; [(Pattern-DLit value)
|
||||
;; (Pattern-DCompound (DCompound-rec (CRec 'lit 1) (hash 0 (Pattern-DLit (DLit value)))))]
|
||||
;; [(Pattern-DCompound (DCompound-rec (CRec label arity) members))
|
||||
;; (Pattern-DCompound
|
||||
;; (DCompound-rec (CRec 'compound 2)
|
||||
;; (hash 0 (Pattern-DCompound
|
||||
;; (DCompound-rec (CRec 'rec 2)
|
||||
;; (hash 0 (Pattern-DLit (DLit label))
|
||||
;; 1 (Pattern-DLit (DLit arity)))))
|
||||
;; 1 (Pattern-DCompound
|
||||
;; (DCompound-dict (CDict)
|
||||
;; (for/hash ([(kv vp) (in-hash members)])
|
||||
;; (values kv (quote-pattern vp))))))))]
|
||||
;; [(Pattern-DCompound (DCompound-arr (CArr arity) members))
|
||||
;; (Pattern-DCompound
|
||||
;; (DCompound-rec (CRec 'compound 2)
|
||||
;; (hash 0 (Pattern-DCompound
|
||||
;; (DCompound-rec (CRec 'arr 1)
|
||||
;; (hash 0 (Pattern-DLit (DLit arity)))))
|
||||
;; 1 (Pattern-DCompound
|
||||
;; (DCompound-dict (CDict)
|
||||
;; (for/hash ([(kv vp) (in-hash members)])
|
||||
;; (values kv (quote-pattern vp))))))))]
|
||||
;; [(Pattern-DCompound (DCompound-dict (CDict) members))
|
||||
;; (Pattern-DCompound
|
||||
;; (DCompound-rec (CRec 'compound 2)
|
||||
;; (hash 0 (Pattern-DCompound
|
||||
;; (DCompound-rec (CRec 'dict 0) (hash)))
|
||||
;; 1 (Pattern-DCompound
|
||||
;; (DCompound-dict (CDict)
|
||||
;; (for/hash ([(kv vp) (in-hash members)])
|
||||
;; (values kv (quote-pattern vp))))))))]))
|
||||
|
||||
(define-syntax (!dump-registered-preserves-patterns! stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
|
|
|
@ -38,22 +38,17 @@
|
|||
(set! bindings-rev saved)
|
||||
(not result)))]
|
||||
[(Pattern-Lit (Lit expected)) (preserve=? expected v)]
|
||||
[(Pattern-PCompound (PCompound (ConstructorSpec-CRec (CRec label arity))
|
||||
(PCompoundMembers members)))
|
||||
[(Pattern-PCompound (PCompound-rec label field-pats))
|
||||
(match v
|
||||
[(record (== label preserve=?) fields)
|
||||
(and (= (length fields) arity)
|
||||
(for/and [((key pp) (in-hash members))]
|
||||
(and (exact-integer? key) (walk pp (list-ref fields key)))))]
|
||||
(and (= (length fields) (length field-pats))
|
||||
(andmap walk field-pats fields))]
|
||||
[_ #f])]
|
||||
[(Pattern-PCompound (PCompound (ConstructorSpec-CArr (CArr arity))
|
||||
(PCompoundMembers members)))
|
||||
[(Pattern-PCompound (PCompound-arr item-pats))
|
||||
(and (list? v)
|
||||
(= (length v) arity)
|
||||
(for/and [((key pp) (in-hash members))]
|
||||
(and (exact-integer? key) (walk pp (list-ref v key)))))]
|
||||
[(Pattern-PCompound (PCompound (ConstructorSpec-CDict (CDict))
|
||||
(PCompoundMembers members)))
|
||||
(= (length v) (length item-pats))
|
||||
(andmap walk item-pats v))]
|
||||
[(Pattern-PCompound (PCompound-dict members))
|
||||
(and (dict? v)
|
||||
(for/and [((key pp) (in-hash members))]
|
||||
(define vv (hash-ref v key (void)))
|
||||
|
@ -72,19 +67,11 @@
|
|||
(list-ref bindings index)
|
||||
(error 'instantiate-Template "Binding index out of range: ~v" index))]
|
||||
[(Template-Lit (Lit v)) v]
|
||||
[(Template-TCompound (TCompound (ConstructorSpec-CRec (CRec label arity))
|
||||
(TCompoundMembers members)))
|
||||
(record label
|
||||
(for/list [(i (in-range 0 arity))]
|
||||
(walk (hash-ref members i (lambda () (error 'instantiate-Template
|
||||
"Missing record field key ~v" i))))))]
|
||||
[(Template-TCompound (TCompound (ConstructorSpec-CArr (CArr arity))
|
||||
(TCompoundMembers members)))
|
||||
(for/list [(i (in-range 0 arity))]
|
||||
(walk (hash-ref members i (lambda () (error 'instantiate-Template
|
||||
"Missing array key ~v" i)))))]
|
||||
[(Template-TCompound (TCompound (ConstructorSpec-CDict (CDict))
|
||||
(TCompoundMembers members)))
|
||||
[(Template-TCompound (TCompound-rec label field-templates))
|
||||
(record label (map walk field-templates))]
|
||||
[(Template-TCompound (TCompound-arr item-templates))
|
||||
(map walk item-templates)]
|
||||
[(Template-TCompound (TCompound-dict members))
|
||||
(for/hash [((key tt) (in-hash members))]
|
||||
(values key (walk tt)))])))
|
||||
|
||||
|
|
|
@ -81,28 +81,17 @@
|
|||
[(CompoundPattern-rec label-pat fields-pat)
|
||||
(match* ((unwrap label-pat) (unwrap fields-pat))
|
||||
[((SimplePattern-lit label) (CompoundPattern-tuple field-pats))
|
||||
`(:pat:make-rec-pattern
|
||||
',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")])]
|
||||
`(:pat:rec ',label (list ,@(map pat-pattern field-pats)))]
|
||||
[(_ _)
|
||||
`#,(raise-syntax-error ',name "Record schema cannot be used as a pattern")])]
|
||||
[(CompoundPattern-tuple pats)
|
||||
`(:pat:make-arr-pattern
|
||||
,(length pats)
|
||||
(hasheqv ,@(append* (for/list [(i (in-naturals))
|
||||
(p (in-list pats))]
|
||||
(define s (pat-pattern p))
|
||||
(if (equal? s discard) `() `(,i ,p))))))]
|
||||
`(:pat:arr (list ,@(map pat-pattern pats)))]
|
||||
[(CompoundPattern-tuplePrefix fixed-pats variable-pat)
|
||||
`#,(raise-syntax-error ',name "Variable-length array cannot be used as a pattern")]
|
||||
[(CompoundPattern-dict entries)
|
||||
`(:pat:make-dict-pattern
|
||||
(hash ,@(append* (for/list [((k p) (in-hash entries))]
|
||||
(define s (pat-pattern p))
|
||||
(if (equal? s discard) `() `(',k ,s))))))]
|
||||
`(:pat:dict (hash ,@(append* (for/list [((k p) (in-hash entries))]
|
||||
(define s (pat-pattern p))
|
||||
`(',k ,s)))))]
|
||||
[other (error 'pat-pattern "Unimplemented: ~v" other)]))
|
||||
|
||||
(define (top-pat top-name name p ty k-nonrecord)
|
||||
|
|
|
@ -26,12 +26,21 @@
|
|||
|
||||
(define-syntax with-services
|
||||
(syntax-rules ()
|
||||
[(_ [] body ...)
|
||||
(begin body ...)]
|
||||
[(_ [service-name more-services ...] body ...)
|
||||
[(_ [service-name ...] body ...)
|
||||
(at registry-dataspace
|
||||
(during (ServiceRunning 'service-name)
|
||||
(with-services [more-services ...] body ...)))]))
|
||||
(begin (log-syndicate/service-debug "Asserting ~v" (RequireService 'service-name))
|
||||
(assert (RequireService 'service-name))) ...
|
||||
(await-services [service-name ...] body ...))]))
|
||||
|
||||
(define-syntax await-services
|
||||
(syntax-rules ()
|
||||
[(_ [] body ...)
|
||||
(begin (log-syndicate/service-debug "Ready!")
|
||||
body ...)]
|
||||
[(_ [service-name more-services ...] body ...)
|
||||
(begin (log-syndicate/service-debug "Awaiting ~v" (ServiceState 'service-name (State-ready)))
|
||||
(during (ServiceState 'service-name (State-ready))
|
||||
(await-services [more-services ...] body ...)))]))
|
||||
|
||||
(define-syntax provide-service
|
||||
(syntax-rules ()
|
||||
|
@ -40,7 +49,8 @@
|
|||
(provide #%service)
|
||||
(define (#%service service-name dataspace)
|
||||
(syntax-parameterize ([registry-dataspace (make-rename-transformer #'dataspace)])
|
||||
(at dataspace (assert (ServiceRunning service-name)))
|
||||
(log-syndicate/service-debug "Providing ~v" (ServiceState service-name (State-ready)))
|
||||
(at dataspace (assert (ServiceState service-name (State-ready))))
|
||||
body ...)))]))
|
||||
|
||||
(define-syntax standard-actor-system/no-services
|
||||
|
@ -65,9 +75,6 @@
|
|||
(spawn #:name 'syndicate/service
|
||||
#:daemon? #t
|
||||
(at ds
|
||||
(during (Observe (:pattern (ServiceRunning ,(DLit $service-name))) _)
|
||||
(assert (RequireService service-name)))
|
||||
|
||||
(during/spawn (RequireService $service-name)
|
||||
#:name service-name
|
||||
#:daemon? #t
|
||||
|
|
|
@ -37,7 +37,7 @@
|
|||
;; A `ConstructorSpec` specifies a record label with arity, or a list
|
||||
;; arity, or a dictionary.
|
||||
;;
|
||||
;; ConstructorSpec = (U CRec CArr CDict) ;; from dataspacePatterns.prs
|
||||
;; ConstructorSpec = (U (cons any nat) nat 'dict)
|
||||
;;
|
||||
(struct skeleton-node (continuation [edges #:mutable]) #:transparent)
|
||||
(struct skeleton-selector (pop-count key) #:transparent)
|
||||
|
@ -154,14 +154,14 @@
|
|||
|
||||
(define (term-matches-ctor-spec? term ctor-spec)
|
||||
(match ctor-spec
|
||||
[(CArr arity)
|
||||
[(? number? arity)
|
||||
(and (list? term) (= (length term) arity))]
|
||||
[(CRec label arity)
|
||||
[(cons label (? number? 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)
|
||||
['dict
|
||||
(hash? term)]))
|
||||
|
||||
(define (subterm-matches-ctor-spec? term path ctor-spec)
|
||||
|
@ -170,9 +170,7 @@
|
|||
(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)))
|
||||
[(Pattern-DCompound compound-pat)
|
||||
(define selector (skeleton-selector pop-count key))
|
||||
(define table
|
||||
(match (assoc selector (skeleton-node-edges sk))
|
||||
|
@ -180,6 +178,11 @@
|
|||
(set-skeleton-node-edges! sk (cons (cons selector table) (skeleton-node-edges sk)))
|
||||
table)]
|
||||
[(cons _selector table) table]))
|
||||
(define ctor-spec
|
||||
(match compound-pat
|
||||
[(DCompound-rec label field-pats) (cons label (length field-pats))]
|
||||
[(DCompound-arr item-pats) (length item-pats)]
|
||||
[(DCompound-dict _entries) 'dict]))
|
||||
(define (make-skeleton-node-with-cache)
|
||||
(define unfiltered (skeleton-continuation-cache (skeleton-node-continuation sk)))
|
||||
(define filtered (make-hash))
|
||||
|
@ -191,9 +194,16 @@
|
|||
(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))))
|
||||
(match compound-pat
|
||||
[(or (DCompound-rec _ pats)
|
||||
(DCompound-arr pats))
|
||||
(for/fold [(pop-count 0) (sk next)]
|
||||
[(key (in-naturals)) (subpat (in-list pats))]
|
||||
(walk-node! (cons key rev-path) sk pop-count key subpat))]
|
||||
[(DCompound-dict members)
|
||||
(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))]
|
||||
[(Pattern-DBind (DBind pat))
|
||||
(walk-node! rev-path sk pop-count key pat)]
|
||||
|
@ -243,11 +253,11 @@
|
|||
(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))]
|
||||
(cons (struct-type-name t) (struct-type-constructor-arity t))]
|
||||
[(list? new-top)
|
||||
(CArr (length new-top))]
|
||||
(length new-top)]
|
||||
[(hash? new-top)
|
||||
(CDict)]
|
||||
'dict]
|
||||
[else #f])
|
||||
#f))
|
||||
(when entry (walk-node! entry (cons new-top popped-stack))))))
|
||||
|
|
|
@ -3,97 +3,52 @@
|
|||
;;; SPDX-FileCopyrightText: Copyright © 2021-2022 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||
;;; Smart constructors for compound patterns.
|
||||
|
||||
(provide make-rec-pattern
|
||||
make-arr-pattern
|
||||
make-dict-pattern
|
||||
(provide rec
|
||||
arr
|
||||
dict
|
||||
|
||||
make-rec-pattern*
|
||||
make-arr-pattern*
|
||||
make-dict-pattern*)
|
||||
rec*
|
||||
arr*
|
||||
dict*
|
||||
|
||||
literal->literal-pattern
|
||||
literal-pattern->literal
|
||||
lit)
|
||||
|
||||
(require racket/dict)
|
||||
(require racket/match)
|
||||
|
||||
(require preserves)
|
||||
(require preserves-schema)
|
||||
|
||||
(require syndicate/schemas/dataspacePatterns)
|
||||
|
||||
(define (rec label arity pats)
|
||||
(Pattern-DCompound (DCompound-rec (CRec label arity) pats)))
|
||||
(define (rec label pats) (Pattern-DCompound (DCompound-rec label pats)))
|
||||
(define (arr pats) (Pattern-DCompound (DCompound-arr pats)))
|
||||
(define (dict pats) (Pattern-DCompound (DCompound-dict pats)))
|
||||
|
||||
(define (arr arity pats)
|
||||
(Pattern-DCompound (DCompound-arr (CArr arity) pats)))
|
||||
(define (rec* label pats) (rec 'rec (list (lit label) (arr pats))))
|
||||
(define (arr* pats) (rec 'arr (list (arr pats))))
|
||||
(define (dict* pats) (rec 'dict (list (dict pats))))
|
||||
|
||||
(define (dict pats)
|
||||
(Pattern-DCompound (DCompound-dict (CDict) pats)))
|
||||
(define (literal->literal-pattern v)
|
||||
(let walk ((v (->preserve v)))
|
||||
(match v
|
||||
[(record label fs) (rec label (map walk fs))]
|
||||
[(? list? vs) (arr (map walk vs))]
|
||||
[(? dict? d) (dict (for/hash [((k v) (in-hash d))] (values k (walk v))))]
|
||||
[other (Pattern-DLit (DLit (parse-AnyAtom! other)))])))
|
||||
|
||||
(define (unlit? p)
|
||||
(match p
|
||||
[(Pattern-DLit (DLit _)) #t]
|
||||
[(DLit _) #t]
|
||||
[_ #f]))
|
||||
(define lit literal->literal-pattern)
|
||||
|
||||
(define (unlit p)
|
||||
(match p
|
||||
[(Pattern-DLit (DLit v)) v]
|
||||
[(DLit v) v]))
|
||||
|
||||
(define (lit v)
|
||||
(Pattern-DLit (DLit v)))
|
||||
|
||||
(define (make-rec-pattern label arity pats)
|
||||
(if (and (= arity (hash-count pats))
|
||||
(andmap unlit? (hash-values pats)))
|
||||
(lit (record label (for/list [(i (in-range arity))] (unlit (hash-ref pats i)))))
|
||||
(rec label arity pats)))
|
||||
|
||||
(define (make-arr-pattern arity pats)
|
||||
(if (and (= arity (hash-count pats))
|
||||
(andmap unlit? (hash-values pats)))
|
||||
(lit (for/list [(i (in-range arity))] (unlit (hash-ref pats i))))
|
||||
(arr arity pats)))
|
||||
|
||||
(define (make-dict-pattern pats)
|
||||
(if (andmap unlit? (hash-values pats))
|
||||
(lit (for/hash [((k v) (in-hash pats))] (values k (unlit v))))
|
||||
(dict pats)))
|
||||
|
||||
(define (rec* label arity pats)
|
||||
(Pattern-DCompound
|
||||
(DCompound-rec (CRec 'compound 2)
|
||||
(hash 0 (lit (CRec label arity))
|
||||
1 (dict pats)))))
|
||||
|
||||
(define (arr* arity pats)
|
||||
(Pattern-DCompound
|
||||
(DCompound-rec (CRec 'compound 2)
|
||||
(hash 0 (lit (CArr arity))
|
||||
1 (dict pats)))))
|
||||
|
||||
(define (dict* pats)
|
||||
(Pattern-DCompound
|
||||
(DCompound-rec (CRec 'compound 2)
|
||||
(hash 0 (lit (CDict))
|
||||
1 (dict pats)))))
|
||||
|
||||
(define (unlit* p)
|
||||
(match p
|
||||
[(Pattern-DCompound (DCompound-rec (CRec 'lit 1) (hash-table [0 v]))) v]
|
||||
[_ #f]))
|
||||
|
||||
(define (lit* v)
|
||||
(rec 'lit 1 (hasheqv 0 v)))
|
||||
|
||||
(define (make-rec-pattern* label arity pats)
|
||||
(if (and (= arity (hash-count pats))
|
||||
(andmap unlit* (hash-values pats)))
|
||||
(lit* (rec label arity (for/hash [((k v) (in-hash pats))] (values k (unlit* v)))))
|
||||
(rec* label arity pats)))
|
||||
|
||||
(define (make-arr-pattern* arity pats)
|
||||
(if (and (= arity (hash-count pats))
|
||||
(andmap unlit* (hash-values pats)))
|
||||
(lit* (arr arity (for/hash [((k v) (in-hash pats))] (values k (unlit* v)))))
|
||||
(arr* arity pats)))
|
||||
|
||||
(define (make-dict-pattern* pats)
|
||||
(if (andmap unlit* (hash-values pats))
|
||||
(lit* (dict (for/hash [((k v) (in-hash pats))] (values k (unlit* v)))))
|
||||
(dict* pats)))
|
||||
(define (literal-pattern->literal p)
|
||||
(let/ec return
|
||||
(let walk ((p p))
|
||||
(match p
|
||||
[(Pattern-DDiscard (DDiscard)) (return (void))]
|
||||
[(Pattern-DBind (DBind pp)) (walk pp)]
|
||||
[(Pattern-DLit (DLit a)) (->preserve a)]
|
||||
[(Pattern-DCompound (DCompound-rec label ps)) (record label (map walk ps))]
|
||||
[(Pattern-DCompound (DCompound-arr ps)) (map walk ps)]
|
||||
[(Pattern-DCompound (DCompound-dict d)) (for/hash [((k pp) (in-hash d))]
|
||||
(values k (walk pp)))]))))
|
||||
|
|
Loading…
Reference in New Issue