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