Skip to content

Instantly share code, notes, and snippets.

@xsc
Created May 11, 2018 10:12
Show Gist options
  • Save xsc/868eb5107e82401e0674e07b590a81a3 to your computer and use it in GitHub Desktop.
Save xsc/868eb5107e82401e0674e07b590a81a3 to your computer and use it in GitHub Desktop.
Transforming rewrite-clj's Midje testcases to standard Clojure tests
(ns user
(:require [rewrite-clj.zip :as z]
[rewrite-clj.node :as n]))
(defn token=
[loc v]
(and (= :token (z/tag loc))
(= v (z/sexpr loc))))
(defn fact?
[loc]
(and (z/list? loc)
(contains? '#{future-fact fact}
(some-> loc z/node n/children first n/sexpr))))
(defn property?
[loc]
(and (z/list? loc)
(= 'property (some-> loc z/node n/children first n/sexpr))))
(defn tabular?
[loc]
(and (z/list? loc)
(= 'tabular (some-> loc z/node n/children first n/sexpr))))
(defn arrow?
[loc]
(and (= :token (z/tag loc))
(= '=> (z/sexpr loc))
(z/right loc)
(z/left loc)))
(defn midje-ns?
[loc]
(and (= :token (z/tag loc))
(= 'midje.sweet (z/sexpr loc))))
(defn helper-ns?
[loc]
(and (= :token (z/tag loc))
(= 'rewrite-clj.test-helpers (z/sexpr loc))))
(defn param?
[loc]
(and (= :token (n/tag loc))
(let [v (n/sexpr loc)]
(and (symbol? v)
(.startsWith (name v) "?")))))
(defn expand-fact
[n]
(-> n
z/down
;; replace 'fact with 'deftest
z/remove
(z/insert-child 'deftest)
;; replace description with symbol
z/down
z/right
(z/edit
(fn [value]
(symbol
(str "t-"
(.. value
toLowerCase
(replaceAll " -> " "->")
(replaceAll "\\s+" "-")
(replaceAll "[^a-z0-9->]" "")
(replaceAll "^about-" ""))))))
z/up))
(defn expand-property
[n]
(-> n
z/down
;; replace 'fact with 'deftest
z/remove
(z/insert-child 'defspec)
;; replace description with symbol
z/down
z/right
(z/edit
(fn [value]
(symbol
(str "t-"
(.. value
toLowerCase
(replaceAll "\\s+" "-")
(replaceAll "[^a-z0-9-]" "")
(replaceAll "^about-" ""))))))
z/up))
(defn expand-arrow
[n]
(let [lhs (z/node (z/left n))
rhs (z/node (z/right n))
new-node (cond (and (= (n/tag rhs) :token)
(symbol? (n/sexpr rhs))
(or (.endsWith (name (n/sexpr rhs)) "?")
(= (n/sexpr rhs) '?pred)))
(n/list-node
[(n/coerce 'is)
(n/whitespace-node " ")
(n/list-node
[rhs
(n/whitespace-node " ")
lhs])])
(and (= (n/tag rhs) :token)
(= (n/sexpr rhs) 'anything))
lhs
(and (= (n/tag rhs) :token)
(contains? '#{true truthy} (n/sexpr rhs)))
(n/list-node
[(n/coerce 'is)
(n/whitespace-node " ")
lhs])
(and (= (n/tag rhs) :list)
(= (first (n/sexpr rhs)) 'throws)
(= (count (n/sexpr rhs)) 2))
(n/list-node
[(n/coerce 'is)
(n/whitespace-node " ")
(n/list-node
[(n/coerce 'thrown?)
(n/whitespace-node " ")
(last (n/sexpr rhs))
(n/whitespace-node " ")
lhs])])
(and (= (n/tag rhs) :list)
(= (first (n/sexpr rhs)) 'has))
(n/list-node
[(n/coerce 'is)
(n/whitespace-node " ")
(n/coerce
(concat
(rest (n/sexpr rhs))
[(n/sexpr lhs)]))])
(and (= (n/tag rhs) :list)
(= (first (n/sexpr rhs)) 'throws)
(= (count (n/sexpr rhs)) 3))
(n/list-node
[(n/coerce 'is)
(n/whitespace-node " ")
(n/list-node
[(n/coerce 'thrown?)
(n/whitespace-node " ")
(second (n/sexpr rhs))
(n/whitespace-node " ")
(last (n/sexpr rhs))
(n/whitespace-node " ")
lhs])])
:else
(n/list-node
[(n/coerce 'is)
(n/whitespace-node " ")
(n/list-node
[(n/coerce '=)
(n/whitespace-node " ")
rhs
(if (> (+ (n/length rhs) (n/length lhs)) 80)
(n/newline-node "\n")
(n/whitespace-node " "))
lhs])]))]
(-> n
z/right
z/remove*
z/left
(z/replace new-node)
z/left
z/remove)))
(defn- wrap-tabular-fact
[fact-form ps vs]
(let [new-node (n/list-node
(concat
[(n/coerce 'are)
(n/whitespace-node " ")
(n/coerce (vec ps))
(n/newline-node "\n")
(z/node fact-form)
(n/newline-node "\n")]
vs))]
(z/replace fact-form new-node)))
(defn- remove-trailing-args
[loc]
(loop [loc (z/right* loc)]
(if-let [r (z/right* loc)]
(recur (-> r z/remove*))
loc)))
(defn wrap-tabular
[n]
(let [sq (n/children (z/node n))
ps (filter param? sq)
vs (->> sq
(drop-while (complement param?))
(drop-while
(fn [n]
(or (param? n)
(n/whitespace? n)))))]
(-> n
z/down
z/right
z/right
(wrap-tabular-fact ps vs)
(remove-trailing-args)
z/up)))
(defn- expand-arrows
[loc]
(loop [loc loc]
(if (z/end? loc)
(z/of-string (z/root-string loc))
(let [n (z/next loc)]
(recur
(if (arrow? n)
(expand-arrow n)
n))))))
(defn process-file
[f]
(loop [loc (expand-arrows (z/of-file f))]
(if (z/end? loc)
(spit f (.. (z/->root-string loc)
(replaceAll "\\)\\s+\\)" "))")))
(let [n (z/next loc)]
(cond (fact? n)
(recur (expand-fact n))
(property? n)
(recur (expand-property n))
(midje-ns? n)
(recur (z/replace n (n/coerce 'clojure.test)))
(helper-ns? n)
(recur (z/replace n (n/coerce 'clojure.test.check.clojure-test)))
(token= n 'truthy)
(recur (z/replace n 'identity))
(token= n 'falsey)
(recur (z/replace n 'not))
(token= n 'facts)
(recur (-> n
z/up
z/splice
z/right
z/remove
z/remove))
(tabular? n)
(let [name-node (-> n z/down z/right z/down z/right z/node)
form-count (-> n z/down z/right z/node n/child-sexprs count (- 2))]
(if (> form-count 1)
(recur
(z/subedit-> n
z/down
z/right
z/down
z/right
z/remove
(z/replace 'do)
z/up
(z/insert-left name-node)
z/up
expand-fact
wrap-tabular))
(recur
(z/subedit-> n
z/down
z/right
z/splice
z/remove
z/up
expand-fact
wrap-tabular))))
:else
(recur n))))))
(doseq [f (->> (file-seq (clojure.java.io/file "test/rewrite_clj"))
(filter #(.isFile %)))]
(try
(process-file f)
(catch Throwable t
(println (format "%s failed: [%s] %s" (.getName f) (class t) (.getMessage t)))
(.printStackTrace t))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment