Skip to content

Instantly share code, notes, and snippets.

@xsc xsc/user.clj
Created May 11, 2018

Embed
What would you like to do?
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
You can’t perform that action at this time.