Permalink
Browse files

Contracts for multi-arity functions

  • Loading branch information...
1 parent 9ea4ad1 commit 0875b8bd1b0f9dd19c797fe2d0c65ce33126d187 @dnaumov committed Apr 8, 2012
Showing with 57 additions and 33 deletions.
  1. +31 −15 src/contracts/core.clj
  2. +26 −18 test/contracts/test/core.clj
View
@@ -17,6 +17,7 @@
(declare =>)
(defn combinator-expr? [expr]
(and (seq? expr)
+ (symbol? (first expr))
(= (resolve (first expr)) #'=>)))
(def current-var (atom nil))
@@ -34,22 +35,35 @@
(defmacro =>
([pre post]
- (let [pre (if-not (vector? pre) [pre] pre)
- args (map #(gensym (str "arg-" (inc %) "__"))
- (range (count pre)))
- pre (zipmap args pre)]
- `(=> [~@args] ~pre ~post)))
- ([args pre post]
- (let [pre-check-results (gensym "pre-check-results")
+ (let [pre (cond
+ (combinator-expr? pre) (list [pre])
+ (symbol? pre) (list [pre])
+ (vector? pre) (list pre)
+ (list? pre) pre)
+ args (map #(vec (repeatedly (count %) (partial gensym "arg__")))
+ pre)
+ pre (map zipmap args pre)]
+ `(=> ~args ~pre ~post)))
+ ([arglist pre post]
+ (let [arglist (if (vector? arglist)
+ (list arglist)
+ arglist)
+ pre (if (map? pre)
+ (list pre)
+ pre)
+ f (gensym "f")
+ pre-check-results (gensym "pre-check-results")
result (gensym "result")]
- `(fn [f#]
- (fn [~@args]
- (let [~pre-check-results ~(gen-check :pre pre)
- ~@(mapcat (fn [arg] [arg `(get ~pre-check-results '~arg ~arg)]) ; contracts can alter the value of args, so we rebind them
- args)]
- (let [~result (f# ~@args)
- ~result (-> ~(gen-check :post {result post}) first val)]
- ~result)))))))
+ `(fn [~f]
+ (fn ~@(-> (fn [args pre]
+ `([~@args]
+ (let [~pre-check-results ~(gen-check :pre pre)
+ ~@(mapcat (fn [arg] [arg `(get ~pre-check-results '~arg ~arg)]) ; contracts can alter the value of args, so we rebind them
+ args)]
+ (let [~result (~f ~@args)
+ ~result (-> ~(gen-check :post {result post}) first val)]
+ ~result))))
+ (map arglist pre)))))))
(defmacro provide-contract [sym contract]
(letfn [(normalize [expr]
@@ -63,3 +77,5 @@
(cons `do
(for [clause clauses]
`(provide-contract ~@clause))))
+
+;; (=> number? pos?)
@@ -60,24 +60,32 @@
(g inc) => (throws AssertionError #"Pre" #"number?")
(h inc) => (throws AssertionError #"Post" #"string?"))))
-(future-fact "Different contracts for different arities"
- (let [f (fn
- ([x] (dec x))
- ([x y] (* x y)))
- f' ((c/=> number? neg?
- [even? odd?] pos?)
- f)]
- (f' 0) => -1
- (f' "foo") => (throws AssertionError #"Pre" #"number?")
- (f' 1) => (throws AssertionError #"Post" #"neg?")
- ;; XXX: <copypasted>
- (f' 2 3) => 6
- (f' 2 2) => (throws AssertionError #"Pre" #"odd?")
- (f' 3 3) => (throws AssertionError #"Pre" #"even?")
- (f' 3 2) => (throws AssertionError #"Pre" #"even?" #"odd?")
- (f' 2 -3) => (throws AssertionError #"Post")
- ;; </copypasted>
- ))
+(fact "Contracts for multi-arity functions"
+ (let [f (fn
+ ([x] (dec x))
+ ([x y] (* x y)))
+ f' ((c/=> ([x] [x y])
+ ({x number?} {x even?, y odd?})
+ pos?)
+ f)]
+ (f' 10) => 9
+ (f' "foo") => (throws AssertionError #"Pre" #"number?")
+ (f' 0) => (throws AssertionError #"Post" #"pos?")
+ (f' 2 3) => 6
+ (f' 2 2) => (throws AssertionError #"Pre" #"odd?")
+ (f' 3 3) => (throws AssertionError #"Pre" #"even?")
+ (f' 2 -3) => (throws AssertionError #"Post")))
+
+(fact "Multi-arity contracts without explicit args declaration"
+ (let [f (fn ([x] (dec x)) ([x y] (* x y)))
+ f' ((c/=> ([number?] [even? odd?]) pos?) f)]
+ (f' 10) => 9
+ (f' "foo") => (throws AssertionError #"Pre" #"number?")
+ (f' 0) => (throws AssertionError #"Post" #"pos?")
+ (f' 2 3) => 6
+ (f' 2 2) => (throws AssertionError #"Pre" #"odd?")
+ (f' 3 3) => (throws AssertionError #"Pre" #"even?")
+ (f' 2 -3) => (throws AssertionError #"Post")))
(defn constrained-inc [x] (inc x))

0 comments on commit 0875b8b

Please sign in to comment.