Permalink
Browse files

Moving over contract building functions and utils.

  • Loading branch information...
1 parent fde7014 commit eec81d8ddd8fb17f413f82fee943c56a94233135 @fogus fogus committed May 7, 2012
@@ -0,0 +1,39 @@
+(ns clojure.core.contracts.impl.transformers
+ (:require [clojure.core.unify :as unify]
+ [clojure.core.contracts.impl.utils :as utils]))
+
+
+(defn build-condition-body
+ [p body prefix-msg]
+ (unify/subst
+ {'?P p
+ '?PREFIX prefix-msg
+ '?BODY body}
+
+ '(try
+ ((fn [] {?P ?PRE}
+ ?BODY))
+ (catch AssertionError ae
+ (throw (AssertionError. (str ?PREFIX ?MSG \newline (.getMessage ae))))))))
+
+
+(defn- build-pre-post-map
+ "(build-pre-post-map '[(odd? n) (pos? n) => (int? %)])
+ ;=> {:pre [...] :post [...]}
+ "
+ [cnstr]
+ (if (vector? cnstr)
+ (let [[L M R] (partition-by #{'=>} cnstr)]
+ {:pre (vec (when (not= L '(=>)) L))
+ :post (vec (if (= L '(=>)) M R))})
+ cnstr))
+
+
+(defn- tag-hocs
+ [cnstr]
+ (map (fn [form]
+ (if (and (seq? form) (= '_ (first form)))
+ (list 'fn? (second form))
+ form))
+ cnstr))
+
@@ -1,34 +1,14 @@
(ns clojure.core.contracts.impl.utils
(:require [clojure.core.unify :as unify]))
+(defn keys-apply [f ks m]
+ (let [only (select-keys m ks)]
+ (zipmap (keys only) (map f (vals only)))))
-(defn build-condition-body
- [p body prefix-msg]
- (unify/subst
- {'?P p
- '?PREFIX prefix-msg
- '?BODY body}
-
- '(try
- ((fn [] {?P ?PRE}
- ?BODY))
- (catch AssertionError ae
- (throw (AssertionError. (str ?PREFIX ?MSG \newline (.getMessage ae))))))))
+(defn manip-map [f ks m]
+ (conj m (keys-apply f ks m)))
-(defn- build-pre-post-map
- [cnstr]
- (if (vector? cnstr)
- (let [[L M R] (partition-by #{'=>} cnstr)]
- {:pre (vec (when (not= L '(=>)) L))
- :post (vec (if (= L '(=>)) M R))})
- cnstr))
-
-(comment
-
- (build-pre-post-map '[(odd? n) (pos? n) => (int? %)])
-
-)
(defmacro ^:private assert-w-message
[check message]

0 comments on commit eec81d8

Please sign in to comment.