Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

One step closer to contract/=>

  • Loading branch information...
commit 92ec2deb461ae67ced5451da8efad57351b37d5d 1 parent eec81d8
Fogus fogus authored
38 src/main/clojure/clojure/core/contracts/impl/funcify.clj
View
@@ -0,0 +1,38 @@
+(ns clojure.core.contracts.impl.funcify)
+
+(declare funcify*)
+(declare funcify-factor)
+
+(defn funcify
+ [args cnstr]
+ (vec (map #(funcify* % args) cnstr)))
+
+
+(defmulti funcify* (fn [e _] (class e)))
+
+(defmethod funcify* clojure.lang.IFn [e args] (list* e args))
+(defmethod funcify* java.util.regex.Pattern [e args] (list* 'clojure.core/re-matches e args))
+(defmethod funcify* java.lang.String [e args] (list* 'clojure.core/= e args))
+(defmethod funcify* java.lang.Number [e args] (list* 'clojure.core/= e args))
+(defmethod funcify* :default [e args] (funcify-factor e args))
+
+
+;; funcify-factor
+
+(defmulti funcify-factor (fn [[h & _] _] h))
+
+(defmethod funcify-factor 'or
+ [e args]
+ (list* 'or (funcify args (rest e))))
+
+(defmethod funcify-factor 'in
+ [e args]
+ (concat (list* 'in args) (rest e)))
+
+(defmethod funcify-factor 'whitelist
+ [e args]
+ (concat (list* 'whitelist args) (rest e)))
+
+(defmethod funcify-factor :default
+ [e args]
+ e)
27 src/main/clojure/clojure/core/contracts/impl/transformers.clj
View
@@ -1,4 +1,5 @@
(ns clojure.core.contracts.impl.transformers
+ (:use [clojure.core.contracts.impl.funcify :only (funcify)])
(:require [clojure.core.unify :as unify]
[clojure.core.contracts.impl.utils :as utils]))
@@ -37,3 +38,29 @@
form))
cnstr))
+(defn- build-constraints-map
+ [args cnstr]
+ (let [cnstr (vec (tag-hocs cnstr))]
+ [args
+ (->> (build-pre-post-map cnstr)
+ (utils/manip-map (partial funcify '[%]) [:post])
+ (utils/manip-map (partial funcify args) [:pre]))]))
+
+
+(defn build-contract-body
+ [args cnstr descr]
+ (let [c (build-constraints-map args cnstr)]
+ (unify/subst
+ {'?ARGS args
+ '?F 'f
+ '?PARMS (vec (list* 'f args))
+ '?PRE (:pre c)
+ '?POST (:post c)
+ '?MSG descr
+ '?PRE-CHECK (build-condition-body :pre '(apply ?F ?ARGS) "Pre-condition failure: ")
+ '?POST-CHECK (build-condition-body :post 'ret "Post-condition failure: ")}
+
+ '(?PARMS
+ (let [ret ?PRE-CHECK]
+ ?POST-CHECK)))))
+
Please sign in to comment.
Something went wrong with that request. Please try again.