1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/contrib/types.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,275 @@
     1.4 +;; Data types
     1.5 +
     1.6 +;; by Konrad Hinsen
     1.7 +;; last updated May 3, 2009
     1.8 +
     1.9 +;; Copyright (c) Konrad Hinsen, 2009. All rights reserved.  The use
    1.10 +;; and distribution terms for this software are covered by the Eclipse
    1.11 +;; Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
    1.12 +;; which can be found in the file epl-v10.html at the root of this
    1.13 +;; distribution.  By using this software in any fashion, you are
    1.14 +;; agreeing to be bound by the terms of this license.  You must not
    1.15 +;; remove this notice, or any other, from this software.
    1.16 +
    1.17 +(ns
    1.18 +  ^{:author "Konrad Hinsen"
    1.19 +     :doc "General and algebraic data types"}
    1.20 +  clojure.contrib.types
    1.21 +  (:refer-clojure :exclude (deftype))
    1.22 +  (:use [clojure.contrib.def :only (name-with-attributes)]))
    1.23 +
    1.24 +;
    1.25 +; Utility functions
    1.26 +;
    1.27 +(defn- qualified-symbol
    1.28 +  [s]
    1.29 +  (symbol (str *ns*) (str s)))
    1.30 +
    1.31 +(defn- qualified-keyword
    1.32 +  [s]
    1.33 +  (keyword (str *ns*) (str s)))
    1.34 +
    1.35 +(defn- unqualified-symbol
    1.36 +  [s]
    1.37 +  (let [s-str (str s)]
    1.38 +    (symbol (subs s-str (inc (.indexOf s-str (int \/)))))))
    1.39 +
    1.40 +(defn- resolve-symbol
    1.41 +  [s]
    1.42 +  (if-let [var (resolve s)]
    1.43 +    (symbol (str (.ns var)) (str (.sym var)))
    1.44 +    s))
    1.45 +
    1.46 +;
    1.47 +; Data type definition
    1.48 +;
    1.49 +(defmulti deconstruct type)
    1.50 +
    1.51 +(defmulti constructor-form type)
    1.52 +(defmethod constructor-form :default
    1.53 +  [o] nil)
    1.54 +(defmethod constructor-form ::type
    1.55 +  [o] (cons (::constructor (meta o)) (deconstruct o)))
    1.56 +
    1.57 +(defmacro deftype
    1.58 +  "Define a data type by a type tag (a namespace-qualified keyword)
    1.59 +   and a symbol naming the constructor function. Optionally, a
    1.60 +   constructor and a deconstructor function can be given as well,
    1.61 +   the defaults being clojure.core/identity and clojure.core/list.
    1.62 +   The full constructor associated with constructor-name calls the
    1.63 +   constructor function and attaches the type tag to its result
    1.64 +   as metadata. The deconstructor function must return the arguments
    1.65 +   to be passed to the constructor in order to create an equivalent
    1.66 +   object. It is used for printing and matching."
    1.67 +  {:arglists
    1.68 +  '([type-tag constructor-name docstring? attr-map?]
    1.69 +    [type-tag constructor-name docstring? attr-map? constructor]
    1.70 +    [type-tag constructor-name docstring? attr-map? constructor deconstructor])}
    1.71 +  [type-tag constructor-name & options]
    1.72 +  (let [[constructor-name options]  (name-with-attributes
    1.73 +				      constructor-name options)
    1.74 +	[constructor deconstructor] options
    1.75 +	constructor   		    (if (nil? constructor)
    1.76 +		      		      'clojure.core/identity
    1.77 +		      		      constructor)
    1.78 +	deconstructor 		    (if (nil? deconstructor)
    1.79 +		      		     'clojure.core/list
    1.80 +		      		     deconstructor)]
    1.81 +    `(do
    1.82 +       (derive ~type-tag ::type)
    1.83 +       (let [meta-map# {:type ~type-tag
    1.84 +			::constructor
    1.85 +			    (quote ~(qualified-symbol constructor-name))}]
    1.86 +	 (def ~constructor-name
    1.87 +	      (comp (fn [~'x] (with-meta ~'x meta-map#)) ~constructor))
    1.88 +	 (defmethod deconstruct ~type-tag [~'x]
    1.89 +	   (~deconstructor (with-meta ~'x {})))))))
    1.90 +
    1.91 +(defmacro deftype-
    1.92 +  "Same as deftype but the constructor is private."
    1.93 +  [type-tag constructor-name & optional]
    1.94 +  `(deftype ~type-tag
    1.95 +     ~(vary-meta constructor-name assoc :private true)
    1.96 +     ~@optional))
    1.97 +
    1.98 +(defmethod print-method ::type [o w]
    1.99 +  (let [cf (constructor-form o)]
   1.100 +    (if (symbol? cf)
   1.101 +      (print-method (unqualified-symbol cf) w)
   1.102 +      (print-method (cons (unqualified-symbol (first cf)) (rest cf)) w))))
   1.103 +
   1.104 +;
   1.105 +; Algebraic types
   1.106 +;
   1.107 +(derive ::adt ::type)
   1.108 +
   1.109 +(defmethod constructor-form ::adt
   1.110 +  [o]
   1.111 +  (let [v (vals o)]
   1.112 +    (if (= 1 (count v))
   1.113 +      (first v)
   1.114 +      v)))
   1.115 +
   1.116 +(defn- constructor-code
   1.117 +  [meta-map-symbol constructor]
   1.118 +  (if (symbol? constructor)
   1.119 +    `(def ~constructor
   1.120 +	  (with-meta {::tag (quote ~(qualified-symbol constructor))}
   1.121 +		     ~meta-map-symbol))
   1.122 +    (let [[name & args] constructor
   1.123 +	  keys (cons ::tag (map (comp keyword str) args))]
   1.124 +      (if (empty? args)
   1.125 +	(throw (IllegalArgumentException. "zero argument constructor"))
   1.126 +	`(let [~'basis (create-struct ~@keys)]
   1.127 +	   (defn ~name ~(vec args)
   1.128 +	     (with-meta (struct ~'basis (quote ~(qualified-symbol name)) ~@args)
   1.129 +			~meta-map-symbol)))))))
   1.130 +
   1.131 +(defmacro defadt
   1.132 +  "Define an algebraic data type name by an exhaustive list of constructors.
   1.133 +   Each constructor can be a symbol (argument-free constructor) or a
   1.134 +   list consisting of a tag symbol followed by the argument symbols.
   1.135 +   The data type tag must be a keyword."
   1.136 +  [type-tag & constructors]
   1.137 +  (let [meta-map-symbol (gensym "mm")]
   1.138 +    `(let [~meta-map-symbol {:type ~type-tag}]
   1.139 +       (derive ~type-tag ::adt)
   1.140 +       ~@(map (partial constructor-code meta-map-symbol) constructors)
   1.141 +       )))
   1.142 +
   1.143 +;
   1.144 +;  Matching templates
   1.145 +;
   1.146 +(defn- symbol-tests-and-bindings
   1.147 +  [template vsymbol]
   1.148 +  [`(= (quote ~(resolve-symbol template)) ~vsymbol)
   1.149 +   []])
   1.150 +
   1.151 +(defn- sequential-tests-and-bindings
   1.152 +  [template vsymbol]
   1.153 +  (let [enum-values (map list template (range (count template)))
   1.154 +        ; Non-symbols in the template create an equality test with the
   1.155 +	; corresponding value in the object's value list
   1.156 +	tests (map (fn [[v i]] `(= ~v (nth ~vsymbol ~i)))
   1.157 +		   (filter (complement #(symbol? (first %))) enum-values))
   1.158 +        ; Symbols in the template become bindings to the corresponding
   1.159 +        ; value in the object. However, if a symbol occurs more than once,
   1.160 +        ; only one binding is generated, and equality tests are added
   1.161 +        ; for the other values.
   1.162 +	bindings (reduce (fn [map [symbol index]]
   1.163 +			   (assoc map symbol
   1.164 +				  (conj (get map symbol []) index)))
   1.165 +			 {}
   1.166 +			 (filter #(symbol? (first %)) enum-values))
   1.167 +	tests (concat tests
   1.168 +		      (map (fn [[symbol indices]]
   1.169 +			     (cons `= (map #(list `nth vsymbol %) indices)))
   1.170 +			   (filter #(> (count (second %)) 1) bindings)))
   1.171 +	bindings (mapcat (fn [[symbol indices]]
   1.172 +			   [symbol (list `nth vsymbol (first indices))])
   1.173 +			 bindings)]
   1.174 +    [tests (vec bindings)]))
   1.175 +
   1.176 +(defn- constr-tests-and-bindings
   1.177 +  [template cfsymbol]
   1.178 +  (let [[tag & values] template
   1.179 +	cfasymbol (gensym)
   1.180 +	[tests bindings] (sequential-tests-and-bindings values cfasymbol)
   1.181 +	argtests (if (empty? tests)
   1.182 +		   tests
   1.183 +		   `((let [~cfasymbol (rest ~cfsymbol)] ~@tests)))]
   1.184 +    [`(and (seq? ~cfsymbol)
   1.185 +	   (= (quote ~(resolve-symbol tag)) (first ~cfsymbol))
   1.186 +	   ~@argtests)
   1.187 +     `[~cfasymbol (rest ~cfsymbol) ~@bindings]]))
   1.188 +
   1.189 +(defn- list-tests-and-bindings
   1.190 +  [template vsymbol]
   1.191 +  (let [[tests bindings] (sequential-tests-and-bindings template vsymbol)]
   1.192 +    [`(and (list? ~vsymbol) ~@tests)
   1.193 +     bindings]))
   1.194 +
   1.195 +(defn- vector-tests-and-bindings
   1.196 +  [template vsymbol]
   1.197 +  (let [[tests bindings] (sequential-tests-and-bindings template vsymbol)]
   1.198 +    [`(and (vector? ~vsymbol) ~@tests)
   1.199 +     bindings]))
   1.200 +
   1.201 +(defn- map-tests-and-bindings
   1.202 +  [template vsymbol]
   1.203 +  (let [; First test if the given keys are all present.
   1.204 +	tests (map (fn [[k v]] `(contains? ~vsymbol ~k)) template)
   1.205 +        ; Non-symbols in the template create an equality test with the
   1.206 +	; corresponding value in the object's value list.
   1.207 +	tests (concat tests
   1.208 +	        (map (fn [[k v]] `(= ~v (~k ~vsymbol)))
   1.209 +		     (filter (complement #(symbol? (second %))) template)))
   1.210 +        ; Symbols in the template become bindings to the corresponding
   1.211 +        ; value in the object. However, if a symbol occurs more than once,
   1.212 +        ; only one binding is generated, and equality tests are added
   1.213 +        ; for the other values.
   1.214 +	bindings (reduce (fn [map [key symbol]]
   1.215 +			   (assoc map symbol
   1.216 +				  (conj (get map symbol []) key)))
   1.217 +			 {}
   1.218 +			 (filter #(symbol? (second %)) template))
   1.219 +	tests (concat tests
   1.220 +	        (map (fn [[symbol keys]]
   1.221 +		       (cons `= (map #(list % vsymbol) keys)))
   1.222 +		     (filter #(> (count (second %)) 1) bindings)))
   1.223 +	bindings (mapcat (fn [[symbol keys]]
   1.224 +			   [symbol (list (first keys) vsymbol)])
   1.225 +			 bindings)]
   1.226 +    [`(and (map? ~vsymbol) ~@tests)
   1.227 +     (vec bindings)]))
   1.228 +
   1.229 +(defn- tests-and-bindings
   1.230 +  [template vsymbol cfsymbol]
   1.231 +  (cond (symbol? template)
   1.232 +	  (symbol-tests-and-bindings template cfsymbol)
   1.233 +	(seq? template)
   1.234 +	  (if (= (first template) 'quote)
   1.235 +	    (list-tests-and-bindings (second template) vsymbol)
   1.236 +	    (constr-tests-and-bindings template cfsymbol))
   1.237 +	(vector? template)
   1.238 +	  (vector-tests-and-bindings template vsymbol)
   1.239 +	(map? template)
   1.240 +	  (map-tests-and-bindings template vsymbol)
   1.241 +	:else
   1.242 +	  (throw (IllegalArgumentException. "illegal template for match"))))
   1.243 +
   1.244 +(defmacro match
   1.245 +  "Given a value and a list of template-expr clauses, evaluate the first
   1.246 +   expr whose template matches the value. There are four kinds of templates:
   1.247 +   1) Lists of the form (tag x1 x2 ...) match instances of types
   1.248 +      whose constructor has the same form as the list.
   1.249 +   2) Quoted lists of the form '(x1 x2 ...) match lists of the same
   1.250 +      length.
   1.251 +   3) Vectors of the form [x1 x2 ...] match vectors of the same length.
   1.252 +   4) Maps of the form {:key1 x1 :key2 x2 ...} match maps that have
   1.253 +      the same keys as the template, but which can have additional keys
   1.254 +      that are not part of the template.
   1.255 +   The values x1, x2, ... can be symbols or non-symbol values. Non-symbols
   1.256 +   must be equal to the corresponding values in the object to be matched.
   1.257 +   Symbols will be bound to the corresponding value in the object in the
   1.258 +   evaluation of expr. If the same symbol occurs more than once in a,
   1.259 +   template the corresponding elements of the object must be equal
   1.260 +   for the template to match."
   1.261 +  [value & clauses]
   1.262 +   (when (odd? (count clauses))
   1.263 +     (throw (Exception. "Odd number of elements in match expression")))
   1.264 +  (let [vsymbol (gensym)
   1.265 +	cfsymbol (gensym)
   1.266 +	terms (mapcat (fn [[template expr]]
   1.267 +			(if (= template :else)
   1.268 +			  [template expr]
   1.269 +			  (let [[tests bindings]
   1.270 +				(tests-and-bindings template vsymbol cfsymbol)]
   1.271 +			    [tests
   1.272 +			     (if (empty? bindings)
   1.273 +			       expr
   1.274 +			       `(let ~bindings ~expr))])))
   1.275 +		      (partition 2 clauses))]
   1.276 +    `(let [~vsymbol ~value
   1.277 +	   ~cfsymbol (constructor-form ~vsymbol)]
   1.278 +       (cond ~@terms))))