(in-package :patmatch)

(define-condition no-pattern (error)
  ((%pattern-obj :initarg :pattern-obj :reader pattern-obj)
   (%pattern-form :initarg :pattern-form :reader pattern-form)
   (%pattern-args :initarg :pattern-args :reader pattern-args)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defgeneric handle-pattern (pattern form &rest args)
    (:method-combination append)

    (:method append ((pattern (eql 'cons)) form &rest args)
      (let ((val-sym (gensym "VAL")))
        (destructuring-bind (car cdr) args
          `((,val-sym ,form)
            (,car (car ,val-sym))
            (,cdr (cdr ,val-sym))))))

    (:method append ((pattern (eql 'vector)) form &rest args)
      (let ((val-sym (gensym "VAL")))
        `((,val-sym ,form)
          ,@ (loop for arg in args
                   for idx from 0
                   collect `(,arg (aref ,val-sym ,idx))))))

    (:method append ((pattern (eql 'hash-table)) form &rest args)
      (let* ((val-sym (gensym "VAL"))
             (binding-forms (loop for (key sym) in args
                                  append `((,sym (gethash ',key ,val-sym))))))
        `((,val-sym ,form)
          ,@binding-forms)))

    (:method append ((pattern symbol) form &rest args)
      (when (closer-mop:subclassp pattern 'standard-object)
        (apply #'handle-pattern
               (closer-mop:class-prototype
                (closer-mop:ensure-finalized (find-class pattern)))
               form
               args))))) 

(defmacro let-pat* ((&rest clauses) &body body)
  `(let* (,@ (loop for ((discriminator . args) val-form) in clauses
                   append (apply 'handle-pattern discriminator val-form args)))
     ,@body))