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

Renamings and better exports

This commit is contained in:
Tony Garnock-Jones 2014-05-07 19:23:11 -04:00
parent 4a142b62b2
commit 7c11b3ace2
1 changed files with 82 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

152
minimart/route.rkt
View File

@ -7,11 +7,15 @@
(require rackunit) (require rackunit)
;; TODO: proper exports (provide ?
(provide ror
pattern->matcher pattern->matcher
? matcher? ;; expensive; see implementation
match-value) matcher-empty
matcher-empty?
matcher-union
matcher-intersect
matcher-erase-path
matcher-match-value)
(define-syntax-rule (define-singleton-struct singleton-name struct-name print-representation) (define-syntax-rule (define-singleton-struct singleton-name struct-name print-representation)
(begin (begin
@ -47,14 +51,22 @@
;; table. ;; table.
(struct wildcard-sequence (matcher) #:transparent) (struct wildcard-sequence (matcher) #:transparent)
(define (rnull) #f) (define (matcher? x)
(define (rempty? r) (not r)) (or (eq? x #f)
(set? x)
(wildcard-sequence? x)
(and (hash? x)
(for/and ([v (in-hash-values x)])
(matcher? v)))))
(define (matcher-empty) #f)
(define (matcher-empty? r) (not r))
(define (rvalue v) (set v)) (define (rvalue v) (set v))
(define (rseq e r) (if (rempty? r) r (hash e r))) (define (rseq e r) (if (matcher-empty? r) r (hash e r)))
(define (rwild r) (rseq ? r)) (define (rwild r) (rseq ? r))
(define (rwildseq r) (if (rempty? r) r (wildcard-sequence r))) (define (rwildseq r) (if (matcher-empty? r) r (wildcard-sequence r)))
(define (rseq* x . xs) (define (rseq* x . xs)
(let walk ((xs (cons x xs))) (let walk ((xs (cons x xs)))
@ -97,7 +109,7 @@
(hash-ref r key (lambda () #f))) (hash-ref r key (lambda () #f)))
(define (rupdate r key k) (define (rupdate r key k)
(if (rempty? k) (if (matcher-empty? k)
(and r (hash-remove r key)) (and r (hash-remove r key))
(hash-set (or r (hash)) key k))) (hash-set (or r (hash)) key k)))
@ -114,10 +126,10 @@
(key-close? k)))) (key-close? k))))
(define (expand-wildseq r) (define (expand-wildseq r)
(ror (rwild (rwildseq r)) (matcher-union (rwild (rwildseq r))
(rseq EOS r))) (rseq EOS r)))
(define ror (define matcher-union
(let () (let ()
(define (merge o1 o2) (define (merge o1 o2)
(match* (o1 o2) (match* (o1 o2)
@ -159,7 +171,7 @@
[(r #f) r] [(r #f) r]
[(r1 r2) (walk r1 r2)])))) [(r1 r2) (walk r1 r2)]))))
(define rand (define matcher-intersect
(let () (let ()
(define (walk re1 re2) (define (walk re1 re2)
(match* (re1 re2) (match* (re1 re2)
@ -201,10 +213,10 @@
[(r #f) #f] [(r #f) #f]
[(r1 r2) (walk r1 r2)])))) [(r1 r2) (walk r1 r2)]))))
(define erase-path (define matcher-erase-path
(let () (let ()
(define (cofinite-pattern) (define (cofinite-pattern)
(error 'erase-path "Cofinite pattern required")) (error 'matcher-erase-path "Cofinite pattern required"))
(define (walk path aggregate) (define (walk path aggregate)
(match* (path aggregate) (match* (path aggregate)
[((wildcard-sequence r1) (wildcard-sequence r2)) (rwildseq (walk r1 r2))] [((wildcard-sequence r1) (wildcard-sequence r2)) (rwildseq (walk r1 r2))]
@ -250,7 +262,7 @@
[(r #f) (cofinite-pattern)] [(r #f) (cofinite-pattern)]
[(r1 r2) (walk r1 r2)])))) [(r1 r2) (walk r1 r2)]))))
(define (match-value r v) (define (matcher-match-value r v)
(let walk ((vs (list v)) (stack '(())) (r r)) (let walk ((vs (list v)) (stack '(())) (r r))
(define (walk-wild vs stack) (define (walk-wild vs stack)
(match (rlookup r ?) (match (rlookup r ?)
@ -276,7 +288,7 @@
[#f (set)] [#f (set)]
[k (walk rest stack1 k)])])] [k (walk rest stack1 k)])])]
[(cons (== ?) rest) [(cons (== ?) rest)
(error 'match-value "Cannot match wildcard as a value")] (error 'matcher-match-value "Cannot match wildcard as a value")]
[(cons (cons v1 v2) rest) [(cons (cons v1 v2) rest)
(match (rlookup r SOP) (match (rlookup r SOP)
[#f (walk-wild rest stack)] [#f (walk-wild rest stack)]
@ -287,7 +299,7 @@
[k (walk vv (cons rest stack) k)])] [k (walk vv (cons rest stack) k)])]
[(cons (? non-object-struct? s) rest) [(cons (? non-object-struct? s) rest)
(define-values (t skipped?) (struct-info s)) (define-values (t skipped?) (struct-info s))
(when skipped? (error 'match-value "Cannot reflect on struct instance ~v" s)) (when skipped? (error 'matcher-match-value "Cannot reflect on struct instance ~v" s))
(define fs (cdr (vector->list (struct->vector s)))) (define fs (cdr (vector->list (struct->vector s))))
(match (rlookup r t) (match (rlookup r t)
[#f (walk-wild rest stack)] [#f (walk-wild rest stack)]
@ -334,7 +346,7 @@
(match tests (match tests
['() (void)] ['() (void)]
[(list* message expectedstr rest) [(list* message expectedstr rest)
(define actualset (match-value matcher message)) (define actualset (matcher-match-value matcher message))
(printf "~v ==> ~v\n" message actualset) (printf "~v ==> ~v\n" message actualset)
(check-equal? actualset (check-equal? actualset
(apply set (map (lambda (c) (string->symbol (string c))) (apply set (map (lambda (c) (string->symbol (string c)))
@ -342,21 +354,21 @@
(walk rest)]))) (walk rest)])))
(void (pretty-print-matcher (void (pretty-print-matcher
(ror (pattern->matcher 'A (list (list ?) 'x)) (matcher-union (pattern->matcher 'A (list (list ?) 'x))
(pattern->matcher 'B (list (list ?) 'y))))) (pattern->matcher 'B (list (list ?) 'y)))))
(void (pretty-print-matcher (void (pretty-print-matcher
(ror (pattern->matcher 'A (list (list 'a 'b) 'x)) (matcher-union (pattern->matcher 'A (list (list 'a 'b) 'x))
(pattern->matcher 'B (list (list 'c 'd) 'y))))) (pattern->matcher 'B (list (list 'c 'd) 'y)))))
(void (pretty-print-matcher (void (pretty-print-matcher
(ror (pattern->matcher 'A (list (list 'a 'b) 'x)) (matcher-union (pattern->matcher 'A (list (list 'a 'b) 'x))
(pattern->matcher 'B (list (list ? ?) 'y))))) (pattern->matcher 'B (list (list ? ?) 'y)))))
(check-matches (check-matches
(pretty-print-matcher (pretty-print-matcher
(ror (pattern->matcher 'A (list (list 'a 'b) 'x)) (matcher-union (pattern->matcher 'A (list (list 'a 'b) 'x))
(pattern->matcher 'B (list (list ? ?) 'x)))) (pattern->matcher 'B (list (list ? ?) 'x))))
(list 'z 'x) "" (list 'z 'x) ""
(list (list 'z 'z) 'x) "B" (list (list 'z 'z) 'x) "B"
(list (list 'z (list 'z)) 'x) "B" (list (list 'z (list 'z)) 'x) "B"
@ -364,8 +376,8 @@
(check-matches (check-matches
(pretty-print-matcher (pretty-print-matcher
(ror (pattern->matcher 'A (list (list 'a 'b) 'x)) (matcher-union (pattern->matcher 'A (list (list 'a 'b) 'x))
(pattern->matcher 'B (list (list ?) 'y)))) (pattern->matcher 'B (list (list ?) 'y))))
(list 'z 'y) "" (list 'z 'y) ""
(list (list 'z 'z) 'y) "" (list (list 'z 'z) 'y) ""
(list (list 'z 'z) 'x) "" (list (list 'z 'z) 'x) ""
@ -373,38 +385,38 @@
(check-matches (check-matches
(pretty-print-matcher (pretty-print-matcher
(ror (pattern->matcher 'A (list (list 'a 'b) 'x)) (matcher-union (pattern->matcher 'A (list (list 'a 'b) 'x))
(pattern->matcher 'B (list ? 'y)))) (pattern->matcher 'B (list ? 'y))))
(list 'z 'y) "B" (list 'z 'y) "B"
(list (list 'z 'z) 'y) "B" (list (list 'z 'z) 'y) "B"
(list (list 'a 'b) 'x) "A") (list (list 'a 'b) 'x) "A")
(check-matches (check-matches
(pretty-print-matcher (pretty-print-matcher
(ror (pattern->matcher 'A (list 'a 'b)) (matcher-union (pattern->matcher 'A (list 'a 'b))
(pattern->matcher 'B (list 'c 'd)))) (pattern->matcher 'B (list 'c 'd))))
(list 'a 'b) "A" (list 'a 'b) "A"
(list 'c 'd) "B" (list 'c 'd) "B"
(list 'a 'd) "" (list 'a 'd) ""
(list 'c 'b) "") (list 'c 'b) "")
(void (pretty-print-matcher (ror (pattern->matcher 'A (list (list 'a 'b) 'x)) (void (pretty-print-matcher (matcher-union (pattern->matcher 'A (list (list 'a 'b) 'x))
;; Note: this is a largely nonsense matcher, ;; Note: this is a largely nonsense matcher,
;; since it expects no input at all ;; since it expects no input at all
(rseq EOS (rvalue 'B))))) (rseq EOS (rvalue 'B)))))
(check-matches (check-matches
(pretty-print-matcher (pretty-print-matcher
(ror (pattern->matcher 'A (list (list 'a 'b) 'x)) (matcher-union (pattern->matcher 'A (list (list 'a 'b) 'x))
(pattern->matcher 'B ?))) (pattern->matcher 'B ?)))
(list (list 'a 'b) 'x) "AB" (list (list 'a 'b) 'x) "AB"
'p "B" 'p "B"
(list 'p) "B") (list 'p) "B")
(check-matches (check-matches
(pretty-print-matcher (pretty-print-matcher
(ror (pattern->matcher 'A (list 'a ?)) (matcher-union (pattern->matcher 'A (list 'a ?))
(pattern->matcher 'B (list 'a (list 'b))))) (pattern->matcher 'B (list 'a (list 'b)))))
(list 'a (list 'b)) "AB" (list 'a (list 'b)) "AB"
(list 'a (list 'b 'b)) "A" (list 'a (list 'b 'b)) "A"
@ -416,9 +428,9 @@
(check-matches (check-matches
(pretty-print-matcher (pretty-print-matcher
(ror (ror (pattern->matcher 'A (list 'a ?)) (matcher-union (matcher-union (pattern->matcher 'A (list 'a ?))
(pattern->matcher 'A (list 'q ?))) (pattern->matcher 'A (list 'q ?)))
(pattern->matcher 'B (list 'a (list 'b))))) (pattern->matcher 'B (list 'a (list 'b)))))
(list 'a (list 'b)) "AB" (list 'a (list 'b)) "AB"
(list 'q (list 'b)) "A" (list 'q (list 'b)) "A"
(list 'a 'x) "A" (list 'a 'x) "A"
@ -432,8 +444,8 @@
(for/list ((c (in-string "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"))) (for/list ((c (in-string "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")))
(define csym (string->symbol (string c))) (define csym (string->symbol (string c)))
(pattern->matcher csym (list csym ?)))) (pattern->matcher csym (list csym ?))))
(ror (foldr ror (rnull) ps) (matcher-union (foldr matcher-union (matcher-empty) ps)
(pattern->matcher '+ (list 'Z (list ? '- ?))))) (pattern->matcher '+ (list 'Z (list ? '- ?)))))
(void (pretty-print-matcher (bigdemo))) (void (pretty-print-matcher (bigdemo)))
(check-matches (check-matches
@ -460,25 +472,25 @@
(list 'b 'c 'd 'e 'f 'a) "" (list 'b 'c 'd 'e 'f 'a) ""
3 "") 3 "")
(void (pretty-print-matcher (rand (pattern->matcher 'A (list 'a)) (void (pretty-print-matcher (matcher-intersect (pattern->matcher 'A (list 'a))
(pattern->matcher 'B (list 'b))))) (pattern->matcher 'B (list 'b)))))
(let ((r1 (ror (pattern->matcher 'A (list ? 'b)) (let ((r1 (matcher-union (pattern->matcher 'A (list ? 'b))
(pattern->matcher 'A (list ? 'c)))) (pattern->matcher 'A (list ? 'c))))
(r2 (ror (pattern->matcher 'B (list 'a ?)) (r2 (matcher-union (pattern->matcher 'B (list 'a ?))
(pattern->matcher 'B (list 'b ?))))) (pattern->matcher 'B (list 'b ?)))))
(pretty-print-matcher (ror r1 r2)) (pretty-print-matcher (matcher-union r1 r2))
(pretty-print-matcher (ror r1 r1)) (pretty-print-matcher (matcher-union r1 r1))
(pretty-print-matcher (ror r2 r2)) (pretty-print-matcher (matcher-union r2 r2))
(pretty-print-matcher (rand r1 r2)) (pretty-print-matcher (matcher-intersect r1 r2))
(pretty-print-matcher (rand r1 r1)) (pretty-print-matcher (matcher-intersect r1 r1))
(pretty-print-matcher (rand r2 r2)) (pretty-print-matcher (matcher-intersect r2 r2))
(void)) (void))
(void (pretty-print-matcher (rand (bigdemo) (pattern->matcher 'X (list 'm 'n))))) (void (pretty-print-matcher (matcher-intersect (bigdemo) (pattern->matcher 'X (list 'm 'n)))))
(check-matches (check-matches
(pretty-print-matcher (rand (bigdemo) (pattern->matcher 'X (list 'Z ?)))) (pretty-print-matcher (matcher-intersect (bigdemo) (pattern->matcher 'X (list 'Z ?))))
(list 'a '-) "" (list 'a '-) ""
(list 'Z '-) "XZ" (list 'Z '-) "XZ"
(list '? '-) "" (list '? '-) ""
@ -498,24 +510,24 @@
(let* ((r1 (pattern->matcher 'A (list ? 'b))) (let* ((r1 (pattern->matcher 'A (list ? 'b)))
(r2 (pattern->matcher 'B (list 'a ?))) (r2 (pattern->matcher 'B (list 'a ?)))
(r12 (ror r1 r2))) (r12 (matcher-union r1 r2)))
(printf "\n-=-=-=-=-=-=-=-=- erase1\n") (printf "\n-=-=-=-=-=-=-=-=- erase1\n")
(pretty-print-matcher r1) (pretty-print-matcher r1)
(pretty-print-matcher r2) (pretty-print-matcher r2)
(pretty-print-matcher r12) (pretty-print-matcher r12)
;; TODO: these next two are not currently "minimal" ;; TODO: these next two are not currently "minimal"
(pretty-print-matcher (erase-path r1 r12)) (pretty-print-matcher (matcher-erase-path r1 r12))
(pretty-print-matcher (erase-path r2 r12)) (pretty-print-matcher (matcher-erase-path r2 r12))
(void)) (void))
(let* ((r1 (ror (pattern->matcher 'A (list 'a ?)) (let* ((r1 (matcher-union (pattern->matcher 'A (list 'a ?))
(pattern->matcher 'A (list 'b ?)))) (pattern->matcher 'A (list 'b ?))))
(r2 (pattern->matcher 'B (list 'b ?))) (r2 (pattern->matcher 'B (list 'b ?)))
(r12 (ror r1 r2))) (r12 (matcher-union r1 r2)))
(printf "\n-=-=-=-=-=-=-=-=- erase2\n") (printf "\n-=-=-=-=-=-=-=-=- erase2\n")
(pretty-print-matcher r12) (pretty-print-matcher r12)
(pretty-print-matcher (erase-path r1 r12)) (pretty-print-matcher (matcher-erase-path r1 r12))
(pretty-print-matcher (erase-path r2 r12)) (pretty-print-matcher (matcher-erase-path r2 r12))
(void)) (void))
) )
@ -525,8 +537,8 @@
(struct b (x) #:transparent) (struct b (x) #:transparent)
(define (intersect a b) (define (intersect a b)
(rand (pattern->matcher 'A a) (matcher-intersect (pattern->matcher 'A a)
(pattern->matcher 'B b))) (pattern->matcher 'B b)))
(define EAB (E 'A 'B)) (define EAB (E 'A 'B))