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

matcher->finite-set -> matcher-key-set

This commit is contained in:
Tony Garnock-Jones 2014-05-19 18:58:27 -04:00
parent cad1dbbbca
commit 2ccd066012
1 changed files with 79 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

141
minimart/route.rkt
View File

@ -23,7 +23,7 @@
matcher-relabel matcher-relabel
compile-projection compile-projection
matcher-project matcher-project
matcher->finite-set matcher-key-set
pretty-print-matcher) pretty-print-matcher)
(define-syntax-rule (define-singleton-struct singleton-name struct-name print-representation) (define-syntax-rule (define-singleton-struct singleton-name struct-name print-representation)
@ -236,9 +236,13 @@
[(r #f) #f] [(r #f) #f]
[(r1 r2) (walk r1 r2)]))) [(r1 r2) (walk r1 r2)])))
(define (set-subtract/false s1 s2)
(define r (set-subtract s1 s2))
(if (set-empty? r) #f r))
;; Removes re2's mappings from re1. Assumes re2 has previously been union'd into re1. ;; Removes re2's mappings from re1. Assumes re2 has previously been union'd into re1.
;; The combine-successes function should return #f to signal "no remaining success values". ;; The combine-successes function should return #f to signal "no remaining success values".
(define (matcher-erase-path re1 re2 [combine-successes set-subtract]) (define (matcher-erase-path re1 re2 [combine-successes set-subtract/false])
(define (cofinite-pattern) (define (cofinite-pattern)
(error 'matcher-erase-path "Cofinite pattern required")) (error 'matcher-erase-path "Cofinite pattern required"))
(define (walk path aggregate) (define (walk path aggregate)
@ -246,7 +250,9 @@
[((wildcard-sequence r1) (wildcard-sequence r2)) (rwildseq (walk r1 r2))] [((wildcard-sequence r1) (wildcard-sequence r2)) (rwildseq (walk r1 r2))]
[((wildcard-sequence r1) r2) (cofinite-pattern)] [((wildcard-sequence r1) r2) (cofinite-pattern)]
[(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2))] [(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2))]
[((success v1) (success v2)) (success (combine-successes v1 v2))] [((success v1) (success v2))
(define new-v (combine-successes v1 v2))
(and new-v (success new-v))]
[((? hash? h1) (? hash? h2)) [((? hash? h1) (? hash? h2))
(define w1 (rlookup h1 ?)) (define w1 (rlookup h1 ?))
(define w2 (rlookup h2 ?)) (define w2 (rlookup h2 ?))
@ -416,8 +422,9 @@
[(? hash?) (error 'pattern->matcher "Cannot match on hash tables at present")] [(? hash?) (error 'pattern->matcher "Cannot match on hash tables at present")]
[other (cons other acc)]))) [other (cons other acc)])))
;; Matcher × CompiledProjection → Matcher ;; Matcher × CompiledProjection [× (Value -> (Option Value))] → Matcher
;; 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".
(define matcher-project (define matcher-project
;; TODO: skip-nested, capture-nested, and the ? and ?! cases in ;; TODO: skip-nested, capture-nested, and the ? and ?! cases in
;; walk-out all share a suspicious amount of code. Refactor it away. ;; walk-out all share a suspicious amount of code. Refactor it away.
@ -449,58 +456,60 @@
[else (rupdate acc key (capture-nested mk k))])))] [else (rupdate acc key (capture-nested mk k))])))]
[_ (matcher-empty)])) [_ (matcher-empty)]))
(define (walk-out m spec) (lambda (m spec [project-success values])
(match spec (define (walk-out m spec)
['() (match spec
(match m ['()
[(success v) (rseq EOS (rseq EOS (success #t)))] (match m
;; ^ the #t yields a matcher that does not preserve map values. [(success v)
[_ (matcher-empty)])] (define new-v (project-success v))
(if new-v
(rseq EOS (rseq EOS (success new-v)))
(matcher-empty))]
[_ (matcher-empty)])]
[(cons (== ?) k) [(cons (== ?) k)
(match m (match m
[(wildcard-sequence _) (walk-out m k)] [(wildcard-sequence _) (walk-out m k)]
[(? hash?) [(? hash?)
(for/fold [(acc (walk-out (rlookup m ?) k))] [((key mk) (in-hash m))] (for/fold [(acc (walk-out (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) (walk-out mk k)))] [(key-open? key) (skip-nested mk (lambda (mk) (walk-out mk k)))]
[(key-close? key) #f] [(key-close? key) #f]
[else (walk-out mk k)]))))] [else (walk-out mk k)]))))]
[_ (matcher-empty)])] [_ (matcher-empty)])]
[(cons (== ?!) k) [(cons (== ?!) k)
(match m (match m
[(wildcard-sequence _) (rwild (walk-out m k))] [(wildcard-sequence _) (rwild (walk-out m k))]
[(? hash?) [(? hash?)
(for/fold [(acc (rwild (walk-out (rlookup m ?) k)))] [((key mk) (in-hash m))] (for/fold [(acc (rwild (walk-out (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) (walk-out mk k))))] (rupdate acc key (capture-nested mk (lambda (mk) (walk-out mk k))))]
[(key-close? key) acc] [(key-close? key) acc]
[else (rupdate acc key (walk-out mk k))])))] [else (rupdate acc key (walk-out mk k))])))]
[_ (matcher-empty)])] [_ (matcher-empty)])]
[(cons sigma k) [(cons sigma k)
(match m (match m
[(wildcard-sequence mk) [(wildcard-sequence mk)
(if (key-close? sigma) (if (key-close? sigma)
(walk-out mk k) (walk-out mk k)
(walk-out m k))] (walk-out m k))]
[(? hash?) [(? hash?)
(matcher-union (walk-out (rlookup m sigma) k) (matcher-union (walk-out (rlookup m sigma) k)
(walk-out (rlookup m ?) k))] (walk-out (rlookup m ?) k))]
[_ (matcher-empty)])])) [_ (matcher-empty)])]))
(lambda (m spec)
(rseq SOV (walk-out m spec))))) (rseq SOV (walk-out 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.
(define matcher->finite-set (define matcher-key-set
(let () (let ()
;; Matcher (Value Matcher -> (Setof Value)) -> (Option (Setof Value)) ;; Matcher (Value Matcher -> (Setof Value)) -> (Option (Setof Value))
;; Calls k with each possible atomic value at this matcher ;; Calls k with each possible atomic value at this matcher
@ -520,7 +529,7 @@
(maybe-union acc (maybe-union acc
(k (transform-seqs vs key) vsk)))))] (k (transform-seqs vs key) vsk)))))]
[(key-close? key) [(key-close? key)
(error 'matcher->finite-set "Internal error: unexpected key-close")] (error 'matcher-key-set "Internal error: unexpected key-close")]
[else [else
(k key mk)]))))] (k key mk)]))))]
[_ (set)])) [_ (set)]))
@ -936,49 +945,57 @@
(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 ?!))
(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 ?!))
(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 ?!))
(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)))))
(check-equal? (matcher->finite-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 ?!))
(lambda (v) #t)))
(set '#(a) '#(b))) (set '#(a) '#(b)))
(check-equal? (matcher->finite-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 ?!))
(lambda (v) #t)))
(set '#(a) '#(#(b c d)))) (set '#(a) '#(#(b c d))))
(check-equal? (matcher->finite-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 ?!))
(lambda (v) #t)))
#f) #f)
(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 ?! ?!))
(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->finite-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 ?! ?!))
(lambda (v) #t)))
(set '#(1 2) '#(3 4))) (set '#(1 2) '#(3 4)))
) )