diff --git a/README.md b/README.md index c2bcd4a..24886a0 100644 --- a/README.md +++ b/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 diff --git a/contrib/package.lisp b/contrib/package.lisp new file mode 100644 index 0000000..46bf714 --- /dev/null +++ b/contrib/package.lisp @@ -0,0 +1,3 @@ +(defpackage :optima.contrib + (:use :cl) + (:export #:ppcre)) diff --git a/contrib/ppcre.lisp b/contrib/ppcre.lisp new file mode 100644 index 0000000..d73b63b --- /dev/null +++ b/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))))) diff --git a/optima.contrib.asd b/optima.contrib.asd new file mode 100644 index 0000000..d3fa1fe --- /dev/null +++ b/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"))))) diff --git a/optima.test.asd b/optima.test.asd index 5bf937e..451c406 100644 --- a/optima.test.asd +++ b/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"))) diff --git a/src/compiler.lisp b/src/compiler.lisp index 6059762..e2a71c3 100644 --- a/src/compiler.lisp +++ b/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)) diff --git a/test/suite.lisp b/test/suite.lisp index 34118c5..581ece4 100644 --- a/test/suite.lisp +++ b/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))