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

projection->pattern

This commit is contained in:
Tony Garnock-Jones 2014-05-21 21:02:38 -04:00
parent 6649689b8f
commit bfa9c9cfcb
2 changed files with 24 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
minimart/core.rkt
View File

@ -21,6 +21,7 @@
(struct-out capture)
pretty-print-matcher
matcher-key-set
projection->pattern
sub
pub

23
minimart/route.rkt
View File

@ -22,6 +22,7 @@
matcher-match-matcher
matcher-relabel
compile-projection
projection->pattern
matcher-project
matcher-key-set
pretty-print-matcher)
@ -429,6 +430,21 @@
[(? hash?) (error 'compile-projection "Cannot match on hash tables at present")]
[other (cons other acc)])))
(define (projection->pattern p)
(let walk ((p p))
(match p
[(capture sub) (walk sub)] ;; TODO: maybe enforce non-nesting here too?
[(cons p1 p2) (cons (walk p1) (walk p2))]
[(? vector? v) (for/vector [(e (in-vector v))] (walk e))]
[(? non-object-struct?)
(define-values (t skipped?) (struct-info p))
(when skipped? (error 'projection->pattern "Cannot reflect on struct instance ~v" p))
(define fs (cdr (vector->list (struct->vector p))))
(apply (struct-type-make-constructor t) (map walk fs))]
;; TODO: consider options for treating hash tables as compounds rather than (useless) atoms
[(? hash?) (error 'projection->pattern "Cannot match on hash tables at present")]
[other other])))
;; Matcher × CompiledProjection [× (Value -> (Option Value))] → Matcher
;; 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".
@ -1092,4 +1108,11 @@
(compile-projection (cons (?!) (?!)))
#:project-success (lambda (v) #t)))
(set '#(1 2) '#(3 4)))
(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 ?))
(check-equal? (projection->pattern (list 'a (?! 'b))) (list 'a 'b))
(check-equal? (projection->pattern (list 'a (?! (vector 'b)))) (list 'a (vector 'b)))
(check-equal? (projection->pattern (list 'a (?! (vector ? ?)))) (list 'a (vector ? ?)))
)