syndicate-rkt/syndicate/term.rkt

195 lines
6.3 KiB
Racket

#lang racket/base
;; Like pattern.rkt, but for dynamic use rather than compile-time use.
(provide term->skeleton-interest
term->skeleton
term->skeleton-proj
term->key
term->capture-proj
instantiate-term->value
term-intersect)
(require racket/match)
(require "support/struct.rkt")
(require "pattern.rkt")
(require "skeleton.rkt")
(define (term->skeleton-interest x handler #:cleanup [cleanup #f])
(skeleton-interest (term->skeleton x)
(term->skeleton-proj x)
(term->key x)
(term->capture-proj x)
handler
cleanup))
(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))]
[(? vector?)
(cons 'vector (map walk (vector->list t)))]
[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)]
[(? vector?)
(walk-edge 0 key-rev (vector->list t))]
[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))]))
(walk-node '() t))
(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))))
(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))))
(struct opaque-placeholder ())
;; ^ not transparent or prefab -- used to frustrate
;; otherwise-potentially-matching constant positions in instantiated
;; terms
(define (instantiate-term->value t actuals
#:visibility-restriction-proj [vrproj (term->capture-proj t)])
(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?)
(for-each pop-captures! (struct-fields t))]
[(? list?)
(for-each pop-captures! t)]
[(? vector?)
(for [(tt (in-vector t))] (pop-captures! tt))]
[_ (void)]))
(define (walk t)
(match t
[(capture detail)
(begin0 (pop-actual!)
(pop-captures! detail))] ;; to consume nested bindings
[(discard)
(opaque-placeholder)]
[(? non-object-struct?)
(struct-map walk t)]
[(? list?)
(map walk t)]
[(? vector?)
(for/vector [(tt t)] (walk tt))]
[other other]))
(if vrproj
(visibility-restriction vrproj (walk t))
(walk t)))
;; 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")
)