@@ -46,22 +46,14 @@

     :author "Ed L <edward@elangley.org>"

     :license "MIT"

     :depends-on (#:alexandria

+                 #:closer-mop

+                 #:parachute

+                 #:serapeum

                  #:uiop)

-    :serial t

     :components ((:module "patmatch"

                   :components ((:file "package")

                                (:file "patmatch" :depends-on ("package"))))))

-(defsystem :fwoar-lisputils/patmatch/test 

-    :description ""

-    :author "Ed L <edward@elangley.org>"

-    :license "MIT"

-    :depends-on (:fwoar-lisputils/patmatch

-                 :parachute)

-    :serial t

-    :components ((:module "patmatch"

-                  :components ((:file "test")))))

-

 (defsystem #:fwoar-lisputils/string-utils

     :description "A string splitter"

     :author "fiddlerwoaroof <fiddlerwoaroof@gmail.com"

@@ -1,17 +1,18 @@

 (in-package #:fwoar.lisputils)

-(defmacro neither (&rest forms) `(not (or ,@forms)))

+(defmacro neither (&rest forms)

+  `(not (or ,@forms)))

 (defmacro neither-null (&rest forms)

   `(neither ,@(loop for form

-                 in forms

-                 collecting `(null ,form))))

+                      in forms

+                    collecting `(null ,form))))

 (defmacro let-each ((&key (be '*)) &body forms)

   "Bind each element successively to the symbol specified via :be"

   `(let* ,(loop for form in forms

-             collect (list be form))

+                collect (list be form))

      ,be))

 (defmacro let-first ((&key (be '*)) bound &body forms)

@@ -114,10 +115,10 @@

 (defmacro m-lambda (sym &rest args)

   (let ((arglist (loop for x in args

-                    unless (member x (list '&optional '&key '&rest))

-                    collect (ctypecase x

-                              (cons                  (car x))

-                              ((or symbol keyword string) x)))))

+                       unless (member x (list '&optional '&key '&rest))

+                         collect (ctypecase x

+                                   (cons                  (car x))

+                                   ((or symbol keyword string) x)))))

     `(lambda (,@args)

        (,sym ,@arglist))))

@@ -133,14 +134,14 @@

                               args))

            (args (mapcar #'list args args-syms))

            (destructuring-expressions

-            (rollup-list

-             (loop for (arg arg-sym) in args

-                collect (if (consp arg)

-                            `(destructuring-bind ,arg ,arg-sym

-                               (declare (ignore ,@ignored) (ignorable ,@ignorable)))

-                            `(let ((,arg ,arg-sym))

-                               ,@(generate-declarations-for arg ignored ignorable))))

-             body)))

+             (rollup-list

+              (loop for (arg arg-sym) in args

+                    collect (if (consp arg)

+                                `(destructuring-bind ,arg ,arg-sym

+                                   (declare (ignore ,@ignored) (ignorable ,@ignorable)))

+                                `(let ((,arg ,arg-sym))

+                                   ,@(generate-declarations-for arg ignored ignorable))))

+              body)))

       `(lambda ,args-syms

          ,destructuring-expressions))))

@@ -176,8 +177,9 @@

   (alexandria:once-only (from to)

     `(progn

        (setf ,@(apply #'append

-                      (iterate:iterate (iterate:for (fro-slot to-slot) iterate:in (ensure-mapping slots))

-                                       (iterate:collect `((slot-value ,to ',to-slot) (slot-value ,from ',fro-slot))))))

+                      (iterate:iterate

+                        (iterate:for (fro-slot to-slot) iterate:in (ensure-mapping slots))

+                        (iterate:collect `((slot-value ,to ',to-slot) (slot-value ,from ',fro-slot))))))

        ,to)))

 (defun transform-alist (function alist)

@@ -207,7 +209,7 @@

              (typecase (cdr form)

                (symbol (list (cdr form)))

                (cons (loop for thing in (cdr form)

-                        append (find-nonoperator-symbols thing))))))))))

+                           append (find-nonoperator-symbols thing))))))))))

 (defmacro may ((op arg))

   (alexandria:once-only (arg)

@@ -237,16 +239,18 @@

 (defun make-pairs (symbols)

                                         ;TODO: does this duplicate ensure-mapping?

   (cons 'list

-        (iterate:iterate (iterate:for (key value) in symbols)

-                         (iterate:collect `(list* ,(symbol-name key) ,value)))))

