#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")
  )