Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Refactored humanizing stuff

  • Loading branch information...
commit 7a9ee0743e55c18609eb70edfaf1d94498d3ca41 1 parent af59715
Dmitri Naumov authored April 21, 2012
58  src/contracts/core.clj
@@ -7,30 +7,48 @@
7 7
 (declare =>)
8 8
 (def current-var (atom nil))
9 9
 
10  
-(defn humanize-symbol-name [s]
11  
-  (condp #(.startsWith %2 %1) s
12  
-    "%&" "<rest-args>"
13  
-    "%" (format "<%s arg>" (case s
14  
-                             ("%" "%1") "first"
15  
-                             "%2" "second"
16  
-                             "%3" "third"
17  
-                             (str (subs s 1) "th")))
18  
-    "(clojure.core/deref (var " (subs s 25 (- (count s) 2))
19  
-    "(clojure.core/deref " (str "@" (subs s 20 (dec (count s))))
20  
-    s))
21  
-
22  
-(defn humanize-pred-expr [pred-expr checked-expr]
23  
-  (match pred-expr ([(:or fn fn*) [arg] body] :seq)
24  
-    (-> pred-expr
25  
-        (nth 2)
26  
-        (->> (postwalk #(if (= % arg) checked-expr %))))))
  10
+(defmacro match-s
  11
+  "Like match, but also wraps every check in (... :seq)"
  12
+  [expr & clauses]
  13
+  (letfn [(wrap-in-seq [form]
  14
+            (postwalk #(if (clj/and (list? %)
  15
+                                    (clj/not (keyword? (first %))))
  16
+                         (list % :seq)
  17
+                         %)
  18
+                      form))]
  19
+    `(match ~expr ~@(->> clauses
  20
+                         (partition 2)
  21
+                         (map (fn [[q a]] [(wrap-in-seq q) a]))
  22
+                         (apply concat)))))
  23
+
  24
+(defn humanize-checked-expr [expr]
  25
+  (let [s (match-s expr
  26
+            (deref (var x)) (name x)
  27
+            (deref x) (str "@" (name x))
  28
+            '%& "<rest-args>"
  29
+            :else (pr-str expr))]
  30
+    (if-not (.startsWith s "%")
  31
+      s
  32
+      (format "<%s arg>" (case s
  33
+                           ("%" "%1") "first"
  34
+                           "%2" "second"
  35
+                           "%3" "third"
  36
+                           (str (subs s 1) "th"))))))
  37
+
  38
+(defn humanize-pred-expr
  39
+  "If expr is anonymous function, formats it's nicely, otherwise returns nil."
  40
+  [pred-expr checked-expr]
  41
+  (match-s pred-expr ((:or fn fn*) [arg] body)
  42
+    (->> body
  43
+         (postwalk #(if (= % arg) (symbol checked-expr) %))
  44
+         pr-str)))
27 45
 
28 46
 (defn report [{:keys [type var pred expr value]}]
29 47
   (let [humanized-expr (if (= type :post)
30 48
                          "<result>"
31  
-                         (humanize-symbol-name (pr-str expr)))
32  
-        expecting (if-let [humanized-pred (humanize-pred-expr pred (symbol humanized-expr))]
33  
-                    (pr-str humanized-pred)
  49
+                         (humanize-checked-expr expr))
  50
+        expecting (if-let [humanized-pred (humanize-pred-expr pred humanized-expr)]
  51
+                    humanized-pred
34 52
                     (format "%s is: %s" humanized-expr pred))]
35 53
     (format "%s failed for %s %n Expecting: %s %n Given: %s"
36 54
             (case type
17  test/contracts/test/core.clj
@@ -38,7 +38,7 @@
38 38
     (*' 2 3) => 6
39 39
     (*' 2 2) => (throws AssertionError #"Pre" #"odd\?")
40 40
     (*' 3 3) => (throws AssertionError #"Pre" #"even\?")
41  
-    (*' 2 -3) => (throws AssertionError #"Post"))) 
  41
+    (*' 2 -3) => (throws AssertionError #"Post")))
42 42
 
43 43
 (facts "Contracts for higher-order functions"
44 44
 
@@ -110,11 +110,18 @@
110 110
     (-' 1 2) => -1
111 111
     (-' 1 -2) => (throws AssertionError #"Pre" #"\(partial every\? pos\?\)")))
112 112
 
  113
+(fact "humanize-checked-expr"
  114
+  (c/humanize-checked-expr `@#'x) => "x"
  115
+  (c/humanize-checked-expr `@x) => "@x"
  116
+  (c/humanize-checked-expr (symbol "%&")) => "<rest-args>"
  117
+  (c/humanize-checked-expr '%) => "<first arg>"
  118
+  (c/humanize-checked-expr '(+ a b)) => "(+ a b)")
  119
+
113 120
 (fact "humanize-pred-expr"
114  
-  (let [f #(c/humanize-pred-expr % :x)]
115  
-    (f '(fn* [p1__17145#] (inc p1__17145#))) => '(inc :x)
116  
-    (f '(fn* [p1__19793#] (* p1__19793# p1__19793#))) => '(* :x :x)
117  
-    (f '(fn [x] (* x (+ 2 x)))) => '(* :x (+ 2 :x))
  121
+  (let [f #(c/humanize-pred-expr % "x")]
  122
+    (f '(fn* [p1__17145#] (inc p1__17145#))) => "(inc x)"
  123
+    (f '(fn* [p1__19793#] (* p1__19793# p1__19793#))) => "(* x x)"
  124
+    (f '(fn [x] (* x (+ 2 x)))) => "(* x (+ 2 x))"
118 125
     (f '(+ 1 2)) => nil
119 126
     (f 'pred?) => nil))
120 127
 

0 notes on commit 7a9ee07

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