+        (iterate:iterate

+          (iterate:for (key value) in symbols)

+          (iterate:collect `(list* ,(symbol-name key) ,value)))))

 (defmacro slots-to-pairs (obj (&rest slots))

   (declare (optimize (debug 3)))

   "Produce a alist from a set of object slots and their values"

   (alexandria:once-only (obj)

     (let* ((slots (ensure-mapping slots))

-           (bindings (iterate:iterate (iterate:for (slot v &key bind-from) in slots)

-                                      (iterate:collect (or bind-from slot)))))

+           (bindings (iterate:iterate

+                       (iterate:for (slot v &key bind-from) in slots)

+                       (iterate:collect (or bind-from slot)))))

       `(with-slots ,bindings ,obj

          ,(make-pairs slots)))))

@@ -6,3 +6,4 @@

 (defpackage :patmatch

   (:use :cl)

   (:export :let-pat* :handle-pattern :no-pattern))

+

new file mode 100644

@@ -0,0 +1,11 @@

+(in-package :asdf-user)

+

+(defsystem :fwoar-lisputils/patmatch/test 

+    :description ""

+    :author "Ed L <edward@elangley.org>"

+    :license "MIT"

+    :depends-on (#:fwoar-lisputils/patmatch

+                 #:parachute

+                 #:serapeum)

+    :components ((:file "test-fixtures")

+                 (:file "test" :depends-on ("test-fixtures"))))

@@ -42,4 +42,3 @@

   `(let* (,@ (loop for ((discriminator . args) val-form) in clauses

                    append (apply 'handle-pattern discriminator val-form args)))

      ,@body))

-

new file mode 100644

@@ -0,0 +1,36 @@

+(defpackage :patmatch/test

+  (:use :cl)

+  (:import-from :parachute

+                #:true #:false #:fail #:is #:isnt #:is-values #:isnt-values

+                #:of-type #:finish #:define-test)

+  (:import-from :patmatch :let-pat*)

+  (:export ))

+(in-package :patmatch/test)

+

+(defclass test-base ()

+  ((a :initform 1)))

+

+(defclass test-sub1 (test-base)

+  ())

+

+(defclass test-sub2 (test-base)

+  ((b :initform 2)))

+

+(eval-when (:compile-toplevel :load-toplevel :execute)

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

@@ -1,118 +1,52 @@

-(defpackage :patmatch/test

-  (:use :cl)

-  (:import-from :parachute

-                #:true #:false #:fail #:is #:isnt #:is-values #:isnt-values

-                #:of-type #:finish #:define-test)

-  (:import-from :patmatch :let-pat*)

-  (:export ))

 (in-package :patmatch/test)

-(define-test add-stuff

-  (is =

-      (progn (sleep 2)

-             2)

-      2))

+(define-test let-pat*)

 (define-test let-pat*-handles-cons

-  (is =

-      2

-      (let-pat* (((cons a b) '(2 . 3)))

-        (declare (ignore b))

-        a)))

-

-#|

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

+  :parent let-pat*

+  (is = 2 (let-pat* (((cons a b) '(2 . 3)))

             (declare (ignore b))

             a))

-  (should be eql

-          3

-          (let-pat* (((vector a b) #(2 3)))

+

+  (is = 3 (let-pat* (((cons 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))))

+(define-test let-pat*-handles-vector

+  :parent let-pat*

+  (is = 2 (let-pat* (((vector a b) #(2 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))))

+  (is = 3 (let-pat* (((vector a b) #(2 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)))))))

+(define-test let-pat*-handles-hash-table

+  :parent let-pat*

+  (is = 2 (let-pat* (((hash-table (:a a) (:b b)) (alexandria:plist-hash-table '(:a 2 :b 3))))

+            (declare (ignore b))

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

+  (is = 3 (let-pat* (((hash-table (:a a) (:b b)) (alexandria:plist-hash-table '(:a 2 :b 3))))

+            (declare (ignore a))

+            b)))

-(deftest let-pat*-handles-object-destructuring ()

-  ""

-  (should be eql

-          1

-          (let-pat* (((test-base :a a) (make-instance 'test-base)))

+(define-test let-pat*-handles-object-destructuring

+  :parent let-pat*

+  (is = 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))

+(define-test let-pat*-handles-inheritance

+  :parent let-pat*

+  (is = 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))

+  (is = 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))

+  (is = 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))))

-|#

+  (is equal '(1 2) (let-pat* (((test-sub2 :a a :b b) (make-instance 'test-sub2)))

+                     (list a b))))