Split out pattern.rkt
This commit is contained in:
parent
2a218dd0a6
commit
d161d50b9a
|
@ -26,19 +26,13 @@
|
||||||
(struct-out actor-state)
|
(struct-out actor-state)
|
||||||
pretty-print-actor-state
|
pretty-print-actor-state
|
||||||
|
|
||||||
(for-syntax analyze-pattern)
|
syndicate-effects-available?
|
||||||
syndicate-actor-prompt-tag-installed?
|
|
||||||
|
|
||||||
(struct-out predicate-match)
|
|
||||||
match-value/captures
|
|
||||||
)
|
)
|
||||||
|
|
||||||
(require (for-syntax racket/base))
|
(require (for-syntax racket/base))
|
||||||
(require (for-syntax racket/sequence))
|
(require (for-syntax racket/sequence))
|
||||||
(require "support/dsl.rkt")
|
(require "support/dsl.rkt")
|
||||||
(require "support/struct.rkt")
|
|
||||||
(require "pretty.rkt")
|
(require "pretty.rkt")
|
||||||
(require "treap.rkt")
|
|
||||||
(require "effect.rkt")
|
(require "effect.rkt")
|
||||||
|
|
||||||
(define&provide-dsl-helper-syntaxes "state/until/forever form"
|
(define&provide-dsl-helper-syntaxes "state/until/forever form"
|
||||||
|
@ -60,6 +54,7 @@
|
||||||
(require (for-syntax racket/list))
|
(require (for-syntax racket/list))
|
||||||
(require (for-syntax syntax/parse))
|
(require (for-syntax syntax/parse))
|
||||||
(require (for-syntax syntax/stx))
|
(require (for-syntax syntax/stx))
|
||||||
|
(require "pattern.rkt")
|
||||||
|
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
@ -186,7 +181,7 @@
|
||||||
|
|
||||||
(define syndicate-tag (make-effect-tag 'syndicate))
|
(define syndicate-tag (make-effect-tag 'syndicate))
|
||||||
|
|
||||||
(define (syndicate-actor-prompt-tag-installed?)
|
(define (syndicate-effects-available?)
|
||||||
(effect-available? syndicate-tag))
|
(effect-available? syndicate-tag))
|
||||||
|
|
||||||
(define do! (perform syndicate-tag))
|
(define do! (perform syndicate-tag))
|
||||||
|
@ -226,62 +221,6 @@
|
||||||
(define (spawn! linkage-kind action-fn)
|
(define (spawn! linkage-kind action-fn)
|
||||||
(do! (spawn-instruction linkage-kind action-fn)))
|
(do! (spawn-instruction linkage-kind action-fn)))
|
||||||
|
|
||||||
(begin-for-syntax
|
|
||||||
(define-splicing-syntax-class name
|
|
||||||
(pattern (~seq #:name N))
|
|
||||||
(pattern (~seq) #:attr N #'#f))
|
|
||||||
|
|
||||||
(define-splicing-syntax-class init
|
|
||||||
(pattern (~seq #:init [I ...]))
|
|
||||||
(pattern (~seq) #:attr [I 1] '()))
|
|
||||||
|
|
||||||
(define-splicing-syntax-class done
|
|
||||||
(pattern (~seq #:done [I ...]))
|
|
||||||
(pattern (~seq) #:attr [I 1] '()))
|
|
||||||
|
|
||||||
(define-splicing-syntax-class bindings
|
|
||||||
(pattern (~seq #:collect [(id init) ...]))
|
|
||||||
(pattern (~seq) #:attr [id 1] '() #:attr [init 1] '())))
|
|
||||||
|
|
||||||
;; Syntax for spawning a 'call-linked actor.
|
|
||||||
(define-syntax (state stx)
|
|
||||||
(syntax-parse stx
|
|
||||||
[(_ init:init [bs:bindings O ...] [E Oe ...] ...)
|
|
||||||
(expand-state #'#f 'call #'(init.I ...) #'(bs.id ...) #'(bs.init ...) #'(O ...) #'([E Oe ...] ...))]))
|
|
||||||
|
|
||||||
;; Sugar
|
|
||||||
(define-syntax (until stx)
|
|
||||||
(syntax-parse stx
|
|
||||||
[(_ E init:init done:done bs:bindings O ...)
|
|
||||||
#'(state #:init [init.I ...] [#:collect [(bs.id bs.init) ...] O ...] [E done.I ... (values)])]))
|
|
||||||
|
|
||||||
;; Sugar
|
|
||||||
(define-syntax (forever stx)
|
|
||||||
(syntax-parse stx
|
|
||||||
[(_ init:init bs:bindings O ...)
|
|
||||||
#'(state #:init [init.I ...] [#:collect [(bs.id bs.init) ...] O ...])]))
|
|
||||||
|
|
||||||
;; Spawn actors with 'actor linkage
|
|
||||||
(define-syntax (actor stx)
|
|
||||||
(syntax-parse stx
|
|
||||||
[(_ name:name I ...)
|
|
||||||
(expand-state #'name.N 'actor #'(I ... (return/no-link-result!)) #'() #'() #'() #'())]))
|
|
||||||
|
|
||||||
;; Spawn whole dataspaces
|
|
||||||
(define-syntax (dataspace stx)
|
|
||||||
(syntax-parse stx
|
|
||||||
[(_ I ...)
|
|
||||||
(expand-state #'#f
|
|
||||||
'dataspace
|
|
||||||
#'(I
|
|
||||||
...
|
|
||||||
(perform-core-action! (quit-dataspace))
|
|
||||||
(return/no-link-result!))
|
|
||||||
#'()
|
|
||||||
#'()
|
|
||||||
#'()
|
|
||||||
#'())]))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Main behavior of HLL actors
|
;; Main behavior of HLL actors
|
||||||
|
|
||||||
|
@ -454,14 +393,70 @@
|
||||||
;; TODO: some better means of keeping track of nested dataspace levels
|
;; TODO: some better means of keeping track of nested dataspace levels
|
||||||
|
|
||||||
(begin-for-syntax
|
(begin-for-syntax
|
||||||
|
(define-splicing-syntax-class name
|
||||||
|
(pattern (~seq #:name N))
|
||||||
|
(pattern (~seq) #:attr N #'#f))
|
||||||
|
|
||||||
|
(define-splicing-syntax-class init
|
||||||
|
(pattern (~seq #:init [I ...]))
|
||||||
|
(pattern (~seq) #:attr [I 1] '()))
|
||||||
|
|
||||||
|
(define-splicing-syntax-class done
|
||||||
|
(pattern (~seq #:done [I ...]))
|
||||||
|
(pattern (~seq) #:attr [I 1] '()))
|
||||||
|
|
||||||
|
(define-splicing-syntax-class bindings
|
||||||
|
(pattern (~seq #:collect [(id init) ...]))
|
||||||
|
(pattern (~seq) #:attr [id 1] '() #:attr [init 1] '()))
|
||||||
|
|
||||||
(define-splicing-syntax-class when-pred
|
(define-splicing-syntax-class when-pred
|
||||||
(pattern (~seq #:when Pred))
|
(pattern (~seq #:when Pred))
|
||||||
(pattern (~seq) #:attr Pred #'#t))
|
(pattern (~seq) #:attr Pred #'#t))
|
||||||
|
|
||||||
(define-splicing-syntax-class meta-level
|
(define-splicing-syntax-class meta-level
|
||||||
(pattern (~seq #:meta-level level:integer))
|
(pattern (~seq #:meta-level level:integer))
|
||||||
(pattern (~seq) #:attr level #'0))
|
(pattern (~seq) #:attr level #'0)))
|
||||||
|
|
||||||
|
;; Syntax for spawning a 'call-linked actor.
|
||||||
|
(define-syntax (state stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ init:init [bs:bindings O ...] [E Oe ...] ...)
|
||||||
|
(expand-state #'#f 'call #'(init.I ...) #'(bs.id ...) #'(bs.init ...) #'(O ...) #'([E Oe ...] ...))]))
|
||||||
|
|
||||||
|
;; Sugar
|
||||||
|
(define-syntax (until stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ E init:init done:done bs:bindings O ...)
|
||||||
|
#'(state #:init [init.I ...] [#:collect [(bs.id bs.init) ...] O ...] [E done.I ... (values)])]))
|
||||||
|
|
||||||
|
;; Sugar
|
||||||
|
(define-syntax (forever stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ init:init bs:bindings O ...)
|
||||||
|
#'(state #:init [init.I ...] [#:collect [(bs.id bs.init) ...] O ...])]))
|
||||||
|
|
||||||
|
;; Spawn actors with 'actor linkage
|
||||||
|
(define-syntax (actor stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ name:name I ...)
|
||||||
|
(expand-state #'name.N 'actor #'(I ... (return/no-link-result!)) #'() #'() #'() #'())]))
|
||||||
|
|
||||||
|
;; Spawn whole dataspaces
|
||||||
|
(define-syntax (dataspace stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ I ...)
|
||||||
|
(expand-state #'#f
|
||||||
|
'dataspace
|
||||||
|
#'(I
|
||||||
|
...
|
||||||
|
(perform-core-action! (quit-dataspace))
|
||||||
|
(return/no-link-result!))
|
||||||
|
#'()
|
||||||
|
#'()
|
||||||
|
#'()
|
||||||
|
#'())]))
|
||||||
|
|
||||||
|
(begin-for-syntax
|
||||||
(define (expand-state name-exp linkage-kind init-actions binding-names binding-inits ongoings edges)
|
(define (expand-state name-exp linkage-kind init-actions binding-names binding-inits ongoings edges)
|
||||||
;; ----------------------------------------
|
;; ----------------------------------------
|
||||||
(define binding-count (length (syntax->list binding-names)))
|
(define binding-count (length (syntax->list binding-names)))
|
||||||
|
@ -764,7 +759,7 @@
|
||||||
;; (pretty-print (syntax->datum action-fn-stx))
|
;; (pretty-print (syntax->datum action-fn-stx))
|
||||||
|
|
||||||
#`(let ((do-spawn (lambda () (spawn! '#,linkage-kind #,action-fn-stx))))
|
#`(let ((do-spawn (lambda () (spawn! '#,linkage-kind #,action-fn-stx))))
|
||||||
(if (syndicate-actor-prompt-tag-installed?)
|
(if (syndicate-effects-available?)
|
||||||
(do-spawn)
|
(do-spawn)
|
||||||
(actor-body->spawn-action do-spawn))))
|
(actor-body->spawn-action do-spawn))))
|
||||||
)
|
)
|
||||||
|
@ -814,140 +809,6 @@
|
||||||
;; (reverse currs-rev)
|
;; (reverse currs-rev)
|
||||||
;; (reverse nexts-rev)))
|
;; (reverse nexts-rev)))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; HLL pattern analysis
|
|
||||||
|
|
||||||
(begin-for-syntax
|
|
||||||
(define (dollar-id? stx)
|
|
||||||
(and (identifier? stx)
|
|
||||||
(char=? (string-ref (symbol->string (syntax-e stx)) 0) #\$)))
|
|
||||||
|
|
||||||
(define (undollar stx)
|
|
||||||
(and (dollar-id? stx)
|
|
||||||
(datum->syntax stx (string->symbol (substring (symbol->string (syntax-e stx)) 1)))))
|
|
||||||
|
|
||||||
;; Syntax -> (Values Projection AssertionSetPattern (ListOf Identifier) Syntax)
|
|
||||||
(define (analyze-pattern outer-expr-stx pat-stx0)
|
|
||||||
(let walk ((pat-stx pat-stx0))
|
|
||||||
(syntax-case pat-stx ($ ? quasiquote unquote quote)
|
|
||||||
;; Extremely limited support for quasiquoting and quoting
|
|
||||||
[(quasiquote (unquote p)) (walk #'p)]
|
|
||||||
[(quasiquote (p ...)) (walk #'(list (quasiquote p) ...))]
|
|
||||||
[(quasiquote p) (values #''p #''p '() #''p)]
|
|
||||||
[(quote p) (values #''p #''p '() #''p)]
|
|
||||||
|
|
||||||
[$v
|
|
||||||
(dollar-id? #'$v)
|
|
||||||
(with-syntax [(v (undollar #'$v))]
|
|
||||||
(values #'(?!)
|
|
||||||
#'?
|
|
||||||
(list #'v)
|
|
||||||
#'v))]
|
|
||||||
|
|
||||||
[($ v p)
|
|
||||||
(let ()
|
|
||||||
(define-values (pr g bs _ins) (walk #'p))
|
|
||||||
(when (not (null? bs))
|
|
||||||
(raise-syntax-error #f "nested bindings not supported" outer-expr-stx pat-stx))
|
|
||||||
(values #`(?! #,pr)
|
|
||||||
g
|
|
||||||
(list #'v)
|
|
||||||
#'v))]
|
|
||||||
|
|
||||||
[(? pred? p)
|
|
||||||
;; TODO: support pred? in asserted/retracted as well as message events
|
|
||||||
(let ()
|
|
||||||
(syntax-parse outer-expr-stx
|
|
||||||
#:literals [message]
|
|
||||||
[(message _ ...) 'ok]
|
|
||||||
[_ (raise-syntax-error #f
|
|
||||||
"Predicate '?' matching only supported in message events"
|
|
||||||
outer-expr-stx
|
|
||||||
pat-stx)])
|
|
||||||
(define-values (pr g bs ins) (walk #'p))
|
|
||||||
(values #`(predicate-match pred? #,pr)
|
|
||||||
g
|
|
||||||
bs
|
|
||||||
ins))]
|
|
||||||
|
|
||||||
[(ctor p ...)
|
|
||||||
(let ()
|
|
||||||
(define parts (if (identifier? #'ctor) #'(p ...) #'(ctor p ...)))
|
|
||||||
(define-values (pr g bs ins)
|
|
||||||
(for/fold [(pr '()) (g '()) (bs '()) (ins '())] [(p (syntax->list parts))]
|
|
||||||
(define-values (pr1 g1 bs1 ins1) (walk p))
|
|
||||||
(values (cons pr1 pr)
|
|
||||||
(cons g1 g)
|
|
||||||
(append bs bs1)
|
|
||||||
(cons ins1 ins))))
|
|
||||||
(if (identifier? #'ctor)
|
|
||||||
(values (cons #'ctor (reverse pr))
|
|
||||||
(cons #'ctor (reverse g))
|
|
||||||
bs
|
|
||||||
(cons #'ctor (reverse ins)))
|
|
||||||
(values (reverse pr)
|
|
||||||
(reverse g)
|
|
||||||
bs
|
|
||||||
(reverse ins))))]
|
|
||||||
|
|
||||||
[?
|
|
||||||
(raise-syntax-error #f
|
|
||||||
"Invalid use of '?' in pattern; use '_' instead"
|
|
||||||
outer-expr-stx
|
|
||||||
pat-stx)]
|
|
||||||
|
|
||||||
[non-pair
|
|
||||||
(if (and (identifier? #'non-pair)
|
|
||||||
(free-identifier=? #'non-pair #'_))
|
|
||||||
(values #'?
|
|
||||||
#'?
|
|
||||||
'()
|
|
||||||
#'_)
|
|
||||||
(values #'non-pair
|
|
||||||
#'non-pair
|
|
||||||
'()
|
|
||||||
#'non-pair))])))
|
|
||||||
|
|
||||||
)
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(struct predicate-match (predicate sub-pattern) #:transparent)
|
|
||||||
|
|
||||||
;; Value Projection -> (Option (Listof Value))
|
|
||||||
;; Match a single value against a projection, returning a list of
|
|
||||||
;; captured values.
|
|
||||||
(define (match-value/captures v p)
|
|
||||||
(define captures-rev
|
|
||||||
(let walk ((v v) (p p) (captures-rev '()))
|
|
||||||
(match* (v p)
|
|
||||||
[(_ (capture sub))
|
|
||||||
(match (walk v sub '())
|
|
||||||
[#f #f]
|
|
||||||
['() (cons v captures-rev)]
|
|
||||||
[_ (error 'match-value/captures "Bindings in capture sub-patterns not supported")])]
|
|
||||||
[(_ (predicate-match pred? sub)) #:when (pred? v)
|
|
||||||
(walk v sub captures-rev)]
|
|
||||||
[(_ (== ?))
|
|
||||||
captures-rev]
|
|
||||||
[((cons v1 v2) (cons p1 p2))
|
|
||||||
(match (walk v1 p1 captures-rev)
|
|
||||||
[#f #f]
|
|
||||||
[c (walk v2 p2 c)])]
|
|
||||||
[((? vector? v) (? vector? p)) #:when (= (vector-length v) (vector-length p))
|
|
||||||
(for/fold [(c captures-rev)] [(vv (in-vector v)) (pp (in-vector p))]
|
|
||||||
(walk vv pp c))]
|
|
||||||
[(_ _) #:when (or (treap? v) (treap? p))
|
|
||||||
(error 'match-value/captures "Cannot match on treaps at present")]
|
|
||||||
[((? non-object-struct?) (? non-object-struct?))
|
|
||||||
#:when (eq? (struct->struct-type v) (struct->struct-type p))
|
|
||||||
(walk (struct->vector v) (struct->vector p) captures-rev)]
|
|
||||||
[(_ _) #:when (equal? v p)
|
|
||||||
captures-rev]
|
|
||||||
[(_ _)
|
|
||||||
#f])))
|
|
||||||
(and captures-rev (reverse captures-rev)))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define (pretty-print-actor-state s [p (current-output-port)])
|
(define (pretty-print-actor-state s [p (current-output-port)])
|
||||||
|
@ -990,46 +851,3 @@
|
||||||
(fprintf p " - ")
|
(fprintf p " - ")
|
||||||
(display (indented-port-output 3 (lambda (p) (syndicate-pretty-print mux p)) #:first-line? #f) p)
|
(display (indented-port-output 3 (lambda (p) (syndicate-pretty-print mux p)) #:first-line? #f) p)
|
||||||
(newline p))
|
(newline p))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
|
|
||||||
(module+ test
|
|
||||||
(require rackunit)
|
|
||||||
|
|
||||||
(check-equal? (match-value/captures (list 1 2 3)
|
|
||||||
(list 1 2 3))
|
|
||||||
'())
|
|
||||||
(check-equal? (match-value/captures (list 1 2 3)
|
|
||||||
(list 1 22 3))
|
|
||||||
#f)
|
|
||||||
(check-equal? (match-value/captures (list 1 2 3)
|
|
||||||
(list (?!) (?!) (?!)))
|
|
||||||
(list 1 2 3))
|
|
||||||
(check-equal? (match-value/captures (list 1 2 3)
|
|
||||||
(list (?!) 2 (?!)))
|
|
||||||
(list 1 3))
|
|
||||||
(check-equal? (match-value/captures (list 1 2 3)
|
|
||||||
(list (?!) ? (?!)))
|
|
||||||
(list 1 3))
|
|
||||||
(check-equal? (match-value/captures (list 1 2 3)
|
|
||||||
(list (?!) (?! 2) (?!)))
|
|
||||||
(list 1 2 3))
|
|
||||||
(check-equal? (match-value/captures (list 1 2 3)
|
|
||||||
(list (?!) (?! 22) (?!)))
|
|
||||||
#f)
|
|
||||||
|
|
||||||
(struct x (a b) #:prefab)
|
|
||||||
(struct y (z w) #:prefab)
|
|
||||||
|
|
||||||
(check-equal? (match-value/captures (x 1 2) (x 1 2)) '())
|
|
||||||
(check-equal? (match-value/captures (x 1 22) (x 1 2)) #f)
|
|
||||||
(check-equal? (match-value/captures (x 1 2) (x 1 22)) #f)
|
|
||||||
(check-equal? (match-value/captures (x 1 2) (?! (x ? ?))) (list (x 1 2)))
|
|
||||||
(check-equal? (match-value/captures (x 1 2) (?! (x ? 2))) (list (x 1 2)))
|
|
||||||
(check-equal? (match-value/captures (x 1 2) (?! (x ? 22))) #f)
|
|
||||||
|
|
||||||
(check-equal? (match-value/captures 123 (predicate-match even? ?)) #f)
|
|
||||||
(check-equal? (match-value/captures 124 (predicate-match even? ?)) '())
|
|
||||||
(check-equal? (match-value/captures (list 123) (list (predicate-match even? ?))) #f)
|
|
||||||
(check-equal? (match-value/captures (list 124) (list (predicate-match even? ?))) '())
|
|
||||||
(check-equal? (match-value/captures (list 124) (?! (list (predicate-match even? ?)))) '((124))))
|
|
||||||
|
|
|
@ -7,7 +7,7 @@
|
||||||
for-trie)
|
for-trie)
|
||||||
|
|
||||||
(require "core.rkt"
|
(require "core.rkt"
|
||||||
(only-in "actor.rkt" analyze-pattern)
|
"pattern.rkt"
|
||||||
(for-syntax racket/syntax)
|
(for-syntax racket/syntax)
|
||||||
(for-syntax syntax/strip-context)
|
(for-syntax syntax/strip-context)
|
||||||
(for-syntax racket/match))
|
(for-syntax racket/match))
|
||||||
|
|
|
@ -0,0 +1,190 @@
|
||||||
|
#lang racket/base
|
||||||
|
;; HLL pattern analysis & processing
|
||||||
|
|
||||||
|
(provide (for-syntax analyze-pattern)
|
||||||
|
(struct-out predicate-match)
|
||||||
|
match-value/captures
|
||||||
|
)
|
||||||
|
|
||||||
|
(require (for-syntax racket/base))
|
||||||
|
(require (for-syntax racket/match))
|
||||||
|
(require (for-syntax syntax/parse))
|
||||||
|
|
||||||
|
(require racket/match)
|
||||||
|
(require "support/struct.rkt")
|
||||||
|
(require "treap.rkt")
|
||||||
|
(require "core.rkt")
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(struct predicate-match (predicate sub-pattern) #:transparent)
|
||||||
|
|
||||||
|
;; Value Projection -> (Option (Listof Value))
|
||||||
|
;; Match a single value against a projection, returning a list of
|
||||||
|
;; captured values.
|
||||||
|
(define (match-value/captures v p)
|
||||||
|
(define captures-rev
|
||||||
|
(let walk ((v v) (p p) (captures-rev '()))
|
||||||
|
(match* (v p)
|
||||||
|
[(_ (capture sub))
|
||||||
|
(match (walk v sub '())
|
||||||
|
[#f #f]
|
||||||
|
['() (cons v captures-rev)]
|
||||||
|
[_ (error 'match-value/captures "Bindings in capture sub-patterns not supported")])]
|
||||||
|
[(_ (predicate-match pred? sub)) #:when (pred? v)
|
||||||
|
(walk v sub captures-rev)]
|
||||||
|
[(_ (== ?))
|
||||||
|
captures-rev]
|
||||||
|
[((cons v1 v2) (cons p1 p2))
|
||||||
|
(match (walk v1 p1 captures-rev)
|
||||||
|
[#f #f]
|
||||||
|
[c (walk v2 p2 c)])]
|
||||||
|
[((? vector? v) (? vector? p)) #:when (= (vector-length v) (vector-length p))
|
||||||
|
(for/fold [(c captures-rev)] [(vv (in-vector v)) (pp (in-vector p))]
|
||||||
|
(walk vv pp c))]
|
||||||
|
[(_ _) #:when (or (treap? v) (treap? p))
|
||||||
|
(error 'match-value/captures "Cannot match on treaps at present")]
|
||||||
|
[((? non-object-struct?) (? non-object-struct?))
|
||||||
|
#:when (eq? (struct->struct-type v) (struct->struct-type p))
|
||||||
|
(walk (struct->vector v) (struct->vector p) captures-rev)]
|
||||||
|
[(_ _) #:when (equal? v p)
|
||||||
|
captures-rev]
|
||||||
|
[(_ _)
|
||||||
|
#f])))
|
||||||
|
(and captures-rev (reverse captures-rev)))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(begin-for-syntax
|
||||||
|
(define (dollar-id? stx)
|
||||||
|
(and (identifier? stx)
|
||||||
|
(char=? (string-ref (symbol->string (syntax-e stx)) 0) #\$)))
|
||||||
|
|
||||||
|
(define (undollar stx)
|
||||||
|
(and (dollar-id? stx)
|
||||||
|
(datum->syntax stx (string->symbol (substring (symbol->string (syntax-e stx)) 1)))))
|
||||||
|
|
||||||
|
;; Syntax -> (Values Projection AssertionSetPattern (ListOf Identifier) Syntax)
|
||||||
|
(define (analyze-pattern outer-expr-stx pat-stx0)
|
||||||
|
(let walk ((pat-stx pat-stx0))
|
||||||
|
(syntax-case pat-stx ($ ? quasiquote unquote quote)
|
||||||
|
;; Extremely limited support for quasiquoting and quoting
|
||||||
|
[(quasiquote (unquote p)) (walk #'p)]
|
||||||
|
[(quasiquote (p ...)) (walk #'(list (quasiquote p) ...))]
|
||||||
|
[(quasiquote p) (values #''p #''p '() #''p)]
|
||||||
|
[(quote p) (values #''p #''p '() #''p)]
|
||||||
|
|
||||||
|
[$v
|
||||||
|
(dollar-id? #'$v)
|
||||||
|
(with-syntax [(v (undollar #'$v))]
|
||||||
|
(values #'(?!)
|
||||||
|
#'?
|
||||||
|
(list #'v)
|
||||||
|
#'v))]
|
||||||
|
|
||||||
|
[($ v p)
|
||||||
|
(let ()
|
||||||
|
(define-values (pr g bs _ins) (walk #'p))
|
||||||
|
(when (not (null? bs))
|
||||||
|
(raise-syntax-error #f "nested bindings not supported" outer-expr-stx pat-stx))
|
||||||
|
(values #`(?! #,pr)
|
||||||
|
g
|
||||||
|
(list #'v)
|
||||||
|
#'v))]
|
||||||
|
|
||||||
|
[(? pred? p)
|
||||||
|
;; TODO: support pred? in asserted/retracted as well as message events
|
||||||
|
(let ()
|
||||||
|
(syntax-parse outer-expr-stx
|
||||||
|
#:literals [message]
|
||||||
|
[(message _ ...) 'ok]
|
||||||
|
[_ (raise-syntax-error #f
|
||||||
|
"Predicate '?' matching only supported in message events"
|
||||||
|
outer-expr-stx
|
||||||
|
pat-stx)])
|
||||||
|
(define-values (pr g bs ins) (walk #'p))
|
||||||
|
(values #`(predicate-match pred? #,pr)
|
||||||
|
g
|
||||||
|
bs
|
||||||
|
ins))]
|
||||||
|
|
||||||
|
[(ctor p ...)
|
||||||
|
(let ()
|
||||||
|
(define parts (if (identifier? #'ctor) #'(p ...) #'(ctor p ...)))
|
||||||
|
(define-values (pr g bs ins)
|
||||||
|
(for/fold [(pr '()) (g '()) (bs '()) (ins '())] [(p (syntax->list parts))]
|
||||||
|
(define-values (pr1 g1 bs1 ins1) (walk p))
|
||||||
|
(values (cons pr1 pr)
|
||||||
|
(cons g1 g)
|
||||||
|
(append bs bs1)
|
||||||
|
(cons ins1 ins))))
|
||||||
|
(if (identifier? #'ctor)
|
||||||
|
(values (cons #'ctor (reverse pr))
|
||||||
|
(cons #'ctor (reverse g))
|
||||||
|
bs
|
||||||
|
(cons #'ctor (reverse ins)))
|
||||||
|
(values (reverse pr)
|
||||||
|
(reverse g)
|
||||||
|
bs
|
||||||
|
(reverse ins))))]
|
||||||
|
|
||||||
|
[?
|
||||||
|
(raise-syntax-error #f
|
||||||
|
"Invalid use of '?' in pattern; use '_' instead"
|
||||||
|
outer-expr-stx
|
||||||
|
pat-stx)]
|
||||||
|
|
||||||
|
[non-pair
|
||||||
|
(if (and (identifier? #'non-pair)
|
||||||
|
(free-identifier=? #'non-pair #'_))
|
||||||
|
(values #'?
|
||||||
|
#'?
|
||||||
|
'()
|
||||||
|
#'_)
|
||||||
|
(values #'non-pair
|
||||||
|
#'non-pair
|
||||||
|
'()
|
||||||
|
#'non-pair))]))))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(require rackunit)
|
||||||
|
|
||||||
|
(check-equal? (match-value/captures (list 1 2 3)
|
||||||
|
(list 1 2 3))
|
||||||
|
'())
|
||||||
|
(check-equal? (match-value/captures (list 1 2 3)
|
||||||
|
(list 1 22 3))
|
||||||
|
#f)
|
||||||
|
(check-equal? (match-value/captures (list 1 2 3)
|
||||||
|
(list (?!) (?!) (?!)))
|
||||||
|
(list 1 2 3))
|
||||||
|
(check-equal? (match-value/captures (list 1 2 3)
|
||||||
|
(list (?!) 2 (?!)))
|
||||||
|
(list 1 3))
|
||||||
|
(check-equal? (match-value/captures (list 1 2 3)
|
||||||
|
(list (?!) ? (?!)))
|
||||||
|
(list 1 3))
|
||||||
|
(check-equal? (match-value/captures (list 1 2 3)
|
||||||
|
(list (?!) (?! 2) (?!)))
|
||||||
|
(list 1 2 3))
|
||||||
|
(check-equal? (match-value/captures (list 1 2 3)
|
||||||
|
(list (?!) (?! 22) (?!)))
|
||||||
|
#f)
|
||||||
|
|
||||||
|
(struct x (a b) #:prefab)
|
||||||
|
(struct y (z w) #:prefab)
|
||||||
|
|
||||||
|
(check-equal? (match-value/captures (x 1 2) (x 1 2)) '())
|
||||||
|
(check-equal? (match-value/captures (x 1 22) (x 1 2)) #f)
|
||||||
|
(check-equal? (match-value/captures (x 1 2) (x 1 22)) #f)
|
||||||
|
(check-equal? (match-value/captures (x 1 2) (?! (x ? ?))) (list (x 1 2)))
|
||||||
|
(check-equal? (match-value/captures (x 1 2) (?! (x ? 2))) (list (x 1 2)))
|
||||||
|
(check-equal? (match-value/captures (x 1 2) (?! (x ? 22))) #f)
|
||||||
|
|
||||||
|
(check-equal? (match-value/captures 123 (predicate-match even? ?)) #f)
|
||||||
|
(check-equal? (match-value/captures 124 (predicate-match even? ?)) '())
|
||||||
|
(check-equal? (match-value/captures (list 123) (list (predicate-match even? ?))) #f)
|
||||||
|
(check-equal? (match-value/captures (list 124) (list (predicate-match even? ?))) '())
|
||||||
|
(check-equal? (match-value/captures (list 124) (?! (list (predicate-match even? ?)))) '((124))))
|
Loading…
Reference in New Issue