(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))


(defpackage :patmatch/test
  (:use :cl :should-test)
  (:import-from :patmatch :let-pat*)
  (:export ))
(in-package :patmatch/test)

#|
(deftest let-pat*-handles-cons ()
    ""
  (should be eql
          2
          (let-pat* (((cons a b) '(2 . 3)))
            (declare (ignore b))
            a))
  (should be eql
          3
          (let-pat* (((cons a b) '(2 . 3)))
            (declare (ignore a))
            b)))

(deftest let-pat*-handles-vector ()
    ""
  (should be eql
          2
          (let-pat* (((vector a b) #(2 3)))
            (declare (ignore b))
            a))
  (should be eql
          3
          (let-pat* (((vector a b) #(2 3)))
            (declare (ignore a))
            b)))

(deftest let-pat*-handles-hash-table ()
    ""
  (should be eql
          2
          (let-pat* (((hash-table (:a a) (:b b)) (alexandria:plist-hash-table '(:a 2 :b 3))))
            (declare (ignore b))
            a))
  (should be eql
          3
          (let-pat* (((hash-table (:a a) (:b b)) (alexandria:plist-hash-table '(:a 2 :b 3))))
            (declare (ignore a))
            b)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defclass test-base ()
    ((a :initform 1)))
  (defclass test-sub1 (test-base)
    ())
  (defclass test-sub2 (test-base)
    ((b :initform 2)))
  (closer-mop:ensure-class 'test-base)
  (closer-mop:ensure-class 'test-sub1)
  (closer-mop:ensure-class 'test-sub2)
  )

(defmethod patmatch:handle-pattern append ((pattern test-base) form &rest args)
  (alexandria:when-let ((arg (getf args :a)))
    (let ((val-sym (gensym "test-base-")))
      `((,val-sym ,form)
         ,@(serapeum:unsplice
             `(,arg (slot-value ,val-sym 'a)))))))

(defmethod patmatch:handle-pattern append ((pattern test-sub2) form &rest args)
  (alexandria:when-let ((arg (getf args :b)))
    (let ((val-sym (gensym "test-base-")))
      `((,val-sym ,form)
        ,@(serapeum:unsplice
           `(,arg (slot-value ,val-sym 'b)))))))


(deftest let-pat*-handles-object-destructuring ()
    ""
  (should be eql
          1
          (let-pat* (((test-base :a a) (make-instance 'test-base)))
            a)))

(deftest let-pat*-handles-inheritance ()
    ""
 (should be eql
          1
          (let-pat* (((test-base :a a) (make-instance 'test-sub1)))
            a))

 (should be eql
          1
          (let-pat* (((test-sub1 :a a) (make-instance 'test-sub1)))
            a))

 (should be eql
         1
         (let-pat* (((test-sub2 :a a) (make-instance 'test-sub2)))
           a))

 (should be equal
         '(1 2)
         (let-pat* (((test-sub2 :a a :b b) (make-instance 'test-sub2)))
           (list a b))))

|#