pattern: implement matching :maybe

src/pattern.lisp

@@ -64,16 +64,21 @@
 ;; TODO Maybe generalize "maybe" and "zero-or-more" into "repetition"
 
 (defstruct (maybe
-            (:constructor maybe (pattern))
+            (:constructor maybe (pattern &optional name))
             :constructor
-            (:predicate maybep))
+            (:predicate maybep)
+            (:include term))
   (pattern nil :read-only t))
 
 (defun maybe= (a b)
   (and (maybep a)
        (maybep b)
        (pattern= (maybe-pattern a)
-                 (maybe-pattern b))))
+                 (maybe-pattern b))
+       (or (null (maybe-name a))
+           (null (maybe-name b))
+           (eq (maybe-name a)
+               (maybe-name b)))))
 
 (defstruct (zero-or-more
             (:constructor zero-or-more (pattern))
@@ -198,6 +203,8 @@
 
 ;; Will I regret implemeting this?
 
+;;; TODO the iterator should take care of skipping inputs
+
 (defstruct iterator
   ;; The vector being iterated on
   vector
@@ -270,25 +277,49 @@ a new iterator."
 
 
 
+(defun make-binding (term input)
+  (list term input))
+
+(defun merge-bindings (bindings1 bindings2)
+  (cond
+    ((eq t bindings1) bindings2)
+    ((eq t bindings2) bindings1)
+    ((or (eq nil bindings1) (eq nil bindings2)) nil)
+    (t (append bindings1 bindings2))))
+
+;; Basic "equal" matching
 (defmethod match (pattern input)
   (equal pattern input))
 
+;; Match a term (create a binding)
 (defmethod match ((pattern term) input)
-  (list pattern input))
+  (make-binding pattern input))
 
+;; Match a typed term (creates a binding)
 (defmethod match ((pattern typed-term) input)
   (when (typep input (typed-term-type pattern))
-    (cons pattern input)))
+    (make-binding pattern input)))
 
+;; Recurse into a referenced pattern
 (defmethod match ((pattern ref) input)
   (match (ref-pattern pattern) input))
 
+(defmethod match ((pattern maybe) input)
+  (or (alexandria:when-let ((bindings (match (maybe-pattern pattern) input)))
+        (if (maybe-name pattern)
+            (merge-bindings bindings (make-binding pattern input))
+            bindings))
+      (not input)))
+
+;; Match a string literal
 (defmethod match ((pattern string) (input string))
   (string= pattern input))
 
+;; "nil" must match "nil"
 (defmethod match ((pattern null) (input null))
   t)
 
+;; the pattern "nil" matches nothing else than "nil"
 (defmethod match ((pattern null) input)
   nil)
 
@@ -308,25 +339,22 @@ a new iterator."
 
 (defmethod match ((pattern vector) (input vector))
   (or (loop
+        :with bindings = t ;; (make-empty-bindings)
         ;; Iterate over the pattern
         :for pattern-iterator := (iterate pattern) :then (iterator-next pattern-iterator)
         :until (iterator-done-p pattern-iterator)
-        ;; :for pat = (iterator-value pattern-iterator)
         ;; Iterate over the input
         :for input-iterator := (iterate input) :then (iterator-next input-iterator)
         :until (iterator-done-p input-iterator)
-        ;; :for in = (iterator-value input-iterator)
         ;; recurse
-        :for match = (match pattern-iterator input-iterator)
-        ;; debug print
-        ;; :do (format *debug-io* "~%pat: ~s in: ~s" pat in)
-        :unless match
+        :for new-bindings = (match pattern-iterator input-iterator)
+        :if new-bindings
+          ;; collect all the bindings
+          :do (setf bindings (merge-bindings bindings new-bindings))
+        :else
           ;; failed to match, bail out of the whole function
           :do (return-from match nil)
-        :when (listp match)
-          ;; collect all the bindings
-          ;; TODO We might want to "merge" the bindings.
-          :append match)
+        :finally (return bindings))
       t))
 
 

tests/pattern.lisp

@@ -57,6 +57,8 @@
                 #:iterator-next
                 #:iterator-value
                 ;; Match
+                #:make-binding
+                #:merge-bindings
                 #:match))
 
 (in-package #:breeze.test.pattern)
@@ -105,7 +107,14 @@
     (true (maybep maybe))
     (is eq :x (maybe-pattern maybe))))
 
-;; TODO maybe=
+(define-test+run maybe=
+  (is maybe= (maybe 'a) (maybe 'a))
+  (is maybe= (maybe 'a :?x) (maybe 'a))
+  (is maybe= (maybe 'a :?x) (maybe 'a :?x))
+  (isnt maybe= (maybe 'a) (maybe 'b))
+  (isnt maybe= (maybe 'a :?x) (maybe 'b))
+  (isnt maybe= (maybe 'a :?x) (maybe 'a :?y))
+  (isnt maybe= (maybe 'a :?x) (maybe 'b :?x)))
 
 (define-test zero-or-more
   (let ((zero-or-more (zero-or-more :x)))
@@ -299,6 +308,17 @@
 
 
 
+(define-test merge-bindings
+  (false (merge-bindings nil nil))
+  (false (merge-bindings nil t))
+  (false (merge-bindings t nil))
+  (true (merge-bindings t t))
+  (false (merge-bindings (make-binding :?x 'a) nil))
+  (false (merge-bindings nil (make-binding :?x 'a)))
+  (is equal '(:?x a) (merge-bindings (make-binding :?x 'a) t))
+  (is equal '(:?x a) (merge-bindings t (make-binding :?x 'a)))
+  (is equal '(:?x a :?y b) (merge-bindings (make-binding :?x 'a) (make-binding :?y 'b))))
+
 (defun test-match (pattern input)
   (match (compile-pattern pattern) input))
 
@@ -316,6 +336,7 @@
   ;; TODO add vectors (but not arrays)
   )
 
+;;; TODO check the actual return values
 (define-test "match terms"
   (true (match (term :?x) nil))
   (true (match (term :?x) 1))
@@ -325,6 +346,7 @@
   (true (match (term :?x) (term :?x)))
   (true (match `#(,(term :?x)) (list 42))))
 
+;;; TODO check the actual return values
 (define-test "match typed-terms"
   (true (match (typed-term 'null :?x) nil))
   (false (match (typed-term 'null :?x) t))
@@ -340,6 +362,16 @@
 
 ;;; TODO test :maybe :zero-or-more and :alternation
 
+(define-test+run "match maybe"
+  (is eq t (match (maybe 'a) 'a))
+  (is eq t (match (maybe 'a) nil))
+  (is eq t (match (maybe 'a :?x) nil))
+  (false (match (maybe 'a :?x) 'b))
+  (false (match (maybe 'a) 'b))
+  (is equalp '(#s(maybe :name :?x :pattern a) a) (match (maybe 'a :?x) 'a))
+  (is equalp '(#s(term :name ?x) a) (match (maybe (term '?x)) 'a))
+  (is equalp '(#s(term :name ?x) nil) (match (maybe (term '?x)) nil)))
+
 
 ;;; Testing patterns with references in them
 

workbench.lisp

@@ -185,4 +185,6 @@
        iterator-maybe-push
        iterator-maybe-pop)
 
+(trace merge-bindings)
+
 (untrace)