diff options
| -rw-r--r-- | src/clojure/contrib/types.clj | 181 | ||||
| -rw-r--r-- | src/clojure/contrib/types/examples.clj | 52 |
2 files changed, 171 insertions, 62 deletions
diff --git a/src/clojure/contrib/types.clj b/src/clojure/contrib/types.clj index c2b48272..672d537f 100644 --- a/src/clojure/contrib/types.clj +++ b/src/clojure/contrib/types.clj @@ -1,7 +1,7 @@ ;; Data types ;; by Konrad Hinsen -;; last updated March 15, 2009 +;; last updated March 29, 2009 ;; Copyright (c) Konrad Hinsen, 2009. All rights reserved. The use ;; and distribution terms for this software are covered by the Eclipse @@ -85,8 +85,10 @@ ~@optional)) (defmethod print-method ::type [o w] - (let [[name & args] (constructor-form o)] - (print-method (cons (unqualified-symbol name) args) w))) + (let [cf (constructor-form o)] + (if (symbol? cf) + (print-method (unqualified-symbol cf) w) + (print-method (cons (unqualified-symbol (first cf)) (rest cf)) w)))) ; ; Algebraic types @@ -130,67 +132,136 @@ ; ; Matching templates ; -(defn- tests-and-bindings +(defn- symbol-tests-and-bindings + [template vsymbol] + [`(= (quote ~(resolve-symbol template)) ~vsymbol) + []]) + +(defn- sequential-tests-and-bindings + [template vsymbol] + (let [enum-values (map list template (range (count template))) + ; Non-symbols in the template create an equality test with the + ; corresponding value in the object's value list + tests (map (fn [[v i]] `(= ~v (nth ~vsymbol ~i))) + (filter (complement #(symbol? (first %))) enum-values)) + ; Symbols in the template become bindings to the corresponding + ; value in the object. However, if a symbol occurs more than once, + ; only one binding is generated, and equality tests are added + ; for the other values. + bindings (reduce (fn [map [symbol index]] + (assoc map symbol + (conj (get map symbol []) index))) + {} + (filter #(symbol? (first %)) enum-values)) + tests (concat tests + (map (fn [[symbol indices]] + (cons `= (map #(list `nth vsymbol %) indices))) + (filter #(> (count (second %)) 1) bindings))) + bindings (mapcat (fn [[symbol indices]] + [symbol (list `nth vsymbol (first indices))]) + bindings)] + [tests (vec bindings)])) + +(defn- constr-tests-and-bindings + [template cfsymbol] + (let [[tag & values] template + cfasymbol (gensym) + [tests bindings] (sequential-tests-and-bindings values cfasymbol) + argtests (if (empty? tests) + tests + `((let [~cfasymbol (rest ~cfsymbol)] ~@tests)))] + [`(and (seq? ~cfsymbol) + (= (quote ~(resolve-symbol tag)) (first ~cfsymbol)) + ~@argtests) + `[~cfasymbol (rest ~cfsymbol) ~@bindings]])) + +(defn- list-tests-and-bindings [template vsymbol] - (if (symbol? template) - [`(= (quote ~(resolve-symbol template)) ~vsymbol) - []] - (let [[tag & values] template - enum-values (map list values (range 1 (inc (count values)))) - ; Non-symbols in the template create an equality test with the - ; corresponding value in the object's value list - tests (map (fn [[v i]] `(= ~v (nth ~vsymbol ~i))) - (filter (complement #(symbol? (first %))) enum-values)) - ; Symbols in the template become bindings to the corresponding - ; value in the object. However, if a symbol occurs more than once, - ; only one binding is generated, and equality tests are added - ; for the other values. - bindings (reduce (fn [map [symbol index]] - (assoc map symbol - (conj (get map symbol []) index))) - {} - (filter #(symbol? (first %)) enum-values)) - tests (concat tests - (map (fn [[symbol indices]] - (cons `= (map #(list `nth vsymbol %) indices))) - (filter #(> (count (second %)) 1) bindings))) - bindings (apply concat - (map (fn [[symbol indices]] - [symbol (list `nth vsymbol (first indices))]) - bindings))] - [(cons `and - (cons `(seq? ~vsymbol) - (cons `(= (quote ~(resolve-symbol tag)) - (first ~vsymbol)) - tests))) - (vec bindings)]))) + (let [[tests bindings] (sequential-tests-and-bindings template vsymbol)] + [`(and (list? ~vsymbol) ~@tests) + bindings])) + +(defn- vector-tests-and-bindings + [template vsymbol] + (let [[tests bindings] (sequential-tests-and-bindings template vsymbol)] + [`(and (vector? ~vsymbol) ~@tests) + bindings])) + +(defn- map-tests-and-bindings + [template vsymbol] + (let [; First test if the given keys are all present. + tests (map (fn [[k v]] `(contains? ~vsymbol ~k)) template) + ; Non-symbols in the template create an equality test with the + ; corresponding value in the object's value list. + tests (concat tests + (map (fn [[k v]] `(= ~v (~k ~vsymbol))) + (filter (complement #(symbol? (second %))) template))) + ; Symbols in the template become bindings to the corresponding + ; value in the object. However, if a symbol occurs more than once, + ; only one binding is generated, and equality tests are added + ; for the other values. + bindings (reduce (fn [map [key symbol]] + (assoc map symbol + (conj (get map symbol []) key))) + {} + (filter #(symbol? (second %)) template)) + tests (concat tests + (map (fn [[symbol keys]] + (cons `= (map #(list % vsymbol) keys))) + (filter #(> (count (second %)) 1) bindings))) + bindings (mapcat (fn [[symbol keys]] + [symbol (list (first keys) vsymbol)]) + bindings)] + [`(and (map? ~vsymbol) ~@tests) + (vec bindings)])) + +(defn- tests-and-bindings + [template vsymbol cfsymbol] + (cond (symbol? template) + (symbol-tests-and-bindings template cfsymbol) + (seq? template) + (if (= (first template) 'quote) + (list-tests-and-bindings (second template) vsymbol) + (constr-tests-and-bindings template cfsymbol)) + (vector? template) + (vector-tests-and-bindings template vsymbol) + (map? template) + (map-tests-and-bindings template vsymbol) + :else + (throw (IllegalArgumentException. "illegal template for match")))) (defmacro match "Given a value and a list of template-expr clauses, evaluate the first - expr whose template matches the value. Templates have the same form - as constructors. The arguments can be expressions, which must be equal - to the corresponding elements of value for the template to match, or - symbols, which will be bound to the corresponding elements of value - in the evaluation of expr. If the same symbol occurs more than once, - the corresponding elements of value must be equal for the template - to match." + expr whose template matches the value. There are four kinds of templates: + 1) Lists of the form (tag x1 x2 ...) match instances of types + whose constructor has the same form as the list. + 2) Quoted lists of the form '(x1 x2 ...) match lists of the same + length. + 3) Vectors of the form [x1 x2 ...] match vectors of the same length. + 4) Maps of the form {:key1 x1 :key2 x2 ...} match maps that have + the same keys as the template, but which can have additional keys + that are not part of the template. + The values x1, x2, ... can be symbols or non-symbol values. Non-symbols + must be equal to the corresponding values in the object to be matched. + Symbols will be bound to the corresponding value in the object in the + evaluation of expr. If the same symbol occurs more than once in a, + template the corresponding elements of the object must be equal + for the template to match." [value & clauses] (when (odd? (count clauses)) (throw (Exception. "Odd number of elements in match expression"))) (let [vsymbol (gensym) cfsymbol (gensym) - terms (apply concat - (map (fn [[template expr]] - (if (= template :else) - [template expr] - (let [[tests bindings] - (tests-and-bindings template cfsymbol)] - [tests - (if (empty? bindings) - expr - `(let ~bindings ~expr))]))) - (partition 2 clauses)))] + terms (mapcat (fn [[template expr]] + (if (= template :else) + [template expr] + (let [[tests bindings] + (tests-and-bindings template vsymbol cfsymbol)] + [tests + (if (empty? bindings) + expr + `(let ~bindings ~expr))]))) + (partition 2 clauses))] `(let [~vsymbol ~value ~cfsymbol (constructor-form ~vsymbol)] (cond ~@terms)))) -
\ No newline at end of file diff --git a/src/clojure/contrib/types/examples.clj b/src/clojure/contrib/types/examples.clj index 8c56b1c5..fc9435fe 100644 --- a/src/clojure/contrib/types/examples.clj +++ b/src/clojure/contrib/types/examples.clj @@ -1,7 +1,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; -;; Application examples for algebraic data types +;; Application examples for data types ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -73,6 +73,7 @@ (node l r) (inc (max (depth l) (depth r))))) (depth empty-tree) +(depth (leaf 42)) (depth a-tree) ; Algebraic data types with multimethods: fmap on a tree @@ -87,6 +88,7 @@ ; ; Nonsense examples to illustrate all the features of match +; for type constructors. ; (defadt ::foo (bar a b c)) @@ -100,9 +102,45 @@ (bar a b 1) (* a b) :else 42)) -(foo-to-int (bar 0 0 0)) -(foo-to-int (bar 0 5 6)) -(foo-to-int (bar 1 2 3)) -(foo-to-int (bar 3 3 1)) -(foo-to-int (bar 0 3 1)) -(foo-to-int (bar 10 20 30)) +(foo-to-int (bar 0 0 0)) ; 0 +(foo-to-int (bar 0 5 6)) ; 11 +(foo-to-int (bar 1 2 3)) ; -1 +(foo-to-int (bar 3 3 1)) ; 9 +(foo-to-int (bar 0 3 1)) ; 4 +(foo-to-int (bar 10 20 30)) ; 42 + +; +; Match can also be used for lists, vectors, and maps. Note that since +; algebraic data types are represented as maps, they can be matched +; either with their type constructor and positional arguments, or +; with a map template. +; + +; Tree depth once again with map templates +(defn depth + [t] + (match t + empty-tree 0 + {:value _} 1 + {:left-tree l :right-tree r} (inc (max (depth l) (depth r))))) + +(depth empty-tree) +(depth (leaf 42)) +(depth a-tree) + +; Match for lists, vectors, and maps: + +(for [x ['(1 2 3) + [1 2 3] + {:x 1 :y 2 :z 3} + '(1 1 1) + [2 1 2] + {:x 1 :y 1 :z 2}]] + (match x + '(a a a) 'list-of-three-equal-values + '(a b c) 'list + [a a a] 'vector-of-three-equal-values + [a b a] 'vector-of-three-with-first-and-last-equal + [a b c] 'vector + {:x a :y z} 'map-with-x-equal-y + {} 'any-map)) |