#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))]
      [(? 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 '(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)]
      [(? 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)
       (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)]
      [(? vector?)
       (for/vector [(tt t)] (walk tt))]
      [other other]))

  (walk t))