Transforming rewrite-clj's Midje testcases to standard Clojure tests

user.clj

(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))))