syndicate-lang
/
minimart-2014
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Make captures able to express and-patterns.

This commit is contained in:
Tony Garnock-Jones 2014-05-21 20:54:36 -04:00
parent 3bd9b338b5
commit 6649689b8f
3 changed files with 150 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
minimart/core.rkt
View File

@ -18,7 +18,7 @@
? ?
wildcard? wildcard?
?! ?!
capture? (struct-out capture)
pretty-print-matcher pretty-print-matcher
matcher-key-set matcher-key-set

2
minimart/ground.rkt
View File

@ -14,7 +14,7 @@
(define (event-handler descriptor) (define (event-handler descriptor)
(handle-evt descriptor (lambda vs (send (event descriptor vs))))) (handle-evt descriptor (lambda vs (send (event descriptor vs)))))
(define event-projection (compile-gestalt-projection (event ?! ?))) (define event-projection (compile-gestalt-projection (event (?!) ?)))
(define (extract-active-events gestalt) (define (extract-active-events gestalt)
(define es (matcher-key-set (gestalt-project gestalt 0 0 #f event-projection))) (define es (matcher-key-set (gestalt-project gestalt 0 0 #f event-projection)))

217
minimart/route.rkt
View File

@ -10,7 +10,7 @@
(provide ? (provide ?
wildcard? wildcard?
?! ?!
capture? (struct-out capture)
pattern->matcher pattern->matcher
matcher? ;; expensive; see implementation matcher? ;; expensive; see implementation
matcher-empty matcher-empty
@ -54,7 +54,15 @@
(define-singleton-struct ? wildcard "★") ;; alternative printing: ¿ (define-singleton-struct ? wildcard "★") ;; alternative printing: ¿
;; When projecting a matcher, the capturing wildcard can be used. ;; When projecting a matcher, the capturing wildcard can be used.
(define-singleton-struct ?! capture "‽") (struct capture (pattern) #:transparent)
;; Capture with default of wildcard.
(define (?! [pattern ?]) (capture pattern))
;; Compiled projections include start-of-capture and end-of-capture
;; elements.
(define-singleton-struct SOC start-of-capture "{{")
(define-singleton-struct EOC end-of-capture "}}")
;; A Matcher is either ;; A Matcher is either
;; - #f, indicating no further matches possible ;; - #f, indicating no further matches possible
@ -408,7 +416,7 @@
;; is how ?! is treated. ;; is how ?! is treated.
(let walk ((p p) (acc (cons EOS '()))) (let walk ((p p) (acc (cons EOS '())))
(match p (match p
[(== ?!) (cons ?! acc)] [(capture sub) (cons SOC (walk sub (cons EOC acc)))] ;; TODO: enforce non-nesting here
[(== ?) (cons ? acc)] [(== ?) (cons ? acc)]
[(cons p1 p2) (cons SOP (walk p1 (walk p2 (cons EOS acc))))] [(cons p1 p2) (cons SOP (walk p1 (walk p2 (cons EOS acc))))]
[(? vector? v) (cons SOV (vector-foldr walk (cons EOS acc) v))] [(? vector? v) (cons SOV (vector-foldr walk (cons EOS acc) v))]
@ -425,82 +433,94 @@
;; The result matches a vector of length equal to the number of captures. ;; The result matches a vector of length equal to the number of captures.
;; The project-success function should return #f to signal "no success values". ;; The project-success function should return #f to signal "no success values".
(define matcher-project (define matcher-project
;; TODO: skip-nested, capture-nested, and the ? and ?! cases in ;; TODO: skip-nested, capture-nested, and various cases in walk all
;; walk-out all share a suspicious amount of code. Refactor it away. ;; share a suspicious amount of code. Refactor it away.
(let () (let ()
(define (skip-nested m k) (define (skip-nested m k)
(match m (match m
[(wildcard-sequence mk) (k mk)] [(wildcard-sequence mk) (k mk)]
[(? hash?) [(? hash?)
(for/fold [(acc (skip-nested (rlookup m ?) k))] [((key mk) (in-hash m))] (for/fold [(acc (skip-nested (rlookup m ?) k))] [((key mk) (in-hash m))]
(if (eq? key ?) (if (eq? key ?)
acc acc
(matcher-union acc (cond (matcher-union acc (cond
[(key-open? key) (skip-nested mk (lambda (mk) (skip-nested mk k)))] [(key-open? key)
[(key-close? key) (k mk)] (skip-nested mk (lambda (mk) (skip-nested mk k)))]
[else (skip-nested mk k)]))))] [(key-close? key) (k mk)]
[_ (matcher-empty)])) [else (skip-nested mk k)]))))]
[_ (matcher-empty)]))
(define (capture-nested m k) (define (capture-nested m k)
(match m (match m
[(wildcard-sequence mk) (rwildseq (k mk))] [(wildcard-sequence mk) (rwildseq (k mk))]
[(? hash?) [(? hash?)
(for/fold [(acc (rwild (capture-nested (rlookup m ?) k)))] [((key mk) (in-hash m))] (for/fold [(acc (rwild (capture-nested (rlookup m ?) k)))] [((key mk) (in-hash m))]
(if (eq? key ?) (if (eq? key ?)
acc acc
(cond (cond
[(key-open? key) [(key-open? key)
(rupdate acc key (capture-nested mk (lambda (mk) (capture-nested mk k))))] (rupdate acc key (capture-nested mk (lambda (mk) (capture-nested mk k))))]
[(key-close? key) (rupdate acc key (k mk))] [(key-close? key) (rupdate acc key (k mk))]
[else (rupdate acc key (capture-nested mk k))])))] [else (rupdate acc key (capture-nested mk k))])))]
[_ (matcher-empty)])) [_ (matcher-empty)]))
(lambda (m spec #:project-success [project-success values]) (lambda (m spec #:project-success [project-success values])
(define (walk-out m spec) (define (walk capturing? m spec)
(match spec (match spec
['() ['()
(when capturing? (error 'matcher-project "Bad specification: unclosed capture"))
(match m (match m
[(success v) (rseq EOS (rseq EOS (rsuccess (project-success v))))] [(success v) (rseq EOS (rseq EOS (rsuccess (project-success v))))]
[_ (matcher-empty)])] [_ (matcher-empty)])]
[(cons (== EOC) k)
(when (not capturing?) (error 'matcher-project "Bad specification: unexpected EOC"))
(walk #f m k)]
[(cons (== SOC) k)
(when capturing? (error 'matcher-project "Bad specification: nested capture"))
(walk #t m k)]
[(cons (== ?) k) [(cons (== ?) k)
(match m (match m
[(wildcard-sequence _) (walk-out m k)] [(wildcard-sequence _)
((if capturing? rwild values) (walk capturing? m k))]
[(? hash?) [(? hash?)
(for/fold [(acc (walk-out (rlookup m ?) k))] [((key mk) (in-hash m))] (if capturing?
(if (eq? key ?) (for/fold [(acc (rwild (walk capturing? (rlookup m ?) k)))]
acc [((key mk) (in-hash m))]
(matcher-union acc (cond (if (eq? key ?)
[(key-open? key) (skip-nested mk (lambda (mk) (walk-out mk k)))] acc
[(key-close? key) #f] (cond
[else (walk-out mk k)]))))] [(key-open? key)
[_ (matcher-empty)])] (rupdate acc key (capture-nested mk (lambda (mk)
(walk capturing? mk k))))]
[(cons (== ?!) k) [(key-close? key) acc]
(match m [else (rupdate acc key (walk capturing? mk k))])))
[(wildcard-sequence _) (rwild (walk-out m k))] (for/fold [(acc (walk capturing? (rlookup m ?) k))] [((key mk) (in-hash m))]
[(? hash?) (if (eq? key ?)
(for/fold [(acc (rwild (walk-out (rlookup m ?) k)))] [((key mk) (in-hash m))] acc
(if (eq? key ?) (matcher-union acc (cond
acc [(key-open? key)
(cond (skip-nested mk (lambda (mk) (walk capturing? mk k)))]
[(key-open? key) [(key-close? key) #f]
(rupdate acc key (capture-nested mk (lambda (mk) (walk-out mk k))))] [else (walk capturing? mk k)])))))]
[(key-close? key) acc]
[else (rupdate acc key (walk-out mk k))])))]
[_ (matcher-empty)])] [_ (matcher-empty)])]
[(cons sigma k) [(cons sigma k)
(match m ((if capturing?
[(wildcard-sequence mk) (lambda (m1) (rseq sigma m1))
(if (key-close? sigma) values)
(walk-out mk k) (match m
(walk-out m k))] [(wildcard-sequence mk)
[(? hash?) (if (key-close? sigma)
(matcher-union (walk-out (rlookup m sigma) k) (walk capturing? mk k)
(walk-out (rlookup m ?) k))] (walk capturing? m k))]
[_ (matcher-empty)])])) [(? hash?)
(rseq SOV (walk-out m spec))))) (matcher-union (walk capturing? (rlookup m sigma) k)
(walk capturing? (rlookup m ?) k))]
[_ (matcher-empty)]))]))
(rseq SOV (walk #f m spec)))))
;; Matcher → (Option (Setof Value)) ;; Matcher → (Option (Setof Value))
;; Multiplies out unions. Returns #f if any dimension of m is infinite. ;; Multiplies out unions. Returns #f if any dimension of m is infinite.
@ -955,26 +975,26 @@
(module+ test (module+ test
(check-equal? (compile-projection (list 'a 'b)) (check-equal? (compile-projection (list 'a 'b))
(list SOP 'a SOP 'b '() EOS EOS EOS)) (list SOP 'a SOP 'b '() EOS EOS EOS))
(check-equal? (compile-projection (list 'a ?!)) (check-equal? (compile-projection (list 'a (?!)))
(list SOP 'a SOP ?! '() EOS EOS EOS)) (list SOP 'a SOP SOC ? EOC '() EOS EOS EOS))
(check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher SB (list 'a 'b))) (pattern->matcher SB (list 'a 'b)))
(compile-projection (list 'a ?!)) (compile-projection (list 'a (?!)))
#:project-success (lambda (v) #t)) #:project-success (lambda (v) #t))
(matcher-union (pattern->matcher #t (vector 'a)) (matcher-union (pattern->matcher #t (vector 'a))
(pattern->matcher #t (vector 'b)))) (pattern->matcher #t (vector 'b))))
(check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher SB (list 'a (vector 'b 'c 'd)))) (pattern->matcher SB (list 'a (vector 'b 'c 'd))))
(compile-projection (list 'a ?!)) (compile-projection (list 'a (?!)))
#:project-success (lambda (v) #t)) #:project-success (lambda (v) #t))
(matcher-union (pattern->matcher #t (vector 'a)) (matcher-union (pattern->matcher #t (vector 'a))
(pattern->matcher #t (vector (vector 'b 'c 'd))))) (pattern->matcher #t (vector (vector 'b 'c 'd)))))
(check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher SB (list 'a (vector 'b ? 'd)))) (pattern->matcher SB (list 'a (vector 'b ? 'd))))
(compile-projection (list 'a ?!)) (compile-projection (list 'a (?!)))
#:project-success (lambda (v) #t)) #:project-success (lambda (v) #t))
(matcher-union (pattern->matcher #t (vector 'a)) (matcher-union (pattern->matcher #t (vector 'a))
(pattern->matcher #t (vector (vector 'b ? 'd))))) (pattern->matcher #t (vector (vector 'b ? 'd)))))
@ -982,35 +1002,94 @@
(check-equal? (matcher-key-set (check-equal? (matcher-key-set
(matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher SB (list 'a 'b))) (pattern->matcher SB (list 'a 'b)))
(compile-projection (list 'a ?!)) (compile-projection (list 'a (?!)))
#:project-success (lambda (v) #t))) #:project-success (lambda (v) #t)))
(set '#(a) '#(b))) (set '#(a) '#(b)))
(check-equal? (matcher-key-set (check-equal? (matcher-key-set
(matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher SB (list 'a (vector 'b 'c 'd)))) (pattern->matcher SB (list 'a (vector 'b 'c 'd))))
(compile-projection (list 'a ?!)) (compile-projection (list 'a (?!)))
#:project-success (lambda (v) #t))) #:project-success (lambda (v) #t)))
(set '#(a) '#(#(b c d)))) (set '#(a) '#(#(b c d))))
(check-equal? (matcher-key-set (check-equal? (matcher-key-set
(matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher SB (list 'a (vector 'b ? 'd)))) (pattern->matcher SB (list 'a (vector 'b ? 'd))))
(compile-projection (list 'a ?!)) (compile-projection (list 'a (?!)))
#:project-success (lambda (v) #t))) #:project-success (lambda (v) #t)))
#f) #f)
(check-equal? (matcher-key-set
(matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher SB (list 'a (vector 'b ? 'd))))
(compile-projection (list 'a (?! 'a)))
#:project-success (lambda (v) #t)))
(set '#(a)))
(check-equal? (matcher-project (matcher-union (pattern->matcher SA (cons 1 2)) (check-equal? (matcher-project (matcher-union (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 3 4))) (pattern->matcher SB (cons 3 4)))
(compile-projection (cons ?! ?!)) (compile-projection (cons (?!) (?!)))
#:project-success (lambda (v) #t)) #:project-success (lambda (v) #t))
(matcher-union (pattern->matcher #t (vector 1 2)) (matcher-union (pattern->matcher #t (vector 1 2))
(pattern->matcher #t (vector 3 4)))) (pattern->matcher #t (vector 3 4))))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 1 4))
(pattern->matcher SC (cons 3 4))))
(compile-projection (cons (?!) (?!)))
#:project-success (lambda (v) #t))
(foldr matcher-union (matcher-empty)
(list (pattern->matcher #t (vector 1 2))
(pattern->matcher #t (vector 1 4))
(pattern->matcher #t (vector 3 4)))))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 1 4))
(pattern->matcher SC (cons 3 4))))
(compile-projection (?! (cons ? ?)))
#:project-success (lambda (v) #t))
(foldr matcher-union (matcher-empty)
(list (pattern->matcher #t (vector (cons 1 2)))
(pattern->matcher #t (vector (cons 1 4)))
(pattern->matcher #t (vector (cons 3 4))))))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 1 4))
(pattern->matcher SC (cons 3 4))))
(compile-projection (?! (cons 1 ?)))
#:project-success (lambda (v) #t))
(foldr matcher-union (matcher-empty)
(list (pattern->matcher #t (vector (cons 1 2)))
(pattern->matcher #t (vector (cons 1 4))))))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 1 4))
(pattern->matcher SC (cons 3 4))))
(compile-projection (cons (?! 1) (?!)))
#:project-success (lambda (v) #t))
(foldr matcher-union (matcher-empty)
(list (pattern->matcher #t (vector 1 2))
(pattern->matcher #t (vector 1 4)))))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 1 4))
(pattern->matcher SC (cons 3 4))))
(compile-projection (cons (?!) (?! 4)))
#:project-success (lambda (v) #t))
(foldr matcher-union (matcher-empty)
(list (pattern->matcher #t (vector 1 4))
(pattern->matcher #t (vector 3 4)))))
(check-equal? (matcher-key-set (check-equal? (matcher-key-set
(matcher-project (matcher-union (pattern->matcher SA (cons 1 2)) (matcher-project (matcher-union (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 3 4))) (pattern->matcher SB (cons 3 4)))
(compile-projection (cons ?! ?!)) (compile-projection (cons (?!) (?!)))
#:project-success (lambda (v) #t))) #:project-success (lambda (v) #t)))
(set '#(1 2) '#(3 4))) (set '#(1 2) '#(3 4)))
) )