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

Simplify matcher-project

This commit is contained in:
Tony Garnock-Jones 2014-06-14 13:10:27 -04:00
parent 1faa122c49
commit 9b05906efb
1 changed files with 57 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

143
minimart/route.rkt
View File

@ -682,100 +682,71 @@
;; Matcher × CompiledProjection -> Matcher ;; Matcher × CompiledProjection -> Matcher
;; The result matches a sequence of inputs of length equal to the number of captures. ;; The result matches a sequence of inputs of length equal to the number of captures.
(define matcher-project (define matcher-project
;; TODO: skip-nested, capture-nested, and various cases in walk all
;; share a suspicious amount of code. Refactor it away.
(let () (let ()
(define (skip-nested m k) (define (drop-match m spec) (general-match values drop-edge drop-sigma drop-balanced m spec))
(match m (define (take-match m spec) (general-match rwild rupdate rseq take-balanced m spec))
[(wildcard-sequence mk) (k mk)]
[(? hash?)
(for/fold [(acc (skip-nested (rlookup m ?) k))] [((key mk) (in-hash m))]
(if (eq? key ?)
acc
(matcher-union acc (cond
[(key-open? key)
(skip-nested mk (lambda (mk) (skip-nested mk k)))]
[(key-close? key) (k mk)]
[else (skip-nested mk k)]))))]
[_ (matcher-empty)]))
(define (capture-nested m k) (define (drop-balanced m k) (general-balanced values values drop-edge m k))
(match m (define (take-balanced m k) (general-balanced rwildseq rwild rupdate m k))
[(wildcard-sequence mk) (rwildseq (k mk))]
[(? hash?)
(for/fold [(acc (rwild (capture-nested (rlookup m ?) k)))] [((key mk) (in-hash m))]
(if (eq? key ?)
acc
(cond
[(key-open? key)
(rupdate acc key (capture-nested mk (lambda (mk) (capture-nested mk k))))]
[(key-close? key) (rupdate acc key (k mk))]
[else (rupdate acc key (capture-nested mk k))])))]
[_ (matcher-empty)]))
;; Boolean Matcher CompiledProjection -> Matcher (define (drop-edge acc key k) (matcher-union acc k))
(define (walk capturing? m spec) (define (drop-sigma sigma k) k)
(match spec
['()
(when capturing? (error 'matcher-project "Bad specification: unclosed capture"))
(match m
[(success v) (rseq EOS (rsuccess ((matcher-project-success) v)))]
[_ (matcher-empty)])]
[(cons (== EOC) k) (define (general-match add-wild add-edge add-sigma balanced m spec)
(when (not capturing?) (error 'matcher-project "Bad specification: unexpected EOC")) (let walk ((m m) (spec spec))
(walk #f m k)] (match spec
['()
(match m
[(success v) (rseq EOS (rsuccess ((matcher-project-success) v)))]
[_ (matcher-empty)])]
[(cons (== SOC) k) [(cons (== EOC) k) (drop-match m k)]
(when capturing? (error 'matcher-project "Bad specification: nested capture")) [(cons (== SOC) k) (take-match m k)]
(walk #t m k)]
[(cons (== ?) k) [(cons (== ?) k)
(match m (match m
[(wildcard-sequence _) [(wildcard-sequence _) (add-wild (walk m k))]
((if capturing? rwild values) (walk capturing? m k))] [(? hash?)
[(? hash?) (for/fold [(acc (add-wild (walk (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))] (add-edge acc key (cond
(if (eq? key ?) [(key-open? key) (balanced mk (lambda (mk) (walk mk k)))]
acc [(key-close? key) #f]
(cond [else (walk mk k)]))))]
[(key-open? key) [_ (matcher-empty)])]
(rupdate acc key (capture-nested mk (lambda (mk)
(walk capturing? mk k))))]
[(key-close? key) acc]
[else (rupdate acc key (walk capturing? mk k))])))
(for/fold [(acc (walk capturing? (rlookup m ?) k))] [((key mk) (in-hash m))]
(if (eq? key ?)
acc
(matcher-union acc (cond
[(key-open? key)
(skip-nested mk (lambda (mk) (walk capturing? mk k)))]
[(key-close? key) #f]
[else (walk capturing? mk k)])))))]
[_ (matcher-empty)])]
[(cons sigma k) [(cons sigma k)
((if capturing? (add-sigma sigma
(lambda (m1) (rseq sigma m1)) (match m
values) [(wildcard-sequence mk)
(match m (cond
[(wildcard-sequence mk) [(key-open? sigma) (walk (rwildseq m) k)]
(cond [(key-close? sigma) (walk mk k)]
[(key-open? sigma) (walk capturing? (rwildseq m) k)] [else (walk m k)])]
[(key-close? sigma) (walk capturing? mk k)] [(? hash?)
[else (walk capturing? m k)])] (matcher-union (walk (rlookup m sigma) k)
[(? hash?) (cond
(matcher-union (walk capturing? (rlookup m sigma) k) [(key-open? sigma) (walk (rwildseq (rlookup m ?)) k)]
(cond [(key-close? sigma) #f]
[(key-open? sigma) (walk capturing? (rwildseq (rlookup m ?)) k)] [else (walk (rlookup m ?) k)]))]
[(key-close? sigma) #f] [_ (matcher-empty)]))])))
[else (walk capturing? (rlookup m ?) k)]))]
[_ (matcher-empty)]))]))
(lambda (m spec) (define (general-balanced add-wildseq add-wild add-edge m k)
(walk #f m spec)))) (let walk ((m m) (k k))
(match m
[(wildcard-sequence mk) (add-wildseq (k mk))]
[(? hash?)
(for/fold [(acc (add-wild (walk (rlookup m ?) k)))] [((key mk) (in-hash m))]
(if (eq? key ?)
acc
(add-edge acc key (cond
[(key-open? key) (walk mk (lambda (mk) (walk mk k)))]
[(key-close? key) (k mk)]
[else (walk mk k)]))))]
[_ (matcher-empty)])))
drop-match))
;; (Listof Sigma) -> (Listof Sigma) ;; (Listof Sigma) -> (Listof Sigma)
;; Hackish support for improper lists. TODO: revisit ;; Hackish support for improper lists. TODO: revisit