Add PPCRE pattern as contrib

README.md

@@ -166,7 +166,7 @@ Syntax:
 
     structure-constructor-pattern ::= (structure CONC-NAME slot*)
                                     | (CONC-NAME slot*)
-
+    
     slot ::= SLOT-NAME
            | (SLOT-NAME PATTERN*)
 
@@ -560,3 +560,38 @@ License
 -------
 
 LLGPL
+
+optima.contrib - Contribution library for optima
+================================================
+
+Contribution library for optima.
+
+Available Patterns
+------------------
+
+### PPCRE
+
+    (ppcre REGEXP PATTERN*)
+
+Matches REGEXP against the target string. Sub-PATTERNs will be used to
+match the matched groups, if REGEXP matched.
+
+Examples:
+
+    (match "2012-11-04"
+      ((ppcre "^\\d{4}-\\d{2}-\\d{2}$" year month day)
+       (list year month day)))
+    => ("2012" "11" "04")
+
+[Package] optima.contrib
+------------------------
+
+Authors
+-------
+
+* Tomohiro Matsuyama
+
+License
+-------
+
+LLGPL

contrib/package.lisp

@@ -0,0 +1,3 @@
+(defpackage :optima.contrib
+  (:use :cl)
+  (:export #:ppcre))

contrib/ppcre.lisp

@@ -0,0 +1,10 @@
+(in-package :optima.contrib)
+
+(defmethod optima::parse-constructor-pattern ((name (eql 'ppcre)) &rest args)
+  (destructuring-bind (re . patterns) args
+    (optima::make-constructor-pattern
+     :specifier `(ppcre ,@args)
+     :signature `(ppcre ,re)
+     :arguments (mapcar #'optima::parse-pattern patterns)
+     :predicate (lambda (var) (values `(nth-value 1 (ppcre:scan-to-strings ,re ,var)) t))
+     :accessor (lambda (var i) `(svref ,var ,i)))))

optima.contrib.asd

@@ -0,0 +1,29 @@
+(asdf:defsystem :optima.contrib
+  :description "Contribution library for optima"
+  :long-description "Contribution library for optima.
+
+Available Patterns
+------------------
+
+### PPCRE
+
+    (ppcre REGEXP PATTERN*)
+
+Matches REGEXP against the target string. Sub-PATTERNs will be used to
+match the matched groups, if REGEXP matched.
+
+Examples:
+
+    (match \"2012-11-04\"
+      ((ppcre \"^\\\\d{4}-\\\\d{2}-\\\\d{2}$\" year month day)
+       (list year month day)))
+    => (\"2012\" \"11\" \"04\")"
+  :version "0.2"
+  :author "Tomohiro Matsuyama"
+  :license "LLGPL"
+  :depends-on (:optima
+               :cl-ppcre)
+  :components ((:module "contrib"
+                :serial t
+                :components ((:file "package")
+                             (:file "ppcre")))))

optima.test.asd

@@ -1,3 +1,3 @@
 (asdf:defsystem :optima.test
-  :depends-on (:optima :eos)
+  :depends-on (:eos :optima :optima.contrib)
   :components ((:file "test/suite")))

src/compiler.lisp

@@ -58,36 +58,46 @@
   (with-slots (arguments predicate accessor) (caaar clauses)
     (let* ((arity (length arguments))
            (var (car vars))
-           (test-form (funcall predicate var))
            (new-vars (make-gensym-list arity))
            (then `(%match ,(append new-vars (cdr vars))
                           ,(loop for ((pattern . rest) . then) in clauses
                                  for args = (constructor-pattern-arguments pattern)
                                  collect `((,@args ,.rest) ,.then))
-                          ,else)))
-      (loop for i from 0 below arity
-            for new-var in new-vars
-            for access = (funcall accessor var i)
-            for binding = `(,new-var ,access)
-            if (loop for ((pattern . nil) . nil) in clauses
-                     for arg = (nth i (constructor-pattern-arguments pattern))
-                     never (place-pattern-included-p arg))
-              collect binding into let-bindings
-            else
-              collect binding into symbol-bindings
-            finally
-               (when symbol-bindings
-                 (setq then `(symbol-macrolet ,symbol-bindings
-                               (declare (ignorable ,@(mapcar #'car symbol-bindings)))
-                               ,then)))
-               (when let-bindings
-                 (setq then `(let ,let-bindings
-                               (declare (ignorable ,@(mapcar #'car let-bindings)))
-                               ,then)))
-               (return
-                 `(iff ,test-form
-                       ,then
-                       ,else))))))
+                          ,else))
+           (wrap #'identity))
+      (multiple-value-bind (test-form bind-var-p)
+          (funcall predicate var)
+        ;; FIXME: BIND-VAR-P is ugly...
+        (when bind-var-p
+          (let ((new-var (gensym))
+                (test test-form))
+            (setq wrap (lambda (form) `(let ((,new-var ,test)) ,form))
+                  var new-var
+                  test-form new-var)))
+        (loop for i from 0 below arity
+              for new-var in new-vars
+              for access = (funcall accessor var i)
+              for binding = `(,new-var ,access)
+              if (loop for ((pattern . nil) . nil) in clauses
+                       for arg = (nth i (constructor-pattern-arguments pattern))
+                       never (place-pattern-included-p arg))
+                collect binding into let-bindings
+              else
+                collect binding into symbol-bindings
+              finally
+                 (when symbol-bindings
+                   (setq then `(symbol-macrolet ,symbol-bindings
+                                 (declare (ignorable ,@(mapcar #'car symbol-bindings)))
+                                 ,then)))
+                 (when let-bindings
+                   (setq then `(let ,let-bindings
+                                 (declare (ignorable ,@(mapcar #'car let-bindings)))
+                                 ,then)))
+                 (return
+                   (funcall wrap
+                            `(iff ,test-form
+                                  ,then
+                                  ,else))))))))
 
 (defun compile-match-or-group (vars clauses else)
   (assert (= (length clauses) 1))

test/suite.lisp

@@ -1,5 +1,5 @@
 (defpackage :optima.test
-  (:use :cl :optima :eos)
+  (:use :cl :eos :optima :optima.contrib)
   (:shadowing-import-from :optima #:fail))
 (in-package :optima.test)
 
@@ -303,6 +303,21 @@
                    (first (match-error-values e))))
                1)))))
 
+;;; Contrib tests
+
+(test ppcre
+  (is-match "a" (ppcre "^a$"))
+  (is-not-match "a" (ppcre "^b$"))
+  (is-true (match "a"
+             ((ppcre "^(.)$")
+              t)))
+  (is (equal (match "2012-11-04"
+               ((ppcre "^(\\d+)-(\\d+)-(\\d+)$" year month day)
+                (list year month day)))
+             '("2012" "11" "04"))))
+
+;;; Regression tests
+
 (test issue39
   (is (eql (match '(0) ((list x) x))
            0))