Changes to factories and default arguments

- remove default arguments for defconstrainedrecord
- fix positional ->* factory to only accept exact
  arguments for defconstrainedtype and defconstrainedrecord
- fix defconstrained record ->* factory to have positional
  args like the clojure.core version
- add contracts to defconstrainedrecord map->* factory
- merged changes with defconstrainedrecord docstring

src/trammel/core.clj

@@ -224,32 +224,62 @@
        ~(str (:doc mdata))
        ~@body)))
 
+; clojure/core_deftype.clj
+(defn- build-positional-factory
+  "Used to build a positional factory for a given type/record.  Because of the
+  limitation of 20 arguments to Clojure functions, this factory needs to be
+  constructed to deal with more arguments.  It does this by building a straight
+  forward type/record ctor call in the <=20 case, and a call to the same
+  ctor pulling the extra args out of the & overage parameter.  Finally, the
+  arity is constrained to the number of expected fields and an ArityException
+  will be thrown at runtime if the actual arg count does not match."
+  [nom classname fields invariants chk]
+  (let [fn-name (symbol (str '-> nom))
+        [field-args over] (split-at 20 fields)
+        field-count (count fields)
+        arg-count (count field-args)
+        over-count (count over)]
+    `(defconstrainedfn ~fn-name
+       [~@field-args ~@(if (seq over) '[& overage] [])]
+       ~invariants
+       (with-meta
+         ~(if (seq over)
+            `(if (= (count ~'overage) ~over-count)
+               (new ~classname
+                    ~@field-args
+                    ~@(for [i (range 0 (count over))]
+                        (list `nth 'overage i)))
+               (throw (clojure.lang.ArityException. (+ ~arg-count (count ~'overage)) (name '~fn-name))))
+            `(new ~classname ~@field-args))
+         {:contract ~chk}))))
+
+
 (defmacro defconstrainedrecord
   [name slots inv-description invariants & etc]
-  (check-args! name slots inv-description invariants)
-  (let [fields       (->> slots (partition 2) (map first) vec)
-        defaults     (->> slots (partition 2) (map second))
-        ctor-name    (symbol (str name \.))
-        factory-name (symbol (str "->" name))]
+  (let [fields       (vec slots)
+        ns-part (namespace-munge *ns*)
+        classname (symbol (str ns-part "." name))
+        ctor-name (symbol (str name \.))
+        positional-factory-name (symbol (str "->" name))
+        map-arrow-factory-name (symbol (str "map->" name))
+        chk `(contract ~(symbol (str "chk-" name))
+                       ~inv-description
+                       [{:keys ~fields :as m#}] ~invariants)]
     `(do
        (let [t# (defrecord ~name ~fields ~@etc)]
          (defn ~(symbol (str name \?)) [r#]
            (= t# (type r#))))
+
+       ~(build-positional-factory name classname fields invariants chk)
 
-       (let [chk# (contract ~(symbol (str "chk-" name))
-                            ~inv-description
-                            [{:keys ~fields :as m#}] ~invariants)]
-         (defconstrainedfn ~factory-name
-           ([] [] (with-meta 
-                    (~ctor-name ~@defaults)
-                    {:contract chk#}))
-           ([& {:keys ~fields :as kwargs# :or ~(apply hash-map slots)}]
-              ~invariants
-              (with-meta
-                (-> (~ctor-name ~@defaults)
-                    (merge kwargs#))
-                {:contract chk#}))))
-       ~name)))
+       (defconstrainedfn ~map-arrow-factory-name
+         ([{:keys ~fields :as kwargs#}]
+          ~invariants
+          (with-meta
+            (. ~classname ~'create kwargs#)
+            {:contract ~chk})))
+
+       ~classname)))
 
 (defn- apply-contract
   [f]

test/fogus/me/invariant_tests.clj

@@ -12,55 +12,55 @@
 ;; remove this notice, or any other, from this software.
 
 (ns fogus.me.invariant-tests
+  (:import (clojure.lang ArityException))
   (:use [trammel.core :only [defconstrainedrecord defconstrainedtype]])
   (:use [clojure.test :only [deftest is]]))
 
-
-(defconstrainedrecord Foo [a 1 b 2]
-  "Foo record fields are expected to hold only numbers."
+(defconstrainedrecord AllNumbersRecord [a b]
+  "AllNumbersRecord record fields are expected to hold only numbers."
   [(every? number? [a b])]
   Object
-  (toString [this] (str "record Foo has " a " and " b)))
+  (toString [this] (str "record AllNumbersRecord has " a " and " b)))
+
+(defconstrainedtype AllNumbersType [a b]
+  "AllNumbersType type fields are expected to hold only numbers."
+  [(every? number? [a b])])
 
 (deftest test-constrained-record-with-vector-spec
-  (is (= (:a (->Foo)) 1))
-  (is (= (:b (->Foo)) 2))
-  (is (= (:a (->Foo :a 42)) 42))
-  (is (= (:b (->Foo :b 108)) 108))
-  (is (= (:a (->Foo :a 42 :b 108)) 42))
-  (is (= (:b (->Foo :a 42 :b 108)) 108))
-  (is (= (:a (->Foo :a 42 :b 108 :c 36)) 42))
-  (is (= (:b (->Foo :a 42 :b 108 :c 36)) 108))
-  (is (= (:c (->Foo :a 42 :b 108 :c 36)) 36))
-  (is (thrown? Error (->Foo :a :b)))
-  (is (thrown? Error (->Foo :a 42 :b nil))))
+  (is (= (:a (->AllNumbersRecord 42 108)) 42))
+  (is (= (:b (->AllNumbersRecord 42 108)) 108))
+  (is (thrown? ArityException (->AllNumbersRecord)))
+  (is (thrown? ArityException (->AllNumbersRecord 12))))
 
 (defconstrainedtype Bar [a b]
   "Bar type fields are expected to hold only numbers."
   [(every? number? [a b])])
 
 (deftest test-constrained-type-with-vector-spec
-  (is (= (.a (->Bar 1 2)) 1))
-  (is (= (.b (->Bar 1 2)) 2))
-  (is (thrown? Error (->Bar :a :b))))
+  (is (= (.a (->AllNumbersType 1 2)) 1))
+  (is (= (.b (->AllNumbersType 1 2)) 2))
+  (is (thrown? ArityException (->AllNumbersType)))
+  (is (thrown? ArityException (->AllNumbersType 1)))
+  (is (thrown? Error (->AllNumbersType :a :b))))
 
 ;; testing default clojure pre/post maps
 
-(defconstrainedrecord Baz [a 1 b 2]
+(defconstrainedrecord Buzz [a b]
   "Baz record fields are expected to hold only numbers."
   {:pre [(every? number? [a b])]}
   Object
-  (toString [this] (str "record Baz has " a " and " b)))
+  (toString [this] (str "record Buzz has " a " and " b)))
 
 (deftest test-constrained-record-with-map-spec
-  (is (= (:a (->Baz)) 1))
-  (is (= (:b (->Baz)) 2))
-  (is (= (:a (->Baz :a 42)) 42))
-  (is (= (:b (->Baz :b 108)) 108))
-  (is (= (:a (->Baz :a 42 :b 108)) 42))
-  (is (= (:b (->Baz :a 42 :b 108)) 108))
-  (is (= (:a (->Baz :a 42 :b 108 :c 36)) 42))
-  (is (= (:b (->Baz :a 42 :b 108 :c 36)) 108))
-  (is (= (:c (->Baz :a 42 :b 108 :c 36)) 36))
-  (is (thrown? Error (->Baz :a :b)))
-  (is (thrown? Error (->Baz :a 42 :b nil))))
+  (is (= (:a (->Buzz 42 108)) 42))
+  (is (= (:b (->Buzz 42 108)) 108))
+  (is (thrown? ArityException (->Buzz)))
+  (is (thrown? ArityException (->Buzz 12))))
+
+; map->* factory
+
+(deftest test-map-factory-for-defconstrainedrecord
+  (is (= (:a (map->Buzz {:a 1 :b 2})) 1))
+  (is (= (:b (map->Buzz {:a 1 :b 2})) 2))
+  (is (= (:c (map->Buzz {:a 1 :b 2 :c "a"})) "a"))
+  (is (thrown? Error (map->Buzz {:a nil})) "a"))