From b750a01e782c522cfb395536d0a01e01ae9aed53 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 20 May 2014 21:50:19 -0400 Subject: [PATCH] Switch gestalt representations to accommodate nmatcher (set #t) p) #f l ml)) -(define (pub p #:meta-level [ml 0] #:level [l 0]) - (simple-gestalt #f (pattern->matcher (set #t) p) l ml)) +(define (sub p #:meta-level [ml 0] #:level [l 0]) (simple-gestalt #f p l ml)) +(define (pub p #:meta-level [ml 0] #:level [l 0]) (simple-gestalt #t p l ml)) (define (spawn behavior state [gestalt (gestalt-empty)]) (process gestalt behavior state)) (define (send body #:meta-level [ml 0]) (message body ml #f)) @@ -191,13 +191,8 @@ (define (update-aggregate-gestalt w pid old-g new-g) (struct-copy world w [aggregate-gestalt - (gestalt-union (gestalt-combine-straight (world-aggregate-gestalt w) - old-g - (lambda (side x) - (case side - [(left-longer) x] - [(right-longer) '()])) - matcher-erase-path) + (gestalt-union (gestalt-erase-path (world-aggregate-gestalt w) + old-g) new-g)])) (define (issue-local-routing-update w relevant-gestalt) @@ -251,14 +246,14 @@ (define (dispatch-event e w) (match e [(message body meta-level feedback?) - (define matcher (gestalt-ref (world-aggregate-gestalt w) meta-level 0 feedback?)) - (define pids (matcher-match-value matcher body)) + (define matcher (gestalt-ref (world-aggregate-gestalt w) meta-level feedback?)) + (define pids (levels->pids (matcher-match-value matcher body '()))) (define pt (world-process-table w)) (for/fold ([w w]) [(pid (in-set pids))] (apply-transition pid (deliver-event e pid (hash-ref pt pid)) w))] [(routing-update affected-subgestalt) (define g (world-aggregate-gestalt w)) - (define-values (affected-pids uninteresting) (gestalt-match g affected-subgestalt)) + (define affected-pids (gestalt-match affected-subgestalt g)) (define pt (world-process-table w)) (for/fold ([w w]) [(pid (in-set affected-pids))] (define p (hash-ref pt pid)) diff --git a/minimart/examples/example-lang.rkt b/minimart/examples/example-lang.rkt index 38dd799..540d365 100644 --- a/minimart/examples/example-lang.rkt +++ b/minimart/examples/example-lang.rkt @@ -3,6 +3,21 @@ (require (only-in racket/port read-line-evt)) (require "../drivers/timer.rkt") +(define (quasi-spy e s) + (printf "----------------------------------------\n") + (printf "QUASI-SPY:\n") + (match e + [(routing-update g) (pretty-print-gestalt g)] + [other + (write other) + (newline)]) + (printf "========================================\n") + #f) +(spawn quasi-spy (void) (gestalt-union (sub ? #:level 10 #:meta-level 1) + (pub ? #:level 10 #:meta-level 1) + (sub ? #:level 10) + (pub ? #:level 10))) + (define (r e s) (match e [(message body _ _) (transition s (send `(print got ,body) #:meta-level 1))] @@ -32,7 +47,7 @@ [(routing-update g) (printf "EMPTY? ~v\n" (gestalt-empty? g)) (printf "REF:") - (pretty-print-matcher (gestalt-ref g 0 0 #f) #:indent 4) + (pretty-print-matcher (gestalt-ref g 0 #f) #:indent 4) (printf "INTERSECTED:\n") (pretty-print-gestalt (gestalt-filter g (pub (set-timer ? ? ?) #:level 1))) #f] diff --git a/minimart/examples/example-plain.rkt b/minimart/examples/example-plain.rkt index 7a38ff3..0de583b 100644 --- a/minimart/examples/example-plain.rkt +++ b/minimart/examples/example-plain.rkt @@ -5,6 +5,17 @@ (require "../main.rkt") (require "../drivers/timer.rkt") +(define (quasi-spy e s) + (printf "----------------------------------------\n") + (printf "QUASI-SPY:\n") + (match e + [(routing-update g) (pretty-print-gestalt g)] + [other + (write other) + (newline)]) + (printf "========================================\n") + #f) + (define (r e s) (match e [(message body _ _) (transition s (send `(print got ,body) #:meta-level 1))] @@ -28,7 +39,7 @@ [(routing-update g) (printf "EMPTY? ~v\n" (gestalt-empty? g)) (printf "REF:") - (pretty-print-matcher (gestalt-ref g 0 0 #f) #:indent 4) + (pretty-print-matcher (gestalt-ref g 0 #f) #:indent 4) (printf "INTERSECTED:\n") (pretty-print-gestalt (gestalt-filter g (pub (set-timer ? ? ?) #:level 1))) #f] @@ -46,7 +57,11 @@ #f] [_ #f])) -(run-ground (spawn-timer-driver) +(run-ground (spawn quasi-spy (void) (gestalt-union (sub ? #:level 10 #:meta-level 1) + (pub ? #:level 10 #:meta-level 1) + (sub ? #:level 10) + (pub ? #:level 10))) + (spawn-timer-driver) (send (set-timer 'tick 1000 'relative)) (spawn ticker 1 (gestalt-union (pub (set-timer ? ? ?) #:level 1) (sub (timer-expired 'tick ?)))) diff --git a/minimart/gestalt.rkt b/minimart/gestalt.rkt index 2cf76d9..2b25dc6 100644 --- a/minimart/gestalt.rkt +++ b/minimart/gestalt.rkt @@ -10,30 +10,35 @@ gestalt-ref compile-gestalt-projection gestalt-project - gestalt-project-key-set + matcher-project-level + levels->pids drop-gestalt lift-gestalt simple-gestalt gestalt-empty gestalt-empty? - gestalt-combine - gestalt-combine-straight - gestalt-combine-crossed gestalt-union gestalt-filter gestalt-match + gestalt-erase-path strip-gestalt-label label-gestalt pretty-print-gestalt) -;; A Gestalt is a (gestalt (Listof (Listof (Pairof Matcher -;; Matcher)))), representing the total interests of a process or group -;; of processes. The outer list has a present entry for each active -;; metalevel, starting with metalevel 0 in the car. The inner lists -;; each have an entry for each active observer level at their -;; metalevel. The innermost pairs have cars holding matchers -;; representing active subscriptions, and cdrs representing active -;; advertisements. +;; A Gestalt is a (gestalt (Listof (Pairof Matcher Matcher))), +;; representing the total interests of a process or group of +;; processes. The outer list has a present entry for each active +;; metalevel, starting with metalevel 0 in the car. The inner pairs +;; have cars holding matchers representing active subscriptions, and +;; cdrs representing active advertisements. Each of the Matchers maps +;; to (Listof (Option (Setof PID))), with the nth entry in the list +;; corresponding to level n, and #f corresponding to empty-set. +;; +;; So, +;; - metalevels: entries in the outermost list. +;; - sub/adv: car or cdr of each inner pair, respectively. +;; - levels: entries in the list at each Matcher success value. +;; ;; ;; "... a few standardised subsystems, identical from citizen to ;; citizen. Two of these were channels for incoming data — one for @@ -44,8 +49,9 @@ ;; (struct gestalt (metalevels) #:prefab) -;; Convention: A GestaltSet is a Gestalt where all the patterns map to -;; #t rather than a PID or any other value. +;; Convention: A GestaltSet is a Gestalt where all the Matchers map to +;; (Listof (Option #t)) rather than the (Listof (Option (Setof PID))) +;; described above or any other value. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -55,64 +61,78 @@ ['() (fail-thunk)] [(cons x xs) (if (zero? n) x (loop xs (- n 1)))]))) +(define (safe-take gcons xs n) + (let walk ((xs xs) (n n)) + (cond [(null? xs) '()] + [(zero? n) '()] + [else (gcons (car xs) (walk (cdr xs) (- n 1)))]))) + (define (safe-cdr xs) (if (null? xs) '() (cdr xs))) -(define (gestalt-ref g metalevel level get-advertisements?) - (define v (safe-list-ref (gestalt-metalevels g) metalevel (lambda () '()))) - (define p (safe-list-ref v level (lambda () '(#f . #f)))) - ((if get-advertisements? cdr car) p)) +(define ((guarded-cons unit) a d) + (if (and (null? d) (equal? a unit)) + '() + (cons a d))) + +(define cons-level (guarded-cons #f)) +(define cons-metalevel (guarded-cons '(#f . #f))) + +;; Gestalt × Natural × Boolean → Matcher +(define (gestalt-ref g metalevel get-advertisements?) + (define v (safe-list-ref (gestalt-metalevels g) metalevel (lambda () '(#f . #f)))) + ((if get-advertisements? cdr car) v)) (define (compile-gestalt-projection spec) (compile-projection spec)) -(define (gestalt-project g metalevel level get-advertisements? capture-spec) - (matcher-project (gestalt-ref g metalevel level get-advertisements?) capture-spec)) +;; Limits the given matcher to only include keys when a subscription +;; at *exactly* the given level exists. +(define (matcher-project-level m level) + (matcher-relabel m (lambda (v) (and (safe-list-ref v level (lambda () #f)) #t)))) -(define (gestalt-project-key-set g metalevel level get-advertisements? capture-spec) - (matcher-key-set (gestalt-project g metalevel level get-advertisements? capture-spec))) +(define (gestalt-project g metalevel get-advertisements? capture-spec) + (matcher-project (gestalt-ref g metalevel get-advertisements?) capture-spec)) + +(define (levels->pids ls) + (foldl (lambda (e acc) (if e (set-union e acc) acc)) (set) ls)) (define (drop-gestalt g) - (match-define (gestalt metalevels) g) - (if (null? metalevels) g (gestalt (cdr metalevels)))) + (gestalt (safe-cdr (gestalt-metalevels g)))) (define (lift-gestalt g) - (gestalt (cons '#() (gestalt-metalevels g)))) + (gestalt (cons-metalevel '(#f . #f) (gestalt-metalevels g)))) (define (prepend n x xs) (if (zero? n) xs (cons x (prepend (- n 1) x xs)))) -(define (simple-gestalt subs advs level metalevel) - (gestalt (prepend metalevel '() (list (prepend level '(#f . #f) (list (cons subs advs))))))) +(define (simple-gestalt is-adv? p level metalevel) + (define m (pattern->matcher (prepend level #f (list #t)) p)) + (gestalt (prepend metalevel '(#f . #f) (list (if is-adv? (cons #f m) (cons m #f)))))) (define (gestalt-empty) (gestalt '())) (define (gestalt-empty? g) - (andmap (lambda (ls) (andmap (lambda (l) (and (matcher-empty? (car l)) (matcher-empty? (cdr l)))) ls)) + (andmap (lambda (ml) (and (matcher-empty? (car ml)) (matcher-empty? (cdr ml)))) (gestalt-metalevels g))) -(define (map-zip imbalance-handler item-handler right-unit ls1 ls2) +(define (map-zip imbalance-handler item-handler gcons ls1 ls2) (let walk ((ls1 ls1) (ls2 ls2)) (match* (ls1 ls2) [('() '()) '()] [('() ls) (imbalance-handler 'right-longer ls)] [(ls '()) (imbalance-handler 'left-longer ls)] [((cons l1 ls1) (cons l2 ls2)) - (define new-item (item-handler l1 l2)) - (define new-tail (walk ls1 ls2)) - (if (and (null? new-tail) (equal? new-item right-unit)) - '() - (cons new-item new-tail))]))) + (gcons (item-handler l1 l2) (walk ls1 ls2))]))) (define (gestalt-combine g1 g2 imbalance-handler matcher-pair-combiner) - (define (yu ls1 ls2) (map-zip imbalance-handler matcher-pair-combiner '(#f . #f) ls1 ls2)) - (define (xu mls1 mls2) (map-zip imbalance-handler yu '() mls1 mls2)) - (gestalt (xu (gestalt-metalevels g1) - (gestalt-metalevels g2)))) + (gestalt (map-zip imbalance-handler matcher-pair-combiner cons-metalevel + (gestalt-metalevels g1) + (gestalt-metalevels g2)))) (define (gestalt-combine-straight g1 g2 imbalance-handler matcher-combiner) (gestalt-combine g1 g2 @@ -128,9 +148,19 @@ (cons (matcher-combiner (car sa1) (cdr sa2)) (matcher-combiner (car sa2) (cdr sa1)))))) -(define (gestalt-union1 g1 g2) (gestalt-combine-straight g1 g2 - (lambda (side x) x) - matcher-union)) +(define (empty->false s) (if (set-empty? s) #f s)) + +(define (union-levels m1 m2) + (matcher-union m1 m2 + #:combine + (lambda (ls1 ls2) + (map-zip (lambda (side x) x) + (lambda (s1 s2) (empty->false (set-union (or s1 (set)) (or s2 (set))))) + cons-level + ls1 + ls2)))) + +(define (gestalt-union1 g1 g2) (gestalt-combine-straight g1 g2 (lambda (side x) x) union-levels)) (define (gestalt-union . gs) (if (null? gs) @@ -140,62 +170,103 @@ [(list g) g] [(cons g rest) (gestalt-union1 g (walk rest))])))) +(define (filter-levels ls1 ls2) + (define r (safe-take cons-level ls1 (- (length ls2) 1))) + (if (null? r) #f r)) +(define (filter-matchers m1 m2) (matcher-intersect m1 m2 #:combine filter-levels)) + ;; View on g1 from g2's perspective. ;; Drops a level from g2 and intersects crossed. (define (gestalt-filter g1 g2) - (gestalt-combine-crossed g1 - (gestalt (map safe-cdr (gestalt-metalevels g2))) - (lambda (side x) '()) - (lambda (g1 g2) (matcher-intersect g1 g2 - #:combine (lambda (v1 v2) v1))))) + (gestalt-combine-crossed g1 g2 (lambda (side x) '()) filter-matchers)) +;; Here we want all pids in sets in ls2 such that there are some pids +;; at lower levels in ls1. +(define (match-combine-levels ls1 ls2 acc) + (let loop ((ls1 ls1) (ls2 ls2)) + (cond + [(null? ls1) acc] + [(null? ls2) acc] + [(not (car ls1)) (loop (cdr ls1) (cdr ls2))] + [else ;; aha! here's a real sub/adv in ls1. The remaining + ;; sub/advs in (cdr ls2) can see it. + (levels->pids (cdr ls2))]))) + +;; Much like gestalt-filter, takes a view on gestalt g1 from g2's +;; perspective. However, instead of returning the filtered g1, returns +;; just the set of values in the g2-map that were overlapped by some +;; part of g1. (define (gestalt-match g1 g2) - (define (zu sa1 sa2) - (define-values (a1 a2) (matcher-match-matcher (car sa1) (car sa2))) - (define-values (d1 d2) (matcher-match-matcher (cdr sa1) (cdr sa2))) - (values (set-union a1 d1) (set-union a2 d2))) - (define (mz xs1 xs2 f) - (match* (xs1 xs2) - [('() xs) (values (set) (set))] - [(xs '()) (values (set) (set))] - [((cons x1 xs1) (cons x2 xs2)) - (define-values (r1 r2) (mz xs1 xs2 f)) - (define-values (v1 v2) (f x1 x2)) - (values (set-union v1 r1) (set-union v2 r2))])) - (define (yu ls1 ls2) (mz ls1 ls2 zu)) - (define (xu mls1 mls2) (mz mls1 mls2 yu)) - (xu (gestalt-metalevels g1) - (gestalt-metalevels g2))) + (let loop ((mls1 (gestalt-metalevels g1)) + (mls2 (gestalt-metalevels g2))) + (cond [(null? mls1) (set)] + [(null? mls2) (set)] + [else (match-define (cons subs1 advs1) (car mls1)) + (match-define (cons subs2 advs2) (car mls2)) + (let* ((acc (loop (cdr mls1) (cdr mls2))) + (acc (matcher-match-matcher subs1 advs2 + #:combine match-combine-levels + #:empty acc)) + (acc (matcher-match-matcher advs1 subs2 + #:combine match-combine-levels + #:empty acc))) + acc)]))) + +(define (erase-imbalance-handler side x) + (case side + [(left-longer) x] + [(right-longer) '()])) + +(define (erase-levels ls1 ls2) + (map-zip erase-imbalance-handler + (lambda (v1 v2) (empty->false (set-subtract (or v1 (set)) (or v2 (set))))) + cons-level + ls1 + ls2)) + +(define (gestalt-erase-path g1 g2) + (gestalt-combine-straight g1 g2 + erase-imbalance-handler + (lambda (m1 m2) (matcher-erase-path m1 m2 #:combine erase-levels)))) + +(define ((guarded-map gcons) f xs) + (foldr (lambda (e acc) (gcons (f e) acc)) '() xs)) + +(define map-metalevels (guarded-map cons-metalevel)) (define (gestalt-matcher-transform g f) - (define (zu sa) (cons (f (car sa)) (f (cdr sa)))) - (define (yu ls) (map zu ls)) - (define (xu mls) (map yu mls)) - (gestalt (xu (gestalt-metalevels g)))) + (gestalt (map-metalevels (lambda (p) (cons (f (car p)) (f (cdr p)))) + (gestalt-metalevels g)))) (define (strip-gestalt-label g) - (gestalt-matcher-transform g (lambda (m) (matcher-relabel m (lambda (old) (set #t)))))) + (define (xform ls) (map (lambda (l) (and l #t)) ls)) + (gestalt-matcher-transform g (lambda (m) (matcher-relabel m xform)))) (define (label-gestalt g pid) - (gestalt-matcher-transform g (lambda (m) (matcher-relabel m (lambda (old) (set pid)))))) + (define pidset (set pid)) + (define (xform ls) (map (lambda (l) (and l pidset)) ls)) + (gestalt-matcher-transform g (lambda (m) (matcher-relabel m xform)))) (define (pretty-print-gestalt g [port (current-output-port)]) - (for [(metalevel (in-naturals)) (ls (in-list (gestalt-metalevels g)))] - (for [(level (in-naturals)) (l (in-list ls))] - (match-define (cons subs advs) l) - (when (or subs advs) - (fprintf port "GESTALT metalevel ~v level ~v:\n" metalevel level) - (when subs (fprintf port " - subs:") (pretty-print-matcher subs port #:indent 9)) - (when advs (fprintf port " - advs:") (pretty-print-matcher advs port #:indent 9)))))) + (for [(metalevel (in-naturals)) (p (in-list (gestalt-metalevels g)))] + (match-define (cons subs advs) p) + (when (or subs advs) + (fprintf port "GESTALT metalevel ~v:\n" metalevel) + (when subs (fprintf port " - subs:") (pretty-print-matcher subs port #:indent 9)) + (when advs (fprintf port " - advs:") (pretty-print-matcher advs port #:indent 9))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (module+ test (require rackunit) - (check-equal? (simple-gestalt 'a 'b 0 0) - (gestalt (list (list (cons 'a 'b))))) - (check-equal? (simple-gestalt 'a 'b 2 2) - (gestalt (list '() '() (list '(#f . #f) - '(#f . #f) - (cons 'a 'b)))))) + (check-equal? (gestalt-union (simple-gestalt #f 'a 0 0) + (simple-gestalt #t 'b 0 0)) + (gestalt (list (cons (pattern->matcher (list #t) 'a) + (pattern->matcher (list #t) 'b))))) + (check-equal? (gestalt-union (simple-gestalt #f 'a 2 2) + (simple-gestalt #t 'b 2 2)) + (gestalt (list (cons #f #f) + (cons #f #f) + (cons (pattern->matcher (list #f #f #t) 'a) + (pattern->matcher (list #f #f #t) 'b)))))) diff --git a/minimart/ground.rkt b/minimart/ground.rkt index e009a06..c1156fe 100644 --- a/minimart/ground.rkt +++ b/minimart/ground.rkt @@ -16,7 +16,8 @@ (define event-projection (compile-gestalt-projection (event ?! ?))) (define (extract-active-events gestalt) - (define es (gestalt-project-key-set gestalt 0 0 #f event-projection)) + (define es + (matcher-key-set (matcher-project-level (gestalt-project gestalt 0 #f event-projection) 0))) ;; TODO: how should the following error be handled, ideally? ;; In principle, security restrictions should make it impossible. ;; But absent those, what should be done? Should an offending diff --git a/minimart/route.rkt b/minimart/route.rkt index 8d470c4..01b9150 100644 --- a/minimart/route.rkt +++ b/minimart/route.rkt @@ -347,63 +347,57 @@ [k (walk rest stack k)])])])))) (define (matcher-match-matcher re1 re2 - #:combine [combine-successes set-union] - #:empty [result-nil (set)]) + #:combine [combine-successes (lambda (v1 v2 a) + (cons (set-union (car a) v1) + (set-union (cdr a) v2)))] + #:empty [result-nil (cons (set) (set))]) (let () - (define (walk re1 re2 acc1 acc2) + (define (walk re1 re2 acc) (match* (re1 re2) - [((wildcard-sequence r1) (wildcard-sequence r2)) (walk r1 r2 acc1 acc2)] - [((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2 acc1 acc2)] - [(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2) acc1 acc2)] - [((success v1) (success v2)) (values (combine-successes acc1 v1) - (combine-successes acc2 v2))] + [((wildcard-sequence r1) (wildcard-sequence r2)) (walk r1 r2 acc)] + [((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2 acc)] + [(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2) acc)] + [((success v1) (success v2)) (combine-successes v1 v2 acc)] [((? hash? h1) (? hash? h2)) (define w1 (rlookup h1 ?)) (define w2 (rlookup h2 ?)) - (define-values (r1 r2) (if (and w1 w2) - (walk w1 w2 acc1 acc2) - (values acc1 acc2))) - (define (examine-key r1 r2 key) + (define r (if (and w1 w2) + (walk w1 w2 acc) + acc)) + (define (examine-key r key) (match* ((rlookup h1 key) (rlookup h2 key)) - [(#f #f) (values r1 r2)] - [(#f k2) - (define-values (rr1 rr2) (walk-wild w1 key k2 r1 r2)) - (values rr1 rr2)] - [(k1 #f) - (define-values (rr2 rr1) (walk-wild w2 key k1 r2 r1)) - (values rr1 rr2)] - [(k1 k2) (walk k1 k2 r1 r2)])) + [(#f #f) r] + [(#f k2) (walk-wild walk w1 key k2 r)] + [(k1 #f) (walk-wild (lambda (re2 re1 acc) (walk re1 re2 acc)) w2 key k1 r)] + [(k1 k2) (walk k1 k2 r)])) ;; We optimize as described in matcher-intersect. (match* (w1 w2) - [(#f #f) (for/fold [(r1 r1) (r2 r2)] [(key (in-hash-keys (smaller-hash h1 h2)))] - (examine-key r1 r2 key))] - [(#f _) (for/fold [(r1 r1) (r2 r2)] [(key (in-hash-keys h1))] (examine-key r1 r2 key))] - [(_ #f) (for/fold [(r1 r1) (r2 r2)] [(key (in-hash-keys h2))] (examine-key r1 r2 key))] - [(_ _) (for/fold [(r1 r1) (r2 r2)] [(key (set-remove (set-union (hash-keys h1) - (hash-keys h2)) - ?))] - (examine-key r1 r2 key))])])) - (define (walk-wild w key k acc1 acc2) + [(#f #f) (for/fold [(r r)] [(key (in-hash-keys (smaller-hash h1 h2)))] (examine-key r key))] + [(#f _) (for/fold [(r r)] [(key (in-hash-keys h1))] (examine-key r key))] + [(_ #f) (for/fold [(r r)] [(key (in-hash-keys h2))] (examine-key r key))] + [(_ _) (for/fold [(r r)] [(key (set-remove (set-union (hash-keys h1) (hash-keys h2)) ?))] + (examine-key r key))])])) + (define (walk-wild walker w key k acc) (if w (cond - [(key-open? key) (walk (rwildseq w) k acc1 acc2)] + [(key-open? key) (walker (rwildseq w) k acc)] [(key-close? key) (if (wildcard-sequence? w) - (walk (wildcard-sequence-matcher w) k acc1 acc2) - (values acc1 acc2))] - [else (walk w k acc1 acc2)]) - (values acc1 acc2))) + (walker (wildcard-sequence-matcher w) k acc) + acc)] + [else (walker w k acc)]) + acc)) (match* (re1 re2) - [(#f r) (values result-nil result-nil)] - [(r #f) (values result-nil result-nil)] - [(r1 r2) (walk r1 r2 result-nil result-nil)]))) + [(#f r) result-nil] + [(r #f) result-nil] + [(r1 r2) (walk r1 r2 result-nil)]))) (define (matcher-relabel m f) (let walk ((m m)) (match m [#f #f] - [(success v) (success (f v))] - [(wildcard-sequence m1) (wildcard-sequence (walk m1))] - [(? hash?) (for/hash [((k v) (in-hash m))] (values k (walk v)))]))) + [(success v) (rsuccess (f v))] + [(wildcard-sequence m1) (rwildseq (walk m1))] + [(? hash?) (for/fold [(acc #f)] [((k v) (in-hash m))] (rupdate acc k (walk v)))]))) (define (compile-projection p) ;; Extremely similar to pattern->matcher. Besides use of conses @@ -928,7 +922,7 @@ (module+ test (define (matcher-match-matcher-list m1 m2) - (define-values (s1 s2) (matcher-match-matcher m1 m2)) + (match-define (cons s1 s2) (matcher-match-matcher m1 m2)) (list s1 s2)) (let ((abc (foldr matcher-union (matcher-empty) (list (pattern->matcher SA (list 'a ?)) @@ -940,6 +934,10 @@ (pattern->matcher SD (list 'd ?)))))) (check-equal? (matcher-match-matcher-list abc abc) (list (set 'A 'B 'C) (set 'A 'B 'C))) + (check-equal? (matcher-match-matcher abc abc + #:combine (lambda (v1 v2 a) (set-union v2 a)) + #:empty (set)) + (set 'A 'B 'C)) (check-equal? (matcher-match-matcher-list abc (matcher-relabel bcd (lambda (old) (set #t)))) (list (set 'B 'C) (set #t))) (check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo ?))