Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Introduce MAKE-INSTANCE style pattern syntax

  • Loading branch information...
commit a73d55cb144d1fd1a3d9d04c09d68039a6f9fab7 1 parent c7177fc
Tomohiro Matsuyama authored
Showing with 62 additions and 2 deletions.
  1. +18 −0 README.md
  2. +18 −0 optima.asd
  3. +18 −0 src/pattern.lisp
  4. +8 −2 test/suite.lisp
View
18 README.md
@@ -240,6 +240,17 @@ Examples:
((person name age) (list name age)))
=> ("foo" 30)
+You can also use MAKE-INSTANCE style pattern syntax like:
+
+ (match foo
+ ((person :name name :age age) (list name age)))
+ => ("foo" 30)
+
+This is equal to the example above except this implicitly resolves the
+slot names using Meta Object Protocol. In this case, you have to make
+sure the slot names can be determined uniquely during the
+compilation. Otherwise, you will get a compilation error.
+
#### STRUCTURE
Matches any structure value, and its slot values.
@@ -283,6 +294,13 @@ Examples:
((p- name age) (list name age)))
=> ("foo" 30)
+Same as class constructor-pattern, you can also use MAKE-INSTANCE
+style pattern syntax like:
+
+ (match (cons 1 2)
+ ((point- :x x :y y) (list x y)))
+ => (1 2)
+
### Derived-Pattern
A derived-pattern is a pattern that is defined with DEFPATTERN. There
View
18 optima.asd
@@ -239,6 +239,17 @@ Examples:
((person name age) (list name age)))
=> (\"foo\" 30)
+You can also use MAKE-INSTANCE style pattern syntax like:
+
+ (match foo
+ ((person :name name :age age) (list name age)))
+ => (\"foo\" 30)
+
+This is equal to the example above except this implicitly resolves the
+slot names using Meta Object Protocol. In this case, you have to make
+sure the slot names can be determined uniquely during the
+compilation. Otherwise, you will get a compilation error.
+
#### STRUCTURE
Matches any structure value, and its slot values.
@@ -282,6 +293,13 @@ Examples:
((p- name age) (list name age)))
=> (\"foo\" 30)
+Same as class constructor-pattern, you can also use MAKE-INSTANCE
+style pattern syntax like:
+
+ (match (cons 1 2)
+ ((point- :x x :y y) (list x y)))
+ => (1 2)
+
### Derived-Pattern
A derived-pattern is a pattern that is defined with DEFPATTERN. There
View
18 src/pattern.lisp
@@ -469,6 +469,20 @@ Examples:
(apply #'make-simple-vector-pattern (mapcar #'parse-pattern args)))
(defun parse-class-pattern (class-name &rest slot-specs)
+ ;; Transform MAKE-INSTANCE style syntax. During the transformation,
+ ;; we also resolve the slot names via MOP. If no slot found or too
+ ;; many slots found, we will raise an error.
+ (when (keywordp (first slot-specs))
+ (setq slot-specs
+ (loop with class = (find-class class-name nil)
+ with all-slot-names = (mapcar #'closer-mop:slot-definition-name
+ (closer-mop:class-slots class))
+ for (slot-name . pattern) in (plist-alist slot-specs)
+ for slot-names = (remove-if (lambda (name) (string/= slot-name name)) all-slot-names)
+ collect (case (length slot-names)
+ (0 (error "Slot ~S not found" slot-name))
+ (1 `(,(first slot-names) ,pattern))
+ (t (error "Ambiguous slot name ~S" slot-name))))))
(apply #'make-class-pattern class-name
(loop for slot-spec in slot-specs
do (setq slot-spec (ensure-list slot-spec))
@@ -479,6 +493,10 @@ Examples:
(make-variable-pattern slot-name)))))))
(defun parse-structure-pattern (conc-name &rest slot-specs)
+ ;; Transform MAKE-INSTANCE style syntax.
+ (when (keywordp (first slot-specs))
+ (setq slot-specs (mapcar (lambda (assoc) (list (car assoc) (cdr assoc)))
+ (plist-alist slot-specs))))
(apply #'make-structure-pattern conc-name
(loop for slot-spec in slot-specs
do (setq slot-spec (ensure-list slot-spec))
View
10 test/suite.lisp
@@ -106,7 +106,10 @@
(is-match person (person (age 31)))
(is-not-match person (person (name "Alice")))
(is-not-match person (person (age 49)))
- (is-not-match 1 (person)))
+ (is-not-match 1 (person))
+ ;; make-instance style
+ (is-match person (person :name "Bob" :age 31))
+ (is-not-match person (person :name "Bob" :age 49)))
;; structure
(let ((point (make-point :x 1 :y 2)))
(is (equal (match point
@@ -123,7 +126,10 @@
(is-match point (point- (x 1)))
(is-match point (point- (y 2)))
(is-not-match point (point- (x 2)))
- (is-not-match 1 (point-))))
+ (is-not-match 1 (point-))
+ ;; make-instance style
+ (is-match point (point- :x 1 :y 2))
+ (is-not-match point (point- :x 2 :y 2))))
(test derived-pattern
;; list
Please sign in to comment.
Something went wrong with that request. Please try again.