51be2765 |
(in-package :patmatch)
|
b05aaebb |
(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)))
|
51be2765 |
(eval-when (:compile-toplevel :load-toplevel :execute)
(defgeneric handle-pattern (pattern form &rest args)
(:method-combination append)
|
b05aaebb |
(:method append ((pattern (eql 'cons)) form &rest args)
|
51be2765 |
(let ((val-sym (gensym "VAL")))
(destructuring-bind (car cdr) args
`((,val-sym ,form)
(,car (car ,val-sym))
(,cdr (cdr ,val-sym))))))
|
b05aaebb |
(:method append ((pattern (eql 'vector)) form &rest args)
|
51be2765 |
(let ((val-sym (gensym "VAL")))
`((,val-sym ,form)
,@ (loop for arg in args
for idx from 0
collect `(,arg (aref ,val-sym ,idx))))))
|
b05aaebb |
(:method append ((pattern (eql 'hash-table)) form &rest args)
|
51be2765 |
(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)
|
b05aaebb |
(when (closer-mop:subclassp pattern 'standard-object)
(apply #'handle-pattern
(closer-mop:class-prototype
|
cbf7d978 |
(closer-mop:ensure-finalized (find-class pattern)))
|
b05aaebb |
form
args)))))
|
51be2765 |
(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))
|
b05aaebb |
(defpackage :patmatch/test
(:use :cl :should-test)
(:import-from :patmatch :let-pat*)
(:export ))
(in-package :patmatch/test)
|
896ff063 |
#|
|
b05aaebb |
(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)))
|
cbf7d978 |
(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass test-base ()
((a :initform 1)))
(defclass test-sub1 (test-base)
())
(defclass test-sub2 (test-base)
|
e9e9641d |
((b :initform 2)))
(closer-mop:ensure-class 'test-base)
(closer-mop:ensure-class 'test-sub1)
(closer-mop:ensure-class 'test-sub2)
)
|
b05aaebb |
(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))))
|
896ff063 |
|#
|