Introduce "smart constructors" for patterns to merge literal chunks where possible, making patterns-over-patterns less annoying to express (hopefully)
This commit is contained in:
parent
8b1d3a5e3f
commit
20eeb6cd55
|
@ -22,28 +22,6 @@
|
|||
(provide-service [ds]
|
||||
(with-services [syndicate/drivers/stream]
|
||||
(at ds
|
||||
;; TODO: this is annoying. We have to pay attention to the *syntactic* structure of the
|
||||
;; listener's pattern in order to match all possible variants:
|
||||
;; - `variable`, where `variable`'s value matches `(TcpLocal _ _)`
|
||||
;; - `(TcpLocal variable1 variable2)`
|
||||
;; - `(TcpLocal "hostname" variable)`
|
||||
;; - `(TcpLocal variable 1234)`
|
||||
;; - `(TcpLocal "hostname" 1234)`
|
||||
;;
|
||||
;; POSSIBLE SOLUTION: have pattern analysis check to see if there are any binds or
|
||||
;; discards within a constructor application; if there are none, it may as well be a
|
||||
;; constant literal, so make it one. This is what the earlier Syndicate/js
|
||||
;; implementations do (because they don't have a compile-time constructor registry and
|
||||
;; have to decide whether to assume a compound or just evaluate some expression), and it
|
||||
;; works fine there.
|
||||
|
||||
(during/spawn (Observe (:pattern (StreamConnection ,_ ,_ (TcpLocal ,$host-pat ,$port-pat))) _)
|
||||
#:match [host (pattern->constant host-pat)]
|
||||
#:match [port (pattern->constant port-pat)]
|
||||
#:when (not (or (void? host) (void? port)))
|
||||
#:name (TcpLocal host port)
|
||||
(run-listener ds host port))
|
||||
|
||||
(during/spawn
|
||||
(Observe (:pattern (StreamConnection ,_ ,_ ,(DLit (TcpLocal $host $port)))) _)
|
||||
#:name (TcpLocal host port)
|
||||
|
|
|
@ -37,6 +37,7 @@
|
|||
(require racket/match)
|
||||
(require racket/list)
|
||||
(require "pattern-expander.rkt")
|
||||
(require "smart-pattern.rkt")
|
||||
(require "schemas/gen/dataspace-patterns.rkt")
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
|
@ -82,22 +83,17 @@
|
|||
(and (dollar-id? stx)
|
||||
(datum->syntax stx (string->symbol (substring (symbol->string (syntax-e stx)) 1)))))
|
||||
|
||||
(define (discard-id? stx)
|
||||
(define (id=? expected stx)
|
||||
(and (identifier? stx)
|
||||
(free-identifier=? #'_ stx)))
|
||||
(free-identifier=? expected stx)))
|
||||
|
||||
(define (id-value stx)
|
||||
(and (identifier? stx)
|
||||
(syntax-local-value stx (lambda () #f))))
|
||||
|
||||
(define (list-id? stx)
|
||||
(and (identifier? stx)
|
||||
(free-identifier=? #'list stx)))
|
||||
|
||||
(define (hash-or-hasheqv-id? stx)
|
||||
(and (identifier? stx)
|
||||
(or (free-identifier=? #'hash stx)
|
||||
(free-identifier=? #'hasheqv stx))))
|
||||
(define (discard-id? stx) (id=? #'_ stx))
|
||||
(define (list-id? stx) (id=? #'list stx))
|
||||
(define (hash-or-hasheqv-id? stx) (or (id=? #'hash stx) (id=? #'hasheqv stx)))
|
||||
|
||||
(define (constructor-registered? stx)
|
||||
(free-id-table-ref preserves-pattern-registry stx #f))
|
||||
|
@ -129,6 +125,8 @@
|
|||
(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)))
|
||||
(let walk ((stx stx))
|
||||
(define disarmed-stx (syntax-disarm stx orig-insp))
|
||||
(syntax-case disarmed-stx ($ quasiquote unquote quote)
|
||||
|
@ -154,29 +152,25 @@
|
|||
(struct-info? (id-value #'ctor))
|
||||
(let-values (((label arity) (struct-label-and-arity #'ctor (length (syntax->list #'(piece ...))))))
|
||||
(check-destructuring
|
||||
#`(Pattern-DCompound
|
||||
(DCompound-rec (CRec '#,label #,arity)
|
||||
(hasheqv #,@(append*
|
||||
(for/list [(n (in-naturals))
|
||||
(piece (in-list (syntax->list #'(piece ...))))]
|
||||
(member-entry n piece))))))))]
|
||||
#`(make-rec-pattern '#,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)
|
||||
(check-destructuring
|
||||
#`(Pattern-DCompound
|
||||
(DCompound-arr (CArr #,(length (syntax->list #'(piece ...))))
|
||||
(hasheqv #,@(append*
|
||||
(for/list [(n (in-naturals))
|
||||
(piece (in-list (syntax->list #'(piece ...))))]
|
||||
(member-entry n piece)))))))]
|
||||
#`(make-arr-pattern #,(length (syntax->list #'(piece ...)))
|
||||
(hasheqv #,@(append*
|
||||
(for/list [(n (in-naturals))
|
||||
(piece (in-list (syntax->list #'(piece ...))))]
|
||||
(member-entry n piece))))))]
|
||||
|
||||
[(hash-stx piece ...)
|
||||
(hash-or-hasheqv-id? #'hash-stx)
|
||||
(check-destructuring
|
||||
#`(Pattern-DCompound
|
||||
(DCompound-dict (CDict)
|
||||
(hash #,@(append-map-pairs member-entry (syntax->list #'(piece ...)))))))]
|
||||
#`(make-dict-pattern (hash #,@(walk-hash #'(piece ...)))))]
|
||||
|
||||
[id
|
||||
(dollar-id? #'id)
|
||||
|
@ -192,6 +186,21 @@
|
|||
(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 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 (hash-stx piece ...))
|
||||
(and (id=? #'make-dict-pattern #'c)
|
||||
(hash-or-hasheqv-id? #'hash-stx))
|
||||
#`(make-dict-pattern* (hash-stx #,@(walk-hash #'(piece ...))))]
|
||||
|
||||
[other
|
||||
#`(Pattern-DLit (DLit #,(wrap-literal #'other)))])))
|
||||
|
||||
|
@ -237,6 +246,21 @@
|
|||
(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 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 (hash-stx piece ...))
|
||||
(and (id=? #'make-dict-pattern #'c)
|
||||
(hash-or-hasheqv-id? #'hash-stx))
|
||||
(append-map-pairs (lambda (_k v) (walk v)) (syntax->list #'(piece ...)))]
|
||||
|
||||
[other
|
||||
'()])))
|
||||
|
||||
|
|
|
@ -83,31 +83,28 @@
|
|||
[(CompoundPattern-rec label-pat fields-pat)
|
||||
(match* ((unwrap label-pat) (unwrap fields-pat))
|
||||
[((SimplePattern-lit label) (CompoundPattern-tuple field-pats))
|
||||
`(,(N 'Pattern-DCompound)
|
||||
(,(N 'DCompound-rec)
|
||||
(,(N 'CRec) ',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)))))))]
|
||||
`(: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")])]
|
||||
[(CompoundPattern-tuple pats)
|
||||
`(,(N 'Pattern-DCompound)
|
||||
(,(N 'DCompound-arr)
|
||||
(,(N 'CArr) ,(length pats))
|
||||
(hasheqv ,@(append* (for/list [(i (in-naturals))
|
||||
`(: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)))))))]
|
||||
(if (equal? s discard) `() `(,i ,p))))))]
|
||||
[(CompoundPattern-tuple* fixed-pats variable-pat)
|
||||
`#,(raise-syntax-error ',name "Variable-length array cannot be used as a pattern")]
|
||||
[(CompoundPattern-dict entries)
|
||||
`(,(N 'Pattern-DCompound)
|
||||
(,(N 'DCompound-dict)
|
||||
(,(N 'CDict))
|
||||
(hash ,@(append* (for/list [((k p) (in-hash entries))]
|
||||
(define s (pat-pattern p))
|
||||
(if (equal? s discard) `() `(',k ,s)))))))]
|
||||
`(:pat:make-dict-pattern
|
||||
(hash ,@(append* (for/list [((k p) (in-hash entries))]
|
||||
(define s (pat-pattern p))
|
||||
(if (equal? s discard) `() `(',k ,s))))))]
|
||||
[other (error 'pat-pattern "Unimplemented: ~v" other)]))
|
||||
|
||||
(define (top-pat top-name name p ty k-nonrecord)
|
||||
|
@ -150,6 +147,7 @@
|
|||
|
||||
(define exprs
|
||||
`((require (prefix-in :pat: ,ds-path))
|
||||
(require (prefix-in :pat: syndicate/smart-pattern))
|
||||
(require syndicate/pattern)
|
||||
(require (for-syntax racket/base))
|
||||
,@(map-Schema-definitions def-pattern schema)))
|
||||
|
|
|
@ -0,0 +1,99 @@
|
|||
#lang racket/base
|
||||
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
||||
;;; SPDX-FileCopyrightText: Copyright © 2021 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||
;;; Smart constructors for compound patterns.
|
||||
|
||||
(provide make-rec-pattern
|
||||
make-arr-pattern
|
||||
make-dict-pattern
|
||||
|
||||
make-rec-pattern*
|
||||
make-arr-pattern*
|
||||
make-dict-pattern*)
|
||||
|
||||
(require racket/match)
|
||||
(require preserves)
|
||||
(require syndicate/schemas/gen/dataspace-patterns)
|
||||
|
||||
(define (rec label arity pats)
|
||||
(Pattern-DCompound (DCompound-rec (CRec label arity) pats)))
|
||||
|
||||
(define (arr arity pats)
|
||||
(Pattern-DCompound (DCompound-arr (CArr arity) pats)))
|
||||
|
||||
(define (dict pats)
|
||||
(Pattern-DCompound (DCompound-dict (CDict) pats)))
|
||||
|
||||
(define (unlit? p)
|
||||
(match p
|
||||
[(Pattern-DLit (DLit _)) #t]
|
||||
[(DLit _) #t]
|
||||
[_ #f]))
|
||||
|
||||
(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)))
|
Loading…
Reference in New Issue