Skip to content
Browse files

switched to lein, updated code

--HG--
extra : rebase_source : 6f51df8ed53c815cdfe2752b2b112bbfa75b56d8
  • Loading branch information...
1 parent 9445eeb commit 7ff1c76cd0681b098a1052f63fc11ac470602253 David McNeil committed
View
3 .gitignore
@@ -0,0 +1,3 @@
+lib
+classes
+*jar
View
3 .hgignore
@@ -0,0 +1,3 @@
+lib
+classes
+\.jar
View
207 defrecord2.clj
@@ -1,207 +0,0 @@
-(ns defrecord2
- (:require [clojure.contrib.str-utils2 :as str2])
- (:use [clojure.set :only (difference)]
- [clojure.string :only (join)]
- [clojure.contrib.pprint :only (*simple-dispatch* use-method pprint-map)])
- (:import [clojure.lang IPersistentList IPersistentVector IPersistentMap ISeq]))
-
-;;;; enhanced records
-
-;; internal helpers for name conversion
-
-(defn take-even [x]
- (take-nth 2 x))
-
-(defn take-odd [x]
- (take-nth 2 (drop 1 x)))
-
-(defn is-upper? [s]
- (= (.toUpperCase s) s))
-
-(defn assemble-words [parts]
- (loop [remaining-parts parts result []]
- (if (seq remaining-parts)
- (let [part (first remaining-parts)]
- (recur (rest remaining-parts)
- (if (is-upper? part)
- (conj result (.toLowerCase part))
- (conj (if (seq result)
- (pop result)
- []) (str (last result) part)))))
- result)))
-
-(defn camel-to-dashed
- "Convert a name like 'BigBlueCar' to 'big-blue-car'."
- [s]
- (let [parts (remove #(= "" %) (str2/partition s #"[A-Z]"))
- words (assemble-words parts)]
- (join "-" words)))
-
-;; internal helpers for changing records via maps
-
-(defn set-record-field
- "Set a single field on a record."
- [source [key value]]
- (assoc source key value))
-
-(defn set-record-fields
- "Set many fields on a record, from a map."
- [initial value-map]
- (reduce set-record-field initial value-map))
-
-;; internal helper for generating constructor function
-
-(defn expected-keys? [map expected-key-set]
- (not (seq (difference (set (keys map)) expected-key-set))))
-
-(defmacro make-record-constructor
- "Define the constructor functions used to instantiate a record."
- [ctor-name type-name field-list default-record]
- `(defn ~ctor-name
- ([value-map#]
- (~ctor-name ~default-record value-map#))
- ([initial# value-map#]
- {:pre [(or (nil? initial#)
- (isa? (class initial#) ~type-name))
- (map? value-map#)
- (expected-keys? value-map# ~(set (map keyword field-list)))]}
- (set-record-fields (if (nil? initial#) ~default-record initial#) value-map#))))
-
-;; internal helpers for printing
-
-(defn remove-nil-native-fields [native-keys record]
- (let [extra-keys (difference (set (keys record))
- native-keys)]
- (apply array-map (reduce into (for [[k v] record]
- (if (or (contains? extra-keys k)
- (not (nil? v)))
- [k v]))))))
-
-(defmacro print-record
- "Low-level function to print a record to a stream using the specified constructor name in the print output and using the provided write-contents function to write out the contents of the record (represented as a map)."
- [ctor ctor-name native-keys record stream write-contents]
- `(do
- (.write ~stream (str "(" ~ctor-name " "))
- (~write-contents (remove-nil-native-fields ~native-keys ~record))
- (.write ~stream ")")))
-
-(defn print-record-contents
- "Simply write the contents of a record to a stream as a string. Used for basic printing."
- [stream contents]
- (.write stream (str contents)))
-
-(defmacro setup-print-record-method [ctor ctor-name native-keys type-name method-name]
- `(defmethod ~method-name ~type-name [record# writer#]
- (print-record ~ctor ~ctor-name ~native-keys record# writer# (partial print-record-contents writer#))))
-
-(defmacro setup-print-record
- "Define the print methods to print a record nicely (so that records will print in a form that can be evaluated as itself)."
- [ctor ctor-name native-keys type-name]
-
- `(do (setup-print-record-method ~ctor ~ctor-name ~native-keys ~type-name print-method)
- (setup-print-record-method ~ctor ~ctor-name ~native-keys ~type-name print-dup)))
-
-(defn generate-record-pprint
- "Return a function that can be used in the pprint dispatch mechanism to handle a specific constructor name."
- [ctor ctor-name native-keys]
- (fn [record]
- (print-record ctor ctor-name native-keys record *out* pprint-map)))
-
-;; internal helpers - walking data structures
-
-;; w - walker function
-;; f - mutator function
-;; n - node in data tree being walked
-
-;; helper - generating walking methods like this:
-(comment (defmethod prewalk2 Foo [f foo]
- (if-let [foo2 (f foo)]
- (new-foo foo2 {:a (prewalk2 f (:a foo2))
- :b (prewalk2 f (:b foo2))})))
-
- (defmethod postwalk2 Foo [f foo]
- (f (new-foo foo {:a (postwalk2 f (:a foo))
- :b (postwalk2 f (:b foo))}))))
-
-(defmulti walk2 (fn [w f n] (class n)))
-
-(defmethod walk2 :default [w f n]
- n)
-
-;; TODO: handle sets
-
-(defmethod walk2 IPersistentVector [w f n]
- (apply vector (map (partial w f) n)))
-
-(defmethod walk2 IPersistentMap [w f n]
- ;; TODO: handle sorted maps
- (apply array-map (mapcat (partial walk2 w f) n)))
-
-(defmethod walk2 IPersistentList [w f n]
- (apply list (map (partial w f) n)))
-
-(prefer-method walk2 IPersistentList ISeq)
-
-(defmethod walk2 ISeq [w f n]
- (map (partial w f) n))
-
-(defmacro walking-helper-field
- ([w f n field]
- `[~(keyword field) (~w ~f (~(keyword field) ~n))])
- ([w f n field & more]
- `(concat (walking-helper-field ~w ~f ~n ~field) (walking-helper-field ~w ~f ~n ~@more))))
-
-(defmacro walking-helper-fields
- [w f n fields]
- `(apply array-map (walking-helper-field ~w ~f ~n ~@fields)))
-
-(defmacro make-prewalk2-method
- "Define the methods used to walk data structures."
- [ctor-name type-name field-list]
- `(defmethod prewalk2 ~type-name [f# n#]
- (if-let [n2# (f# n#)]
- (~ctor-name n2# (walking-helper-fields prewalk2 f# n2# ~field-list)))))
-
-(defmacro make-postwalk2-method
- "Define the methods used to walk data structures."
- [ctor-name type-name field-list]
- `(defmethod postwalk2 ~type-name [f# n#]
- (f# (~ctor-name n# (walking-helper-fields postwalk2 f# n# ~field-list)))))
-
-;; public entry points
-
-(defmulti prewalk2 (fn [f n] (class n)))
-
-(defmethod prewalk2 :default [f n]
- (walk2 prewalk2 f (f n)))
-
-(defmulti postwalk2 (fn [f n] (class n)))
-
-(defmethod postwalk2 :default [f n]
- (f (walk2 postwalk2 f n)))
-
-(defmacro defrecord2
- "Defines a record and sets up constructor functions, printing, and pprinting for the new record type."
- ([type-name field-list]
- `(defrecord2 ~type-name ~field-list
- ;; invoke defrecord2 with default constructor function name
- ~(symbol (str "new-" (camel-to-dashed (str type-name))))))
- ([type-name field-list ctor-name]
- `(do
- ;; define the record
- (defrecord ~type-name ~field-list)
- ;; define the constructor functions
- (make-record-constructor ~ctor-name
- ~type-name
- ~field-list
- (~(symbol (str type-name ".")) ~@(repeat (count field-list) nil)))
- ;; setup tree walking methods
- (make-prewalk2-method ~ctor-name ~type-name ~field-list)
- (make-postwalk2-method ~ctor-name ~type-name ~field-list)
-
- ;; setup printing
- (let [empty-record# (~ctor-name {})
- native-keys# (set (keys empty-record#))]
- (setup-print-record ~ctor-name (quote ~ctor-name) native-keys# ~type-name)
- ;; setup pprinting
- (use-method *simple-dispatch* ~type-name (generate-record-pprint ~ctor-name (quote ~ctor-name) native-keys#))))))
View
104 pom.xml
@@ -1,104 +0,0 @@
-<?xml version="1.0" encoding="UTF-8"?>
-<project xmlns="http://maven.apache.org/POM/4.0.0" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
- xsi:schemaLocation="http://maven.apache.org/POM/4.0.0 http://maven.apache.org/xsd/maven-4.0.0.xsd">
-
- <modelVersion>4.0.0</modelVersion>
- <groupId>defrecord2</groupId>
- <artifactId>defrecord2</artifactId>
- <name>defrecord2</name>
- <version>0.1-SNAPSHOT</version>
-
- <repositories>
- <repository>
- <id>clojars</id>
- <url>http://clojars.org/repo</url>
- </repository>
- <repository>
- <id>clojure-releases</id>
- <url>http://build.clojure.org/releases</url>
- <releases>
- <enabled>true</enabled>
- </releases>
- <snapshots>
- <enabled>false</enabled>
- </snapshots>
- </repository>
- <repository>
- <id>clojure-snapshots</id>
- <url>http://build.clojure.org/snapshots</url>
- <releases>
- <enabled>false</enabled>
- </releases>
- <snapshots>
- <enabled>true</enabled>
- </snapshots>
- </repository>
- </repositories>
-
- <dependencies>
- <dependency>
- <groupId>org.clojure</groupId>
- <artifactId>clojure</artifactId>
- <version>1.2.0-RC3</version>
- </dependency>
- <dependency>
- <groupId>org.clojure</groupId>
- <artifactId>clojure-contrib</artifactId>
- <version>1.2.0-RC3</version>
- </dependency>
- <dependency>
- <groupId>jline</groupId>
- <artifactId>jline</artifactId>
- <version>0.9.94</version>
- <scope>provided</scope>
- </dependency>
- <dependency>
- <groupId>swank-clojure</groupId>
- <artifactId>swank-clojure</artifactId>
- <version>1.2.1</version>
- <scope>provided</scope>
- </dependency>
- </dependencies>
-
- <build>
- <plugins>
- <plugin>
- <groupId>com.theoryinpractise</groupId>
- <artifactId>clojure-maven-plugin</artifactId>
- <version>1.3.2</version>
- <executions>
- <execution>
- <id>compile-clojure</id>
- <phase>compile</phase>
- <goals>
- <goal>compile</goal>
- </goals>
- </execution>
- <execution>
- <id>test-clojure</id>
- <phase>test</phase>
- <goals>
- <goal>test</goal>
- </goals>
- </execution>
- <execution>
- <id>test-compile</id>
- <phase>generate-test-sources</phase>
- <goals>
- <goal>testCompile</goal>
- </goals>
- </execution>
- </executions>
- </plugin>
- <plugin>
- <artifactId>maven-compiler-plugin</artifactId>
- <version>2.3</version>
- <configuration>
- <source>1.6</source>
- <target>1.6</target>
- </configuration>
- </plugin>
- </plugins>
- </build>
-
-</project>
View
6 project.clj
@@ -0,0 +1,6 @@
+(defproject defrecord2 "1.0.0-SNAPSHOT"
+ :description "Enhanced clojure records."
+ :dependencies [[org.clojure/clojure "1.2.0"]
+ [org.clojure/clojure-contrib "1.2.0"]
+ [david-mcneil/matchure "0.9.2"]]
+ :dev-dependencies [[swank-clojure "1.2.1"]])
View
491 src/defrecord2/defrecord2_core.clj
@@ -0,0 +1,491 @@
+(ns defrecord2.defrecord2-core
+ "Enhanced defrecord support"
+ (:require [clojure.contrib.str-utils2 :as str2]
+ [clojure.string :as str])
+ (:use [clojure.contrib.generic.functor :only (fmap)]
+ [clojure.set :only (difference)]
+ [clojure.string :only (join)]
+ [clojure.pprint :only (simple-dispatch pprint)]
+ [clojure.zip :only (zipper)]
+ [matchure :only (if-match)])
+ (:import [clojure.lang IPersistentList IPersistentVector IPersistentMap IPersistentSet ISeq]))
+
+;; internal helpers for name conversion
+
+(defn is-upper? [s]
+ (= (.toUpperCase s) s))
+
+(defn assemble-words [parts]
+ (loop [remaining-parts parts result []]
+ (if (seq remaining-parts)
+ (let [part (first remaining-parts)]
+ (recur (rest remaining-parts)
+ (if (is-upper? part)
+ (conj result (.toLowerCase part))
+ (conj (if (seq result)
+ (pop result)
+ []) (str (last result) part)))))
+ result)))
+
+(defn camel-to-dashed
+ "Convert a name like 'BigBlueCar' to 'big-blue-car'."
+ [s]
+ (let [parts (remove #(= "" %) (str2/partition s #"[A-Z]"))
+ words (assemble-words parts)]
+ (join "-" words)))
+
+;; internal helpers for changing records via maps
+
+(defn set-record-field
+ "Set a single field on a record."
+ [source [key value]]
+ (assoc source key value))
+
+(defn set-record-fields
+ "Set many fields on a record, from a map."
+ [initial value-map]
+ (reduce set-record-field initial value-map))
+
+;; universal constructor function
+
+(defmulti new-record
+ "A universal constructor function that can create a new instance of any type of record from a current record and a new value map."
+ (fn [initial value-map] (class initial)))
+
+(defmacro make-universal-constructor
+ "Define the implementation of new-record for this type."
+ [ctor-name type-name]
+ `(defmethod new-record ~type-name
+ [initial# value-map#]
+ (~ctor-name initial# value-map#)))
+
+;; internal helper for generating constructor function
+
+(defn expected-keys? [map expected-key-set]
+ (not (seq (difference (set (keys map)) expected-key-set))))
+
+(defmacro make-record-constructor
+ "Define the constructor functions used to instantiate a record."
+ [ctor-name type-name field-list default-record]
+ `(defn ~ctor-name
+ ([value-map#]
+ (~ctor-name ~default-record value-map#))
+ ([initial# value-map#]
+ {:pre [(or (nil? initial#)
+ (isa? (class initial#) ~type-name))
+ (map? value-map#)
+ (expected-keys? value-map# ~(set (map keyword field-list)))]}
+ (set-record-fields (if (nil? initial#) ~default-record initial#) value-map#))))
+
+;; internal helpers for printing
+
+(defn remove-nil-native-fields [native-keys record]
+ (let [extra-keys (difference (set (keys record))
+ native-keys)]
+ (let [contents (reduce into [] (for [[k v] record]
+ (if (or (contains? extra-keys k)
+ (not (nil? v)))
+ [k v])))]
+ (apply array-map contents))))
+
+(defmacro print-record
+ "Low-level function to print a record to a stream using the specified constructor name in the print output and using the provided write-contents function to write out the contents of the record (represented as a map)."
+ [ctor ctor-name native-keys record stream write-contents]
+ `(do
+ (.write ~stream (str "(" ~ctor-name " "))
+ (~write-contents (remove-nil-native-fields ~native-keys ~record))
+ (.write ~stream ")")))
+
+(defn print-record-contents
+ "Simply write the contents of a record to a stream as a string. Used for basic printing."
+ [stream contents]
+ (.write stream (str contents)))
+
+(defmacro setup-print-record-method [ctor ctor-name native-keys type-name method-name]
+ `(defmethod ~method-name ~type-name [record# writer#]
+ (print-record ~ctor ~ctor-name ~native-keys record# writer# (partial print-record-contents writer#))))
+
+(defmacro setup-print-record
+ "Define the print methods to print a record nicely (so that records will print in a form that can be evaluated as itself)."
+ [ctor ctor-name native-keys type-name]
+
+ `(do (setup-print-record-method ~ctor ~ctor-name ~native-keys ~type-name print-method)
+ (setup-print-record-method ~ctor ~ctor-name ~native-keys ~type-name print-dup)))
+
+(defn generate-record-pprint
+ "Return a function that can be used in the pprint dispatch mechanism to handle a specific constructor name."
+ [ctor ctor-name native-keys]
+ (fn [record]
+ ;; clojure.pprint/pprint-map is private hence the dance here:
+ (print-record ctor ctor-name native-keys record *out* @#'clojure.pprint/pprint-map)))
+
+;; internal helpers - walking data structures
+
+;; w - walker function
+;; f - mutator function
+;; n - node in data tree being walked
+
+;; helper - generating walking methods like this:
+(comment (defmethod prewalk2 Foo [f foo]
+ (if-let [foo2 (f foo)]
+ (new-foo foo2 {:a (prewalk2 f (:a foo2))
+ :b (prewalk2 f (:b foo2))})))
+
+ (defmethod postwalk2 Foo [f foo]
+ (f (new-foo foo {:a (postwalk2 f (:a foo))
+ :b (postwalk2 f (:b foo))}))))
+
+(defmulti walk2 (fn [w f n] (class n)))
+
+(defmethod walk2 :default [w f n]
+ n)
+
+(defmethod walk2 IPersistentVector [w f n]
+ (apply vector (map (partial w f) n)))
+
+(defmethod walk2 IPersistentMap [w f n]
+ ;; TODO: handle sorted maps
+ (apply array-map (mapcat (partial walk2 w f) n)))
+
+(defmethod walk2 IPersistentSet [w f n]
+ (set (map (partial w f) n)))
+
+(defmethod walk2 IPersistentList [w f n]
+ (apply list (map (partial w f) n)))
+
+(prefer-method walk2 IPersistentList ISeq)
+
+(defmethod walk2 ISeq [w f n]
+ (map (partial w f) n))
+
+(defmacro walking-helper-field
+ ([w f n field]
+ `[~(keyword field) (~w ~f (~(keyword field) ~n))])
+ ([w f n field & more]
+ `(concat (walking-helper-field ~w ~f ~n ~field) (walking-helper-field ~w ~f ~n ~@more))))
+
+(defmacro walking-helper-fields
+ [w f n fields]
+ (if (seq fields)
+ `(apply array-map (walking-helper-field ~w ~f ~n ~@fields))
+ []))
+
+(defmacro make-prewalk2-method
+ "Define the methods used to walk data structures."
+ [ctor-name type-name field-list]
+ `(defmethod prewalk2 ~type-name [f# n#]
+ (if-let [n2# (f# n#)]
+ ;; TODO: better check than comparing classes to determine if
+ ;; the old contents can be inserted into the new node?
+ (if (= (class n#) (class n2#))
+ (let [contents# (walking-helper-fields prewalk2 f# n2# ~field-list)]
+ (~ctor-name n2# contents#))
+ n2#))))
+
+(defmacro make-postwalk2-method
+ "Define the methods used to walk data structures."
+ [ctor-name type-name field-list]
+ `(defmethod postwalk2 ~type-name [f# n#]
+ (f# (~ctor-name n# (walking-helper-fields postwalk2 f# n# ~field-list)))))
+
+;;;; zipper methods
+
+(defmulti record-branch?
+ "The branch? function to use when creating zippers on records."
+ class)
+
+(defmethod record-branch? :default [_]
+ false)
+
+(defmethod record-branch? IPersistentVector [n]
+ (> (count n) 0))
+
+(defmethod record-branch? IPersistentMap [n]
+ (> (count n) 0))
+
+(defmethod record-branch? IPersistentList [n]
+ (> (count n) 0))
+
+(defmethod record-branch? ISeq [n]
+ (> (count n) 0))
+
+(prefer-method record-branch? IPersistentList ISeq)
+
+(defmacro make-record-branch?-method
+ "Generate the record-branch? method for a type."
+ [type-name]
+ `(defmethod record-branch? ~type-name [_#]
+ true))
+
+;;
+
+(defmulti record-node-children
+ "The node-children method to use when creating zippers on records."
+ class)
+
+(defmethod record-node-children IPersistentVector [n]
+ n)
+
+(defmethod record-node-children IPersistentMap [n]
+ (seq n))
+
+(defmethod record-node-children IPersistentList [n]
+ n)
+
+(defmethod record-node-children ISeq [n]
+ n)
+
+(prefer-method record-node-children IPersistentList ISeq)
+
+(defmacro rnc-helper-field
+ ([n field]
+ `[(~(keyword field) ~n)])
+ ([n field & more]
+ `(concat (rnc-helper-field ~n ~field) (rnc-helper-field ~n ~@more))))
+
+(defmacro rnc-helper-fields
+ [n fields]
+ (if (seq fields)
+ `(rnc-helper-field ~n ~@fields)
+ []))
+
+(defmacro make-record-node-children-method
+ "Generate the record-node-children method for a type."
+ [type-name field-list]
+ `(defmethod record-node-children ~type-name [node#]
+ (rnc-helper-fields node# ~field-list)))
+
+;;
+
+(defmulti record-make-node
+ "The make-node method to use when creating zippers on records."
+ (fn [node children] (class node)))
+
+(defmethod record-make-node IPersistentVector [node children]
+ (vec children))
+
+(defmethod record-make-node IPersistentMap [node children]
+ (apply hash-map (apply concat children)))
+
+(defmethod record-make-node IPersistentList [node children]
+ children)
+
+(defmethod record-make-node ISeq [node children]
+ (apply list children))
+
+(prefer-method record-make-node IPersistentList ISeq)
+
+(defmacro apply-to-symbol [f count]
+ "Return a function that takes a vector of args and which will do the equivalent of (apply f args). This is suitable for getting 'apply' like functionality from generated record constructors."
+ `(fn [x#]
+ (let [~'x x#]
+ (~f ~@(map (fn [i] (list 'nth 'x i)) (range count))))) )
+
+(defmacro make-record-make-node-method
+ "Generate the record-make-node method for a type."
+ [type-name field-list]
+ `(defmethod record-make-node ~type-name [_# children#]
+ ((apply-to-symbol ~(symbol (str (.getName type-name) ".")) ~(count field-list))
+ children#)))
+
+;; helpers for custom zippers
+
+(defn record-branch?-or-map
+ "Creates a custom function to use as the branch? fn in the zipper. The field-map contains keys which are classes and values which are sequences of keywords identifying fields in the class. These keywords identify the fields, and their order, which will be visited as children by the zipper. If an empty sequence is placed as a value in the field-map then that class will not be considered a branch point for the zipper."
+ [field-map]
+ (if (seq field-map)
+ (fn [node]
+ (let [fields (field-map (class node))]
+ (if fields
+ (if (seq fields)
+ true
+ false)
+ (record-branch? node))))
+ record-branch?))
+
+(defn record-node-children-or-map
+ "Creates a custom function to use as the children fn in the zipper. The field-map contains keys which are classes and values which are sequences of keywords identifying fields in the class. These keywords identify the fields, and their order, which will be visited as children by the zipper."
+ [field-map]
+ (if (seq field-map)
+ (fn [node]
+ (let [fields (field-map (class node))
+ alternate-children-f (if (seq fields) (apply juxt fields))]
+ (if alternate-children-f
+ (alternate-children-f node)
+ (record-node-children node))))
+ record-node-children))
+
+(defn record-make-node-or-map
+ "Creates a custom function to use as the make-node fn in the zipper using
+ a field-map and a constructor map.
+
+ Field-map (may be nil):
+ - key = record Class
+ - value = seq of field keywords that should be treated as child nodes
+
+ Constructor-map (may be nil):
+ - key = record Class
+ - val = (fn [node {:field value ...}]) - custom record constructor
+
+ Execution cases:
+ 1) Fields and custom constructor both specified. Call custom constructor with
+ only the custom fields in the second map argument.
+ 2) Custom constructor specifed but NO field set specified. Call custom
+ constructor but include ALL fields in the value map.
+ 3) Field set specified but NO custom constructor specified. Call universal
+ new-record constructor with node and a map of only the specified fields.
+ 4) Neither field set nor customer constructor specified. Construct the Clojure
+ record as a Java class with all field values specified."
+ [field-map ctor-map]
+ (fn [node children]
+ (let [type (class node)
+ fields (when (seq field-map) (field-map type))
+ ctor (when (seq ctor-map) (ctor-map type))]
+ (if (or fields ctor)
+ (let [record-ctor (or ctor new-record)
+ fields (or fields (keys node))
+ children-map (zipmap fields children)]
+ (record-ctor node children-map))
+ (record-make-node node children)))))
+
+;; record?
+
+(defmulti record? (fn [x] (.getName (class x))))
+
+(defmethod record? :default [_]
+ false)
+
+(defmacro make-record?
+ "Define the implementation of record? for this type."
+ [type-name]
+ `(defmethod record? ~(.getName (resolve type-name))
+ [_#]
+ true))
+
+;; record pattern matching
+
+(defmulti record-matcher (fn [form]
+ (let [dispatch-value (if (and (list? form)
+ (symbol? (first form)))
+ (let [sym (first form)]
+ (if-let [resolved (resolve sym)]
+ (try
+ (let [test-obj (resolved {})]
+ (if (record? test-obj)
+ (symbol (.getName (class test-obj)))))
+ (catch IllegalArgumentException e
+ ;;ignore this
+ ))
+ (throw (RuntimeException. (str "Unknown symbol: " sym))))))]
+ (or dispatch-value
+ :default))))
+
+(defn seq-to-list [s]
+ (reverse (into '() s)))
+
+(defmethod record-matcher :default [x]
+ (if (list? x)
+ (let [converted-x (seq-to-list (map record-matcher x))]
+ converted-x)
+ x))
+
+(defmacro make-record-matcher
+ "Generate the record-make-node method for a type."
+ [ctor-name]
+ `(defmethod record-matcher '~(symbol (.getName (class ((resolve ctor-name) {}))))
+ [[_# value-map#]]
+ (list '~'and (symbol (.getName (class (~ctor-name {}))))
+ (fmap record-matcher value-map#))))
+
+(defmacro match-record
+ ([matches expr]
+ `(match-record ~matches ~expr nil))
+ ([[record in] expr fail-expr]
+ `(matchure/if-match [~(record-matcher record) ~in] ~expr ~fail-expr)))
+
+;; public entry points
+
+(defmulti prewalk2 (fn [f n] (class n)))
+
+(defmethod prewalk2 :default [f n]
+ (walk2 prewalk2 f (f n)))
+
+(defmulti postwalk2 (fn [f n] (class n)))
+
+(defmethod postwalk2 :default [f n]
+ (f (walk2 postwalk2 f n)))
+
+(defn record-zip
+ "Create a zipper on a tree of records."
+ ([node]
+ (record-zip node nil nil))
+ ([node field-map]
+ (record-zip node field-map nil))
+ ([node field-map ctor-map]
+ (zipper (record-branch?-or-map field-map)
+ (record-node-children-or-map field-map)
+ (record-make-node-or-map field-map ctor-map)
+ node)))
+
+(defmulti dissoc2
+ "Enhanced version of dissoc that will return a new record of the same type with the given fields removed.
+ (Calling dissoc on a record will yield a map.)"
+ (fn [n & ks] (class n)))
+
+(defn dissoc2*
+ [ctor-f native-keys n & ks]
+ (let [d (apply dissoc n ks)
+ extra-keys (difference (set (keys d)) native-keys)
+ new-record (ctor-f (select-keys d native-keys))]
+ (if (empty? extra-keys)
+ new-record
+ (merge new-record (select-keys d extra-keys)))))
+
+(defmacro make-dissoc2-method
+ [ctor-name type-name native-keys]
+ `(defmethod dissoc2 ~type-name [n# & ks#]
+ (apply dissoc2* ~ctor-name ~native-keys n# ks#)))
+
+(defmacro defrecord2
+ "Defines a record and sets up constructor functions, printing, and pprinting for the new record type."
+ ([type-name field-list]
+ `(defrecord2 ~type-name ~field-list
+ ;; invoke defrecord2 with default constructor function name
+ ~(symbol (str "new-" (camel-to-dashed (str type-name))))))
+ ([type-name field-list ctor-name & opts+specs]
+ `(do
+ ;; define the record
+ (defrecord ~type-name ~field-list ~@opts+specs)
+
+ ;; define the constructor functions
+ (make-record-constructor ~ctor-name
+ ~type-name
+ ~field-list
+ (~(symbol (str type-name ".")) ~@(repeat (count field-list) nil)))
+ (make-universal-constructor ~ctor-name ~type-name)
+
+ (make-record? ~type-name)
+
+ ;; setup tree walking methods
+ (make-prewalk2-method ~ctor-name ~type-name ~field-list)
+ (make-postwalk2-method ~ctor-name ~type-name ~field-list)
+
+ ;; setup dissoc2 method
+ (make-dissoc2-method ~ctor-name ~type-name (set (keys (~ctor-name {}))))
+
+ ;; setup zipper methods
+ (make-record-branch?-method ~type-name)
+ (make-record-node-children-method ~type-name ~field-list)
+ (make-record-make-node-method ~type-name ~field-list)
+
+ ;; setup pattern matching
+ (make-record-matcher ~ctor-name)
+
+ ;; setup printing
+ (let [empty-record# (~ctor-name {})
+ native-keys# (set (keys empty-record#))
+ pprint-fn# (generate-record-pprint ~ctor-name (quote ~ctor-name) native-keys#)]
+ (setup-print-record ~ctor-name (quote ~ctor-name) native-keys# ~type-name)
+ ;; setup clojure.pprinting
+ (.addMethod simple-dispatch ~type-name pprint-fn#)))))
+
View
159 test-defrecord2.clj
@@ -1,159 +0,0 @@
-(ns test-defrecord2
- (:use [clojure test]
- [defrecord2 :only (defrecord2 prewalk2 postwalk2 camel-to-dashed)]
- [clojure.contrib.pprint :only (pprint)])
- (:import [clojure.lang IPersistentVector]))
-
-;;
-
-(deftest test-camel-to-dashed
- (are [expected in] (= expected (camel-to-dashed in))
- "wow" "wow"
- "a" "a"
- "a" "A"
- "a-big" "aBig"
- "a-team" "ATeam"
- "a-team-x" "ATeamX"
- "a-x" "aX"))
-
-;;
-
-(defrecord2 Foo [x y])
-
-(deftest test-defrecord2
- (is (= "(new-foo {:x 10})" (print-str (new-foo {:x 10})))))
-
-(deftest test-defrecord2-pprint
- (is (=
- "(new-foo {:x 10})\n"
- (with-out-str (pprint (new-foo {:x 10}))))))
-
-(deftest test-defrecord2-pprint-deep
- (is (= "(new-foo {:x 10,\n :y\n (new-foo {:x 10,\n :y\n (new-foo {:x 10, :y (new-foo {:x 10, :y 20})})})})\n"
- (with-out-str (pprint (new-foo {:x 10 :y (new-foo {:x 10 :y (new-foo {:x 10 :y (new-foo {:x 10 :y 20})})})}))))))
-
-(deftest test-defrecord2-dont-skip-extra-nils-but-do-skip-native-nils
- (is (= "(new-foo {:x 10, :b nil, :a 4})"
- (print-str (assoc (new-foo {:x 10}) :a 4 :b nil))))
- (is (= "(new-foo {:x 10, :b nil, :a 4})"
- (print-str (assoc (new-foo {:x 10 :y nil}) :a 4 :b nil)))))
-
-(deftest test-contructor-wrong-args-first-arg-is-not-a-record
- (is (thrown? AssertionError (new-foo :x {}))))
-
-(deftest test-contructor-wrong-args-second-arg-is-not-a-map
- (is (thrown? AssertionError (new-foo (new-foo {:x 10}) 20))))
-
-(deftest test-contructor-wrong-args-only-arg-is-not-a-map
- (is (thrown? AssertionError (new-foo 20))))
-
-(deftest test-typo-in-field-name
- (is (thrown? AssertionError (new-foo {:a 1})))
- (is (thrown? AssertionError (new-foo {:a 1 :x 10})))
- (is (thrown? AssertionError (new-foo {:a 1 :x 10 :y 20}))))
-
-;;
-
-(defrecord2 F [z x b a])
-
-(deftest test-single-char-type-name
- (is (= (F. nil nil nil 20)
- (new-f {:a 20}))))
-
-(deftest test-order-of-printed-fields
- (is (= "(new-f {:z 100, :x 99, :b 2, :a 1})"
- (print-str (new-f {:a 1 :b 2 :x 99 :z 100})))))
-
-;; test tree walking
-
-(defmulti test-incrementer class)
-
-(defmethod test-incrementer Number [x]
- (+ 1 x))
-
-(defmethod test-incrementer :default [x]
- x)
-
-(defn test-pre-and-post [expected x]
- (is (= expected
- (prewalk2 test-incrementer x)))
- (is (= expected
- (postwalk2 test-incrementer x))) )
-
-(deftest test-walk
- (are [expected x] (and (is (= expected
- (prewalk2 test-incrementer x)))
- (is (= expected
- (postwalk2 test-incrementer x)))))
-
- (new-foo {:x 101 :y 201})
- (new-foo {:x 100 :y 200})
-
- (new-foo {:x 101
- :y (new-foo {:x 301 :y 401})})
- (new-foo {:x 100
- :y (new-foo {:x 300 :y 400})})
-
- (new-foo {:x [101 201]})
- (new-foo {:x [100 200]})
-
- (new-foo {:x '(101 201)})
- (new-foo {:x '(100 200)})
-
- (new-foo {:x {:a 101 :b 201}})
- (new-foo {:x {:a 100 :b 200}})
-
- (new-foo {:x {:a 101
- :b (new-foo {:x {:a 101 :b 201}})}})
- (new-foo {:x {:a 100
- :b (new-foo {:x {:a 100 :b 200}})}})
-
- (new-foo {:x {:a 101
- :b [(new-foo {:x {:a 101 :b 201}})]}})
- (new-foo {:x {:a 100
- :b [(new-foo {:x {:a 100 :b 200}})]}})
-
- (new-foo {:x (range 2 11)})
- (new-foo {:x (range 1 10)}))
-
-;; more tree walking tests
-
-(defrecord2 Bar [a b])
-
-(defmulti test-mutator class)
-
-(defmethod test-mutator :default [x]
- (if (nil? x)
- nil
- (+ 1 x)))
-
-(defmethod test-mutator Foo [x]
- (new-foo x {:x 100}))
-
-(defmethod test-mutator Bar [x]
- nil)
-
-(deftest test-walk-multi-types
- (is (= (new-foo {:x 101})
- (prewalk2 test-mutator (new-foo {:x 1 :y (new-bar {})}))))
- (is (= (new-foo {:x 100})
- (postwalk2 test-mutator (new-foo {:x 1 :y (new-bar {})})))) )
-
-;; tree walking - mutate clojure data types
-
-(defmulti remove-nils class)
-
-(defmethod remove-nils :default [x]
- x)
-
-(defmethod remove-nils IPersistentVector [v]
- (apply vector (remove nil? v)))
-
-(deftest test-mutate-vector
- (is (= {:x [:a [:b :c]]}
- (prewalk2 remove-nils {:x [:a nil [:b nil :c]]}))))
-;;
-
-(deftest test-mutate-nil
- (is (= (new-foo {:x 1})
- (new-foo nil {:x 1}))))
View
6 test/defrecord2/test/core.clj
@@ -0,0 +1,6 @@
+(ns defrecord2.test.core
+ (:use [defrecord2.core] :reload)
+ (:use [clojure.test]))
+
+(deftest replace-me ;; FIXME: write
+ (is false "No tests have been written."))
View
525 test/defrecord2/test_defrecord2_core.clj
@@ -0,0 +1,525 @@
+(ns defrecord2.test-defrecord2-core
+ (:require [clojure.zip :as z]
+ [defrecord2.test-record-helper :as helper])
+ (:use [clojure test]
+ [clojure.string :only (upper-case)]
+ [defrecord2.test-record-helper :only (new-foo-helper)]
+ [defrecord2.defrecord2-core]
+ [clojure.pprint :only (pprint)])
+ (:import [clojure.lang IPersistentVector]))
+
+;;
+
+(deftest test-camel-to-dashed
+ (are [expected in] (= expected (camel-to-dashed in))
+ "wow" "wow"
+ "a" "a"
+ "a" "A"
+ "a-big" "aBig"
+ "a-team" "ATeam"
+ "a-team-x" "ATeamX"
+ "a-x" "aX"))
+
+;;
+
+(defrecord2 Foo [x y])
+
+(deftest test-defrecord2
+ (is (= "(new-foo {:x 10})" (print-str (new-foo {:x 10})))))
+
+(deftest test-defrecord2-pprint
+ (is (=
+ "(new-foo {:x 10})\n"
+ (with-out-str (pprint (new-foo {:x 10})))))
+ (is (= "(new-foo {:y 2})\n"
+ (with-out-str (pprint (new-foo {:x nil :y 2}))))))
+
+(deftest test-defrecord2-pprint-deep
+ (is (= "(new-foo {:x 10,\n :y\n (new-foo {:x 10,\n :y\n (new-foo {:x 10, :y (new-foo {:x 10, :y 20})})})})\n"
+ (with-out-str (pprint (new-foo {:x 10
+ :y (new-foo {:x 10
+ :y (new-foo {:x 10
+ :y (new-foo {:x 10 :y 20})})})}))))))
+
+(deftest test-defrecord2-dont-skip-extra-nils-but-do-skip-native-nils
+ (is (= "(new-foo {:x 10, :b nil, :a 4})"
+ (print-str (assoc (new-foo {:x 10}) :a 4 :b nil))))
+ (is (= "(new-foo {:x 10, :b nil, :a 4})"
+ (print-str (assoc (new-foo {:x 10 :y nil}) :a 4 :b nil)))))
+
+(deftest test-constructor-wrong-args-first-arg-is-not-a-record
+ (is (thrown? AssertionError (new-foo :x {}))))
+
+(deftest test-constructor-wrong-args-second-arg-is-not-a-map
+ (is (thrown? AssertionError (new-foo (new-foo {:x 10}) 20))))
+
+(deftest test-constructor-wrong-args-only-arg-is-not-a-map
+ (is (thrown? AssertionError (new-foo 20))))
+
+(deftest test-typo-in-field-name
+ (is (thrown? AssertionError (new-foo {:a 1})))
+ (is (thrown? AssertionError (new-foo {:a 1 :x 10})))
+ (is (thrown? AssertionError (new-foo {:a 1 :x 10 :y 20}))))
+
+(deftest test-new-record
+ (is (= (new-foo {:x 100})
+ (new-record (new-foo {:x 1}) {:x 100})))
+ (is (= (new-foo {:x 1 :y 100})
+ (new-record (new-foo {:x 1}) {:y 100})))
+ (is (thrown? AssertionError
+ (new-record (new-foo {:x 1}) {:z 100}))))
+
+(deftest test-dissoc2
+ (is (= (new-foo {:x 1})
+ (dissoc2 (new-foo {:x 1 :y 2}) :y)))
+ (is (= (new-foo {})
+ (dissoc2 (new-foo {:x 1 :y 2}) :x :y)))
+ (is (= (assoc (new-foo {:x 1}) :z 3)
+ (dissoc2 (assoc (new-foo {:x 1 :y 2}) :z 3) :y)))
+ (is (= (new-foo {:x 1})
+ (dissoc2 (assoc (new-foo {:x 1 :y 2}) :z 3) :y :z))))
+
+;;
+
+(defrecord2 F [z x b a])
+
+(deftest test-single-char-type-name
+ (is (= (F. nil nil nil 20)
+ (new-f {:a 20}))))
+
+(deftest test-order-of-printed-fields
+ (is (= "(new-f {:z 100, :x 99, :b 2, :a 1})"
+ (print-str (new-f {:a 1 :b 2 :x 99 :z 100})))))
+
+;; test tree walking
+
+(defmulti test-incrementer class)
+
+(defmethod test-incrementer Number [x]
+ (+ 1 x))
+
+(defmethod test-incrementer :default [x]
+ x)
+
+(defn test-pre-and-post [expected x]
+ (is (= expected
+ (prewalk2 test-incrementer x)))
+ (is (= expected
+ (postwalk2 test-incrementer x))) )
+
+(deftest test-walk
+ (are [expected x] (and (= expected
+ (prewalk2 test-incrementer x))
+ (= expected
+ (postwalk2 test-incrementer x)))
+
+ (new-foo {:x 101 :y 201})
+ (new-foo {:x 100 :y 200})
+
+ (new-foo {:x 101
+ :y (new-foo {:x 301 :y 401})})
+ (new-foo {:x 100
+ :y (new-foo {:x 300 :y 400})})
+
+ (new-foo {:x [101 201]})
+ (new-foo {:x [100 200]})
+
+ (new-foo {:x '(101 201)})
+ (new-foo {:x '(100 200)})
+
+ (new-foo {:x {:a 101 :b 201}})
+ (new-foo {:x {:a 100 :b 200}})
+
+ (new-foo {:x #{101 201}})
+ (new-foo {:x #{100 200}})
+
+ (new-foo {:x {:a 101
+ :b (new-foo {:x {:a 101 :b 201}})}})
+ (new-foo {:x {:a 100
+ :b (new-foo {:x {:a 100 :b 200}})}})
+
+ (new-foo {:x {:a 101
+ :b [(new-foo {:x {:a 101 :b 201}})]}})
+ (new-foo {:x {:a 100
+ :b [(new-foo {:x {:a 100 :b 200}})]}})
+
+ (new-foo {:x (range 2 11)})
+ (new-foo {:x (range 1 10)})))
+
+;; more tree walking tests
+
+(defrecord2 Bar [a b])
+
+(deftest test-walk-change-type
+ (let [node (new-foo {:x (new-foo {:x 1})})
+ new-node (new-bar {:a 100})
+ mutator (fn [old-node]
+ (if (= Foo (class old-node))
+ new-node
+ old-node))]
+ (is (= new-node
+ (prewalk2 mutator node)))
+ (is (= new-node
+ (postwalk2 mutator node)))))
+
+(defmulti test-mutator class)
+
+(defmethod test-mutator :default [x]
+ (if (nil? x)
+ nil
+ (+ 1 x)))
+
+(defmethod test-mutator Foo [x]
+ (new-foo x {:x 100}))
+
+(defmethod test-mutator Bar [x]
+ nil)
+
+(deftest test-walk-multi-types
+ (is (= (new-foo {:x 101})
+ (prewalk2 test-mutator (new-foo {:x 1 :y (new-bar {})}))))
+ (is (= (new-foo {:x 100})
+ (postwalk2 test-mutator (new-foo {:x 1 :y (new-bar {})})))) )
+
+;; tree walking - mutate clojure data types
+
+(defmulti remove-nils class)
+
+(defmethod remove-nils :default [x]
+ x)
+
+(defmethod remove-nils IPersistentVector [v]
+ (apply vector (remove nil? v)))
+
+(deftest test-mutate-vector
+ (is (= {:x [:a [:b :c]]}
+ (prewalk2 remove-nils {:x [:a nil [:b nil :c]]}))))
+
+(defmulti caps class)
+
+(defmethod caps :default [x] x)
+
+(defmethod caps String [s]
+ (upper-case s))
+
+(deftest test-mutate-map
+ (is (= {:x {:a "WOW"}}
+ (prewalk2 caps {:x {:a "wow"}}))))
+
+(deftest test-mutate-nil
+ (is (= (new-foo {:x 1})
+ (new-foo nil {:x 1}))))
+
+;; record with no fields
+(defrecord2 Empty [])
+
+(deftest test-empty
+ (is (= (Empty.)
+ (new-empty {})))
+ (is (= "(new-empty {})"
+ (with-out-str (print (new-empty {}))))))
+
+(deftest test-apply-to-symbol
+ (comment (is (thrown? ClassNotFoundException
+ (apply Bar. [100 200]))))
+ (is (= (new-bar {:a 100, :b 200})
+ ((apply-to-symbol Bar. 2) [100 200]))))
+
+(deftest test-zipper
+ (let [lll (new-bar {:a (new-foo {:x 11 :y 21})})
+ ll (new-bar {:a lll})
+ l [ll]
+ rl (new-bar {:a 2})
+ r (list rl)
+ tree (new-foo {:x l :y r})
+ zipper (record-zip tree)]
+ (is (= l (z/node (z/down zipper))))
+ (is (= ll (z/node (z/down (z/down zipper)))))
+ (is (= lll (z/node (z/down (z/down (z/down zipper))))))
+
+ (is (= r (z/node (z/right (z/down zipper)))))
+ (is (= rl (z/node (z/down (z/right (z/down zipper))))))
+ (is (= 2 (z/node (z/down (z/down (z/right (z/down zipper)))))))
+
+ (is (not (record-branch? (z/node (z/down (z/down (z/right (z/down zipper))))))))))
+
+
+(defn- trace-zipper [f zipper]
+ (map f (map z/node (take-while #(not (z/end? %)) (iterate z/next zipper)))))
+
+(deftest test-custom-zipper
+ (let [tree (new-bar {:a (new-foo {:x 10 :y 20}) :b (new-foo {:x 100 :y 200})})]
+ (is (= [defrecord2.test-defrecord2-core.Bar
+ defrecord2.test-defrecord2-core.Foo
+ java.lang.Integer
+ java.lang.Integer
+ defrecord2.test-defrecord2-core.Foo
+ java.lang.Integer
+ java.lang.Integer]
+ (trace-zipper class (record-zip tree))))
+
+ (is (= [defrecord2.test-defrecord2-core.Bar
+ defrecord2.test-defrecord2-core.Foo
+ defrecord2.test-defrecord2-core.Foo]
+ (trace-zipper class (record-zip tree {Foo []}))))
+
+ (is (= [defrecord2.test-defrecord2-core.Bar
+ defrecord2.test-defrecord2-core.Foo
+ java.lang.Integer]
+ (trace-zipper class (record-zip tree {Foo [:x]
+ Bar [:b]}))))
+
+ (is (= [(new-bar {:a (new-foo {:x 10, :y 20})
+ :b (new-foo {:x 100, :y 200})})
+ (new-foo {:x 100, :y 200})
+ 100]
+ (trace-zipper identity (record-zip tree {Foo [:x]
+ Bar [:b]}))))
+
+ (is (= [(new-bar {:a (new-foo {:x 10, :y 20})
+ :b (new-foo {:x 100, :y 200})})
+ (new-foo {:x 10, :y 20})
+ (new-foo {:x 100, :y 200})]
+ (trace-zipper identity (record-zip tree {Foo []}))))
+
+ (is (= [(new-bar {:a (new-foo {:x 10, :y 20})
+ :b (new-foo {:x 100, :y 200})})
+ (new-foo {:x 10, :y 20})
+ 20
+ 10
+ (new-foo {:x 100, :y 200})
+ 200
+ 100]
+ (trace-zipper identity (record-zip tree {Foo [:y :x]}))))))
+
+(deftest test-custom-zipper-constructor
+ (let [tree (new-bar {:a (new-foo {:x 10 :y 20}) :b (new-foo {:x 100 :y 200})})]
+
+ ;; if no ctor-map is provided then the default ctor is used
+ (let [zipper (record-zip tree {Foo [:x :y]})]
+ (is (= (new-bar {:a (new-foo {:x -1 :y 20}) :b (new-foo {:x 100 :y 200})})
+ (z/root (z/edit (z/next (z/next zipper)) (constantly -1))))))
+
+ ;; if fields are specifies in the field-map then the new children
+ ;; are passed into the ctor fn in a map keyed by field keyword
+ (let [zipper (record-zip tree {Foo [:x :y]} {Foo (fn [node {:keys (x y)}]
+ (new-foo {:x (+ x 1) :y (+ y 1)}))})]
+ (is (= (new-bar {:a (new-foo {:x 0 :y 21}) :b (new-foo {:x 100 :y 200})})
+ (z/root (z/edit (z/next (z/next zipper)) (constantly -1))))))
+
+ ;; if no fields are specified in the field-map then the new
+ ;; children are passed into the ctor fn in a map keyed by field keyword
+ (let [zipper (record-zip tree
+ {}
+ {Foo (fn [node {:keys (x y) :as z}]
+ ;; reverse the args
+ (new-foo {:x y :y x}))})]
+ (is (= (new-bar {:a (new-foo {:x 20 :y -1}) :b (new-foo {:x 100 :y 200})})
+ (z/root (z/edit (z/next (z/next zipper)) (constantly -1))))))
+
+ (let [zipper (record-zip tree {Foo [:x]})]
+ (is (= (new-bar {:a (new-foo {:x -1 :y 20}) :b (new-foo {:x 100 :y 200})})
+ (z/root (z/edit (z/next (z/next zipper)) (constantly -1))))))
+ ))
+
+(deftest test-record-zipper-on-vectors
+ ;; record-branch?
+ (are [expected node] (= expected (record-branch? node))
+ false []
+ true [1])
+ ;; record-node-children
+ (are [expected node] (= expected (record-node-children node))
+ [] []
+ [1 2] [1 2])
+ ;; record-make-node
+ (are [expected node children] (= expected (record-make-node node children))
+ [] [] []
+ [1 2] [] [1 2]))
+
+(deftest test-record-zipper-on-lists
+ ;; record-branch?
+ (are [expected node] (= expected (record-branch? node))
+ false (list)
+ false '()
+ true '(1))
+ ;; record-node-children
+ (are [expected node] (= expected (record-node-children node))
+ '() (list)
+ '() '()
+ '(1 2) '(1 2))
+ ;; record-make-node
+ (are [expected node children] (= expected (record-make-node node children))
+ '() '() []
+ '(1 2) '() [1 2]))
+
+(defn- to-lazy [s] (map identity s))
+
+(deftest test-record-zipper-on-seqs
+ ;; record-branch?
+ (are [expected node] (= expected (record-branch? (to-lazy node)))
+ false (list)
+ false '()
+ true '(1))
+ ;; record-node-children
+ (are [expected node] (= expected (record-node-children (to-lazy node)))
+ '() (list)
+ '() '()
+ '(1 2) '(1 2))
+ ;; record-make-node
+ (are [expected node children] (= expected (record-make-node (to-lazy node) children))
+ '() '() []
+ '(1 2) '() [1 2]))
+
+(deftest test-record-zipper-on-maps
+ ;; record-branch?
+ (are [expected node] (= expected (record-branch? node))
+ false {}
+ true {:a 1})
+ ;; record-node-children
+ (are [expected node] (= expected (record-node-children node))
+ nil {}
+ [[:a 1]] {:a 1}
+ [[:a 1] [:b 2]] {:a 1 :b 2})
+ ;; record-make-node
+ (are [expected node children] (= expected (record-make-node node children))
+ {} {} []
+ {:a 1} {} [[:a 1]]
+ {:a 1 :b 2} {} [[:a 1] [:b 2]]
+ {:a 1 :b 2} {:c 3 :d 4} [[:a 1] [:b 2]]))
+
+(deftest test-record-zipper-map-navigation-and-editing
+ (let [tree {:a {:b 1}}
+ z (record-zip tree)]
+ (is (= 1
+ (-> z z/down ;; to first mapentry
+ z/down ;; to key of mapentry
+ z/right ;; to value of mapentry (also a map)
+ z/down ;; repeat down/down/right
+ z/down
+ z/right
+ z/node))) ;; to 1
+ (is (= {:a {:b 42} :c 999}
+ (-> z
+ (z/append-child [:c 999])
+ z/down z/down z/right z/down z/down z/right
+ (z/edit (fn [loc] 42))
+ z/root)))))
+
+(deftest test-pattern-matching
+ (is (= 100 (match-record [(new-foo {:x 1
+ :y (new-bar {:a ?a})})
+ (new-foo {:x 1 :y (new-bar {:a 100 :b 200})})]
+ a
+ :fail)))
+
+ ;; test with a record from another namespace
+ (is (= 2 (match-record [(new-foo-helper {:p 1 :q ?a})
+ (new-foo-helper {:p 1 :q 2})]
+ a
+ :fail)))
+
+ ;; match fails, default is to return nil
+ (is (= nil (match-record [(new-foo {:x 1
+ :y (new-bar {:a ?a})}) (new-foo {:x 1 :y (new-foo {:x 100 :y 200})})]
+ a)))
+
+ ;; test explicit failure expression
+ (is (= :fail (match-record [(new-foo {:x 1
+ :y (new-bar {:a ?a})}) (new-foo {:x 1 :y (new-foo {:x 100 :y 200})})]
+ a
+ :fail)))
+
+ ;; deep match fails
+ (is (= nil (match-record [(new-foo {:x 1
+ :y (new-bar {:a ?a :b 2})})
+ (new-foo {:x 1 :y (new-bar {:a 100 :b 200})})]
+ a)))
+
+ ;; deep capture
+ (is (= 100 (match-record [(new-foo {:x 1
+ :y (new-bar {:a ?a :b 2})})
+ (new-foo {:x 1 :y (new-bar {:a 100 :b 2})})]
+ a)))
+
+ ;; use record patterns composed with other conditions
+ (is (= 100 (match-record [(and (new-foo {:x 1
+ :y (new-bar {:a ?a :b 2})})
+ (= 2 (count ?)))
+ (new-foo {:x 1 :y (new-bar {:a 100 :b 2})})]
+ a)))
+
+ ;; nested captures
+ (is (= [100
+ (new-bar {:a 100, :b 2})
+ (new-foo {:x 1 :y (new-bar {:a 100 :b 2})})]
+ (match-record [(and ?foo
+ (new-foo {:x 1
+ :y ?bar})
+ (new-foo {:x 1
+ :y (new-bar {:a ?a :b 2})}))
+ (new-foo {:x 1 :y (new-bar {:a 100 :b 2})})]
+ [a bar foo])))
+
+ ;; compound patterns without any record patterns still work
+ (is (= 100
+ (match-record [(and {:x ?a}
+ (= 1 (count ?)))
+ {:x 100}]
+ a)))
+
+ ;; or works
+ (is (= :match
+ (match-record [(or {:x ?a}
+ (= 1 (count ?)))
+ {:z 100}]
+ :match)))
+
+ ;; failures without any record patterns work
+ (is (= :fail
+ (match-record [(or {:x ?a}
+ (= 2 (count ?)))
+ {:z 100}]
+ :match
+ :fail)))
+
+ (binding [*ns* (find-ns 'defrecord2.test-defrecord2-core)]
+
+ (is (= '(and defrecord2.test-defrecord2-core.Foo {:y ?y, :x 1})
+ (record-matcher '(new-foo {:x 1 :y ?y}))))
+
+ (is (= '(and defrecord2.test-record-helper.FooHelper {:p 1, :q ?y})
+ (record-matcher '(new-foo-helper {:p 1 :q ?y}))))
+
+ (is (= '(and defrecord2.test-record-helper.FooHelperOther {:p 1, :q ?y})
+ (record-matcher '(helper/new-foo-helper-other {:p 1 :q ?y})))))
+
+ (is (thrown-with-msg? RuntimeException #"Unknown symbol: new-x"
+ (record-matcher '(new-x {}))))
+
+ ;; deeply nested patterns work
+ (is (= 100
+ (match-record [(and
+ (and
+ (and
+ (and {:x ?a}
+ (= 1 (count ?)))
+ (> 10 (count ?)))
+ (> 100 (count ?)))
+ (= 1 (count ?)))
+ {:x 100}]
+ a))))
+
+(deftest test-pattern-match-with-variables-as-input
+ (let [x (new-foo {:x 1 :y 2})]
+ (is (= 2 (match-record [(new-foo {:x 1 :y ?y})
+ x]
+ y)))))
+
+(def x (new-foo {:x 1 :y 2}))
+
+(deftest test-pattern-match-with-global-variables-as-input
+ (is (= 2 (match-record [(new-foo {:x 1 :y ?y})
+ x]
+ y))))
+
+;;(run-tests)
View
9 test/defrecord2/test_record_helper.clj
@@ -0,0 +1,9 @@
+(ns defrecord2.test-record-helper
+ (:use [defrecord2.defrecord2-core :only (defrecord2)]))
+
+;; these are for testing record pattern matching using types from
+;; another namespace
+
+(defrecord2 FooHelper [p q])
+
+(defrecord2 FooHelperOther [p q])

0 comments on commit 7ff1c76

Please sign in to comment.
Something went wrong with that request. Please try again.