|
rlm@10
|
1 ;; Data types
|
|
rlm@10
|
2
|
|
rlm@10
|
3 ;; by Konrad Hinsen
|
|
rlm@10
|
4 ;; last updated May 3, 2009
|
|
rlm@10
|
5
|
|
rlm@10
|
6 ;; Copyright (c) Konrad Hinsen, 2009. All rights reserved. The use
|
|
rlm@10
|
7 ;; and distribution terms for this software are covered by the Eclipse
|
|
rlm@10
|
8 ;; Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
|
|
rlm@10
|
9 ;; which can be found in the file epl-v10.html at the root of this
|
|
rlm@10
|
10 ;; distribution. By using this software in any fashion, you are
|
|
rlm@10
|
11 ;; agreeing to be bound by the terms of this license. You must not
|
|
rlm@10
|
12 ;; remove this notice, or any other, from this software.
|
|
rlm@10
|
13
|
|
rlm@10
|
14 (ns
|
|
rlm@10
|
15 ^{:author "Konrad Hinsen"
|
|
rlm@10
|
16 :doc "General and algebraic data types"}
|
|
rlm@10
|
17 clojure.contrib.types
|
|
rlm@10
|
18 (:refer-clojure :exclude (deftype))
|
|
rlm@10
|
19 (:use [clojure.contrib.def :only (name-with-attributes)]))
|
|
rlm@10
|
20
|
|
rlm@10
|
21 ;
|
|
rlm@10
|
22 ; Utility functions
|
|
rlm@10
|
23 ;
|
|
rlm@10
|
24 (defn- qualified-symbol
|
|
rlm@10
|
25 [s]
|
|
rlm@10
|
26 (symbol (str *ns*) (str s)))
|
|
rlm@10
|
27
|
|
rlm@10
|
28 (defn- qualified-keyword
|
|
rlm@10
|
29 [s]
|
|
rlm@10
|
30 (keyword (str *ns*) (str s)))
|
|
rlm@10
|
31
|
|
rlm@10
|
32 (defn- unqualified-symbol
|
|
rlm@10
|
33 [s]
|
|
rlm@10
|
34 (let [s-str (str s)]
|
|
rlm@10
|
35 (symbol (subs s-str (inc (.indexOf s-str (int \/)))))))
|
|
rlm@10
|
36
|
|
rlm@10
|
37 (defn- resolve-symbol
|
|
rlm@10
|
38 [s]
|
|
rlm@10
|
39 (if-let [var (resolve s)]
|
|
rlm@10
|
40 (symbol (str (.ns var)) (str (.sym var)))
|
|
rlm@10
|
41 s))
|
|
rlm@10
|
42
|
|
rlm@10
|
43 ;
|
|
rlm@10
|
44 ; Data type definition
|
|
rlm@10
|
45 ;
|
|
rlm@10
|
46 (defmulti deconstruct type)
|
|
rlm@10
|
47
|
|
rlm@10
|
48 (defmulti constructor-form type)
|
|
rlm@10
|
49 (defmethod constructor-form :default
|
|
rlm@10
|
50 [o] nil)
|
|
rlm@10
|
51 (defmethod constructor-form ::type
|
|
rlm@10
|
52 [o] (cons (::constructor (meta o)) (deconstruct o)))
|
|
rlm@10
|
53
|
|
rlm@10
|
54 (defmacro deftype
|
|
rlm@10
|
55 "Define a data type by a type tag (a namespace-qualified keyword)
|
|
rlm@10
|
56 and a symbol naming the constructor function. Optionally, a
|
|
rlm@10
|
57 constructor and a deconstructor function can be given as well,
|
|
rlm@10
|
58 the defaults being clojure.core/identity and clojure.core/list.
|
|
rlm@10
|
59 The full constructor associated with constructor-name calls the
|
|
rlm@10
|
60 constructor function and attaches the type tag to its result
|
|
rlm@10
|
61 as metadata. The deconstructor function must return the arguments
|
|
rlm@10
|
62 to be passed to the constructor in order to create an equivalent
|
|
rlm@10
|
63 object. It is used for printing and matching."
|
|
rlm@10
|
64 {:arglists
|
|
rlm@10
|
65 '([type-tag constructor-name docstring? attr-map?]
|
|
rlm@10
|
66 [type-tag constructor-name docstring? attr-map? constructor]
|
|
rlm@10
|
67 [type-tag constructor-name docstring? attr-map? constructor deconstructor])}
|
|
rlm@10
|
68 [type-tag constructor-name & options]
|
|
rlm@10
|
69 (let [[constructor-name options] (name-with-attributes
|
|
rlm@10
|
70 constructor-name options)
|
|
rlm@10
|
71 [constructor deconstructor] options
|
|
rlm@10
|
72 constructor (if (nil? constructor)
|
|
rlm@10
|
73 'clojure.core/identity
|
|
rlm@10
|
74 constructor)
|
|
rlm@10
|
75 deconstructor (if (nil? deconstructor)
|
|
rlm@10
|
76 'clojure.core/list
|
|
rlm@10
|
77 deconstructor)]
|
|
rlm@10
|
78 `(do
|
|
rlm@10
|
79 (derive ~type-tag ::type)
|
|
rlm@10
|
80 (let [meta-map# {:type ~type-tag
|
|
rlm@10
|
81 ::constructor
|
|
rlm@10
|
82 (quote ~(qualified-symbol constructor-name))}]
|
|
rlm@10
|
83 (def ~constructor-name
|
|
rlm@10
|
84 (comp (fn [~'x] (with-meta ~'x meta-map#)) ~constructor))
|
|
rlm@10
|
85 (defmethod deconstruct ~type-tag [~'x]
|
|
rlm@10
|
86 (~deconstructor (with-meta ~'x {})))))))
|
|
rlm@10
|
87
|
|
rlm@10
|
88 (defmacro deftype-
|
|
rlm@10
|
89 "Same as deftype but the constructor is private."
|
|
rlm@10
|
90 [type-tag constructor-name & optional]
|
|
rlm@10
|
91 `(deftype ~type-tag
|
|
rlm@10
|
92 ~(vary-meta constructor-name assoc :private true)
|
|
rlm@10
|
93 ~@optional))
|
|
rlm@10
|
94
|
|
rlm@10
|
95 (defmethod print-method ::type [o w]
|
|
rlm@10
|
96 (let [cf (constructor-form o)]
|
|
rlm@10
|
97 (if (symbol? cf)
|
|
rlm@10
|
98 (print-method (unqualified-symbol cf) w)
|
|
rlm@10
|
99 (print-method (cons (unqualified-symbol (first cf)) (rest cf)) w))))
|
|
rlm@10
|
100
|
|
rlm@10
|
101 ;
|
|
rlm@10
|
102 ; Algebraic types
|
|
rlm@10
|
103 ;
|
|
rlm@10
|
104 (derive ::adt ::type)
|
|
rlm@10
|
105
|
|
rlm@10
|
106 (defmethod constructor-form ::adt
|
|
rlm@10
|
107 [o]
|
|
rlm@10
|
108 (let [v (vals o)]
|
|
rlm@10
|
109 (if (= 1 (count v))
|
|
rlm@10
|
110 (first v)
|
|
rlm@10
|
111 v)))
|
|
rlm@10
|
112
|
|
rlm@10
|
113 (defn- constructor-code
|
|
rlm@10
|
114 [meta-map-symbol constructor]
|
|
rlm@10
|
115 (if (symbol? constructor)
|
|
rlm@10
|
116 `(def ~constructor
|
|
rlm@10
|
117 (with-meta {::tag (quote ~(qualified-symbol constructor))}
|
|
rlm@10
|
118 ~meta-map-symbol))
|
|
rlm@10
|
119 (let [[name & args] constructor
|
|
rlm@10
|
120 keys (cons ::tag (map (comp keyword str) args))]
|
|
rlm@10
|
121 (if (empty? args)
|
|
rlm@10
|
122 (throw (IllegalArgumentException. "zero argument constructor"))
|
|
rlm@10
|
123 `(let [~'basis (create-struct ~@keys)]
|
|
rlm@10
|
124 (defn ~name ~(vec args)
|
|
rlm@10
|
125 (with-meta (struct ~'basis (quote ~(qualified-symbol name)) ~@args)
|
|
rlm@10
|
126 ~meta-map-symbol)))))))
|
|
rlm@10
|
127
|
|
rlm@10
|
128 (defmacro defadt
|
|
rlm@10
|
129 "Define an algebraic data type name by an exhaustive list of constructors.
|
|
rlm@10
|
130 Each constructor can be a symbol (argument-free constructor) or a
|
|
rlm@10
|
131 list consisting of a tag symbol followed by the argument symbols.
|
|
rlm@10
|
132 The data type tag must be a keyword."
|
|
rlm@10
|
133 [type-tag & constructors]
|
|
rlm@10
|
134 (let [meta-map-symbol (gensym "mm")]
|
|
rlm@10
|
135 `(let [~meta-map-symbol {:type ~type-tag}]
|
|
rlm@10
|
136 (derive ~type-tag ::adt)
|
|
rlm@10
|
137 ~@(map (partial constructor-code meta-map-symbol) constructors)
|
|
rlm@10
|
138 )))
|
|
rlm@10
|
139
|
|
rlm@10
|
140 ;
|
|
rlm@10
|
141 ; Matching templates
|
|
rlm@10
|
142 ;
|
|
rlm@10
|
143 (defn- symbol-tests-and-bindings
|
|
rlm@10
|
144 [template vsymbol]
|
|
rlm@10
|
145 [`(= (quote ~(resolve-symbol template)) ~vsymbol)
|
|
rlm@10
|
146 []])
|
|
rlm@10
|
147
|
|
rlm@10
|
148 (defn- sequential-tests-and-bindings
|
|
rlm@10
|
149 [template vsymbol]
|
|
rlm@10
|
150 (let [enum-values (map list template (range (count template)))
|
|
rlm@10
|
151 ; Non-symbols in the template create an equality test with the
|
|
rlm@10
|
152 ; corresponding value in the object's value list
|
|
rlm@10
|
153 tests (map (fn [[v i]] `(= ~v (nth ~vsymbol ~i)))
|
|
rlm@10
|
154 (filter (complement #(symbol? (first %))) enum-values))
|
|
rlm@10
|
155 ; Symbols in the template become bindings to the corresponding
|
|
rlm@10
|
156 ; value in the object. However, if a symbol occurs more than once,
|
|
rlm@10
|
157 ; only one binding is generated, and equality tests are added
|
|
rlm@10
|
158 ; for the other values.
|
|
rlm@10
|
159 bindings (reduce (fn [map [symbol index]]
|
|
rlm@10
|
160 (assoc map symbol
|
|
rlm@10
|
161 (conj (get map symbol []) index)))
|
|
rlm@10
|
162 {}
|
|
rlm@10
|
163 (filter #(symbol? (first %)) enum-values))
|
|
rlm@10
|
164 tests (concat tests
|
|
rlm@10
|
165 (map (fn [[symbol indices]]
|
|
rlm@10
|
166 (cons `= (map #(list `nth vsymbol %) indices)))
|
|
rlm@10
|
167 (filter #(> (count (second %)) 1) bindings)))
|
|
rlm@10
|
168 bindings (mapcat (fn [[symbol indices]]
|
|
rlm@10
|
169 [symbol (list `nth vsymbol (first indices))])
|
|
rlm@10
|
170 bindings)]
|
|
rlm@10
|
171 [tests (vec bindings)]))
|
|
rlm@10
|
172
|
|
rlm@10
|
173 (defn- constr-tests-and-bindings
|
|
rlm@10
|
174 [template cfsymbol]
|
|
rlm@10
|
175 (let [[tag & values] template
|
|
rlm@10
|
176 cfasymbol (gensym)
|
|
rlm@10
|
177 [tests bindings] (sequential-tests-and-bindings values cfasymbol)
|
|
rlm@10
|
178 argtests (if (empty? tests)
|
|
rlm@10
|
179 tests
|
|
rlm@10
|
180 `((let [~cfasymbol (rest ~cfsymbol)] ~@tests)))]
|
|
rlm@10
|
181 [`(and (seq? ~cfsymbol)
|
|
rlm@10
|
182 (= (quote ~(resolve-symbol tag)) (first ~cfsymbol))
|
|
rlm@10
|
183 ~@argtests)
|
|
rlm@10
|
184 `[~cfasymbol (rest ~cfsymbol) ~@bindings]]))
|
|
rlm@10
|
185
|
|
rlm@10
|
186 (defn- list-tests-and-bindings
|
|
rlm@10
|
187 [template vsymbol]
|
|
rlm@10
|
188 (let [[tests bindings] (sequential-tests-and-bindings template vsymbol)]
|
|
rlm@10
|
189 [`(and (list? ~vsymbol) ~@tests)
|
|
rlm@10
|
190 bindings]))
|
|
rlm@10
|
191
|
|
rlm@10
|
192 (defn- vector-tests-and-bindings
|
|
rlm@10
|
193 [template vsymbol]
|
|
rlm@10
|
194 (let [[tests bindings] (sequential-tests-and-bindings template vsymbol)]
|
|
rlm@10
|
195 [`(and (vector? ~vsymbol) ~@tests)
|
|
rlm@10
|
196 bindings]))
|
|
rlm@10
|
197
|
|
rlm@10
|
198 (defn- map-tests-and-bindings
|
|
rlm@10
|
199 [template vsymbol]
|
|
rlm@10
|
200 (let [; First test if the given keys are all present.
|
|
rlm@10
|
201 tests (map (fn [[k v]] `(contains? ~vsymbol ~k)) template)
|
|
rlm@10
|
202 ; Non-symbols in the template create an equality test with the
|
|
rlm@10
|
203 ; corresponding value in the object's value list.
|
|
rlm@10
|
204 tests (concat tests
|
|
rlm@10
|
205 (map (fn [[k v]] `(= ~v (~k ~vsymbol)))
|
|
rlm@10
|
206 (filter (complement #(symbol? (second %))) template)))
|
|
rlm@10
|
207 ; Symbols in the template become bindings to the corresponding
|
|
rlm@10
|
208 ; value in the object. However, if a symbol occurs more than once,
|
|
rlm@10
|
209 ; only one binding is generated, and equality tests are added
|
|
rlm@10
|
210 ; for the other values.
|
|
rlm@10
|
211 bindings (reduce (fn [map [key symbol]]
|
|
rlm@10
|
212 (assoc map symbol
|
|
rlm@10
|
213 (conj (get map symbol []) key)))
|
|
rlm@10
|
214 {}
|
|
rlm@10
|
215 (filter #(symbol? (second %)) template))
|
|
rlm@10
|
216 tests (concat tests
|
|
rlm@10
|
217 (map (fn [[symbol keys]]
|
|
rlm@10
|
218 (cons `= (map #(list % vsymbol) keys)))
|
|
rlm@10
|
219 (filter #(> (count (second %)) 1) bindings)))
|
|
rlm@10
|
220 bindings (mapcat (fn [[symbol keys]]
|
|
rlm@10
|
221 [symbol (list (first keys) vsymbol)])
|
|
rlm@10
|
222 bindings)]
|
|
rlm@10
|
223 [`(and (map? ~vsymbol) ~@tests)
|
|
rlm@10
|
224 (vec bindings)]))
|
|
rlm@10
|
225
|
|
rlm@10
|
226 (defn- tests-and-bindings
|
|
rlm@10
|
227 [template vsymbol cfsymbol]
|
|
rlm@10
|
228 (cond (symbol? template)
|
|
rlm@10
|
229 (symbol-tests-and-bindings template cfsymbol)
|
|
rlm@10
|
230 (seq? template)
|
|
rlm@10
|
231 (if (= (first template) 'quote)
|
|
rlm@10
|
232 (list-tests-and-bindings (second template) vsymbol)
|
|
rlm@10
|
233 (constr-tests-and-bindings template cfsymbol))
|
|
rlm@10
|
234 (vector? template)
|
|
rlm@10
|
235 (vector-tests-and-bindings template vsymbol)
|
|
rlm@10
|
236 (map? template)
|
|
rlm@10
|
237 (map-tests-and-bindings template vsymbol)
|
|
rlm@10
|
238 :else
|
|
rlm@10
|
239 (throw (IllegalArgumentException. "illegal template for match"))))
|
|
rlm@10
|
240
|
|
rlm@10
|
241 (defmacro match
|
|
rlm@10
|
242 "Given a value and a list of template-expr clauses, evaluate the first
|
|
rlm@10
|
243 expr whose template matches the value. There are four kinds of templates:
|
|
rlm@10
|
244 1) Lists of the form (tag x1 x2 ...) match instances of types
|
|
rlm@10
|
245 whose constructor has the same form as the list.
|
|
rlm@10
|
246 2) Quoted lists of the form '(x1 x2 ...) match lists of the same
|
|
rlm@10
|
247 length.
|
|
rlm@10
|
248 3) Vectors of the form [x1 x2 ...] match vectors of the same length.
|
|
rlm@10
|
249 4) Maps of the form {:key1 x1 :key2 x2 ...} match maps that have
|
|
rlm@10
|
250 the same keys as the template, but which can have additional keys
|
|
rlm@10
|
251 that are not part of the template.
|
|
rlm@10
|
252 The values x1, x2, ... can be symbols or non-symbol values. Non-symbols
|
|
rlm@10
|
253 must be equal to the corresponding values in the object to be matched.
|
|
rlm@10
|
254 Symbols will be bound to the corresponding value in the object in the
|
|
rlm@10
|
255 evaluation of expr. If the same symbol occurs more than once in a,
|
|
rlm@10
|
256 template the corresponding elements of the object must be equal
|
|
rlm@10
|
257 for the template to match."
|
|
rlm@10
|
258 [value & clauses]
|
|
rlm@10
|
259 (when (odd? (count clauses))
|
|
rlm@10
|
260 (throw (Exception. "Odd number of elements in match expression")))
|
|
rlm@10
|
261 (let [vsymbol (gensym)
|
|
rlm@10
|
262 cfsymbol (gensym)
|
|
rlm@10
|
263 terms (mapcat (fn [[template expr]]
|
|
rlm@10
|
264 (if (= template :else)
|
|
rlm@10
|
265 [template expr]
|
|
rlm@10
|
266 (let [[tests bindings]
|
|
rlm@10
|
267 (tests-and-bindings template vsymbol cfsymbol)]
|
|
rlm@10
|
268 [tests
|
|
rlm@10
|
269 (if (empty? bindings)
|
|
rlm@10
|
270 expr
|
|
rlm@10
|
271 `(let ~bindings ~expr))])))
|
|
rlm@10
|
272 (partition 2 clauses))]
|
|
rlm@10
|
273 `(let [~vsymbol ~value
|
|
rlm@10
|
274 ~cfsymbol (constructor-form ~vsymbol)]
|
|
rlm@10
|
275 (cond ~@terms))))
|
