types: redesign

3 files changed, 158 insertions, 97 deletions

diff --git a/src/clojure/contrib/accumulators.clj b/src/clojure/contrib/accumulators.clj
index f06badf7..d32dbda6 100644
--- a/src/clojure/contrib/accumulators.clj
+++ b/src/clojure/contrib/accumulators.clj
@@ -1,7 +1,7 @@
 ;; Accumulators
 
 ;; by Konrad Hinsen
-;; last updated March 2, 2009
+;; last updated March 11, 2009
 
 ;; This module defines various accumulators (list, vector, map,
 ;; sum, product, counter, and combinations thereof) with a common
@@ -19,7 +19,7 @@
 ;; remove this notice, or any other, from this software.
 
 (ns clojure.contrib.accumulators
-  (:use [clojure.contrib.types :only (deftype get-value get-values)])
+  (:use [clojure.contrib.types :only (deftype)])
   (:use [clojure.contrib.def :only (defvar defvar- defmacro-)]))
 
 (defmulti add
@@ -135,31 +135,17 @@
 ;
 (defmacro- defacc
   [name op empty doc-string]
-  (let [type-name (symbol (str name "-type"))
+  (let [type-tag (keyword (str *ns*) (str name))
 	empty-symbol (symbol (str "empty-" name))]
   `(let [op# ~op]
-     (deftype ~type-name (~name ~'v))
+     (deftype ~type-tag ~name
+       (fn [~'x] {:value ~'x})
+       (fn [~'x] (list (:value ~'x))))
      (defvar ~empty-symbol (~name ~empty) ~doc-string)
-     (defmethod combine ~type-name [& vs#]
-       (~name (apply op# (map clojure.contrib.types/get-value vs#))))
-     (defmethod add ~type-name [v# e#]
-       (~name (op# (clojure.contrib.types/get-value v#) e#))))))
-
-;; (defmacro- defacc
-;;   [name op empty doc-string]
-;;   (let [struct-tag (keyword (str name))
-;; 	meta-tag (keyword (str *ns*) (str name))
-;; 	empty-symbol (symbol (str "empty-" name))]
-;;   `(let [op# ~op
-;; 	 meta-data# {::accumulator ~meta-tag}
-;; 	 struct-basis# (create-struct ~struct-tag)
-;; 	 get-value# (accessor struct-basis# ~struct-tag)
-;; 	 make-fn# (fn [n#] (with-meta (struct struct-basis# n#) meta-data#))]
-;;      (defvar ~empty-symbol (make-fn# ~empty) ~doc-string)
-;;      (defmethod combine ~meta-tag [& vs#]
-;;        (make-fn# (apply op# (map get-value# vs#))))
-;;      (defmethod add ~meta-tag [v# e#]
-;;        (make-fn# (op# (get-value# v#) e#))))))
+     (defmethod combine ~type-tag [& vs#]
+       (~name (apply op# (map :value vs#))))
+     (defmethod add ~type-tag [v# e#]
+       (~name (op# (:value v#) e#))))))
 
 (defacc sum + 0
   "An empty sum accumulator. Only numbers can be added.")
@@ -188,23 +174,24 @@
 ; Numeric min-max accumulator
 ; (combination of minimum and maximum)
 ;
-(deftype min-max-type
-  (min-max min max))
+(deftype ::min-max min-max
+  (fn [min max] {:min min :max max})
+  (fn [mm] (list (:min mm) (:max mm))))
 
 (defvar empty-min-max (min-max nil nil)
   "An empty min-max accumulator, combining minimum and maximum.
    Only numbers can be added.")
 
-(defmethod combine min-max-type
+(defmethod combine ::min-max
   [& vs]
-  (let [values (map get-values vs)
-	total-min (apply min (map first values))
-	total-max (apply max (map second values))]
+  (let [total-min (apply min (map :min vs))
+	total-max (apply max (map :max vs))]
     (min-max total-min total-max)))
 
-(defmethod add min-max-type
+(defmethod add ::min-max
   [v e]
-  (let [[min-v max-v] (get-values v)
+  (let [min-v (:min v)
+	max-v (:max v)
 	new-min (if (nil? min-v) e (min min-v e))
 	new-max (if (nil? max-v) e (max max-v e))]
     (min-max new-min new-max)))
@@ -212,63 +199,57 @@
 ;
 ; Counter accumulator
 ;
-(let [type-tag ::counter
-      meta-map {:type type-tag}]
+(deftype ::counter counter)
 
-  (defvar empty-counter (with-meta {} meta-map)
-    "An empty counter accumulator. Its value is a map that stores for
-     every item the number of times it was added.")
+(defvar empty-counter (counter {})
+  "An empty counter accumulator. Its value is a map that stores for
+   every item the number of times it was added.")
 
-  (defmethod combine type-tag
-    [v & vs]
-    (letfn [(add-item [counter [item n]]
-    	        (assoc counter item (+ n (get counter item 0))))
-	    (add-two [c1 c2] (reduce add-item c1 c2))]
-	   (reduce add-two v vs)))
+(defmethod combine ::counter
+  [v & vs]
+  (letfn [(add-item [cntr [item n]]
+		    (assoc cntr item (+ n (get cntr item 0))))
+	  (add-two [c1 c2] (reduce add-item c1 c2))]
+	 (reduce add-two v vs)))
 
-  (defmethod add type-tag
-    [v e]
-    (assoc v e (inc (get v e 0)))))
+(defmethod add ::counter
+  [v e]
+  (assoc v e (inc (get v e 0))))
 
 ;
 ; Counter accumulator with total count
 ;
+(deftype ::counter-with-total counter-with-total)
+(derive ::counter-with-total ::counter)
 
-(let [type-tag ::counter-with-total
-      meta-map {:type type-tag}]
-
-  (derive type-tag ::counter)
-
-  (defvar empty-counter-with-total
-    (with-meta {:total 0} meta-map)
-    "An empty counter-with-total accumulator. It works like the counter
-     accumulator, except that the total number of items added is stored as the
-     value of the key :totall.")
+(defvar empty-counter-with-total
+  (counter-with-total {:total 0})
+  "An empty counter-with-total accumulator. It works like the counter
+   accumulator, except that the total number of items added is stored as the
+   value of the key :total.")
 
-  (defmethod add type-tag
-    [v e]
-    (assoc v e (inc (get v e 0))
-	     :total (inc (:total v)))))
+(defmethod add ::counter-with-total
+  [v e]
+  (assoc v e (inc (get v e 0))
+	 :total (inc (:total v))))
 
 ;
 ; Accumulator n-tuple
 ;
-(let [type-tag ::tuple
-      meta-map {:type type-tag}
-      make (fn [s] (with-meta (into [] s) meta-map))]
-
-  (defn empty-tuple
-    "Returns an accumulator tuple with the supplied empty-accumulators
-     as its value. Accumulator tuples consist of several accumulators that
-     work in parallel. Added items must be sequences whose number of elements
-     matches the number of sub-accumulators."
-    [empty-accumulators]
-    (make empty-accumulators))
-
-  (defmethod combine ::tuple
-    [& vs]
-    (make (map combine vs)))
-
-  (defmethod add ::tuple
-    [v e]
-    (make (map add v e))))
+(deftype ::tuple acc-tuple)
+
+(defn empty-tuple
+  "Returns an accumulator tuple with the supplied empty-accumulators
+   as its value. Accumulator tuples consist of several accumulators that
+   work in parallel. Added items must be sequences whose number of elements
+   matches the number of sub-accumulators."
+  [empty-accumulators]
+  (acc-tuple (into [] empty-accumulators)))
+
+(defmethod combine ::tuple
+  [& vs]
+  (acc-tuple (vec (map combine vs))))
+
+(defmethod add ::tuple
+  [v e]
+  (acc-tuple (vec (map add v e))))
diff --git a/src/clojure/contrib/types.clj b/src/clojure/contrib/types.clj
index 38f13cb2..53cdb816 100644
--- a/src/clojure/contrib/types.clj
+++ b/src/clojure/contrib/types.clj
@@ -1,7 +1,7 @@
-;; Algebraic data types
+;; Data types
 
 ;; by Konrad Hinsen
-;; last updated February 26, 2009
+;; last updated March 12, 2009
 
 ;; Copyright (c) Konrad Hinsen, 2009. All rights reserved.  The use
 ;; and distribution terms for this software are covered by the Eclipse
@@ -12,11 +12,46 @@
 ;; remove this notice, or any other, from this software.
 
 (ns clojure.contrib.types
-  "Algebraic data types")
+  "General and algebraic data types
+
+   NOTE: This library is experimental. It may change significantly
+   with future release.")
+
+;
+; Data type definition
+;
+(defmulti deconstruct type)
+(defmethod deconstruct :default [x] (list x))
+
+(defmacro deftype
+  "Define a data type by a type tag (a namespace-qualified keyword)
+  and a symbol naming the constructor function. Optionally, a pair
+  of constructor and deconstructor functions can be given as well,
+  the defaults are clojure.core/identity and clojure.core/list.
+  The full constructor associated with constructor-name calls the
+  constructor function and attaches the type tag to its result
+  as metadata. The deconstructor function must return the arguments
+  to be passed to the constructor in order to create an equivalent
+  object. It is used for printing and matching."
+  ([type-tag constructor-name]
+   `(deftype ~type-tag ~constructor-name identity list))
+  ([type-tag constructor-name constructor deconstructor]
+   `(do
+      (derive ~type-tag ::type)
+      (let [meta-map# {:type ~type-tag ::constructor (quote ~constructor-name)}]
+        (def ~constructor-name
+	  (comp (fn [~'x] (with-meta ~'x meta-map#)) ~constructor))
+	(defmethod deconstruct ~type-tag [~'x]
+	  (~deconstructor (with-meta ~'x {})))))))
+
+(defmethod print-method ::type [o w]
+  (print-method (cons (::constructor ^o) (deconstruct o)) w))
 
 ;
 ; Defining algebraic types
 ;
+(derive ::adt ::type)
+
 (defn- qualified-symbol
   [s]
   (symbol (str *ns*) (str s)))
@@ -38,15 +73,13 @@
 	   (with-meta [(quote ~(qualified-symbol name)) ~@args]
 		      ~meta-map-symbol))))))
 
-(defmacro deftype
-  "Define the algebraic data type name by an exhaustive list of constructors.
+(defmacro defadt
+  "Define an algebraic data type name by an exhaustive list of constructors.
    Each constructor can be a symbol (argument-free constructor) or a
    list consisting of a tag symbol followed by the argument symbols.
-   The data type itself is a keyword declared as deriving from
-   :clojure.contrib.types/adt."
-  [name & constructors]
-  (let [type-tag (qualified-keyword name)
-	meta-map-symbol (gensym "mm")
+   The data type tag must be a keyword."
+  [type-tag & constructors]
+  (let [meta-map-symbol (gensym "mm")
 	accessor1 (if (and (= 1 (count constructors))
 			   (seq? (first constructors))
 			   (= 2 (count (first constructors))))
@@ -60,7 +93,6 @@
 		    nil)]
     `(let [~meta-map-symbol {:type ~type-tag}]
        (derive ~type-tag ::adt)
-       (def ~name ~type-tag)
        ~@(map (partial constructor-code meta-map-symbol) constructors)
        ~accessor1
        ~accessor2
@@ -72,7 +104,7 @@
 (defn- unqualified-symbol
   [s]
   (let [s-str (str s)]
-    (symbol (.substring s-str (inc (.indexOf s-str (int \/)))))))
+    (symbol (subs s-str (inc (.indexOf s-str (int \/)))))))
 
 (defmethod print-method ::adt [o w]
   (if (symbol? o)
diff --git a/src/clojure/contrib/types/examples.clj b/src/clojure/contrib/types/examples.clj
index 5a39938f..e38d6425 100644
--- a/src/clojure/contrib/types/examples.clj
+++ b/src/clojure/contrib/types/examples.clj
@@ -7,12 +7,60 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (ns clojure.contrib.types.examples
-  (:use [clojure.contrib.types :only (deftype match get-value get-values)]))
+  (:use [clojure.contrib.types
+	 :only (deftype defadt match get-value get-values)]))
 
 ;
-; A simple tree structure
+; Multisets implemented as maps to integers
 ;
-(deftype tree
+
+; The most basic type definition. A more elaborate version could add
+; a constructor that verifies that its argument is a map with integer values.
+(deftype ::multiset multiset)
+
+; Some set operations generalized to multisets
+; Note that the multiset constructor is not called anywhere, as the
+; map operations all preserve the metadata.
+(defmulti my-conj (fn [& args] (type (first args))))
+
+(defmethod my-conj :default
+  [& args]
+  (apply clojure.core/conj args))
+
+(defmethod my-conj ::multiset
+  ([ms x]
+   (assoc ms x (inc (get ms x 0))))
+  ([ms x & xs]
+    (reduce my-conj (my-conj ms x) xs)))
+
+(defmulti union (fn [& sets] (type (first sets))))
+
+(defmethod union clojure.lang.IPersistentSet
+  [& sets]
+  (apply clojure.set/union sets))
+
+; Note: a production-quality implementation should accept standard sets
+; and perhaps other collections for its second argument.
+(defmethod union ::multiset
+  ([ms] ms)
+  ([ms1 ms2]
+     (letfn [(add-item [ms [item n]]
+		       (assoc ms item (+ n (get ms item 0))))]
+       (reduce add-item ms1 ms2)))
+  ([ms1 ms2 & mss]
+     (reduce union (union ms1 ms2) mss)))
+
+; Let's use it:
+(my-conj #{} :a :a :b :c)
+(my-conj (multiset {}) :a :a :b :c)
+
+(union #{:a :b} #{:b :c})
+(union (multiset {:a 1 :b 1}) (multiset {:b 1 :c 2}))
+
+;
+; A simple tree structure defined as an algebraic data type
+;
+(defadt ::tree
   empty-tree
   (leaf value)
   (node left-tree right-tree))
@@ -52,7 +100,7 @@
   (into {} (for [[k v] m] [k (f v)])))
 
 ; Trees
-(defmethod fmap tree
+(defmethod fmap ::tree
   [f t]
   (match t
     empty-tree  empty-tree
@@ -67,7 +115,7 @@
 ;
 ; Nonsense examples to illustrate all the features of match
 ;
-(deftype foo
+(defadt ::foo
   (bar a b c))
 
 (defn foo-to-int
@@ -97,7 +145,7 @@
 (get-value (bar 1 2 3))  ; fails
 (get-values (bar 1 2 3))
 
-(deftype sum-type
+(defadt ::sum
   (sum x))
 
 (get-value (sum 42))