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

Canonicalize matchers to permit quick equality testing

This commit is contained in:
Tony Garnock-Jones 2014-07-16 11:13:45 -07:00
parent 8bce94c2e3
commit 41666ff408
2 changed files with 230 additions and 168 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
minimart/canonicalize.rkt Normal file
View File

@ -0,0 +1,47 @@
#lang racket/base
;; Poor-man's hash consing.
(provide canonicalize)
(define canonical-values (make-weak-hash))
(define sentinel (cons #f #f))
(define (canonicalize val)
(define b (hash-ref canonical-values
val
(lambda ()
(define new-b (make-weak-box val))
(hash-set! canonical-values val new-b)
#f)))
(if (not b)
(canonicalize val)
(let ((v (weak-box-value b sentinel)))
(if (eq? v sentinel) (canonicalize val) v))))
(module+ test
(require rackunit)
(define v1 (canonicalize (cons 1 2)))
(let ((v2 (canonicalize (cons 1 2))))
(check-eq? v1 v2))
(collect-garbage)
(check-equal? (hash-count canonical-values) 1)
(let ((v2 (canonicalize (cons 1 2))))
(check-eq? v1 v2))
(set! v1 (canonicalize (cons 1 2)))
(collect-garbage)
(check-equal? (hash-count canonical-values) 1)
(let ((v2 (canonicalize (cons 1 2))))
(check-eq? v1 v2))
(set! v1 #f)
(collect-garbage)
(check-equal? (hash-count canonical-values) 0))

351
minimart/route.rkt
View File

@ -54,6 +54,7 @@
(require racket/match) (require racket/match)
(require (only-in racket/port call-with-output-string with-output-to-string)) (require (only-in racket/port call-with-output-string with-output-to-string))
(require (only-in racket/class object?)) (require (only-in racket/class object?))
(require "canonicalize.rkt")
(require rackunit) (require rackunit)
@ -175,15 +176,24 @@
;; prepending tokens to a Matcher unless there's some possibility it ;; prepending tokens to a Matcher unless there's some possibility it
;; can map to one or more Values. ;; can map to one or more Values.
;; Matcher Matcher -> Boolean
;; Exploits canonicalization to replace an expensive equal? check with eq?.
(define (requal? a b)
(eq? a b))
;; (Option Value) -> Matcher ;; (Option Value) -> Matcher
;; If the argument is #f, returns the empty matcher; otherwise, a success Matcher. ;; If the argument is #f, returns the empty matcher; otherwise, a success Matcher.
(define (rsuccess v) (define (rsuccess v)
(and v (success v))) (and v (canonicalize (success v))))
;; (U Sigma Wildcard) Matcher -> Matcher ;; (U Sigma Wildcard) Matcher -> Matcher
;; Prepends e to r, if r is non-empty. ;; Prepends e to r, if r is non-empty.
(define (rseq e r) (define (rseq e r)
(if (matcher-empty? r) r (hash e r))) (if (matcher-empty? r) r (canonicalize (hash e r))))
;; [ (U Sigma Wildcard) Matcher ] ... -> Matcher
(define (rseq-multi . ers)
(canonicalize (apply hash ers)))
;; Matcher -> Matcher ;; Matcher -> Matcher
;; Prepends the wildcard pseudo-Sigma to r, if r is non-empty. ;; Prepends the wildcard pseudo-Sigma to r, if r is non-empty.
@ -194,7 +204,7 @@
;; If r is non-empty, returns a matcher that consumes input up to and ;; If r is non-empty, returns a matcher that consumes input up to and
;; including EOS, then continuing with r. ;; including EOS, then continuing with r.
(define (rwildseq r) (define (rwildseq r)
(if (matcher-empty? r) r (wildcard-sequence r))) (if (matcher-empty? r) r (canonicalize (wildcard-sequence r))))
;; Matcher (U Sigma Wildcard) -> Matcher ;; Matcher (U Sigma Wildcard) -> Matcher
;; r must be a hashtable matcher. Retrieves the continuation after ;; r must be a hashtable matcher. Retrieves the continuation after
@ -215,7 +225,7 @@
;; If the argument is empty, returns the canonical empty matcher; ;; If the argument is empty, returns the canonical empty matcher;
;; otherwise, returns the argument. ;; otherwise, returns the argument.
(define (empty-hash-guard h) (define (empty-hash-guard h)
(and (positive? (hash-count h)) h)) (and (positive? (hash-count h)) (canonicalize h)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Pattern compilation ;; Pattern compilation
@ -408,18 +418,17 @@
;; Here we ensure a "minimal" remainder in cases where ;; Here we ensure a "minimal" remainder in cases where
;; after an erasure, a particular key's continuation is the ;; after an erasure, a particular key's continuation is the
;; same as the wildcard's continuation. ;; same as the wildcard's continuation.
;; TODO: the equal? check may be expensive. If so, how can it be made cheaper?
(cond (cond
[(key-open? key) [(key-open? key)
(if (and (wildcard-sequence? updated-k) (if (and (wildcard-sequence? updated-k)
(equal? (wildcard-sequence-matcher updated-k) w)) (requal? (wildcard-sequence-matcher updated-k) w))
(rupdate acc key #f) (rupdate acc key #f)
(rupdate acc key updated-k))] (rupdate acc key updated-k))]
[(key-close? key) [(key-close? key)
;; We will check whether this can be removed later, in collapse-wildcard-sequences. ;; We will check whether this can be removed later, in collapse-wildcard-sequences.
(rupdate acc key updated-k)] (rupdate acc key updated-k)]
[else [else
(rupdate acc key (if (equal? updated-k w) #f updated-k))])) (rupdate acc key (if (requal? updated-k w) #f updated-k))]))
;; We only need to examine all keys of h1 if w2 nonfalse. ;; We only need to examine all keys of h1 if w2 nonfalse.
(collapse-wildcard-sequences (collapse-wildcard-sequences
(if w2 (if w2
@ -455,7 +464,7 @@
(match (set->list (set-remove (hash-keys h) ?)) (match (set->list (set-remove (hash-keys h) ?))
[(list (? key-close? other-key)) [(list (? key-close? other-key))
(define k (rlookup h other-key)) (define k (rlookup h other-key))
(if (equal? k (wildcard-sequence-matcher w)) (if (requal? k (wildcard-sequence-matcher w))
w w
h)] h)]
[_ h]) [_ h])
@ -906,24 +915,26 @@
['() #f] ['() #f]
[(list "" vj) (rsuccess (jsexpr->success vj))] [(list "" vj) (rsuccess (jsexpr->success vj))]
[(list "...)" j1) (rwildseq (walk j1))] [(list "...)" j1) (rwildseq (walk j1))]
[(list (list kjs vjs) ...) (for/hash [(kj kjs) (vj vjs)] [(list (list kjs vjs) ...)
(values (match kj (canonicalize
[(list "__") ?] (for/hash [(kj kjs) (vj vjs)]
[(list "(") SOL] (values (match kj
[(list "#(") SOV] [(list "__") ?]
[(list ")") EOS] [(list "(") SOL]
[(list (? string? s)) [(list "#(") SOV]
(match (deserialize-struct-type-name s) [(list ")") EOS]
[#f (error 'jsexpr->matcher [(list (? string? s))
"Illegal open-parenthesis mark ~v" (match (deserialize-struct-type-name s)
kj)] [#f (error 'jsexpr->matcher
[tn (match (struct-type-name->struct-type tn) "Illegal open-parenthesis mark ~v"
[#f (error 'jsexpr->matcher kj)]
"Unexpected struct type ~v" [tn (match (struct-type-name->struct-type tn)
tn)] [#f (error 'jsexpr->matcher
[t t])])] "Unexpected struct type ~v"
[other other]) tn)]
(walk vj)))]))) [t t])])]
[other other])
(walk vj))))])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -937,16 +948,16 @@
(define Sfoo (set 'foo)) (define Sfoo (set 'foo))
(define S+ (set '+)) (define S+ (set '+))
(define SX (set 'X)) (define SX (set 'X))
(define (E v) (hash EOS (success v))) (define (E v) (rseq EOS (rsuccess v)))
(check-equal? (pattern->matcher SA 123) (hash 123 (E SA))) (check-equal? (pattern->matcher SA 123) (rseq 123 (E SA)))
(check-equal? (pattern->matcher SA (cons 1 2)) (check-equal? (pattern->matcher SA (cons 1 2))
(hash SOL (hash 1 (hash ILM (hash 2 (hash EOS (E SA))))))) (rseq SOL (rseq 1 (rseq ILM (rseq 2 (rseq EOS (E SA)))))))
(check-equal? (pattern->matcher SA (cons ? 2)) (check-equal? (pattern->matcher SA (cons ? 2))
(hash SOL (hash ? (hash ILM (hash 2 (hash EOS (E SA))))))) (rseq SOL (rseq ? (rseq ILM (rseq 2 (rseq EOS (E SA)))))))
(check-equal? (pattern->matcher SA (list 1 2)) (hash SOL (hash 1 (hash 2 (hash EOS (E SA)))))) (check-equal? (pattern->matcher SA (list 1 2)) (rseq SOL (rseq 1 (rseq 2 (rseq EOS (E SA))))))
(check-equal? (pattern->matcher SA (list ? 2)) (hash SOL (hash ? (hash 2 (hash EOS (E SA)))))) (check-equal? (pattern->matcher SA (list ? 2)) (rseq SOL (rseq ? (rseq 2 (rseq EOS (E SA))))))
(check-equal? (pattern->matcher SA SOL) (hash struct:start-of-list (hash EOS (E SA)))) (check-equal? (pattern->matcher SA SOL) (rseq struct:start-of-list (rseq EOS (E SA))))
(check-equal? (pattern->matcher SA ?) (hash ? (E SA))) (check-equal? (pattern->matcher SA ?) (rseq ? (E SA)))
) )
(module+ test (module+ test
@ -1213,64 +1224,68 @@
[(list r) r] [(list r) r]
[(cons e xs1) (rseq e (walk xs1))]))) [(cons e xs1) (rseq e (walk xs1))])))
(check-equal? (intersect ? ?) (rwild EAB)) (define (check-requal? actual expected)
(check-equal? (intersect 'a ?) (rseq 'a EAB)) (check-eq? actual expected))
(check-equal? (intersect 123 ?) (rseq 123 EAB))
(check-equal? (intersect (cons ? 2) (cons 1 ?)) (rseq* SOL 1 ILM 2 EOS EAB))
(check-equal? (intersect (list ? 2) (list 1 ?)) (rseq* SOL 1 2 EOS EAB))
(check-equal? (intersect (cons 1 2) ?) (rseq* SOL 1 ILM 2 EOS EAB))
(check-equal? (intersect (list 1 2) ?) (rseq* SOL 1 2 EOS EAB))
(check-equal? (intersect 1 2) #f)
(check-equal? (intersect (cons 1 2) (cons ? 2)) (rseq* SOL 1 ILM 2 EOS EAB))
(check-equal? (intersect (list 1 2) (list ? 2)) (rseq* SOL 1 2 EOS EAB))
(check-equal? (intersect (cons 1 2) (cons 3 2)) #f)
(check-equal? (intersect (cons 1 2) (cons 1 3)) #f)
(check-equal? (intersect (vector 1 2) (vector 1 2)) (rseq* SOV 1 2 EOS EAB))
(check-equal? (intersect (vector 1 2) (vector 1 2 3)) #f)
(check-equal? (intersect (a 'a) (a 'b)) #f) (check-requal? (intersect ? ?) (rwild EAB))
(check-equal? (intersect (a 'a) (a 'a)) (rseq* struct:a 'a EOS EAB)) (check-requal? (intersect 'a ?) (rseq 'a EAB))
(check-equal? (intersect (a 'a) (a ?)) (rseq* struct:a 'a EOS EAB)) (check-requal? (intersect 123 ?) (rseq 123 EAB))
(check-equal? (intersect (a 'a) ?) (rseq* struct:a 'a EOS EAB)) (check-requal? (intersect (cons ? 2) (cons 1 ?)) (rseq* SOL 1 ILM 2 EOS EAB))
(check-equal? (intersect (b 'a) (b 'b)) #f) (check-requal? (intersect (list ? 2) (list 1 ?)) (rseq* SOL 1 2 EOS EAB))
(check-equal? (intersect (b 'a) (b 'a)) (rseq* struct:b 'a EOS EAB)) (check-requal? (intersect (cons 1 2) ?) (rseq* SOL 1 ILM 2 EOS EAB))
(check-equal? (intersect (b 'a) (b ?)) (rseq* struct:b 'a EOS EAB)) (check-requal? (intersect (list 1 2) ?) (rseq* SOL 1 2 EOS EAB))
(check-equal? (intersect (b 'a) ?) (rseq* struct:b 'a EOS EAB)) (check-requal? (intersect 1 2) #f)
(check-requal? (intersect (cons 1 2) (cons ? 2)) (rseq* SOL 1 ILM 2 EOS EAB))
(check-requal? (intersect (list 1 2) (list ? 2)) (rseq* SOL 1 2 EOS EAB))
(check-requal? (intersect (cons 1 2) (cons 3 2)) #f)
(check-requal? (intersect (cons 1 2) (cons 1 3)) #f)
(check-requal? (intersect (vector 1 2) (vector 1 2)) (rseq* SOV 1 2 EOS EAB))
(check-requal? (intersect (vector 1 2) (vector 1 2 3)) #f)
(check-equal? (intersect (a 'a) (b 'a)) #f) (check-requal? (intersect (a 'a) (a 'b)) #f)
(check-requal? (intersect (a 'a) (a 'a)) (rseq* struct:a 'a EOS EAB))
(check-requal? (intersect (a 'a) (a ?)) (rseq* struct:a 'a EOS EAB))
(check-requal? (intersect (a 'a) ?) (rseq* struct:a 'a EOS EAB))
(check-requal? (intersect (b 'a) (b 'b)) #f)
(check-requal? (intersect (b 'a) (b 'a)) (rseq* struct:b 'a EOS EAB))
(check-requal? (intersect (b 'a) (b ?)) (rseq* struct:b 'a EOS EAB))
(check-requal? (intersect (b 'a) ?) (rseq* struct:b 'a EOS EAB))
(check-requal? (intersect (a 'a) (b 'a)) #f)
(check-exn #px"Cannot match on hash tables at present" (check-exn #px"Cannot match on hash tables at present"
(lambda () (lambda ()
(intersect (hash 'a 1 'b ?) (hash 'a ? 'b 2)))) (intersect (canonicalize (hash 'a 1 'b ?))
;; (check-equal? (intersect (hash 'a 1 'b ?) (hash 'a ? 'b 2)) (hash 'a 1 'b 2)) (canonicalize (hash 'a ? 'b 2)))))
;; (check-equal? (intersect (hash 'a 1 'b ?) (hash 'a ?)) (void)) ;; (check-requal? (intersect (rseq 'a 1 'b ?) (rseq 'a ? 'b 2)) (rseq 'a 1 'b 2))
;; (check-equal? (intersect (hash 'a 1 'b ?) (hash 'a 1 'b ?)) (hash 'a 1 'b ?)) ;; (check-requal? (intersect (rseq 'a 1 'b ?) (rseq 'a ?)) (void))
;; (check-equal? (intersect (hash 'a 1 'b ?) (hash 'a ? 'c ?)) (void)) ;; (check-requal? (intersect (rseq 'a 1 'b ?) (rseq 'a 1 'b ?)) (rseq 'a 1 'b ?))
;; (check-requal? (intersect (rseq 'a 1 'b ?) (rseq 'a ? 'c ?)) (void))
;; (check-equal? (intersect (hash 'a 1 'b ?) (hash 'a 1 'b (list 2 ?))) ;; (check-requal? (intersect (rseq 'a 1 'b ?) (rseq 'a 1 'b (list 2 ?)))
;; (hash 'a 1 'b (list 2 ?))) ;; (rseq 'a 1 'b (list 2 ?)))
;; (check-equal? (intersect (hash 'a 1 'b (list ? 3)) (hash 'a 1 'b (list 2 ?))) ;; (check-requal? (intersect (rseq 'a 1 'b (list ? 3)) (rseq 'a 1 'b (list 2 ?)))
;; (hash 'a 1 'b (list 2 3))) ;; (rseq 'a 1 'b (list 2 3)))
(let ((H hash)) (let ((H rseq-multi))
(newline) (newline)
(printf "Checking that intersection with wildcard is identity-like\n") (printf "Checking that intersection with wildcard is identity-like\n")
(define m1 (pretty-print-matcher* (define m1 (pretty-print-matcher*
(foldr matcher-union (matcher-empty) (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (list 'a ?)) (list (pattern->matcher SA (list 'a ?))
(pattern->matcher SB (list 'b ?)) (pattern->matcher SB (list 'b ?))
(pattern->matcher SC (list 'b 'c)))))) (pattern->matcher SC (list 'b 'c))))))
(define m2 (pretty-print-matcher* (pattern->matcher SD ?))) (define m2 (pretty-print-matcher* (pattern->matcher SD ?)))
(define mi (pretty-print-matcher* (matcher-intersect m1 m2))) (define mi (pretty-print-matcher* (matcher-intersect m1 m2)))
(check-equal? mi (check-requal? mi
(H SOL (H 'a (H ? (H EOS (E (set 'A 'D)))) (H SOL (H 'a (H ? (H EOS (E (set 'A 'D))))
'b (H ? (H EOS (E (set 'B 'D))) 'b (H ? (H EOS (E (set 'B 'D)))
'c (H EOS (E (set 'B 'C 'D))))))) 'c (H EOS (E (set 'B 'C 'D)))))))
(check-equal? (pretty-print-matcher* (check-requal? (pretty-print-matcher*
(parameterize ((matcher-intersect-successes (lambda (v1 v2) v1))) (parameterize ((matcher-intersect-successes (lambda (v1 v2) v1)))
(matcher-intersect m1 m2))) (matcher-intersect m1 m2)))
m1)) m1))
) )
(module+ test (module+ test
(define (matcher-match-matcher-list m1 m2) (define (matcher-match-matcher-list m1 m2)
@ -1313,23 +1328,23 @@
(list SOL 'a SOC ? EOC EOS EOS)) (list SOL 'a SOC ? EOC EOS EOS))
(parameterize ((matcher-project-success (lambda (v) #t))) (parameterize ((matcher-project-success (lambda (v) #t)))
(check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (check-requal? (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 (?!))))
(matcher-union (pattern->matcher #t 'a) (matcher-union (pattern->matcher #t 'a)
(pattern->matcher #t 'b))) (pattern->matcher #t 'b)))
(check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (check-requal? (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 (?!))))
(matcher-union (pattern->matcher #t 'a) (matcher-union (pattern->matcher #t 'a)
(pattern->matcher #t (vector 'b 'c 'd)))) (pattern->matcher #t (vector 'b 'c 'd))))
(check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (check-requal? (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 (?!))))
(matcher-union (pattern->matcher #t 'a) (matcher-union (pattern->matcher #t 'a)
(pattern->matcher #t (vector 'b ? 'd)))) (pattern->matcher #t (vector 'b ? '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))
@ -1355,58 +1370,58 @@
(compile-projection (list 'a (?! 'a))))) (compile-projection (list 'a (?! 'a)))))
(set '(a))) (set '(a)))
(check-equal? (matcher-project (matcher-union (pattern->matcher SA (cons 1 2)) (check-requal? (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 (?!) (?!))))
(matcher-union (pattern->matcher #t 1 2) (matcher-union (pattern->matcher #t 1 2)
(pattern->matcher #t 3 4))) (pattern->matcher #t 3 4)))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty) (check-requal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2)) (list (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 1 4)) (pattern->matcher SB (cons 1 4))
(pattern->matcher SC (cons 3 4)))) (pattern->matcher SC (cons 3 4))))
(compile-projection (cons (?!) (?!)))) (compile-projection (cons (?!) (?!))))
(foldr matcher-union (matcher-empty) (foldr matcher-union (matcher-empty)
(list (pattern->matcher #t 1 2) (list (pattern->matcher #t 1 2)
(pattern->matcher #t 1 4) (pattern->matcher #t 1 4)
(pattern->matcher #t 3 4)))) (pattern->matcher #t 3 4))))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty) (check-requal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2)) (list (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 1 4)) (pattern->matcher SB (cons 1 4))
(pattern->matcher SC (cons 3 4)))) (pattern->matcher SC (cons 3 4))))
(compile-projection (?! (cons ? ?)))) (compile-projection (?! (cons ? ?))))
(foldr matcher-union (matcher-empty) (foldr matcher-union (matcher-empty)
(list (pattern->matcher #t (cons 1 2)) (list (pattern->matcher #t (cons 1 2))
(pattern->matcher #t (cons 1 4)) (pattern->matcher #t (cons 1 4))
(pattern->matcher #t (cons 3 4))))) (pattern->matcher #t (cons 3 4)))))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty) (check-requal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2)) (list (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 1 4)) (pattern->matcher SB (cons 1 4))
(pattern->matcher SC (cons 3 4)))) (pattern->matcher SC (cons 3 4))))
(compile-projection (?! (cons 1 ?)))) (compile-projection (?! (cons 1 ?))))
(foldr matcher-union (matcher-empty) (foldr matcher-union (matcher-empty)
(list (pattern->matcher #t (cons 1 2)) (list (pattern->matcher #t (cons 1 2))
(pattern->matcher #t (cons 1 4))))) (pattern->matcher #t (cons 1 4)))))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty) (check-requal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2)) (list (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 1 4)) (pattern->matcher SB (cons 1 4))
(pattern->matcher SC (cons 3 4)))) (pattern->matcher SC (cons 3 4))))
(compile-projection (cons (?! 1) (?!)))) (compile-projection (cons (?! 1) (?!))))
(foldr matcher-union (matcher-empty) (foldr matcher-union (matcher-empty)
(list (pattern->matcher #t 1 2) (list (pattern->matcher #t 1 2)
(pattern->matcher #t 1 4)))) (pattern->matcher #t 1 4))))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty) (check-requal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2)) (list (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 1 4)) (pattern->matcher SB (cons 1 4))
(pattern->matcher SC (cons 3 4)))) (pattern->matcher SC (cons 3 4))))
(compile-projection (cons (?!) (?! 4)))) (compile-projection (cons (?!) (?! 4))))
(foldr matcher-union (matcher-empty) (foldr matcher-union (matcher-empty)
(list (pattern->matcher #t 1 4) (list (pattern->matcher #t 1 4)
(pattern->matcher #t 3 4)))) (pattern->matcher #t 3 4))))
(check-equal? (matcher-key-set (check-equal? (matcher-key-set
(matcher-project (foldr matcher-union (matcher-empty) (matcher-project (foldr matcher-union (matcher-empty)
@ -1430,10 +1445,10 @@
(compile-projection (cons (?!) (?!))))) (compile-projection (cons (?!) (?!)))))
(set '(1 2) '(3 4)))) (set '(1 2) '(3 4))))
(check-equal? (matcher-project (matcher-union (pattern->matcher SA ?) (check-requal? (matcher-project (matcher-union (pattern->matcher SA ?)
(pattern->matcher SB (list 'a))) (pattern->matcher SB (list 'a)))
(compile-projection (?! (list (list ?))))) (compile-projection (?! (list (list ?)))))
(pattern->matcher SA (list (list ?)))) (pattern->matcher SA (list (list ?))))
(check-equal? (projection->pattern (list 'a 'b)) (list 'a 'b)) (check-equal? (projection->pattern (list 'a 'b)) (list 'a 'b))
(check-equal? (projection->pattern (list 'a ?)) (list 'a ?)) (check-equal? (projection->pattern (list 'a ?)) (list 'a ?))
@ -1446,18 +1461,18 @@
(module+ test (module+ test
(let ((A (pattern->matcher SA ?)) (let ((A (pattern->matcher SA ?))
(B (pattern->matcher SB (list (list (list (list 'foo))))))) (B (pattern->matcher SB (list (list (list (list 'foo)))))))
(check-equal? (pretty-print-matcher* (matcher-erase-path (matcher-union A B) B)) (check-requal? (pretty-print-matcher* (matcher-erase-path (matcher-union A B) B))
A)) A))
(let ((A (pattern->matcher SA ?)) (let ((A (pattern->matcher SA ?))
(B (matcher-union (pattern->matcher SB (list (list (list (list 'foo))))) (B (matcher-union (pattern->matcher SB (list (list (list (list 'foo)))))
(pattern->matcher SB (list (list (list (list 'bar)))))))) (pattern->matcher SB (list (list (list (list 'bar))))))))
(check-equal? (pretty-print-matcher* (matcher-erase-path (matcher-union A B) B)) (check-requal? (pretty-print-matcher* (matcher-erase-path (matcher-union A B) B))
A)) A))
(let ((A (pattern->matcher SA ?)) (let ((A (pattern->matcher SA ?))
(B (matcher-union (pattern->matcher SB (list (list (list (list 'foo))))) (B (matcher-union (pattern->matcher SB (list (list (list (list 'foo)))))
(pattern->matcher SB (list (list (list (list 'bar)))))))) (pattern->matcher SB (list (list (list (list 'bar))))))))
(check-equal? (pretty-print-matcher* (matcher-erase-path (matcher-union A B) A)) (check-requal? (pretty-print-matcher* (matcher-erase-path (matcher-union A B) A))
B))) B)))
(module+ test (module+ test
(let ((M (foldr matcher-union (matcher-empty) (let ((M (foldr matcher-union (matcher-empty)
@ -1474,18 +1489,18 @@
(3 (((")") (((")") ("" ("D"))))))) (3 (((")") (((")") ("" ("D")))))))
(4 (((")") (((")") ("" ("B")))))))))))))) (4 (((")") (((")") ("" ("B"))))))))))))))
(check-equal? (matcher->jsexpr M (lambda (v) (map symbol->string (set->list v)))) S) (check-equal? (matcher->jsexpr M (lambda (v) (map symbol->string (set->list v)))) S)
(check-equal? (jsexpr->matcher S (lambda (v) (list->set (map string->symbol v)))) M))) (check-requal? (jsexpr->matcher S (lambda (v) (list->set (map string->symbol v)))) M)))
(module+ test (module+ test
(check-equal? (pretty-print-matcher* (check-requal? (pretty-print-matcher*
(pattern->matcher SA (list 1 (pattern->matcher SA (list 1
(embedded-matcher (embedded-matcher
(pattern->matcher SB (list 2 3))) (pattern->matcher SB (list 2 3)))
4))) 4)))
(pattern->matcher SA (list 1 (list 2 3) 4))) (pattern->matcher SA (list 1 (list 2 3) 4)))
(check-equal? (pretty-print-matcher* (check-requal? (pretty-print-matcher*
(pattern->matcher SA (pattern->matcher SA
(list (embedded-matcher (pattern->matcher SB (list 1 2))) (list (embedded-matcher (pattern->matcher SB (list 1 2)))
(embedded-matcher (pattern->matcher SC (list 3 4)))))) (embedded-matcher (pattern->matcher SC (list 3 4))))))
(pattern->matcher SA (list (list 1 2) (list 3 4))))) (pattern->matcher SA (list (list 1 2) (list 3 4)))))