2018-04-29 13:54:14 +00:00
|
|
|
#lang racket/base
|
|
|
|
;; Like pattern.rkt, but for dynamic use rather than compile-time use.
|
|
|
|
|
|
|
|
(provide term->skeleton
|
|
|
|
term->skeleton-proj
|
|
|
|
term->key
|
|
|
|
term->capture-proj
|
2018-08-13 20:32:51 +00:00
|
|
|
instantiate-term->value
|
|
|
|
term-intersect)
|
2018-04-29 13:54:14 +00:00
|
|
|
|
|
|
|
(require racket/match)
|
|
|
|
(require syndicate/support/struct)
|
|
|
|
(require "pattern.rkt")
|
|
|
|
|
|
|
|
(define (term->skeleton t)
|
|
|
|
(let walk ((t t))
|
|
|
|
(match t
|
|
|
|
[(capture detail)
|
|
|
|
(walk detail)]
|
|
|
|
[(discard)
|
|
|
|
#f]
|
|
|
|
[(? non-object-struct?)
|
|
|
|
(cons (struct->struct-type t) (map walk (cdr (vector->list (struct->vector t)))))]
|
|
|
|
[(? list?)
|
|
|
|
(cons 'list (map walk t))]
|
2018-05-01 19:57:22 +00:00
|
|
|
[(? vector?)
|
|
|
|
(cons 'vector (map walk (vector->list t)))]
|
2018-04-29 13:54:14 +00:00
|
|
|
[atom
|
|
|
|
#f])))
|
|
|
|
|
|
|
|
(define (select-term-leaves t capture-fn atom-fn)
|
|
|
|
(define (walk-node key-rev t)
|
|
|
|
(match t
|
|
|
|
[(capture detail)
|
|
|
|
(append (capture-fn key-rev) (walk-node key-rev detail))]
|
|
|
|
[(discard)
|
|
|
|
(list)]
|
|
|
|
[(? non-object-struct?)
|
|
|
|
(walk-edge 0 key-rev (cdr (vector->list (struct->vector t))))]
|
|
|
|
[(? list?)
|
|
|
|
(walk-edge 0 key-rev t)]
|
2018-05-01 19:57:22 +00:00
|
|
|
[(? vector?)
|
|
|
|
(walk-edge 0 key-rev (vector->list t))]
|
2018-04-29 13:54:14 +00:00
|
|
|
[atom
|
|
|
|
(atom-fn key-rev atom)]))
|
|
|
|
|
|
|
|
(define (walk-edge index key-rev pieces)
|
|
|
|
(match pieces
|
|
|
|
['() '()]
|
|
|
|
[(cons p pieces) (append (walk-node (cons index key-rev) p)
|
|
|
|
(walk-edge (+ index 1) key-rev pieces))]))
|
|
|
|
|
2018-10-20 17:27:15 +00:00
|
|
|
(walk-node '() t))
|
2018-04-29 13:54:14 +00:00
|
|
|
|
|
|
|
(define (term->skeleton-proj t)
|
|
|
|
(select-term-leaves t
|
|
|
|
(lambda (key-rev) (list))
|
|
|
|
(lambda (key-rev atom) (list (reverse key-rev)))))
|
|
|
|
|
|
|
|
(define (term->key t)
|
|
|
|
(select-term-leaves t
|
|
|
|
(lambda (key-rev) (list))
|
|
|
|
(lambda (key-rev atom) (list atom))))
|
|
|
|
|
|
|
|
(define (term->capture-proj t)
|
|
|
|
(select-term-leaves t
|
|
|
|
(lambda (key-rev) (list (reverse key-rev)))
|
|
|
|
(lambda (key-rev atom) (list))))
|
|
|
|
|
2018-08-13 20:32:51 +00:00
|
|
|
(define (struct-fields t)
|
|
|
|
(cdr (vector->list (struct->vector t))))
|
|
|
|
|
|
|
|
(define (struct-map f t)
|
|
|
|
(apply (struct-type-make-constructor (struct->struct-type t))
|
|
|
|
(map f (struct-fields t))))
|
|
|
|
|
2018-04-29 13:54:14 +00:00
|
|
|
(define (instantiate-term->value t actuals)
|
|
|
|
(define (pop-actual!)
|
|
|
|
(define v (car actuals))
|
|
|
|
(set! actuals (cdr actuals))
|
|
|
|
v)
|
|
|
|
|
|
|
|
(define (pop-captures! t)
|
|
|
|
(match t
|
|
|
|
[(capture detail)
|
|
|
|
(pop-actual!)
|
|
|
|
(pop-captures! detail)]
|
|
|
|
[(discard)
|
|
|
|
(void)]
|
|
|
|
[(? non-object-struct?)
|
2018-08-13 20:32:51 +00:00
|
|
|
(for-each pop-captures! (struct-fields t))]
|
2018-04-29 13:54:14 +00:00
|
|
|
[(? list?)
|
|
|
|
(for-each pop-captures! t)]
|
2018-05-01 19:57:22 +00:00
|
|
|
[(? vector?)
|
|
|
|
(for [(tt (in-vector t))] (pop-captures! tt))]
|
2018-04-29 13:54:14 +00:00
|
|
|
[_ (void)]))
|
|
|
|
|
|
|
|
(define (walk t)
|
|
|
|
(match t
|
|
|
|
[(capture detail)
|
|
|
|
(begin0 (pop-actual!)
|
|
|
|
(pop-captures! detail))] ;; to consume nested bindings
|
|
|
|
[(discard)
|
|
|
|
(discard)]
|
|
|
|
[(? non-object-struct?)
|
2018-08-13 20:32:51 +00:00
|
|
|
(struct-map walk t)]
|
2018-04-29 13:54:14 +00:00
|
|
|
[(? list?)
|
|
|
|
(map walk t)]
|
2018-05-01 19:57:22 +00:00
|
|
|
[(? vector?)
|
|
|
|
(for/vector [(tt t)] (walk tt))]
|
2018-04-29 13:54:14 +00:00
|
|
|
[other other]))
|
|
|
|
|
|
|
|
(walk t))
|
2018-08-13 20:32:51 +00:00
|
|
|
|
|
|
|
;; Omits captures.
|
|
|
|
(define (term-intersect t1 t2 ks kf)
|
|
|
|
(define (walk-lists xs1 xs2 ks)
|
|
|
|
(let inner ((xs1 xs1) (xs2 xs2) (acc '()))
|
|
|
|
(match* (xs1 xs2)
|
|
|
|
[('() '())
|
|
|
|
(ks (reverse acc))]
|
|
|
|
[((cons x1 xs1) (cons x2 xs2))
|
|
|
|
(walk x1 x2 (lambda (v) (inner xs1 xs2 (cons v acc))))]
|
|
|
|
[(_ _)
|
|
|
|
(kf)])))
|
|
|
|
(define (walk t1 t2 ks)
|
|
|
|
(match* (t1 t2)
|
|
|
|
[((capture d1) d2) (walk d1 d2 ks)]
|
|
|
|
[(d1 (capture d2)) (walk d1 d2 ks)]
|
|
|
|
[((discard) other) (ks other)]
|
|
|
|
[(other (discard)) (ks other)]
|
|
|
|
[((? non-object-struct?) (? non-object-struct?))
|
|
|
|
(define ty (struct->struct-type t1))
|
|
|
|
(if (eq? ty (struct->struct-type t2))
|
|
|
|
(walk-lists (struct-fields t1)
|
|
|
|
(struct-fields t2)
|
|
|
|
(lambda (vs) (ks (apply (struct-type-make-constructor ty) vs))))
|
|
|
|
(kf))]
|
|
|
|
[('() '()) (ks '())]
|
|
|
|
[((cons d1 t1) (cons d2 t2))
|
|
|
|
(walk d1 d2 (lambda (a) (walk t1 t2 (lambda (d) (ks (cons a d))))))]
|
|
|
|
[((? vector?) (? vector?))
|
|
|
|
(walk-lists (vector->list t1)
|
|
|
|
(vector->list t2)
|
|
|
|
(lambda (vs) (ks (list->vector vs))))]
|
|
|
|
[(_ _)
|
|
|
|
(if (equal? t1 t2)
|
|
|
|
(ks t1)
|
|
|
|
(kf))]))
|
|
|
|
(walk t1 t2 ks))
|
|
|
|
|
|
|
|
(module+ test
|
|
|
|
(require rackunit)
|
|
|
|
(check-equal? (term-intersect (list 'a 'b 'c) (list 'a 'b 'c) values void) (list 'a 'b 'c))
|
|
|
|
(check-equal? (term-intersect (list 'a 'b 'c) (list 'a 'c 'b) values void) (void))
|
|
|
|
(check-equal? (term-intersect (list 'a 'b 'c) (list 'a (discard) 'c) values void) (list 'a 'b 'c))
|
|
|
|
(check-equal? (term-intersect (list 'a (discard) 'c) (list 'a 'b 'c) values void) (list 'a 'b 'c))
|
|
|
|
(check-equal? (term-intersect (list 'a (discard) 'c) (list 'a 'b (discard)) values void)
|
|
|
|
(list 'a 'b 'c))
|
|
|
|
(check-equal? (term-intersect (vector 'a (discard) 'c) (vector 'a 'b (discard)) values void)
|
|
|
|
(vector 'a 'b 'c))
|
|
|
|
(struct X (A B C) #:transparent)
|
|
|
|
(check-equal? (term-intersect (X 'a (discard) 'c) (X 'a 'b (discard)) values void) (X 'a 'b 'c))
|
|
|
|
(check-equal? (term-intersect (X (capture 'a) (discard) 'c) (X 'a 'b (discard)) values void)
|
|
|
|
(X 'a 'b 'c))
|
|
|
|
(check-equal? (term-intersect (capture (X (capture 'a) (discard) 'c))
|
|
|
|
(X 'a (capture 'b) (discard))
|
|
|
|
values
|
|
|
|
void)
|
|
|
|
(X 'a 'b 'c))
|
|
|
|
(check-equal? (term-intersect 'a 'b values void) (void))
|
|
|
|
(check-equal? (term-intersect 'a 'a values void) 'a)
|
|
|
|
(check-equal? (term-intersect (cons 1 2) (cons 1 2) values void) (cons 1 2))
|
|
|
|
(check-equal? (term-intersect "hi" "hi" values void) "hi")
|
|
|
|
)
|