Permalink
Browse files

Finished record invariants

  • Loading branch information...
1 parent 48af6dc commit 1d9b30ff447976516fdf454661d635dc284c912f @dnaumov committed May 18, 2012
Showing with 46 additions and 29 deletions.
  1. +32 −25 src/contracts/core.clj
  2. +14 −4 test/contracts/test/core.clj
View
@@ -135,35 +135,42 @@
:expr `(deref ~target)
:value newval}))))
-(defprotocol Constrained
- (check-constraint [this]))
-
-(defn apply-record-contract [f & args]
- (let [result (apply f args)]
- (if (satisfies? Constrained result)
- (check-constraint result)
- result)))
-
-(comment
- (doseq [v [#'assoc #'dissoc #'assoc-in #'update-in
- #'conj #'into #'merge #'merge-with]]
- (add-hook v #'apply-record-contract)))
+;; XXX: it's used instead of protocols because protocol function call
+;; in `apply-record-contract` causes infinite recursion and
+;; throws StackOverflowException.
+(def record-hooks (atom {}))
+
+(defn add-record-hook [class f]
+ (swap! record-hooks assoc class f))
+
+(defn apply-record-contract [f]
+ (if (:hooked (meta f))
+ f
+ (with-meta
+ (fn [m & args]
+ (if-let [hook (get @record-hooks (class m))]
+ (hook (apply f m args))
+ (apply f m args)))
+ {:hooked true})))
+
+(doseq [v [#'assoc #'dissoc #'assoc-in #'update-in
+ #'conj #'into #'merge #'merge-with]]
+ (alter-var-root v #'apply-record-contract))
(defn gen-constrain-record [class pred]
(let [name (.getSimpleName class)
this (gensym "this")
[factory map-factory] (map #(symbol (str % name)) ["->" "map->"])]
- `(do (add-hook (var ~factory) #'apply-record-contract)
- (add-hook (var ~map-factory) #'apply-record-contract)
- (extend ~class
- Constrained
- {:check-constraint (fn [~this]
- ~(gen-check* {:type :invariant
- :cond `(~pred ~this)
- :return-val this
- :pred pred
- :expr (symbol "<record>")
- :value this}))}))))
+ `(do (alter-var-root (var ~factory) #'apply-record-contract)
+ (alter-var-root (var ~map-factory) #'apply-record-contract)
+ (add-record-hook ~class
+ (fn [~this]
+ ~(gen-check* {:type :invariant
+ :cond `(~pred ~this)
+ :return-val this
+ :pred pred
+ :expr (symbol "<record>")
+ :value this}))))))
(defmacro provide-contract [target contract]
(let [contract (normalize-contract contract)
@@ -186,4 +193,4 @@
(load "preds")
-;; (load "curried") ; this line should be commented out during development
+(load "curried") ; this line should be commented out during development
@@ -232,7 +232,17 @@
(map->ARecord {:a 1 :b 2}) => #contracts.test.core.ARecord{:a 1 :b 2}
(map->ARecord {:a 2 :b 2}) => (throws AssertionError #"Invariant"))
- (future-fact "Modifying functions"
- (let [a (ARecord. 1 2)]
- (assoc a :b 10) => {:a 1 :b 10}
- (assoc a :a 10) => (throws AssertionError #"Invariant" #"10"))))
+ (fact "Modifying functions"
+ (let [r (ARecord. 1 2)]
+ (assoc r :b 10) => {:a 1 :b 10}
+ (assoc r :a 10) => (throws AssertionError #"Invariant" #"10")
+ (dissoc r :a) => (throws AssertionError #"Invariant" #"\{:b 2\}")
+ (assoc-in r [:a] 10) => (throws AssertionError #"Invariant" #"10")
+ (update-in r [:a] inc) => (throws AssertionError #"Invariant" #"2")
+ (conj r [:c 3]) => {:a 1 :b 2 :c 3}
+ (conj r [:a 2]) => (throws AssertionError #"Invariant" #"2")
+ (into {:a 2} r) => {:a 1 :b 2}
+ (into r {:a 2}) => (throws AssertionError #"Invariant" #"2")
+ (merge {:a 2} r) => {:a 1 :b 2}
+ (merge r {:a 2}) => (throws AssertionError #"Invariant" #"2")
+ (merge-with + r {:a 1}) => (throws AssertionError #"Invariant" #"2"))))

0 comments on commit 1d9b30f

Please sign in to comment.