generic: new module comparison plus general support code

6 files changed, 142 insertions, 49 deletions

diff --git a/build.xml b/build.xml
index 581640d2..ca8ee1bd 100644
--- a/build.xml
+++ b/build.xml
@@ -84,8 +84,10 @@
       <arg value="clojure.contrib.duck-streams"/>
       <arg value="clojure.contrib.except"/>
       <arg value="clojure.contrib.fcase"/>
+      <arg value="clojure.contrib.generic"/>
       <arg value="clojure.contrib.generic.arithmetic"/>
       <arg value="clojure.contrib.generic.collection"/>
+      <arg value="clojure.contrib.generic.comparison"/>
       <arg value="clojure.contrib.generic.functor"/>
       <arg value="clojure.contrib.generic.math-functions"/>
       <arg value="clojure.contrib.import-static"/>
diff --git a/src/clojure/contrib/gen_html_docs.clj b/src/clojure/contrib/gen_html_docs.clj
index a008a75a..631081e5 100644
--- a/src/clojure/contrib/gen_html_docs.clj
+++ b/src/clojure/contrib/gen_html_docs.clj
@@ -482,8 +482,10 @@ emits the generated HTML to the path named by path."
      'clojure.contrib.error-kit
      'clojure.contrib.except
      'clojure.contrib.fcase
+     'clojure.contrib.generic
      'clojure.contrib.generic.arithmetic
      'clojure.contrib.generic.collection
+     'clojure.contrib.generic.comparison
      'clojure.contrib.generic.functor
      'clojure.contrib.generic.math-functions
      'clojure.contrib.import-static
diff --git a/src/clojure/contrib/generic.clj b/src/clojure/contrib/generic.clj
new file mode 100644
index 00000000..d16e5ed0
--- /dev/null
+++ b/src/clojure/contrib/generic.clj
@@ -0,0 +1,36 @@
+;; Support code for generic interfaces
+
+(ns clojure.contrib.generic
+  "Generic interface support code
+
+   NOTE: This library is VERY experimental. It WILL change significantly
+   with future release."
+  (:use [clojure.contrib.types :only (defadt)]))
+
+;
+; A dispatch function that separates nulary, unary, binary, and
+; higher arity calls and also selects on type for unary and binary
+; calls.
+;
+(defn nary-dispatch
+  ([] ::nulary)
+  ([x] (type x))
+  ([x y]
+     [(type x) (type y)])
+  ([x y & more] ::nary))
+
+;
+; We can't use [::binary :default], so we need to define a root type
+; of the type hierarcy. The derivation for Object covers all classes,
+; but all non-class types will need an explicit derive clause.
+; Ultimately, a macro might take care of this.
+;
+(def root-type ::any)
+(derive Object root-type)
+
+;
+; Symbols referring to ::nulary and ::n-ary
+;
+(def nulary-type ::nulary)
+(def nary-type ::nary)
+
diff --git a/src/clojure/contrib/generic/arithmetic.clj b/src/clojure/contrib/generic/arithmetic.clj
index 98d5cfef..e7e01b42 100644
--- a/src/clojure/contrib/generic/arithmetic.clj
+++ b/src/clojure/contrib/generic/arithmetic.clj
@@ -1,7 +1,7 @@
 ;; Generic interfaces for arithmetic operations
 
 ;; by Konrad Hinsen
-;; last updated March 13, 2009
+;; last updated March 19, 2009
 
 ;; Copyright (c) Konrad Hinsen, 2009. All rights reserved.  The use
 ;; and distribution terms for this software are covered by the Eclipse
@@ -22,36 +22,19 @@
    for a type are binary + and * plus unary - and /. Everything else
    is derived from these automatically. Explicit binary definitions
    for - and / can be provided for efficiency reasons."
-  (:use [clojure.contrib.types :only (defadt)])
+  (:use [clojure.contrib.generic
+	 :only (root-type nulary-type nary-type nary-dispatch)]
+	[clojure.contrib.types :only (defadt)])
   (:refer-clojure :exclude [+ - * /]))
 
 ;
-; A dispatch function that separates nulary, unary, binary, and
-; higher arity calls and also selects on type for unary and binary
-; calls.
-;
-(defn- nary-dispatch
-  ([] ::nulary)
-  ([x] (type x))
-  ([x y]
-     [(type x) (type y)])
-  ([x y & more] ::n-ary))
-
-;
 ; Universal zero and one values
 ;
 (defadt ::zero zero)
 (defadt ::one one)
 
-;
-; We can't use [::binary :default], so we need to define a root type
-; of the type hierarcy. The derivation for Object covers all classes,
-; but all non-class types will need an explicit derive clause.
-; Ultimately, a macro might take care of this.
-;
-(derive Object ::any)
-(derive ::zero ::any)
-(derive ::one ::any)
+(derive ::zero root-type)
+(derive ::one root-type)
 
 ;
 ; Addition
@@ -62,20 +45,20 @@
 ;
 (defmulti + nary-dispatch)
 
