types: match works also for list, vector, and map templates

2 files changed, 171 insertions, 62 deletions

diff --git a/src/clojure/contrib/types.clj b/src/clojure/contrib/types.clj
index c2b48272..672d537f 100644
--- a/src/clojure/contrib/types.clj
+++ b/src/clojure/contrib/types.clj
@@ -1,7 +1,7 @@
 ;; Data types
 
 ;; by Konrad Hinsen
-;; last updated March 15, 2009
+;; last updated March 29, 2009
 
 ;; Copyright (c) Konrad Hinsen, 2009. All rights reserved.  The use
 ;; and distribution terms for this software are covered by the Eclipse
@@ -85,8 +85,10 @@
      ~@optional))
 
 (defmethod print-method ::type [o w]
-  (let [[name & args] (constructor-form o)]
-    (print-method (cons (unqualified-symbol name) args) w)))
+  (let [cf (constructor-form o)]
+    (if (symbol? cf)
+      (print-method (unqualified-symbol cf) w)
+      (print-method (cons (unqualified-symbol (first cf)) (rest cf)) w))))
 
 ;
 ; Algebraic types
@@ -130,67 +132,136 @@
 ;
 ;  Matching templates
 ;
-(defn- tests-and-bindings
+(defn- symbol-tests-and-bindings
+  [template vsymbol]
+  [`(= (quote ~(resolve-symbol template)) ~vsymbol)
+   []])
+
+(defn- sequential-tests-and-bindings
+  [template vsymbol]
+  (let [enum-values (map list template (range (count template)))
+        ; Non-symbols in the template create an equality test with the
+	; corresponding value in the object's value list
+	tests (map (fn [[v i]] `(= ~v (nth ~vsymbol ~i)))
+		   (filter (complement #(symbol? (first %))) enum-values))
+        ; Symbols in the template become bindings to the corresponding
+        ; value in the object. However, if a symbol occurs more than once,
+        ; only one binding is generated, and equality tests are added
+        ; for the other values.
+	bindings (reduce (fn [map [symbol index]]
+			   (assoc map symbol
+				  (conj (get map symbol []) index)))
+			 {}
+			 (filter #(symbol? (first %)) enum-values))
+	tests (concat tests
+		      (map (fn [[symbol indices]]
+			     (cons `= (map #(list `nth vsymbol %) indices)))
+			   (filter #(> (count (second %)) 1) bindings)))
+	bindings (mapcat (fn [[symbol indices]]
+			   [symbol (list `nth vsymbol (first indices))])
+			 bindings)]
+    [tests (vec bindings)]))
+
+(defn- constr-tests-and-bindings
+  [template cfsymbol]
+  (let [[tag & values] template
+	cfasymbol (gensym)
+	[tests bindings] (sequential-tests-and-bindings values cfasymbol)
+	argtests (if (empty? tests)
+		   tests
+		   `((let [~cfasymbol (rest ~cfsymbol)] ~@tests)))]
+    [`(and (seq? ~cfsymbol)
+	   (= (quote ~(resolve-symbol tag)) (first ~cfsymbol))
+	   ~@argtests)
+     `[~cfasymbol (rest ~cfsymbol) ~@bindings]]))
+
+(defn- list-tests-and-bindings
   [template vsymbol]
-  (if (symbol? template)
-    [`(= (quote ~(resolve-symbol template)) ~vsymbol)
-     []]
-    (let [[tag & values] template
-          enum-values (map list values (range 1 (inc (count values))))
-          ; Non-symbols in the template create an equality test with the
-	  ; corresponding value in the object's value list
-	  tests (map (fn [[v i]] `(= ~v (nth ~vsymbol ~i)))
-		     (filter (complement #(symbol? (first %))) enum-values))
-          ; Symbols in the template become bindings to the corresponding
-          ; value in the object. However, if a symbol occurs more than once,
-          ; only one binding is generated, and equality tests are added
-          ; for the other values.
-	  bindings (reduce (fn [map [symbol index]]
-			     (assoc map symbol
-				    (conj (get map symbol []) index)))
-			   {}
-			   (filter #(symbol? (first %)) enum-values))
-	  tests (concat tests
-			(map (fn [[symbol indices]]
-			       (cons `= (map #(list `nth vsymbol %) indices)))
-			     (filter #(> (count (second %)) 1) bindings)))
-	  bindings (apply concat
-			  (map (fn [[symbol indices]]
-				 [symbol (list `nth vsymbol (first indices))])
-			       bindings))]
-      [(cons `and
-	     (cons `(seq? ~vsymbol)
-		   (cons `(= (quote ~(resolve-symbol tag))
-			     (first ~vsymbol))
-			 tests)))
-       (vec bindings)])))
+  (let [[tests bindings] (sequential-tests-and-bindings template vsymbol)]
+    [`(and (list? ~vsymbol) ~@tests)
+     bindings]))
+
+(defn- vector-tests-and-bindings
+  [template vsymbol]
+  (let [[tests bindings] (sequential-tests-and-bindings template vsymbol)]
+    [`(and (vector? ~vsymbol) ~@tests)
+     bindings]))
+
+(defn- map-tests-and-bindings
+  [template vsymbol]
+  (let [; First test if the given keys are all present.
+	tests (map (fn [[k v]] `(contains? ~vsymbol ~k)) template)
+        ; Non-symbols in the template create an equality test with the
+	; corresponding value in the object's value list.
+	tests (concat tests
+	        (map (fn [[k v]] `(= ~v (~k ~vsymbol)))
+		     (filter (complement #(symbol? (second %))) template)))
+        ; Symbols in the template become bindings to the corresponding
+        ; value in the object. However, if a symbol occurs more than once,
+        ; only one binding is generated, and equality tests are added
+        ; for the other values.
+	bindings (reduce (fn [map [key symbol]]
+			   (assoc map symbol
+				  (conj (get map symbol []) key)))
+			 {}
+			 (filter #(symbol? (second %)) template))
+	tests (concat tests
+	        (map (fn [[symbol keys]]
+		       (cons `= (map #(list % vsymbol) keys)))
+		     (filter #(> (count (second %)) 1) bindings)))
+	bindings (mapcat (fn [[symbol keys]]
+			   [symbol (list (first keys) vsymbol)])
+			 bindings)]
+    [`(and (map? ~vsymbol) ~@tests)
+     (vec bindings)]))
+
+(defn- tests-and-bindings
+  [template vsymbol cfsymbol]
+  (cond (symbol? template)
+	  (symbol-tests-and-bindings template cfsymbol)
+	(seq? template)
+	  (if (= (first template) 'quote)
+	    (list-tests-and-bindings (second template) vsymbol)
+	    (constr-tests-and-bindings template cfsymbol))
+	(vector? template)
+	  (vector-tests-and-bindings template vsymbol)
+	(map? template)
+	  (map-tests-and-bindings template vsymbol)
+	:else
+	  (throw (IllegalArgumentException. "illegal template for match"))))
 
 (defmacro match
   "Given a value and a list of template-expr clauses, evaluate the first
-   expr whose template matches the value. Templates have the same form
-   as constructors. The arguments can be expressions, which must be equal
-   to the corresponding elements of value for the template to match, or
-   symbols, which will be bound to the corresponding elements of value
-   in the evaluation of expr. If the same symbol occurs more than once,
-   the corresponding elements of value must be equal for the template
-   to match."
+   expr whose template matches the value. There are four kinds of templates:
+   1) Lists of the form (tag x1 x2 ...) match instances of types
+      whose constructor has the same form as the list.
+   2) Quoted lists of the form '(x1 x2 ...) match lists of the same
+      length.
+   3) Vectors of the form [x1 x2 ...] match vectors of the same length.
+   4) Maps of the form {:key1 x1 :key2 x2 ...} match maps that have
+      the same keys as the template, but which can have additional keys
+      that are not part of the template.
+   The values x1, x2, ... can be symbols or non-symbol values. Non-symbols
+   must be equal to the corresponding values in the object to be matched.
+   Symbols will be bound to the corresponding value in the object in the
+   evaluation of expr. If the same symbol occurs more than once in a,
+   template the corresponding elements of the object must be equal
+   for the template to match."
   [value & clauses]
    (when (odd? (count clauses))
      (throw (Exception. "Odd number of elements in match expression")))
   (let [vsymbol (gensym)
 	cfsymbol (gensym)
-	terms (apply concat
-		     (map (fn [[template expr]]
-			    (if (= template :else)
-			      [template expr]
-			      (let [[tests bindings]
-				    (tests-and-bindings template cfsymbol)]
-				[tests
-				 (if (empty? bindings)
-				   expr
-				   `(let ~bindings ~expr))])))
-			  (partition 2 clauses)))]
+	terms (mapcat (fn [[template expr]]
+			(if (= template :else)
+			  [template expr]
+			  (let [[tests bindings]
+				(tests-and-bindings template vsymbol cfsymbol)]
+			    [tests
+			     (if (empty? bindings)
+			       expr
+			       `(let ~bindings ~expr))])))
+		      (partition 2 clauses))]
     `(let [~vsymbol ~value
 	   ~cfsymbol (constructor-form ~vsymbol)]
        (cond ~@terms))))
- 
\ No newline at end of file
diff --git a/src/clojure/contrib/types/examples.clj b/src/clojure/contrib/types/examples.clj
index 8c56b1c5..fc9435fe 100644
--- a/src/clojure/contrib/types/examples.clj
+++ b/src/clojure/contrib/types/examples.clj
@@ -1,7 +1,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
-;; Application examples for algebraic data types
+;; Application examples for data types
 ;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -73,6 +73,7 @@
     (node l r)  (inc (max (depth l) (depth r)))))
 
 (depth empty-tree)
+(depth (leaf 42))
 (depth a-tree)
 
 ; Algebraic data types with multimethods: fmap on a tree
@@ -87,6 +88,7 @@
 
 ;
 ; Nonsense examples to illustrate all the features of match
+; for type constructors.
 ;
 (defadt ::foo
   (bar a b c))
@@ -100,9 +102,45 @@
     (bar a b 1)  (* a b)
     :else        42))
 
-(foo-to-int (bar 0 0 0))
-(foo-to-int (bar 0 5 6))
-(foo-to-int (bar 1 2 3))
-(foo-to-int (bar 3 3 1))
-(foo-to-int (bar 0 3 1))
-(foo-to-int (bar 10 20 30))
+(foo-to-int (bar 0 0 0))    ; 0
+(foo-to-int (bar 0 5 6))    ; 11
+(foo-to-int (bar 1 2 3))    ; -1
+(foo-to-int (bar 3 3 1))    ; 9
+(foo-to-int (bar 0 3 1))    ; 4
+(foo-to-int (bar 10 20 30)) ; 42
+
+;
+; Match can also be used for lists, vectors, and maps. Note that since
+; algebraic data types are represented as maps, they can be matched
+; either with their type constructor and positional arguments, or
+; with a map template.
+;
+
+; Tree depth once again with map templates
+(defn depth
+  [t]
+  (match t
+    empty-tree  0
+    {:value _}  1
+    {:left-tree l :right-tree r}  (inc (max (depth l) (depth r)))))
+
+(depth empty-tree)
+(depth (leaf 42))
+(depth a-tree)
+
+; Match for lists, vectors, and maps:
+
+(for [x ['(1 2 3)
+	 [1 2 3]
+	 {:x 1 :y 2 :z 3}
+	 '(1 1 1)
+	 [2 1 2]
+	 {:x 1 :y 1 :z 2}]]
+  (match x
+    '(a a a)  	 'list-of-three-equal-values
+    '(a b c)  	 'list
+    [a a a]   	 'vector-of-three-equal-values
+    [a b a]   	 'vector-of-three-with-first-and-last-equal
+    [a b c]      'vector
+    {:x a :y z}  'map-with-x-equal-y
+    {}           'any-map))