Skip to content
Browse files

Merge pull request #16 from frenchy64/master

Changes to factories and default arguments
  • Loading branch information...
2 parents dd1da43 + 8980afa commit e6fc0b80849a4afeb38be65f572b2630ace56a65 @fogus fogus committed Mar 31, 2012
Showing with 80 additions and 50 deletions.
  1. +49 −19 src/trammel/core.clj
  2. +31 −31 test/fogus/me/invariant_tests.clj
View
68 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]
View
62 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"))

0 comments on commit e6fc0b8

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