-(defmethod + ::nulary
+(defmethod + nulary-type
   []
   zero)
 
-(defmethod + ::any
+(defmethod + root-type
   [x] x)
 
-(defmethod + [::any ::zero]
+(defmethod + [root-type ::zero]
   [x y] x)
 
-(defmethod + [::zero ::any]
+(defmethod + [::zero root-type]
   [x y] y)
 
-(defmethod + ::n-ary
+(defmethod + nary-type
   [x y & more]
   (if more
     (recur (+ x y) (first more) (next more))
@@ -84,27 +67,27 @@
 ;
 ; Subtraction
 ;
-; The minimal implementation is for [::unary my-type]. A default binary
+; The minimal implementation is for unary my-type. A default binary
 ; implementation is provided as (+ x (- y)), but it is possible to
-; implement [::unary my-type] explicitly for efficiency reasons.
+; implement unary my-type explicitly for efficiency reasons.
 ;
 (defmulti - nary-dispatch)
 
-(defmethod - ::nulary
+(defmethod - nulary-type
   []
   (throw (java.lang.IllegalArgumentException.
 	  "Wrong number of arguments passed")))
 
-(defmethod - [::any ::zero]
+(defmethod - [root-type ::zero]
   [x y] x)
 
-(defmethod - [::zero ::any]
+(defmethod - [::zero root-type]
   [x y] (- y))
 
-(defmethod - [::any ::any]
+(defmethod - [root-type root-type]
   [x y] (+ x (- y)))
 
-(defmethod - ::n-ary
+(defmethod - nary-type
   [x y & more]
   (if more
     (recur (- x y) (first more) (next more))
@@ -113,26 +96,26 @@
 ;
 ; Multiplication
 ;
-; The minimal implementation is for [::binary my-type]. It is possible
-; in principle to implement [::unary my-type] as well, though this
+; The minimal implementation is for binary [my-type my-type]. It is possible
+; in principle to implement unary my-type as well, though this
 ; doesn't make any sense.
 ;
 (defmulti * nary-dispatch)
 
-(defmethod * ::nulary
+(defmethod * nulary-type
   []
   one)
 
-(defmethod * ::any
+(defmethod * root-type
   [x] x)
 
-(defmethod * [::any ::one]
+(defmethod * [root-type ::one]
   [x y] x)
 
-(defmethod * [::one ::any]
+(defmethod * [::one root-type]
   [x y] y)
 
-(defmethod * ::n-ary
+(defmethod * nary-type
   [x y & more]
   (if more
     (recur (* x y) (first more) (next more))
@@ -141,33 +124,45 @@
 ;
 ; Division
 ;
-; The minimal implementation is for [::unary my-type]. A default binary
+; The minimal implementation is for unary my-type. A default binary
 ; implementation is provided as (* x (/ y)), but it is possible to
-; implement [::unary my-type] explicitly for efficiency reasons.
+; implement binary [my-type my-type] explicitly for efficiency reasons.
 ;
 (defmulti / nary-dispatch)
 
-(defmethod / ::nulary
+(defmethod / nulary-type
   []
   (throw (java.lang.IllegalArgumentException.
 	  "Wrong number of arguments passed")))
 
-(defmethod / [::any ::one]
+(defmethod / [root-type ::one]
   [x y] x)
 
-(defmethod / [::one ::any]
+(defmethod / [::one root-type]
   [x y] (/ y))
 
-(defmethod / [::any ::any]
+(defmethod / [root-type root-type]
   [x y] (* x (/ y)))
 
-(defmethod / ::n-ary
+(defmethod / nary-type
   [x y & more]
   (if more
     (recur (/ x y) (first more) (next more))
     (/ x y)))
 
 ;
+; Macros to permit access to the / multimethod via namespace qualification
+;
+(defmacro defmethod*
+  [ns name & args]
+  (let [qsym (symbol (str ns) (str name))]
+    `(defmethod ~qsym ~@args)))
+
+(defmacro qsym
+  [ns sym]
+  (symbol (str ns) (str sym)))
+
+;
 ; Minimal implementations for java.lang.Number
 ;
 (defmethod + [java.lang.Number java.lang.Number]
diff --git a/src/clojure/contrib/generic/comparison.clj b/src/clojure/contrib/generic/comparison.clj
new file mode 100644
index 00000000..6bd34184
--- /dev/null
+++ b/src/clojure/contrib/generic/comparison.clj
@@ -0,0 +1,56 @@
+;; Generic interfaces for comparison operations
+
+;; by Konrad Hinsen
+;; last updated March 19, 2009
+
+;; Copyright (c) Konrad Hinsen, 2009. All rights reserved.  The use
+;; and distribution terms for this software are covered by the Eclipse
+;; Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this
+;; distribution.  By using this software in any fashion, you are
+;; agreeing to be bound by the terms of this license.  You must not
+;; remove this notice, or any other, from this software.
+
+(ns clojure.contrib.generic.comparison
+  "Generic comparison interface
+
+   NOTE: This library is VERY experimental. It WILL change significantly
+   with future release.
+
+   This library defines generic versions of = < > <= >= zero? as multimethods
+   that can be defined for any type."
+  (:refer-clojure :exclude [= < > <= >= zero?])
+  (:use [clojure.contrib.generic
+	 :only (root-type nulary-type nary-type nary-dispatch)]))
+
+;
+; zero?
+;
+(defmulti zero? type)
+
+;
+; Equality
+;
+(defmulti = nary-dispatch)
+
+(defmethod = root-type
+  [x] true)
+
+(defmethod = nary-type
+  [x y & more]
+  (if (= x y)
+    (if (next more)
+      (recur y (first more) (next more))
+      (= y (first more)))
+    false))
+
+;
+; Implementations for Clojure's built-in types
+;
+(defmethod zero? java.lang.Number
+  [x]
+  (clojure.core/zero? x))
+
+(defmethod = [Object Object]
+  [x y]
+  (clojure.core/= x y))
diff --git a/src/clojure/contrib/load_all.clj b/src/clojure/contrib/load_all.clj
index 6cbdd872..cfe706af 100644
--- a/src/clojure/contrib/load_all.clj
+++ b/src/clojure/contrib/load_all.clj
@@ -42,8 +42,10 @@ duck-streams
 error-kit
 except
 fcase
+generic
 generic.arithmetic
 generic.collection
+generic.comparison
 generic.functor
 generic.math-functions
 import-static