Added Optima pattern for pattern-matching on Erlang binaries.

erlang-term-optima.asd

@@ -5,6 +5,8 @@
   ((:module :optima
             :components
             ((:file "package")
+             (:file "binary"
+                    :depends-on ("package"))
              (:file "erlang-string"
                     :depends-on ("package"))
              (:file "tuple"

optima/binary.lisp

@@ -0,0 +1,65 @@
+(in-package :erlang-term-optima)
+
+;;
+;; Pattern matching for Erlang binaries.
+;;
+;; Syntax:
+;;
+;; binary-pattern-constructor ::= (binary SEGMENT*)
+;;
+;;
+;; Example:
+;;
+;; (match (binary 1 2 88)
+;;   ((binary 1 b "X") b))
+;; => 2
+;;
+
+
+;;;
+;;; BINARY pattern
+;;;
+
+(defstruct (binary-pattern
+             (:include optima::constructor-pattern)
+             (:constructor make-binary-pattern (&rest optima::subpatterns)))
+  )
+
+
+(defmethod optima::destructor-equal ((x binary-pattern) (y binary-pattern))
+  (= (optima::constructor-pattern-arity x)
+     (optima::constructor-pattern-arity y)))
+
+(defmethod optima::destructor-predicate-form ((pattern binary-pattern) var)
+  `(and (typep ,var 'erlang-binary)
+        (= (size ,var) ,(optima::constructor-pattern-arity pattern))))
+
+(defmethod optima::destructor-forms ((pattern binary-pattern) var)
+  (loop
+     for i from 0 below (optima::constructor-pattern-arity pattern)
+     collect `(aref (bytes ,var) ,i)))
+
+(defmethod optima::parse-constructor-pattern ((name (eql 'binary)) &rest args)
+  (apply #'make-binary-pattern
+         (mapcar #'optima::parse-pattern
+                 (flatten-string-patterns-to-bytes args))))
+
+(defmethod optima::unparse-pattern ((pattern binary-pattern))
+  ;; Currently strings in patterns will not be unparsed back to strings,
+  ;; they will be unparsed to constant bytes.
+  `(binary ,@(mapcar #'optima::unparse-pattern
+                     (binary-pattern-subpatterns pattern))))
+
+
+;;;
+;;; Helper functions
+;;;
+
+(defun flatten-string-patterns-to-bytes (patterns)
+  (reduce #'(lambda (pattern acc)
+              (if (stringp pattern)
+                  (nconc (string-to-byte-list pattern) acc)
+                  (cons pattern acc)))
+          patterns
+          :initial-value nil
+          :from-end t))

test/optima-tests.lisp

@@ -2,6 +2,40 @@
 
 (in-suite optima-patterns)
 
+(test binary-pattern
+
+  (is-true (match (binary)
+             ((binary 0) nil)
+             ((binary 1 2 3) nil)
+             ((binary) t)))
+
+  (is-true (match (binary 255 255 255 0)
+             ((binary) nil)
+             ((binary 255 255 255) nil)
+             ((binary 255 255 255 0 0) nil)
+             ((binary a b c d)
+              (and (= 255 a b c) (= 0 d)))))
+
+  (is-true (match (string-to-binary "hej")
+             ((binary) nil)
+             ((binary 104 101 106 33) nil)
+             ((binary 104 101) nil)
+             ((binary 104 101 106) t)))
+
+  (is-true (match (binary (char-code #\X))
+             ((binary 0 "X" 34) nil)
+             ((binary "X" 0) t)
+             ((binary "X") t)))
+
+  (is-true (match (binary 104 101 106)
+             ((binary) nil)
+             ((binary "hej!") nil)
+             ((binary "he") nil)
+             ((binary "hej") t)))
+
+  )
+
+
 (test erlang-string-pattern
   (is-true (match (list)
              ((erlang-string "hello") nil)