Skip to content
Browse files

Add PPCRE pattern as contrib

  • Loading branch information...
1 parent 9e6f5b6 commit 540138412a9f682027602bd1487a32daa90e89a4 Tomohiro Matsuyama committed Nov 4, 2012
Showing with 130 additions and 28 deletions.
  1. +36 −1 README.md
  2. +3 −0 contrib/package.lisp
  3. +10 −0 contrib/ppcre.lisp
  4. +29 −0 optima.contrib.asd
  5. +1 −1 optima.test.asd
  6. +35 −25 src/compiler.lisp
  7. +16 −1 test/suite.lisp
View
37 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
View
3 contrib/package.lisp
@@ -0,0 +1,3 @@
+(defpackage :optima.contrib
+ (:use :cl)
+ (:export #:ppcre))
View
10 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)))))
View
29 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")))))
View
2 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")))
View
60 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))
View
17 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))

0 comments on commit 5401384

Please sign in to comment.
Something went wrong with that request. Please try again.