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:
Tony Garnock-Jones 2021-06-18 17:02:56 +02:00
parent 8b1d3a5e3f
commit 20eeb6cd55
4 changed files with 164 additions and 65 deletions

View File

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

View File

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

View File

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

View File

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