;;; This code was written by Alex Shinn, who has placed it in the Public Domain.

;; updated 2006/12/24

(define-syntax match
  (syntax-rules ()
    ((match (app ...) (pat . body) ...)
     (let ((v (app ...)))
       (match-next v (app ...) (set! (app ...)) (pat . body) ...)))
    ;; ((match #(vec ...) (pat . body) ...)
    ;;  (let ((v #(vec ...)))
    ;;    (match-next v v (set! v) (pat . body) ...)))
    ((match atom (pat . body) ...)
     (match-next atom atom (set! atom) (pat . body) ...))
    ))

(define-syntax match-next
  (syntax-rules (=>)
    ((match-next v g s)
     (error "no matches"))
    ((match-next v g s (pat (=> failure) . body) . rest)
     (let ((failure (lambda () (match-next v g s . rest))))
       (match-one v pat g s (match-drop-ids (begin . body)) (failure) ())))
    ((match-next v g s (pat . body) . rest)
     (match-next v g s (pat (=> failure) . body) . rest))))

;; (cond-expand
;;  (syntax-case
;;   (define-syntax (match-check-ellipse stx)
;;     (syntax-case stx ()
;;       ((_ (p q) sk fk)
;;        (if (eq? '... (syntax-object->datum (syntax q)))
;;          (syntax sk)
;;          (syntax fk)))
;;       ((_ x sk fk)
;;        (syntax fk)))))
;;  (syntactic-closures
;;   (define-syntax match-check-ellipse
;;     (transformer
;;      (lambda (x e)
;;        (if (and (pair? (cadr x)) (pair? (cdadr x)) (eq? '... (cadadr x)))
;;          (make-syntactic-closure e '() (caddr x))
;;          (make-syntactic-closure e '() (cadddr x)))))))
;;  (else
;;   (define-syntax match-check-ellipse
;;     (syntax-rules (...)
;;       ((_ (p ...) sk fk) sk)
;;       ((_ x sk fk) fk)))))

;; (define-syntax match-check-ellipse
;;   (syntax-rules ()
;;     ((_ x sk fk) fk)))

(define-syntax match-check-ellipse
  (lambda (form rename compare)
    (if (and (pair? (cadr form))
             (pair? (cdadr form))
             (null? (cddadr form))
             (compare (cadadr form)
                      (rename '...)))
        (caddr form)
        (cadddr form))))

(define-syntax match-one
  (syntax-rules ()
    ((match-one v (p q) g s sk fk i)
     (match-check-ellipse
      (p q)
      (match-extract-vars p (match-gen-ellipses v p g s sk fk i) i ())
      (match-two v (p q) g s sk fk i)))
    ((match-one . x)
     (match-two . x))))

(define-syntax match-drop-ids
  (syntax-rules ()
    ((_ expr ids) expr)))

(define-syntax match-two
  (syntax-rules (_ ___ quote quasiquote ? $ = and or not set! get!)
    ((match-two v () g s (sk ...) fk i)
     (if (null? v) (sk ... i) fk))
    ((match-two v (quote p) g s (sk ...) fk i)
     (if (equal? v 'p) (sk ... i) fk))
    ((match-two v (quasiquote p) g s sk fk i)
     (match-quasiquote v p g s sk fk i))
    ((match-two v (and) g s (sk ...) fk i) (sk ... i))
    ((match-two v (and p q ...) g s sk fk i)
     (match-one v p g s (match-one v (and q ...) g s sk fk) fk i))
    ((match-two v (or) g s sk fk i) fk)
    ((match-two v (or p) g s sk fk i)
     (match-one v p g s sk fk i))
    ((match-two v (or p ...) g s sk fk i)
     (match-extract-vars (or p ...)
                         (match-gen-or v (p ...) g s sk fk i)
                         i
                         ()))
    ((match-two v (not p) g s (sk ...) fk i)
     (match-one v p g s (match-drop-ids fk) (sk ... i) i))
    ((match-two v (get! getter) g s (sk ...) fk i)
     (let ((getter (lambda () g))) (sk ... i)))
    ((match-two v (set! setter) g (s ...) (sk ...) fk i)
     (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
    ((match-two v (? pred p ...) g s sk fk i)
     (if (pred v) (match-one v (and p ...) g s sk fk i) fk))
    ((match-two v (= proc p) g s sk fk i)
     (let ((w (proc v)))
       (match-one w p g s sk fk i)))
    ((match-two v (p ___) g s sk fk i)
     (match-extract-vars p (match-gen-ellipses v p g s sk fk i) i ()))
    ((match-two v (p) g s sk fk i)
     (if (and (pair? v) (null? (cdr v)))
       (let ((w (car v)))
         (match-one w p (car v) (set-car! v) sk fk i))
       fk))
    ((match-two v (p . q) g s sk fk i)
     (if (pair? v)
       (let ((w (car v)) (x (cdr v)))
         (match-one w p (car v) (set-car! v)
                    (match-one x q (cdr v) (set-cdr! v) sk fk)
                    fk
                    i))
       fk))
    ;; ((match-two v #(p ...) g s sk fk i)
    ;;  (if (vector? v)
    ;;    (match-vector v 0 () (p ...) sk fk i)
    ;;    fk))
    ((match-two v _ g s (sk ...) fk i) (sk ... i))
    ((match-two v x g s (sk ...) fk (id ...))
     (let-syntax
         ((sym?
           (syntax-rules (id ...)
             ((sym? id sk2 fk2) fk2) ...
             ((sym? x sk2 fk2) sk2)
             ((sym? y sk2 fk2) fk2))))
       (sym? abracadabra  ; thanks Oleg
             (let ((x v)) (sk ... (id ... x)))
             (if (equal? v x) (sk ... (id ...)) fk))))
    ))

(define-syntax match-quasiquote
  (syntax-rules (unquote unquote-splicing quasiquote)
    ((_ v (unquote p) g s sk fk i)
     (match-one v p g s sk fk i))
    ((_ v ((unquote-splicing p) . rest) g s sk fk i)
     (if (pair? v)
       (match-one v
                  (p . tmp)
                  (match-quasiquote tmp rest g s sk fk)
                  fk
                  i)
       fk))
    ((_ v (quasiquote p) g s sk fk i . depth)
     (match-quasiquote v p g s sk fk i #f . depth))
    ((_ v (unquote p) g s sk fk i  x . depth)
     (match-quasiquote v p g s sk fk i . depth))
    ((_ v (unquote-splicing p) g s sk fk i x . depth)
     (match-quasiquote v p g s sk fk i . depth))
    ((_ v (p . q) g s sk fk i . depth)
     (if (pair? v)
       (let ((w (car v)) (x (cdr v)))
         (match-quasiquote
          w p g s
          (match-quasiquote x q g s sk fk i . depth)
          fk i . depth))
       fk))
    ;; ((_ v #(elt ...) g s sk fk i . depth)
    ;;  (if (vector? v)
    ;;    (let ((ls (vector->list v)))
    ;;      (match-quasiquote ls (elt ...) g s sk fk i . depth))
    ;;    fk))
    ((_ v x g s sk fk i . depth)
     (match-one v 'x g s sk fk i))))

(define-syntax match-gen-or
  (syntax-rules ()
    ((_ v p g s (sk ...) fk (i ...) ((id id-ls) ...))
     (let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
       (match-gen-or-step
        v p g s (match-drop-ids (sk2 id ...)) fk (i ...))))))

(define-syntax match-gen-or-step
  (syntax-rules ()
    ((_ v () g s sk fk i)
     fk)
    ((_ v (p) g s sk fk i)
     (match-one v p g s sk fk i))
    ((_ v (p . q) g s sk fk i)
     (match-one v p g s sk (match-gen-or-step v q g s sk fk i) i))
    ))

(define-syntax match-gen-ellipses
  (syntax-rules ()
    ((_ v p g s (sk ...) fk i ((id id-ls) ...))
     (let loop ((ls v) (id-ls '()) ...)
       (cond
         ((null? ls)
          (let ((id (reverse id-ls)) ...) (sk ... i)))
         ((pair? ls)
          (let ((w (car ls)))
            (match-one w p (car ls) (set-car! ls)
                       (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
                       fk i)))
         (else
          fk))))))

(define-syntax match-vector
  (syntax-rules (___)
    ((_ v n pats (p q) sk fk i)
     (match-check-ellipse (p q)
                          (match-vector-ellipses v n pats p sk fk i)
                          (match-vector-two v n pats (p q) sk fk i)))
    ((_ v n pats (p ___) sk fk i)
     (match-vector-ellipses v n pats p sk fk i))
    ((_ . x)
     (match-vector-two . x))))

(define-syntax match-vector-two
  (syntax-rules ()
    ((_ v n ((pat index) ...) () sk fk i)
     (if (vector? v)
       (let ((len (vector-length v)))
         (if (= len n)
           (match-vector-step v ((pat index) ...) sk fk i)
           fk))
       fk))
    ((_ v n (pats ...) (p . q) sk fk i)
     (match-vector v (+ n 1) (pats ... (p n)) q sk fk i))
    ))

(define-syntax match-vector-step
  (syntax-rules ()
    ((_ v () (sk ...) fk i) (sk ... i))
    ((_ v ((pat index) . rest) sk fk i)
     (let ((w (vector-ref v index)))
       (match-one w pat (vector-ref v index) (vector-set! v index)
                  (match-vector-step v rest sk fk)
                  fk i)))))

(define-syntax match-vector-ellipses
  (syntax-rules ()
    ((_ v n ((pat index) ...) p sk fk i)
     (if (vector? v)
       (let ((len (vector-length v)))
         (if (>= len n)
           (match-vector-step v ((pat index) ...)
                              (match-vector-tail v p n len sk fk)
                              fk i)
           fk))
       fk))))

(define-syntax match-vector-tail
  (syntax-rules ()
    ((_ v p n len sk fk i)
     (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))

(define-syntax match-vector-tail-two
  (syntax-rules ()
    ((_ v p n len (sk ...) fk i ((id id-ls) ...))
     (let loop ((j n) (id-ls '()) ...)
       (if (>= j len)
         (let ((id (reverse id-ls)) ...) (sk ... i))
         (let ((w (vector-ref v j)))
           (match-one w p (vector-ref v j) (vetor-set! v j)
                      (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
                      fk i)))))))

(define-syntax match-extract-vars
  (syntax-rules (_ ___ ? $ = quote quasiquote and or not get! set!)
    ((match-extract-vars (? pred . p) k i v)
     (match-extract-vars p k i v))
    ((match-extract-vars ($ rec . p) k i v)
     (match-extract-vars p k i v))
    ((match-extract-vars (= proc p) k i v)
     (match-extract-vars p k i v))
    ((match-extract-vars (quote x) (k ...) i v) (k ... v))
    ((match-extract-vars (quasiquote x) (k ...) i v) (k ... v))
    ((match-extract-vars (and . p) k i v)
     (match-extract-vars p k i v))
    ((match-extract-vars (or . p) k i v)
     (match-extract-vars p k i v))
    ((match-extract-vars (not . p) k i v)
     (match-extract-vars p k i v))
    ((match-extract-vars (p . q) k i v)
     (match-check-ellipse
      (p . q)
      (match-extract-vars p k i v)
      (match-extract-vars p (match-extract-vars-step q k i v) i ())))
    ;; ((match-extract-vars #(p ...) k i v)
    ;;  (match-extract-vars (p ...) k i v))
    ((match-extract-vars _ (k ...) i v)    (k ... v))
    ((match-extract-vars ___ (k ...) i v)  (k ... v))
    ((match-extract-vars p (k ...) (i ...) v)
     (let-syntax
         ((sym?
           (syntax-rules (i ...)
             ((sym? i sk fk) fk) ...
             ((sym? p sk fk) sk)
             ((sym? x sk fk) fk))))
       (sym? abracadabra (k ... ((p p-ls) . v)) (k ... v))))
    ))

(define-syntax match-extract-vars-step
  (syntax-rules ()
    ((_ p k i v ((v2 v2-ls) ...))
     (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; gimme some sugar, baby

(define-syntax match-lambda
  (syntax-rules ()
    ((_ clause ...) (lambda (expr) (match expr clause ...)))))

(define-syntax match-lambda*
  (syntax-rules ()
    ((_ clause ...) (lambda expr (match expr clause ...)))))

(define-syntax match-let
  (syntax-rules ()
    ((_ (vars ...) . body)
     (match-let/helper let () () (vars ...) . body))
    ((_ loop . rest)
     (match-named-let loop () . rest))))

(define-syntax match-letrec
  (syntax-rules ()
    ((_ vars . body) (match-let/helper letrec () () vars . body))))

(define-syntax match-let/helper
  (syntax-rules ()
    ((_ let ((var expr) ...) () () . body)
     (let ((var expr) ...) . body))
    ((_ let ((var expr) ...) ((pat tmp) ...) () . body)
     (let ((var expr) ...)
       (match-let* ((pat tmp) ...)
         . body)))
    ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
     (match-let/helper let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
    ;; ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
    ;;  (match-let/helper let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
    ((_ let (v ...) (p ...) ((a expr) . rest) . body)
     (match-let/helper let (v ... (a expr)) (p ...) rest . body))
    ))

(define-syntax match-named-let
  (syntax-rules ()
    ((_ loop ((pat expr var) ...) () . body)
     (let loop ((var expr) ...)
       (match-let ((pat var) ...)
         . body)))
    ((_ loop (v ...) ((pat expr) . rest) . body)
     (match-named-let loop (v ... (pat expr tmp)) rest . body))))

(define-syntax match-let*
  (syntax-rules ()
    ((_ () . body)
     (begin . body))
    ((_ ((pat expr) . rest) . body)
     (match expr (pat (match-let* rest . body))))))