Permalink
Browse files

Add ASSOC and PASSOC patterns

Plus, move PLIST and ALIST patterns into CONTRIB package.
  • Loading branch information...
1 parent 268ef07 commit 2475a18ed8257be17b110f86bb22388ad92f99ea Tomohiro Matsuyama committed Nov 9, 2012
Showing with 183 additions and 93 deletions.
  1. +52 −27 README.md
  2. +7 −2 contrib/package.lisp
  3. +9 −0 contrib/patterns.lisp
  4. +22 −2 optima.asd
  5. +35 −0 optima.contrib.asd
  6. +0 −26 src/extra.lisp
  7. +3 −35 src/package.lisp
  8. +18 −0 src/pattern.lisp
  9. +22 −0 src/{equal.lisp → runtime.lisp}
  10. +15 −1 test/suite.lisp
View
@@ -99,6 +99,27 @@ Examples:
((cons a b) (+ a b)))
=> 3
+#### ASSOC
+
+Syntax:
+
+ assoc-constructor-pattern ::= (assoc KEY PATTERN &key key test)
+
+Examples:
+
+ (match '((1 . :one))
+ ((assoc 1 x) x))
+ => :ONE
+ (match '((1 . :one) (2 . :two))
+ ((assoc 2 x) x))
+ => :TWO
+ (match '(1 (2 . 3))
+ ((assoc 2 x) x))
+ => 3
+ (match '(("a" . 123))
+ ((assoc "A" 123 :test #'string-equal) t))
+ => T
+
#### VECTOR
Syntax:
@@ -521,56 +542,60 @@ Equivalent to `(defun-ematch name (PATTERN BODY...)).
Equivalent to `(defun-cmatch name (PATTERN BODY...)).
-[Package] optima.extra
-----------------------
+Authors
+-------
-This package contains derived and constructor patterns with
-designators not from COMMON-LISP package.
+* Tomohiro Matsuyama
-#### PLIST
+License
+-------
-Syntax:
+LLGPL
- plist-constructor-pattern ::= (plist (key PATTERN)*)
+optima.contrib - Contribution library for optima
+================================================
-Examples:
+Contribution library for optima.
- (match '(:one 1 :two 2 :three 3)
- ((plist :one 1 :two x) x))
- => 2
+Available Patterns
+------------------
-#### ALIST
+### ALIST
Syntax:
- alist-constructor-pattern ::= (alist (key . PATTERN)*)
+ (alist (KEY . PATTERN)*)
+
+Expansion:
+
+ (alist (k . p)*) => (and (assoc k p)*)
Examples:
- (match '((:one . 1) (:two . 2) (:three . 3))
- ((alist (:one . 1) (:two . x)) x))
- => 2
+ (match '((1 . :one) (2 . :two) (3 . :three))
+ ((alist (1 . x) (3 . y)) (list x y)))
+ => (:ONE :THREE)
-Authors
--------
+### PLIST
-* Tomohiro Matsuyama
+Syntax:
-License
--------
+ (plist {KEY PATTERN}*)
-LLGPL
+Expansion:
-optima.contrib - Contribution library for optima
-================================================
+ (plist {k p}*) => (and (passoc k p)*)
-Contribution library for optima.
+Examples:
-Available Patterns
-------------------
+ (match '(:name "John" :age 23)
+ ((plist :name "John" :age age) age))
+ => 23
### PPCRE
+Syntax:
+
(ppcre REGEXP PATTERN*)
Matches REGEXP against the target string. Sub-PATTERNs will be used to
View
@@ -1,3 +1,8 @@
(defpackage :optima.contrib
- (:use :cl)
- (:export #:ppcre))
+ (:use :cl :optima)
+ (:import-from :alexandria
+ #:plist-alist)
+ (:export #:alist
+ #:plist
+
+ #:ppcre))
View
@@ -0,0 +1,9 @@
+(in-package :optima.contrib)
+
+(defpattern alist (&rest args)
+ `(and ,@(loop for (key . value) in args
+ collect `(assoc ,key ,value))))
+
+(defpattern plist (&rest args)
+ `(and ,@(loop for (key . value) in (plist-alist args)
+ collect `(optima::passoc ,key ,value))))
View
@@ -98,6 +98,27 @@ Examples:
((cons a b) (+ a b)))
=> 3
+#### ASSOC
+
+Syntax:
+
+ assoc-constructor-pattern ::= (assoc KEY PATTERN &key key test)
+
+Examples:
+
+ (match '((1 . :one))
+ ((assoc 1 x) x))
+ => :ONE
+ (match '((1 . :one) (2 . :two))
+ ((assoc 2 x) x))
+ => :TWO
+ (match '(1 (2 . 3))
+ ((assoc 2 x) x))
+ => 3
+ (match '((\"a\" . 123))
+ ((assoc \"A\" 123 :test #'string-equal) t))
+ => T
+
#### VECTOR
Syntax:
@@ -306,9 +327,8 @@ Expansion of TYPEP derived patterns:
:serial t
:components ((:file "package")
(:file "util")
- (:file "equal")
+ (:file "runtime")
(:file "pattern")
- (:file "extra")
(:file "fail")
(:file "compiler")
(:file "match")
View
@@ -5,8 +5,42 @@
Available Patterns
------------------
+### ALIST
+
+Syntax:
+
+ (alist (KEY . PATTERN)*)
+
+Expansion:
+
+ (alist (k . p)*) => (and (assoc k p)*)
+
+Examples:
+
+ (match '((1 . :one) (2 . :two) (3 . :three))
+ ((alist (1 . x) (3 . y)) (list x y)))
+ => (:ONE :THREE)
+
+### PLIST
+
+Syntax:
+
+ (plist {KEY PATTERN}*)
+
+Expansion:
+
+ (plist {k p}*) => (and (passoc k p)*)
+
+Examples:
+
+ (match '(:name \"John\" :age 23)
+ ((plist :name \"John\" :age age) age))
+ => 23
+
### PPCRE
+Syntax:
+
(ppcre REGEXP PATTERN*)
Matches REGEXP against the target string. Sub-PATTERNs will be used to
@@ -26,4 +60,5 @@ Examples:
:components ((:module "contrib"
:serial t
:components ((:file "package")
+ (:file "patterns")
(:file "ppcre")))))
View
@@ -1,26 +0,0 @@
-(in-package :optima.extra)
-
-(defmethod optima::parse-constructor-pattern ((name (eql 'plist)) &rest args)
- (let (keys values)
- (loop for (key value) on args by #'cddr
- do (push key keys)
- do (push value values))
- (unless (= (length keys)
- (length values))
- (error "plist pattern has an extra key: ~A" args))
- (optima::make-constructor-pattern
- :signature `(plist ,@keys)
- :arguments (mapcar #'optima::parse-pattern values)
- :predicate (lambda (var) `(zerop (rem (length ,var) 2))) ; Optimize/simplify to just consp?
- :accessor (lambda (var i) `(getf ,var (nth ,i ',keys))))))
-
-(defmethod optima::parse-constructor-pattern ((name (eql 'alist)) &rest args)
- (let (keys values)
- (loop for (key . value) in args
- do (push key keys)
- do (push value values))
- (optima::make-constructor-pattern
- :signature `(alist ,@keys)
- :arguments (mapcar #'optima::parse-pattern values)
- :predicate (lambda (var) `(every #'consp ,var)) ; Optimize/simplify to just consp?
- :accessor (lambda (var i) `(cdr (assoc (nth ,i ',keys) ,var))))))
View
@@ -10,9 +10,10 @@
#:required-argument
#:with-unique-names
#:once-only
- #:if-let
+ #:if-let
#:when-let
- #:destructuring-case)
+ #:destructuring-case
+ #:plist-alist)
(:import-from :closer-mop
#:slot-definition-name
#:class-slots)
@@ -24,7 +25,6 @@
#:multiple-value-cmatch
#:fail
-
#:match-error
#:match-error-values
#:match-error-patterns
@@ -49,35 +49,3 @@
#:defun-match1
#:defun-ematch1
#:defun-cmatch1))
-
-(defpackage :optima.extra
- (:use :cl :optima)
- (:export #:plist
- #:alist)
- (:documentation
- "This package contains derived and constructor patterns with
-designators not from COMMON-LISP package.
-
-#### PLIST
-
-Syntax:
-
- plist-constructor-pattern ::= (plist (key PATTERN)*)
-
-Examples:
-
- (match '(:one 1 :two 2 :three 3)
- ((plist :one 1 :two x) x))
- => 2
-
-#### ALIST
-
-Syntax:
-
- alist-constructor-pattern ::= (alist (key . PATTERN)*)
-
-Examples:
-
- (match '((:one . 1) (:two . 2) (:three . 3))
- ((alist (:one . 1) (:two . x)) x))
- => 2"))
View
@@ -263,6 +263,24 @@ Examples:
:predicate (lambda (var) `(consp ,var))
:accessor (lambda (var i) `(,(ecase i (0 'car) (1 'cdr)) ,var)))))
+(defmethod optima::parse-constructor-pattern ((name (eql 'assoc)) &rest args)
+ (destructuring-bind (key value . assoc-args) args
+ (optima::make-constructor-pattern
+ :specifier `(assoc ,@args)
+ :signature `(assoc ,key ,@assoc-args)
+ :arguments (list (parse-pattern value))
+ :predicate (lambda (var) (values `(%assoc ,key ,var ,@assoc-args) t))
+ :accessor (lambda (var i) (assert (zerop i)) `(cdr ,var)))))
+
+(defmethod optima::parse-constructor-pattern ((name (eql 'passoc)) &rest args)
+ (destructuring-bind (key value) args
+ (optima::make-constructor-pattern
+ :specifier `(passoc ,@args)
+ :signature `(passoc ,key)
+ :arguments (list (parse-pattern value))
+ :predicate (lambda (var) (values `(%passoc ,key ,var) t))
+ :accessor (lambda (var i) (assert (zerop i)) `(cadr ,var)))))
+
(defmethod parse-constructor-pattern ((name (eql 'vector)) &rest args)
(let* ((args (mapcar #'parse-pattern args))
(arity (length args)))
@@ -23,3 +23,25 @@ the comparison form to some specific form as follows:
((literalp value) `(eql ,var ,value))
((consp value) `(%equal ,var ',value))
(t `(%equal ,var ,value))))
+
+(defun %assoc (item alist &key (key #'identity) (test #'eql))
+ "Safe ASSOC."
+ (declare (optimize (speed 3) (safety 0) (space 0)))
+ (loop
+ (unless (consp alist) (return))
+ (let ((cons (car alist)))
+ (when (and (consp cons)
+ (funcall test item (funcall key (car cons))))
+ (return cons)))
+ (setq alist (cdr alist))))
+
+(defun %passoc (item plist)
+ "Safe plist assoc."
+ (declare (optimize (speed 3) (safety 0) (space 0)))
+ (loop
+ (unless (consp plist) (return))
+ (let ((cons (cdr plist)))
+ (unless (consp cons) (return))
+ (when (eql item (car plist))
+ (return plist))
+ (setq plist (cdr cons)))))
View
@@ -70,6 +70,14 @@
(test constructor-pattern
;; cons
(is-match (cons 1 2) (cons 1 2))
+ ;; assoc
+ (is-match '((1 . 2)) (assoc 1 2))
+ (is-match '((1 . 2) (3 . 4)) (assoc 3 4))
+ (is-match '(1 (2 . 3)) (assoc 2 3))
+ (is-not-match 1 (assoc 1 2))
+ (is-not-match '((1 . 2)) (assoc 3 4))
+ (is-not-match '((1 . 2) (3 . 4)) (assoc 3 5))
+ (is-match '(("a" . 1)) (assoc "A" 1 :test #'string-equal))
;; vector
(is-match (vector 1 2) (vector 1 2))
;; simple-vector
@@ -106,7 +114,13 @@
(test derived-pattern
;; list
- (is-match (list 1 2 3) (list 1 2 3))
+ (is-match '(1 2 3) (list 1 2 3))
+ ;; list*
+ (is-match '(1 2 3) (list* 1 2 (list 3)))
+ ;; alist
+ (is-match '((1 . 2) (2 . 3) (3 . 4)) (alist (3 . 4) (1 . 2)))
+ ;; plist
+ (is-match '(:a 1 :b 2 :c 3) (plist :c 3 :a 1))
;; satisfies
(is-match 1 (satisfies numberp))
(is-not-match 1 (satisfies stringp))

0 comments on commit 2475a18

Please sign in to comment.