Skip to content
Browse files

Started working on record invariants

  • Loading branch information...
1 parent 60df7e9 commit c3c66cffdb52b84c84db127ac53953cdd7bef96d @dnaumov committed May 16, 2012
Showing with 57 additions and 5 deletions.
  1. +35 −5 src/contracts/core.clj
  2. +22 −0 test/contracts/test/core.clj
View
40 src/contracts/core.clj
@@ -134,17 +134,47 @@
:expr `(deref ~target)
:value newval}))))
+(defprotocol Constrained
+ (check-constraint [this]))
+
+(defn apply-record-contract [f]
+ (fn [& 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]]
+ (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 (alter-var-root (var ~factory) apply-record-contract)
+ (alter-var-root (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}))}))))
+
(defmacro provide-contract [target contract]
(let [contract (normalize-contract contract)
resolved-target (if (symbol? target)
(resolve target)
target)]
(reset! current-target resolved-target)
`(do ~(cond
- (fn-contract-expr? contract)
- `(alter-var-root (var ~target) ~contract)
- :else
- `(set-validator! ~target ~(gen-iref-contract target contract)))
+ (fn-contract-expr? contract) `(alter-var-root (var ~target) ~contract)
+ (class? resolved-target) (gen-constrain-record resolved-target contract)
+ :else `(set-validator! ~target ~(gen-iref-contract target contract)))
(reset! current-target nil))))
(defmacro provide-contracts [& clauses]
@@ -154,4 +184,4 @@
(load "preds")
-(load "curried") ; this line should be commented out during development
+;; (load "curried") ; this line should be commented out during development
View
22 test/contracts/test/core.clj
@@ -214,3 +214,25 @@
(do (send z -) (await z) @z) => -1
(do (send z inc) (Thread/sleep 100) (throw (agent-error z)))
=> (throws AssertionError #"0")))
+
+
+(defrecord ARecord [a b])
+(c/provide-contract ARecord
+ #(= 1 (:a %)))
+
+(facts "Record invariants"
+
+ (fact "Factory functions and error messages"
+ (->ARecord 1 2) => #contracts.test.core.ARecord{:a 1 :b 2}
+ (->ARecord 2 2) => (throws AssertionError
+ #"Invariant"
+ #"contracts\.test\.core\.ARecord"
+ #"Expecting: \(= 1 \(:a <record>\)\)"
+ #"Given: #contracts.test.core.ARecord\{:a 2, :b 2\}")
+ (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"))))

0 comments on commit c3c66cf

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