99 lines
2.6 KiB
Racket
99 lines
2.6 KiB
Racket
|
#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
|
||
|
|
instantiate-term->value)
|
||
|
|
|
||
|
|
(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))]
|
||
|
|
[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)]
|
||
|
|
[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 '(0) 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 (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?)
|
||
|
|
(for-each pop-captures! (cdr (vector->list (struct->vector t))))]
|
||
|
|
[(? list?)
|
||
|
|
(for-each pop-captures! t)]
|
||
|
|
[_ (void)]))
|
||
|
|
|
||
|
|
(define (walk t)
|
||
|
|
(match t
|
||
|
|
[(capture detail)
|
||
|
|
(begin0 (pop-actual!)
|
||
|
|
(pop-captures! detail))] ;; to consume nested bindings
|
||
|
|
[(discard)
|
||
|
|
(discard)]
|
||
|
|
[(? non-object-struct?)
|
||
|
|
(apply (struct-type-make-constructor (struct->struct-type t))
|
||
|
|
(map walk (cdr (vector->list (struct->vector t)))))]
|
||
|
|
[(? list?)
|
||
|
|
(map walk t)]
|
||
|
|
[other other]))
|
||
|
|
|
||
|
|
(walk t))
|