Update code to match latest schema changes

This commit is contained in:
Tony Garnock-Jones 2022-01-17 00:18:57 +01:00
parent 8d0a88e4c2
commit 1b9eddc0b6
8 changed files with 145 additions and 286 deletions

View File

@ -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)

View File

@ -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))

View File

@ -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 ()
[(_)

View File

@ -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)))])))

View File

@ -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)

View File

@ -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

View File

@ -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))))))

View File

@ -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)))]))))