Repository: ladderlife/autochrome
Branch: master
Commit: d454e4450658
Files: 19
Total size: 100.9 KB
Directory structure:
gitextract_90iweypm/
├── .gitignore
├── LICENSE
├── README.md
├── project.clj
└── src/
└── autochrome/
├── align.clj
├── annotation.clj
├── common.clj
├── components.clj
├── core.clj
├── diff.clj
├── difflog.clj
├── github.clj
├── page.clj
├── parse.clj
├── readme.clj
├── scope.clj
├── styles.clj
├── tree.clj
└── xref.clj
================================================
FILE CONTENTS
================================================
================================================
FILE: .gitignore
================================================
/target/*
/.idea/*
.nrepl-port
autochrome.iml
================================================
FILE: LICENSE
================================================
Eclipse Public License - v 1.0
THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC
LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM
CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT.
1. DEFINITIONS
"Contribution" means:
a) in the case of the initial Contributor, the initial code and documentation
distributed under this Agreement, and
b) in the case of each subsequent Contributor:
i) changes to the Program, and
ii) additions to the Program;
where such changes and/or additions to the Program originate from and are
distributed by that particular Contributor. A Contribution 'originates'
from a Contributor if it was added to the Program by such Contributor
itself or anyone acting on such Contributor's behalf. Contributions do not
include additions to the Program which: (i) are separate modules of
software distributed in conjunction with the Program under their own
license agreement, and (ii) are not derivative works of the Program.
"Contributor" means any person or entity that distributes the Program.
"Licensed Patents" mean patent claims licensable by a Contributor which are
necessarily infringed by the use or sale of its Contribution alone or when
combined with the Program.
"Program" means the Contributions distributed in accordance with this
Agreement.
"Recipient" means anyone who receives the Program under this Agreement,
including all Contributors.
2. GRANT OF RIGHTS
a) Subject to the terms of this Agreement, each Contributor hereby grants
Recipient a non-exclusive, worldwide, royalty-free copyright license to
reproduce, prepare derivative works of, publicly display, publicly
perform, distribute and sublicense the Contribution of such Contributor,
if any, and such derivative works, in source code and object code form.
b) Subject to the terms of this Agreement, each Contributor hereby grants
Recipient a non-exclusive, worldwide, royalty-free patent license under
Licensed Patents to make, use, sell, offer to sell, import and otherwise
transfer the Contribution of such Contributor, if any, in source code and
object code form. This patent license shall apply to the combination of
the Contribution and the Program if, at the time the Contribution is
added by the Contributor, such addition of the Contribution causes such
combination to be covered by the Licensed Patents. The patent license
shall not apply to any other combinations which include the Contribution.
No hardware per se is licensed hereunder.
c) Recipient understands that although each Contributor grants the licenses
to its Contributions set forth herein, no assurances are provided by any
Contributor that the Program does not infringe the patent or other
intellectual property rights of any other entity. Each Contributor
disclaims any liability to Recipient for claims brought by any other
entity based on infringement of intellectual property rights or
otherwise. As a condition to exercising the rights and licenses granted
hereunder, each Recipient hereby assumes sole responsibility to secure
any other intellectual property rights needed, if any. For example, if a
third party patent license is required to allow Recipient to distribute
the Program, it is Recipient's responsibility to acquire that license
before distributing the Program.
d) Each Contributor represents that to its knowledge it has sufficient
copyright rights in its Contribution, if any, to grant the copyright
license set forth in this Agreement.
3. REQUIREMENTS
A Contributor may choose to distribute the Program in object code form under
its own license agreement, provided that:
a) it complies with the terms and conditions of this Agreement; and
b) its license agreement:
i) effectively disclaims on behalf of all Contributors all warranties
and conditions, express and implied, including warranties or
conditions of title and non-infringement, and implied warranties or
conditions of merchantability and fitness for a particular purpose;
ii) effectively excludes on behalf of all Contributors all liability for
damages, including direct, indirect, special, incidental and
consequential damages, such as lost profits;
iii) states that any provisions which differ from this Agreement are
offered by that Contributor alone and not by any other party; and
iv) states that source code for the Program is available from such
Contributor, and informs licensees how to obtain it in a reasonable
manner on or through a medium customarily used for software exchange.
When the Program is made available in source code form:
a) it must be made available under this Agreement; and
b) a copy of this Agreement must be included with each copy of the Program.
Contributors may not remove or alter any copyright notices contained
within the Program.
Each Contributor must identify itself as the originator of its Contribution,
if
any, in a manner that reasonably allows subsequent Recipients to identify the
originator of the Contribution.
4. COMMERCIAL DISTRIBUTION
Commercial distributors of software may accept certain responsibilities with
respect to end users, business partners and the like. While this license is
intended to facilitate the commercial use of the Program, the Contributor who
includes the Program in a commercial product offering should do so in a manner
which does not create potential liability for other Contributors. Therefore,
if a Contributor includes the Program in a commercial product offering, such
Contributor ("Commercial Contributor") hereby agrees to defend and indemnify
every other Contributor ("Indemnified Contributor") against any losses,
damages and costs (collectively "Losses") arising from claims, lawsuits and
other legal actions brought by a third party against the Indemnified
Contributor to the extent caused by the acts or omissions of such Commercial
Contributor in connection with its distribution of the Program in a commercial
product offering. The obligations in this section do not apply to any claims
or Losses relating to any actual or alleged intellectual property
infringement. In order to qualify, an Indemnified Contributor must:
a) promptly notify the Commercial Contributor in writing of such claim, and
b) allow the Commercial Contributor to control, and cooperate with the
Commercial Contributor in, the defense and any related settlement
negotiations. The Indemnified Contributor may participate in any such claim at
its own expense.
For example, a Contributor might include the Program in a commercial product
offering, Product X. That Contributor is then a Commercial Contributor. If
that Commercial Contributor then makes performance claims, or offers
warranties related to Product X, those performance claims and warranties are
such Commercial Contributor's responsibility alone. Under this section, the
Commercial Contributor would have to defend claims against the other
Contributors related to those performance claims and warranties, and if a
court requires any other Contributor to pay any damages as a result, the
Commercial Contributor must pay those damages.
5. NO WARRANTY
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON AN
"AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR
IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF TITLE,
NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Each
Recipient is solely responsible for determining the appropriateness of using
and distributing the Program and assumes all risks associated with its
exercise of rights under this Agreement , including but not limited to the
risks and costs of program errors, compliance with applicable laws, damage to
or loss of data, programs or equipment, and unavailability or interruption of
operations.
6. DISCLAIMER OF LIABILITY
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY
CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION
LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE
EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY
OF SUCH DAMAGES.
7. GENERAL
If any provision of this Agreement is invalid or unenforceable under
applicable law, it shall not affect the validity or enforceability of the
remainder of the terms of this Agreement, and without further action by the
parties hereto, such provision shall be reformed to the minimum extent
necessary to make such provision valid and enforceable.
If Recipient institutes patent litigation against any entity (including a
cross-claim or counterclaim in a lawsuit) alleging that the Program itself
(excluding combinations of the Program with other software or hardware)
infringes such Recipient's patent(s), then such Recipient's rights granted
under Section 2(b) shall terminate as of the date such litigation is filed.
All Recipient's rights under this Agreement shall terminate if it fails to
comply with any of the material terms or conditions of this Agreement and does
not cure such failure in a reasonable period of time after becoming aware of
such noncompliance. If all Recipient's rights under this Agreement terminate,
Recipient agrees to cease use and distribution of the Program as soon as
reasonably practicable. However, Recipient's obligations under this Agreement
and any licenses granted by Recipient relating to the Program shall continue
and survive.
Everyone is permitted to copy and distribute copies of this Agreement, but in
order to avoid inconsistency the Agreement is copyrighted and may only be
modified in the following manner. The Agreement Steward reserves the right to
publish new versions (including revisions) of this Agreement from time to
time. No one other than the Agreement Steward has the right to modify this
Agreement. The Eclipse Foundation is the initial Agreement Steward. The
Eclipse Foundation may assign the responsibility to serve as the Agreement
Steward to a suitable separate entity. Each new version of the Agreement will
be given a distinguishing version number. The Program (including
Contributions) may always be distributed subject to the version of the
Agreement under which it was received. In addition, after a new version of the
Agreement is published, Contributor may elect to distribute the Program
(including its Contributions) under the new version. Except as expressly
stated in Sections 2(a) and 2(b) above, Recipient receives no rights or
licenses to the intellectual property of any Contributor under this Agreement,
whether expressly, by implication, estoppel or otherwise. All rights in the
Program not expressly granted under this Agreement are reserved.
This Agreement is governed by the laws of the State of New York and the
intellectual property laws of the United States of America. No party to this
Agreement will bring a legal action under this Agreement more than one year
after the cause of action arose. Each party waives its rights to a jury trial in
any resulting litigation.
================================================
FILE: README.md
================================================
# autochrome
Autochrome is a program for structurally diffing and highlighting clojure source code. It generates diffs as static HTML from
github pull requests or local git repos. For more information, some examples, and a description of how it works, please see
[the HTML readme](https://fazzone.github.io/autochrome.html)
(generated from [readme.clj](https://github.com/ladderlife/autochrome/blob/master/src/autochrome/readme.clj)).
## Usage
### From local git repo:
```
$ lein run --open --git-dir /path/to/repo <old-ref> [<new-ref>]
```
- `old-ref` and `new-ref` are just like the arguments to `git diff`
- `--open` tries to open the diff in a browser. With no arguments you get HTML on stdout.
- `-o <file>` also works.
### From github:
```
$ lein run <owner> <repo> <pr-number> -o diff.html # write a diff for a GitHub pull request
$ lein run --token user:123abc <owner> <repo> <pr-number> # use supplied auth token for github api
```
## License
Copyright © 2018 Ladder Financial, Inc.
Distributed under the Eclipse Public License either version 1.0 or (at
your option) any later version.
================================================
FILE: project.clj
================================================
(defproject autochrome "0.1.0-SNAPSHOT"
:description "FIXME: write description"
:url "http://example.com/FIXME"
:license {:name "Eclipse Public License"
:url "http://www.eclipse.org/legal/epl-v10.html"}
:dependencies [[org.clojure/clojure "1.8.0"]
[hiccup "1.0.5"]
[org.omcljs/om "1.0.0-beta1"]
[garden "1.3.3"]
[cheshire "5.8.0"]
[clj-http "3.7.0"]
[org.clojure/tools.cli "0.3.5"]
[com.climate/claypoole "1.1.4"]
;; explicit dependency on jaxb-api for java 9 compatibility
[javax.xml.bind/jaxb-api "2.3.0"]]
:main autochrome.core
:target-path "target/%s"
:profiles {:uberjar {:aot :all}})
================================================
FILE: src/autochrome/align.clj
================================================
(ns autochrome.align
(:require [autochrome.diff :as diff])
(:import [java.util IdentityHashMap Map]))
(defn get-diffs
[source-forms target-forms]
(let [prep (diff/diff-prep source-forms target-forms)
^IdentityHashMap hashes (:hashes prep)
^IdentityHashMap sizes (:sizes prep)
hash->source-form (zipmap (map #(.get hashes %) source-forms) source-forms)
^IdentityHashMap matched-forms (IdentityHashMap.)
unmatched? #(not (.containsKey matched-forms %))]
(doseq [tf target-forms]
(when-let [sf (hash->source-form (.get hashes tf))]
(.put matched-forms tf :matched)
(.put matched-forms sf :matched)))
(loop [diffs []
[the-source & sources] (filterv unmatched? source-forms)
targets (filterv unmatched? target-forms)]
(cond
(and (nil? the-source) (empty? targets))
diffs
(nil? the-source)
(concat diffs
(for [t targets]
[nil t (doto (IdentityHashMap.) (.put t :added))]))
(empty? targets)
(concat diffs
(for [s (cons the-source sources)]
[s nil (doto (IdentityHashMap.) (.put s :deleted))]))
:else
(let [goal (diff/dforms the-source (cons nil targets) hashes sizes)
the-target (diff/get-target goal)]
(.put matched-forms the-target :matched)
(recur
(conj diffs [the-source the-target (diff/diffstate->annotations goal)])
sources
(filter unmatched? targets)))))))
================================================
FILE: src/autochrome/annotation.clj
================================================
(ns autochrome.annotation
(:require [autochrome.common :as clj-common]
[autochrome.scope :as scope]
[autochrome.tree :as tree]
[autochrome.xref :as xref])
(:import [java.util IdentityHashMap]))
(defn attach
[{:keys [type text delim wscontents] :as form} ann]
(let [a (.get ann form)
rec (cond
(or (= type :coll)
(= type :reader-conditional)
(= type :reader-conditional-splicing)
(clj-common/decoration? form))
(assoc form :wscontents (mapv #(attach % ann) wscontents))
(= type :quote)
(assoc form :val (list (attach (first (:val form)) ann)))
(= type :lambda)
(assoc form :text (attach text ann))
:else form)]
(cond-> rec
a (assoc :annotation a))))
(defn annotated?
[form ann]
(or
(.get ann form)
(when-let [children (tree/->children form)]
(loop [[c & cs] children]
(when c
(if (annotated? c ann)
true
(recur cs)))))))
(defn syntax-highlighting
[form]
(let [ann (IdentityHashMap.)]
(scope/execute-writer
(scope/walk-with-scope
form
(fn [c f]
(if-let [sym (scope/form->real-symbol c f)]
(.put ann f
(let [locally-bound (get (:scope c) sym)
qual (scope/qualify-symbol c f)]
(cond
(get (:scope c) sym)
:local
(and (nil? qual) (xref/javadoc-link (:text f)))
:java-class
(and (symbol? qual) (= "clojure.core" (namespace qual)))
:core
:else sym)))
(when (some-> f :text (.startsWith "."))
(.put ann f :java-class))))
scope/default-context))
ann))
================================================
FILE: src/autochrome/common.clj
================================================
(ns autochrome.common)
(def ^:const special-forms
["def" "do" "loop" "if" "new" "fn" "try" "catch" "throw" "finally"
"recur" "quote" "set!"])
(def special-form? (set special-forms))
(def open->closed
{\( \)
\[ \]
\{ \}
"#{" \}})
(def closed->open
{\) \(
\] \[
\} \{})
(defn decoration?
[{:keys [type]}]
(or (= type :deref)
(= type :syntax-quote)
(= type :unquote)
(= type :unquote-splicing)
(= type :data-reader)
(= type :meta)))
(defn ->decorator
[{:keys [type] :as arg}]
(case type
:deref "@"
:syntax-quote "`"
:unquote "~"
:unquote-splicing "~@"
(throw (ex-info "what" {:arg arg}))))
(def core-scope
(delay
(->> (ns-publics 'clojure.core)
(keys)
(map (fn [s] [s (symbol (name 'clojure.core) (name s))]))
;; def is a special form
(into
(->> (mapv symbol special-forms)
(map (fn [s] [s (symbol (name 'clojure.core) (name s))]))
(into {}))))))
(defn clojure-core-scope
[]
@core-scope)
================================================
FILE: src/autochrome/components.clj
================================================
(ns autochrome.components
(:require [autochrome.common :as clj-common :refer [special-form? open->closed]]
[autochrome.parse :as parse]
[autochrome.xref :as xref]
[om.dom :as dom :refer [span]]))
(defmacro defcomponent
[name & [[props children] & body]]
`(defn ~name [& args#]
(let [[~props & ~children] args#]
~@body)))
(defn xref-clojure-core
[text]
(let [macro? (or (some-> text symbol resolve meta :macro)
(special-form? text))]
(dom/a {:href (xref/clojure-core-link text)}
(span {:className (if macro? "macro clojure-core" "clojure-core")}
text))))
(defn xref-java
[text]
(let [link (xref/javadoc-link text)]
(cond->> (dom/span {:className "java-class"} text)
link (dom/a {:href link}))))
(defcomponent symbol-component
[{a :annotation :keys [text xref] :as the-form} _]
;; not much to do here now
(if xref
(dom/a {:href xref} (symbol-component (dissoc the-form :xref)))
(cond
(nil? a) text
;; do something more interesting with locals?
(= :local a) text
(= :java-class a) (xref-java text)
(= :core a) (xref-clojure-core text)
(= :broken a) (span {:className "unparsed"} text)
(= :shead a) (span {:className "shead"} text)
(= :thead a) (span {:className "thead"} text)
(keyword? a) (span {:className (str (name a))} text)
(namespace a) (dom/span {} (dom/span {:className "ns-ref"} (namespace a))
"/" (dom/span {:className "var-ref"} (name a)))
(symbol? a) (dom/span {:className "var-ref"} text)
:else (throw (ex-info "unrecognized annotation" the-form)))))
(defn meta-class
[mf]
(let [[c & more] (:contents mf)]
(cond
more "meta"
(= (:type c) :symbol)
(if (some-> c :text first Character/isUpperCase)
"java-class"
"var-ref")
(= (:type c) :keyword) "meta-keyword"
:else "meta")))
(defcomponent form
[{:keys [type text annotation] :as the-form} _]
(let [form-annotation? (contains? #{:added :deleted :shead :thead} annotation)
the-form (cond-> the-form form-annotation? (dissoc :annotation))
rendered
(case type
:newline (span "\n")
:ws (if (= :comment (:subtype the-form))
(span {:className "comment"} text)
text)
:symbol (symbol-component the-form)
:keyword (span {:className "keyword"} text)
:string (span {:className "string"} text)
:data-reader (span {:className "metadata"}
"#"
(:text the-form)
(mapv form (:wscontents the-form)))
:regex (span {} "#" (span {:className "string"} text))
:char-literal (span {:className "string"} text)
:quote (span {} "'" (form (first (:val the-form))))
:var-quote (span {:className "var-ref"} "#'" text)
(:deref :syntax-quote :unquote :unquote-splicing)
(span {} (clj-common/->decorator the-form)
(mapv form (:wscontents the-form)))
:hash-under
(span {:className "comment"}
(parse/render-dup the-form))
:coll
(let [left (str (:delim the-form))
right (str (open->closed (:delim the-form)))
inner (mapv form (:wscontents the-form))]
(cond
(= :parens-added annotation)
(span {} (span {:className "added"} left)
(conj inner (span {:className "added"} right)))
(= :parens-deleted annotation)
(span {} (span {:className "deleted"} left)
(conj inner (span {:className "deleted"} right)))
:else (span {} left (conj inner right))))
:lambda
(span {} "#" (form (:text the-form)))
:reader-conditional
(span {} "#?(" (mapv form (:wscontents the-form)) ")")
:reader-conditional-splicing
(span {} "#?@(" (mapv form (:wscontents the-form)) ")")
:meta
(span {:className (meta-class the-form)}
"^" (mapv form (:wscontents the-form)))
(span {:className "unparsed"} (pr-str the-form)))]
(cond->> rendered
form-annotation? (dom/span {:className (str (name annotation))}))))
(defn line-numbers
[{:keys [lines start-line linkbase] :as the-form :or {linkbase "hahaha"}}]
(for [i (range start-line (+ start-line lines))]
(cond->> (dom/div {} (str i))
linkbase (dom/a {:href (str linkbase i)}))))
(defcomponent code
[{:keys [lines start-line linkbase things annotation id] :as the-form} children]
(dom/div
{:className "code-card"
:id id}
(dom/div {:className "code-card-heading"}
(first children)
(dom/div {:className "code-card-heading-extra"} (rest children)))
(dom/div {:className "container"}
(dom/pre {:className "gutter"}
(dom/code {:className "punctuation"} (line-numbers the-form)))
(dom/div {:style {:width "1px"}})
(dom/pre
{:className
(cond-> "source"
annotation (str " " (name annotation)))}
(for [th things]
(if (map? th) (form th) th))))))
(defcomponent top-level-comment
[{:keys [lines start-line text] :as the-form} _]
(dom/div
{:className "code-card top-comment"}
(dom/div {:className "container"}
(dom/pre {:className "gutter"}
(dom/code
{:className "punctuation"}
(line-numbers the-form)))
(dom/div {:style {:width "1px"}})
(dom/pre {:className "source"}
(dom/span {:className "comment"} text)))))
(defcomponent panes
[props children]
(let [[left right] children]
(dom/div
{:style {:display "flex"
:flex-direction "row"}}
(dom/div {:className "diffpane"} left)
(dom/div {:className "diffpane"} right))))
(defcomponent root
[_ children]
(dom/div
{:style {:display "flex"
:flex-direction "column"}}
children))
(defn heading
[text]
(dom/div {:className "filename-heading"} text))
(defn spacer
[]
(dom/div {:className "spacer"}))
================================================
FILE: src/autochrome/core.clj
================================================
(ns autochrome.core
(:require [autochrome.diff :as diff]
[autochrome.github :as github]
[autochrome.page :as page]
[clojure.java.io :as io]
[clojure.tools.cli :as cli])
(:import [java.awt Desktop]
[java.io File])
(:gen-class))
(def cli-options
[[nil "--open" "If set, write HTML to a temp file and try to open it in a browser"]
["-t" "--token TOKEN" "github api bearer auth token e.g. username:123abcdef"]
["-o" "--output FILE" "output filename"]
[nil "--clojure-only" "only show clojure diffs"]
[nil "--git-dir PATH" "path to the git repo"]])
(defn do-main
[& args]
(let [{:keys [options arguments]} (cli/parse-opts args cli-options)
[a b c] arguments
the-page (binding [github/*auth-token* (:token options)
page/*clojure-only* (:clojure-only options)
github/*git-dir* (or (:git-dir options) ".")]
(cond
c (page/pull-request-diff a b (Integer/parseInt c))
b (page/local-diff a b)
a (page/local-diff-work-tree a)))
output-file (if (:output options)
(io/file (:output options))
(File/createTempFile "diff" ".html"))]
(binding [*out* *err*] (println 'processed @diff/nprocessed 'states))
(if-not the-page
(println "expected 2 or 3 args [treeA treeB] or [owner repo pr-id] ")
(spit output-file the-page))
(if (and (:open options) (Desktop/isDesktopSupported))
(.browse (Desktop/getDesktop)
(.toURI output-file))
(when-not (:output options)
(io/copy output-file *out*)))))
(defn -main
[& args]
(apply do-main args)
(shutdown-agents))
================================================
FILE: src/autochrome/diff.clj
================================================
(ns autochrome.diff
(:require [autochrome.tree :as tree])
(:import [clojure.lang Util]
[java.util HashMap PriorityQueue IdentityHashMap]))
(set! *warn-on-reflection* true)
(defn compare-vectors-by-identity
[a b]
(let [na (count a)]
(if-not (= na (count b))
false
(loop [i 0]
(if (= i na)
true
(when (identical? (nth a i) (nth b i))
(recur (inc i))))))))
(deftype DiffContext [prevsources prevtargets]
;; `prevsources` and `prevtargets` are basically two independent stacks
Object
(hashCode [this]
(Util/hashCombine
(System/identityHashCode (peek prevsources))
(System/identityHashCode (peek prevtargets))))
(equals ^boolean [this that-obj]
(let [^DiffContext that that-obj]
(boolean
(and (compare-vectors-by-identity (.-prevsources this) (.-prevsources that))
(compare-vectors-by-identity (.-prevtargets this) (.-prevtargets that)))))))
(deftype DiffState [cost source target context changes origtarget]
;; `source` and `target` are seqs, and we are diffing their heads
;; `cost` is the sum of the size of all the added or deleted nodes in this diff
;; `context` is how we know 'where we are' in the source & target structures
;; without context, we can't tell when we're finished, since all states
;; where source=target=nil would be indistinguishable.
;; `changes` is a vector of [form change] where change is :added, :deleted etc
;; `origtarget` is the whole target form we are diffing against
Object
(hashCode [this]
(unchecked-add-int
(.hashCode context)
(unchecked-add-int (System/identityHashCode source)
(System/identityHashCode target))))
(equals [this that-obj]
(let [^DiffState that that-obj]
(and (identical? (.-source this) (.-source that))
(identical? (.-target this) (.-target that))
(.equals (.-context this) (.-context that)))))
Comparable
(compareTo [this that-obj]
(let [^DiffState that that-obj]
(- (.-cost this) (.-cost that)))))
(defn get-target
[^DiffState ds]
(.-origtarget ds))
;; for difflog
(def explored-states (atom []))
(def state-info (atom {}))
(def nprocessed (atom 0))
(defn diff-prep
[sources targets]
(let [hashes (IdentityHashMap.)
sizes (IdentityHashMap.)]
(doseq [f (concat sources targets)]
(tree/put-hashes hashes f)
(tree/put-sizes sizes f))
{:hashes hashes :sizes sizes}))
(defn dforms
([source targets]
(let [{:keys [hashes sizes]} (diff-prep [source] targets)]
(dforms source targets hashes sizes)))
([source targets ^IdentityHashMap hashes ^IdentityHashMap sizes]
(let [real-cost (HashMap.)
pq (PriorityQueue.)
explore (fn [ncost ^DiffState predstate nsource ntarget nctx changes]
(let [ds (DiffState. ncost nsource ntarget nctx changes (.-origtarget predstate))
prev-cost (.get real-cost ds)]
(swap! state-info update (System/identityHashCode ds) assoc :pred (System/identityHashCode predstate))
(when (and (or (nil? prev-cost) (< ncost prev-cost)))
(.put real-cost ds ncost)
(.offer pq ds))))]
(reset! explored-states [])
(reset! state-info {})
(doseq [t targets
:let [start-state (DiffState. 0 (list source) (list t) (DiffContext. [] []) [] t)]]
(.offer pq start-state)
(.put real-cost start-state 0))
(loop []
(when-let [^DiffState c (.poll pq)]
(swap! nprocessed inc)
(swap! explored-states conj c)
(let [[shead & smore :as sforms] (.-source c)
[thead & tmore :as tforms] (.-target c)
cost (.get real-cost c)
^DiffContext context (.-context c)
prevsources (.-prevsources context)
prevtargets (.-prevtargets context)]
(swap! state-info update (System/identityHashCode c) update :attrib conj :popped)
(if (and (nil? shead) (nil? thead) (empty? prevsources) (empty? prevtargets))
c
(let [ssize (.get sizes shead)
tsize (.get sizes thead)]
;; if we can match subtrees, don't bother doing anything else
(if (and shead thead (= (.get hashes shead) (.get hashes thead)))
(explore cost c smore tmore context (.-changes c))
(do
(if shead
;; addition/deletion costs an extra point so that we prefer removing entire lists
(explore (inc (+ cost ssize)) c smore tforms context (conj (.-changes c) [shead :deleted]))
;; if we are at the end of the source seq, pop back out if we can
(when (not= 0 (count prevsources))
(explore cost c (peek prevsources) tforms
(DiffContext. (pop prevsources) prevtargets) (.-changes c))))
(if thead
;; addition
(explore (inc (+ cost tsize)) c sforms tmore context (conj (.-changes c) [thead :added]))
;; pop back out
(when (not= 0 (count prevtargets))
(explore cost c sforms (peek prevtargets)
(DiffContext. prevsources (pop prevtargets)) (.-changes c))))
;; going into matching collections is not costless, again to prefer deleting entire lists
(when (and (tree/branch? shead) (tree/branch? thead) (= (:delim shead) (:delim thead)))
(explore (inc cost) c (tree/->children shead) (tree/->children thead)
(DiffContext. (conj prevsources smore) (conj prevtargets tmore)) (.-changes c)))
;; going into source node corresponds to stripping a pair of parens
(when (tree/branch? shead)
(explore (+ 2 cost) c (tree/->children shead) tforms
(DiffContext. (conj prevsources smore) prevtargets) (conj (.-changes c) [shead :parens-deleted])))
;; going into target node is wrapping with a new set of parens
(when (and (tree/branch? thead))
(explore (+ 2 cost) c sforms (tree/->children thead)
(DiffContext. prevsources (conj prevtargets tmore)) (conj (.-changes c) [thead :parens-added])))))
(recur)))))))))
(defn diffstate->annotations
[^DiffState dst]
(let [ann (IdentityHashMap.)]
(doseq [[ptr a] (.-changes dst)]
(.put ann ptr a))
ann))
(defn diff-forms
[source target]
(diffstate->annotations (dforms source target)))
================================================
FILE: src/autochrome/difflog.clj
================================================
(ns autochrome.difflog
(:require [autochrome.annotation :as ann]
[autochrome.components :as comp]
[autochrome.diff :as diff]
[autochrome.page :as page]
[autochrome.parse :as parse]
[om.dom :as dom]))
(defn diff2
[ann a b]
(comp/panes
{}
(when a
(page/render-top-level-form
(ann/attach a (doto (ann/syntax-highlighting a) (.putAll ann)))))
(when b
(page/render-top-level-form
(ann/attach b (doto (ann/syntax-highlighting b) (.putAll ann)))))))
(defn diff-log
[aroot broots]
(let [goalstate (diff/dforms aroot broots)
maxdigits (count (str (count @diff/explored-states)))]
(for [index (range (count @diff/explored-states))
:let [c (nth @diff/explored-states index)
idhc (System/identityHashCode c)
info (get @diff/state-info idhc)]]
(let [shead (first (.-source c))
thead (first (.-target c))]
(dom/div
{:id (str idhc)}
(comp/heading
(dom/span
{:style {:font-size "16px"}}
(str
(format (str "#%0" maxdigits "d ") index)
(if (identical? c goalstate) "goal! " "")
; "(" (string/join " " (map name (:attrib info))) ")"
" -" (count (filter (comp #{:deleted :parens-deleted} second) (.-changes c)))
",+" (count (filter (comp #{:added :parens-added} second) (.-changes c)))
" cost " (.-cost c)
;; "/" (- (.-cost c) (max (.-sremain c) (.-tremain c)))
; " remain " (.-sremain c)
;"/" (.-tremain c)
(if (nil? shead) " (nil S)" "")
(if (nil? thead) " (nil T)" ""))
#_(dom/span {} " (" (Integer/toHexString idhc) " from "
(dom/a {:href (str "#" (:pred info))} (some-> (:pred info) Integer/toHexString))
")")))
(diff2
(doto (diff/diffstate->annotations c)
(.put shead :shead)
(.put thead :thead))
aroot
(.-origtarget c))
#_(comp/spacer))))))
(defn write-difflog
[title astr bstrs]
(let [a (parse/parse-one astr)
bs (map parse/parse-one bstrs)]
(spit (str title ".html")
(page/page
title
(comp/root {}
(diff-log a bs))))))
(comment
(write-difflog
"difflog2"
"#:: {:foo :bar}"
["#::some-ns{:foo :bar}"]))
================================================
FILE: src/autochrome/github.clj
================================================
(ns autochrome.github
(:require [clj-http.client :as http]
[clojure.java.io :as io]
[clojure.java.shell :as sh]
[clojure.string :as string]))
(def ^:dynamic *auth-token* nil)
(defn pr-request-params
[owner repo num]
(let [url (format "https://api.github.com/repos/%s/%s/pulls/%s" owner repo num)]
(cond-> {:method :get :url url :content-type :json}
*auth-token* (assoc :basic-auth *auth-token*))))
(defn pr-diffinfo
[owner repo num]
(let [params (pr-request-params owner repo num)]
{:info (try (-> params
(assoc :as :json)
http/request :body)
(catch Exception e
(throw (Exception. (str "getting info params=" (pr-str params))))))
:diff (try (-> params
(assoc :accept "application/vnd.github.VERSION.diff")
http/request :body)
(catch Exception e
(throw (Exception. "getting diff"))))}))
(defn parse-hunk-spec
[hunk]
(zipmap
[:old-start :old-lines :new-start :new-lines]
(map read-string ; fine to read the numbers we just regex'd out
(rest (re-find #"@@ -(\d+),(\d+) \+(\d+),(\d+) @@" hunk)))))
(defn strip-prefix
[s pre]
(if-not (.startsWith s pre)
s
(.substring s (count pre))))
(defn parse-diff
[diff]
(let [lines (string/split-lines diff)
put-line (fn [c k l] (update c k conj (.substring l 1)))
line->path #(-> (second (.split % " "))
(strip-prefix "a/")
(strip-prefix "b/"))
hunks (volatile! (transient []))
filechanges (volatile! (transient []))
default-ctx {:new [] :old [] :start 0}]
(loop [context default-ctx
line-index 0]
(let [^String line (get lines line-index)]
(if-not line
{:hunks (persistent! (vswap! hunks conj! context))
:filechanges
(persistent!
(vswap! filechanges conj!
(assoc context :raw
(subvec lines (:start context) line-index))))}
(cond
(.startsWith line "diff --git")
(do (when (:hunk context)
(vswap! hunks conj! context)
(vswap! filechanges conj!
(assoc context :raw
(subvec lines (:start context) line-index))))
(recur (assoc default-ctx :start line-index) (inc line-index)))
(.startsWith line "---")
(recur (assoc context :old-path (line->path line)) (inc line-index))
(.startsWith line "+++")
(recur (assoc context :new-path (line->path line)) (inc line-index))
(.startsWith line "@@")
(do (when (:hunk context)
(vswap! hunks conj! context))
(recur
(merge context {:new [] :old [] :hunk (parse-hunk-spec line)})
(inc line-index)))
(.startsWith line "+")
(recur (put-line context :new line) (inc line-index))
(.startsWith line "-")
(recur (put-line context :old line) (inc line-index))
:else
(if-let [{:keys [old-lines new-lines]} (:hunk context)]
(let [nnew (count (:new context))
nold (count (:old context))]
(if (and (= nnew new-lines) (= nold old-lines))
(do (vswap! hunks conj! context)
(recur (dissoc context :hunk) (inc line-index)))
(recur (-> context
(put-line :new line)
(put-line :old line))
(inc line-index))))
(recur context (inc line-index)))))))))
;; need to apply patches in reverse because I don't know how to get the
;; old text to diff from using the github api
(defn reverse-apply-patches
[new-text patches]
(if-not new-text
(string/join "\n" (conj (mapcat :old patches) ""))
(let [lines (.split new-text "\n")
line->patch (into {} (map (juxt (comp :new-start :hunk) identity) patches))
sb (StringBuilder.)]
(loop [idx 0]
(if-not (< idx (count lines))
(.toString sb)
(let [linenum (inc idx)]
(if-let [{:keys [hunk] :as patch} (line->patch linenum)]
(do
(doseq [line (:old patch)]
(.append sb line)
(.append sb "\n"))
(recur (dec (+ (:new-start hunk) (:new-lines hunk)))))
(do (.append sb (nth lines idx))
(.append sb "\n")
(recur (inc idx))))))))))
(defn slurp-blob-from-github
[owner repo tree path]
(let [url (format "https://raw.githubusercontent.com/%s/%s/%s/%s" owner repo tree path)]
(try
(:body
(http/request
(cond->
{:method :get
:url url
:content-type :json
:accept "application/vnd.github.VERSION.raw"}
*auth-token* (assoc :basic-auth *auth-token*))))
(catch Exception e
(throw (Exception. (str "slurping " (pr-str url)) e))))))
;; local git stuff
(def ^:dynamic *git-dir* ".")
(defn ls-tree
[rev]
(reduce
(fn [m line]
(let [sp (.split line "\\s")
;; [mode type sha path]
sha (aget sp 2)
path (aget sp 3)]
(assoc m path sha)))
{}
(-> (sh/sh "git" "ls-tree" "-r" rev :dir *git-dir*)
:out
(.split "\n"))))
(defn ->changed-files
[rawdiff slurp-new-blob-fn]
(let [{:keys [hunks filechanges]} (parse-diff rawdiff)
new-path->text
(into {}
(for [new-path (set (map :new-path hunks))]
[new-path (future (slurp-new-blob-fn new-path))]))
new-path->rawdiff (group-by :new-path filechanges)
old-path->rawdiff (group-by :old-path filechanges)]
(concat
(for [[new-path patches] (group-by :new-path hunks)
:when (not= "/dev/null" new-path)]
(let [new-path (:new-path (first patches))
new-text (deref (new-path->text new-path))
old-path (:old-path (first patches))
old-text (reverse-apply-patches new-text patches)]
(cond-> {:new-path new-path :new-text new-text
:rawdiff (-> new-path new-path->rawdiff first :raw)}
old-path (assoc :old-path old-path)
old-text (assoc :old-text old-text))))
(for [[old-path patches] (->> hunks
(filter #(= "/dev/null" (:new-path %)))
(group-by :old-path))]
{:old-path old-path
:old-text (string/join "\n" (conj (mapcat :old patches) ""))
:new-path "/dev/null"
:new-text ""
:rawdiff (-> old-path old-path->rawdiff first :raw)}))))
(defn pull-request-diff
[owner repo num]
(let [{:keys [diff info]} (pr-diffinfo owner repo num)
src (-> info :head :repo)]
(->changed-files
diff
#(slurp-blob-from-github (-> src :owner :login) (:name src) (-> info :head :sha) %))))
(defn slurp-blob-from-local-git
[sha]
(let [result (sh/sh "git" "cat-file" "blob" sha :dir *git-dir*)]
(when (= 0 (:exit result))
(:out result))))
(defn local-diff
[oldref newref]
(let [new-tree (ls-tree newref)
rawdiff (:out (sh/sh "git" "diff" oldref newref :dir *git-dir*))]
(->changed-files
rawdiff
#(when-let [sha (get new-tree %)]
(slurp-blob-from-local-git sha)))))
(defn local-diff-work-tree
[oldref]
(let [rawdiff (:out (sh/sh "git" "diff" oldref :dir *git-dir*))
basedir (io/file *git-dir*)]
(->changed-files rawdiff #(slurp (io/file basedir %)))))
================================================
FILE: src/autochrome/page.clj
================================================
(ns autochrome.page
(:require [autochrome.align :as align]
[autochrome.annotation :as annotation]
[autochrome.common :as clj-common]
[autochrome.components :as comp]
[autochrome.github :as github]
[autochrome.parse :as parse]
[autochrome.styles :as styles]
[com.climate.claypoole :as cp]
[hiccup.page :as hp]
[om.dom :as dom])
(:import [java.security MessageDigest]
[javax.xml.bind DatatypeConverter]))
(defn clojure-file?
[s]
(and s
(or (.endsWith s ".clj")
(.endsWith s ".cljc")
(.endsWith s ".cljs"))))
(defn remove-react-stuff
"no need for this until we have a client-side..."
[html]
(-> html
(.replaceAll "<!--.*?-->" "")
(.replaceAll " data-reactid=\"[0-9]+\"" "")))
(defn page
[title root]
(hp/html5
[:head
[:style styles/styles]
[:title (str title)]]
[:body (remove-react-stuff (dom/render-to-str root))]))
(defn unnest
[form]
(let [acc (volatile! (transient []))
sb (StringBuilder.)]
(letfn [(emit [thing]
(if (map? thing)
(do (vswap! acc conj! (.toString sb))
(.setLength sb 0)
(vswap! acc conj! thing))
(.append sb thing)))
(go [{:keys [type text delim wscontents] :as form}]
(cond
(and (= :coll type) (nil? (:annotation form)))
(do (emit delim)
(run! go wscontents)
(emit (clj-common/open->closed delim)))
(= :comment (:subtype form))
(emit form)
(= :ws type) (emit (:text form))
:else (emit form)))]
(go form)
(persistent! (conj! @acc (.toString sb))))))
(defn md5sum
[s]
(-> (MessageDigest/getInstance "MD5")
(.digest (.getBytes s))
;; https://stackoverflow.com/a/25758008
DatatypeConverter/printHexBinary
(.toLowerCase)))
(defn render-top-level-form
[form]
(comp/code (assoc form :things (unnest form))))
(defn diff-pane
[linkbase ann contents]
(for [f contents]
(-> (annotation/attach f (doto (annotation/syntax-highlighting f) (.putAll ann)))
(assoc :linkbase linkbase)
render-top-level-form)))
(defn two-file-diff
[linkbase old new]
(->> (align/get-diffs (:contents (:root old)) (:contents (:root new)))
(sort-by
(fn [[s t _]]
(or (:start-line t) (:start-line s))))
(map
(fn [[s t ann]]
(comp/panes
{}
(some->> s list (diff-pane (str linkbase (md5sum (:path old)) "L") ann))
(some->> t list (diff-pane (str linkbase (md5sum (:path new)) "R") ann)))))
(interpose (comp/spacer))))
(defn delete-everything
[root]
(assoc root :contents (map #(assoc % :annotation :deleted) (:contents root))))
;; don't restrict width to 50% when there is no other file to display
(defn one-file-diff
[linkbase path lr root]
(comp/root {} (diff-pane (str linkbase (md5sum path) lr) {} (:contents root))))
(defn patch-heading
[{:keys [old-path new-path]}]
(comp/heading
(cond
(= old-path "/dev/null") (str new-path " (new file)")
(= new-path "/dev/null") (str old-path " (deleted)")
(not= old-path new-path) (str new-path " -> " new-path)
:else new-path)))
(defn clojure-diff
[linkbase {:keys [old-path old-text new-path new-text]}]
(cond
(= old-path "/dev/null")
(one-file-diff linkbase new-path "R" (parse/parse new-text))
(= new-path "/dev/null")
(one-file-diff linkbase old-path "L"
(-> old-text parse/parse delete-everything))
:else
(let [the-diff
(two-file-diff
linkbase
{:path old-path :root (parse/parse old-text)}
{:path new-path :root (parse/parse new-text)})]
(if-not (seq the-diff)
(dom/span {:className "comment"} ";; no code changes")
the-diff))))
(defn raw-diff
[linkbase {:keys [rawdiff]}]
(->> (for [line (drop 4 rawdiff)]
(cond->> (.substring line 1)
(.startsWith line "+") (dom/span {:className "added"})
(.startsWith line "-") (dom/span {:className "deleted"})))
(interpose "\n")
(dom/pre {})))
(def ^:dynamic *clojure-only* false)
(defn diff-page
[linkbase title changed-files]
(println (count changed-files) "changed files")
(->> changed-files
(cp/upmap
(cp/threadpool (cp/ncpus))
(fn [{:keys [old-path new-path] :as patch}]
(let [file-diff
(if (or (clojure-file? new-path)
(and (= "/dev/null" new-path)
(clojure-file? old-path)))
(clojure-diff linkbase patch)
(when-not *clojure-only*
(raw-diff linkbase patch)))]
(when file-diff
[(patch-heading patch) file-diff (comp/spacer) (comp/spacer)]))))
(apply concat)
(comp/root {})
(page title)))
(defn github-pr-diff-linkbase
[owner repo num]
(format "https://github.com/%s/%s/pull/%s/files#diff-" owner repo num))
;; these return the html as string
(defn pull-request-diff
[owner repo num]
(diff-page
(github-pr-diff-linkbase owner repo num)
(str owner "/" repo " #" num)
(github/pull-request-diff owner repo num)))
(defn local-diff
[a b]
(diff-page
"local"
(str a "..." b)
(github/local-diff a b)))
(defn local-diff-work-tree
[a]
(diff-page
"local"
(str a "... current")
(github/local-diff-work-tree a)))
================================================
FILE: src/autochrome/parse.clj
================================================
(ns autochrome.parse
(:require [autochrome.common :refer [open->closed closed->open]]
[clojure.java.io :as io]
[clojure.string :as string]))
(defn ns->source-string
[ns]
(when-let [path (some-> ns ns-publics first val meta :file)]
(-> path io/resource slurp)))
(defn clj-whitespace
[c]
(case c
;; (\, \space \newline \tab)
(\, \space \tab) true
false))
(defn clj-special
[c]
(case c
(\( \) \{ \} \[ \] \, \space \newline \tab \") true
false))
(defn whitespace-string
[{:keys [^String buf pos]}]
(loop [idx pos]
(if (and (< idx (.length buf)) (clj-whitespace (.charAt buf idx)))
(recur (inc idx))
(.substring ^String buf pos idx))))
(defn symbol-string
[{:keys [^String buf pos]}]
(loop [idx pos]
(if (and (< idx (.length buf)) (not (clj-special (.charAt buf idx))))
(recur (inc idx))
(.substring ^String buf pos idx))))
(defn count-newlines-in-string
[s]
(let [n (volatile! 0)]
(dotimes [i (.length s)]
(when (= \newline (.charAt s i))
(vswap! n inc)))
@n))
(def ^:dynamic *line-number* (atom 0))
(defn lex
[orig-ctx]
(loop [{:keys [^String buf pos] :as ctx} (transient orig-ctx)
tokens (transient [])]
(if (>= pos (.length buf))
(persistent! tokens)
(case (.charAt buf pos)
\newline
(recur (assoc! ctx :pos (inc pos))
(conj! tokens \newline))
(\, \space \tab)
(let [^String whitespace (whitespace-string ctx)]
(recur (assoc! ctx :pos (+ pos (.length whitespace)))
(conj! tokens {:type :ws :text whitespace})))
\# (let [nt (.charAt buf (inc pos))]
(if (= \_ nt)
(recur (assoc! ctx :pos (+ 2 pos)) (conj! tokens "#_"))
(recur (assoc! ctx :pos (inc pos))
(conj! tokens (.charAt buf pos)))))
(\( \) \{ \} \[ \] \` \~ \^ \')
(recur (assoc! ctx :pos (inc pos))
(conj! tokens (.charAt buf pos)))
\" (let [string-end (loop [i (inc pos)
escaped false]
(cond
(and (not escaped) (= \" (.charAt buf i)))
(inc i)
(= \\ (.charAt buf i))
(recur (inc i) (not escaped))
:else
(recur (inc i) false)))
text (.substring buf pos string-end)]
(recur (assoc! ctx :pos string-end)
(conj! tokens {:type :string :text text :nlines (count-newlines-in-string text)})))
\; (let [comment-end (loop [i pos]
(cond
(>= i (.length buf))
i
;; coalesce multiline comments
(= \newline (.charAt buf i))
(let [past-end? (>= (inc i) (.length buf))]
(if (and (not past-end?)
(= \; (.charAt buf (inc i))))
(recur (+ 2 i))
i))
:else (recur (inc i))))
comment-text (.substring buf pos comment-end)]
(recur (assoc! ctx :pos comment-end)
(conj! tokens {:type :ws
:subtype :comment
:nlines (count-newlines-in-string comment-text)
:text comment-text})))
\\ (let [literal-end (loop [i (+ 2 pos)]
(if (clj-special (.charAt buf i))
i
(recur (inc i))))]
(recur (assoc! ctx :pos literal-end)
(conj! tokens {:type :char-literal :text (.substring buf pos literal-end)})))
\@ (recur (assoc! ctx :pos (inc pos))
(conj! tokens (.charAt buf pos)))
\: (let [^String sym (symbol-string ctx)]
(recur (assoc! ctx :pos (+ pos (.length sym)))
(conj! tokens {:type :keyword :text sym})))
(let [^String sym (symbol-string ctx)]
(recur (assoc! ctx :pos (+ pos (.length sym)))
(conj! tokens {:type :symbol :text sym})))))))
(def ^:const clojure-core-ns (find-ns 'clojure.core))
(declare parse-list)
(declare -parse-one)
;; 'decoration' precedes one form eg deref, quote, data reader etc.
(defn parse-decoration
([base ts] (parse-decoration base ts []))
([base ts init]
;; collect leading whitespace
(loop [ws init
[t & more :as ts] ts]
(cond
(= :ws (:type t))
(recur (conj ws t) more)
(char? t)
(let [{:keys [val rest]} (-parse-one ts)]
{:val (-> (assoc base :wscontents (conj ws val))
(assoc :contents (conj init val)))
:rest rest})
(map? t)
{:val (-> (assoc base :wscontents (conj ws t))
(assoc :contents (conj init t)))
:rest more}))))
(defn collect-hash-unders
[ts]
(loop [n 0
hashes []
[t & more :as ts] ts]
(cond
(= t "#_") (recur (inc n) (conj hashes t) more)
(= :ws (:type t)) (recur n (conj hashes (:text t)) more)
:else {:hashes hashes :n n :rest ts })))
(defn next-n-forms
[n ts]
(loop [n n
forms []
ts ts]
(cond
(or (zero? n) (empty? ts)) {:forms forms :rest ts}
:else
(let [{:keys [val rest]} (-parse-one ts)]
(recur
(if (not= :ws (:type val)) (dec n) n)
(conj forms val) rest)))))
(defn ignore-whitespace
[ts]
(loop [ts ts]
(if-not (= :ws (:type (first ts)))
ts
(recur (next ts)))))
;; :contents needs to be a list, due to object identity shenanigans in DiffContext
(defn vec->list
[v]
(loop [head nil
idx (dec (count v))]
(if (< idx 0)
head
(recur (cons (nth v idx) head) (dec idx)))))
(defn nows
[forms]
(vec->list (filterv #(not= :ws (:type %)) forms)))
(defn -parse-one
[ts]
(when-let [t (first ts)]
(if-let [closing-delimiter (open->closed t)]
(parse-list closing-delimiter (next ts))
(case t
\#
(let [ts (next ts)
nt (first ts)]
;; dispatch
(case nt
;; \_ (-> (parse-one nt) :rest parse-one)
\( (let [{:keys [val rest]} (-parse-one ts)]
{:val {:type :lambda :text val} :rest rest})
\{ (assoc-in (-parse-one ts) [:val :delim] "#{")
\' (let [{:keys [val rest]} (-parse-one (next ts))]
{:val {:type :var-quote :text (:text val)} :rest rest})
;; reader conditional
{:type :symbol :text "?"}
(let [{:keys [val rest]} (-parse-one (ignore-whitespace (next ts)))]
{:val (assoc val :type :reader-conditional) :rest rest})
{:type :symbol :text "?@"}
(let [{:keys [val rest]} (-parse-one (ignore-whitespace (next ts)))]
{:val (assoc val :type :reader-conditional-splicing) :rest rest})
(case (:type nt)
:string
(let [{:keys [val rest]} (-parse-one ts)]
{:val {:type :regex :text (:text val)} :rest rest})
(:symbol :keyword)
(parse-decoration {:type :data-reader} (next ts) [nt])
(throw (ex-info "bad dispatch form" {:bad-token nt})))))
"#_"
(let [{:keys [n hashes rest]} (collect-hash-unders ts)
{:keys [forms rest]} (next-n-forms n rest)]
{:val {:type :hash-under
:hashes hashes
:wscontents forms
:contents (nows forms)}
:rest rest})
\^ (parse-decoration {:type :meta} (next ts))
\@ (parse-decoration {:type :deref} (next ts))
\~ (if (= \@ (second ts))
(parse-decoration {:type :unquote-splicing} (nnext ts))
(parse-decoration {:type :unquote} (next ts)))
\` (parse-decoration {:type :syntax-quote} (next ts))
;; quote has :val instead of :contents because most of the time
;; you don't want to recurse into quote forms
\' (let [{:keys [val rest]} (-parse-one (next ts))]
{:val {:type :quote :val (list val)} :rest rest})
\newline (do (swap! *line-number* inc)
{:val {:type :ws :text "\n"}
:rest (next ts)})
(do
(when-let [nlines (:nlines t)]
(swap! *line-number* + nlines))
{:val t :rest (next ts)})))))
(defn parse-list
[closer ots]
(loop [forms []
ts ots]
(if-let [t (first ts)]
(if-let [sub-closer (open->closed t)]
(let [{:keys [val rest]} (parse-list sub-closer (next ts))]
(recur (conj forms val) rest))
(if (= closer t)
{:val {:type :coll
:delim (closed->open closer)
:wscontents forms
:contents (nows forms)}
:rest (next ts)}
(let [{:keys [val rest]} (-parse-one ts)]
(recur (if (vector? val)
(into forms val)
(conj forms val))
rest))))
(let [msg {:msg "expecting closer" :closer closer :ts ts :forms forms}]
(println (pr-str msg))
#_(fipp.edn/pprint forms)
(throw (ex-info "expecting closer" {:closer closer :ts ts}))))))
(defn parse-many
[ts]
(binding [*line-number* (atom 1)]
(loop [forms []
ts ts]
(if (some? ts)
(let [start-line @*line-number*
{:keys [val rest]} (-parse-one ts)]
(recur
(cond
(vector? val) (into forms val)
(map? val) (conj forms (-> val
(assoc :start-line start-line)
(assoc :lines (inc (- @*line-number* start-line)))))
:else (conj forms val))
rest))
forms))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Public API
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn parse
[s]
{:pre [(string? s)]}
(let [wscontents (parse-many (lex {:pos 0 :buf s}))]
{:type :root
:wscontents wscontents
:contents (nows wscontents)}))
(defn parse-one
[s]
(-> s parse :contents first))
(declare render*)
(defn render-contents
[the-form ->cts]
(let [rendered (for [f (->cts the-form)] (render* f ->cts))]
(apply str (if (= :contents ->cts)
(interpose " " rendered)
rendered))))
(defn render*
[t ->cts]
(cond
(sequential? t) (apply str (for [f (->cts t)] (render* f ->cts)))
(string? t) t
:else
(case (:type t)
(:ws :symbol :string :comment :keyword) (:text t)
:data-reader (str "#" (:text t))
:regex (str "#" (:text t))
:char-literal (:text t)
:meta (apply str "^" (for [f (->cts t)] (render* f ->cts)))
:quote (str "'" (render* (:val t) ->cts))
:syntax-quote (apply str "`" (for [f (->cts t)] (render* f ->cts)))
:unquote (apply str "~" (for [f (->cts t)] (render* f ->cts)))
:deref (apply str "@" (for [f (->cts t)] (render* f ->cts)))
:var-quote (str "#'" (:text t))
:hash-under (str (string/join (:hashes t))
(render-contents t ->cts))
:coll
(str (:delim t)
(render-contents t ->cts)
(open->closed (:delim t)))
:lambda (str "#" (render* (:text t) ->cts))
:root (apply str
(for [f (->cts t)]
(render* f ->cts)))
(case t
(\` \~ \@) t
(pr-str t)))))
(defn render
[t]
(render* t :contents))
(defn render-dup
[t]
(render* t :wscontents))
================================================
FILE: src/autochrome/readme.clj
================================================
(ns autochrome.readme
(:refer-clojure :exclude [comment])
(:require [autochrome.annotation :as annotation]
[autochrome.components :as comp]
[autochrome.diff :as diff]
[autochrome.difflog :as difflog]
[autochrome.page :as page]
[autochrome.parse :as parse]
[autochrome.styles :as styles]
[garden.core :refer [css]]
[hiccup.page :as hp]
[om.dom :as dom]))
(def readme-styles
(css
[:body {:color "white"}]
[:p :.caption
{:font-family "sans-serif"
:text-align "left"
:font-size "18px"}]
[:.caption {:font-size "14px"}]
[:p {:text-indent "2em"}]
[:.diffpane {:width "unset"}]
[:.text {:font-family "sans-serif"}]
[:.textcontainer {:width "57%"
:font-size "18px"}]
[:.title {:font-size "32px"}]
[:.sectiontitle {:font-size "24px"
:text-decoration "underline"}]
[:.insetcontainer {:display "flex"
:justify-content "space-between"}]
[:.insetcenter {:display "flex"
:justify-content "center"}]
[:.logside {:width "50%"}]
[:.inset {:border "2px solid"
:border-color "#969896"
:padding "10px"
:display "flex"
;:margin "10px auto"
}]
[:.examplesection {:font-size "16px"
:width "70%"
:margin "auto"}]
[:.fixed {:font-family "monospace"
:background-color "#111"}]))
(def page-title "Autochrome - Structural diffs for Clojure source code")
(defn readme-page
[outfile root]
(spit outfile
(hp/html5
[:head
[:title page-title]
[:style styles/styles]
[:style readme-styles]]
[:body (page/remove-react-stuff (dom/render-to-str root))])))
(defn inset
[thing]
(dom/div {:className "insetcontainer"}
(dom/div {:className "inset"} thing)
(dom/div {:style {:width "100%"}})))
(defn inset-center
[thing]
(dom/div {:className "insetcenter"}
(dom/div {:className "inset"} thing)))
(defn loginset
[log & more]
(inset log)
(dom/div
{:style {:margin-bottom "40px"}
:className "insetcontainer"}
(dom/div
{:style [["min-width" "fit-content"]
["min-width" "-moz-fit-content"]]
:className "inset"}
log)
(dom/div {})
(dom/div {:className "logside"} more)))
(defn term
[& children]
(inset-center (dom/pre {} children)))
(defn diff2
[atext btext]
(let [aroot (parse/parse-one atext)
broot (parse/parse-one btext)]
(difflog/diff2 (diff/diff-forms aroot [broot]) aroot broot)))
(defn side-caption
[& body]
(dom/div {:style {:display "flex"
:height "100%"
:flex-direction "column"
:justify-content "center"}}
(dom/div {})
(dom/div {:className "caption"} body)))
(defn code-inset
[text]
(let [parsed (parse/parse-one text)]
(inset
(comp/code
(merge
parsed
{:linkbase "more hacks"
:things (-> parsed
(annotation/attach
(annotation/syntax-highlighting parsed))
page/unnest)})))))
(defn p
[& args]
(dom/p {} args))
(defn caption
[& args]
(dom/div {:className "caption"} args))
(defn section*
[props title & children]
(dom/div
props
(dom/div {:className "sectiontitle"} title)
children))
(defn section
[title & children]
(apply section* {} title children))
(def example1
["(defn example
[x]
(println \"hello!\")
{:more (inc x)
:less (dec x)})"
"(defn example
[x]
(-> {:more (inc x)
:less (dec x)}
(assoc :twice (+ x x))))"])
(def highlight-example
"(let [keyword :hello/world
name (name keyword)
[a b :as vec] (map inc [1 2 3])]
(str (namespace keyword) name))")
(def wrap-example
["{:a :really
:big :thing
:these :entries
:which :is
:were :removed
:very :annoying
:to :read}"
"(keys
(merge
{:a :really
:big :thing
:which :is
:very :annoying
:to :read}
{:more :stuff}))"])
(def ws-example
["(def Y(fn[f]((fn[x](x,x))
(fn[x](f(fn[y]((x,x),y)))))))"
"(def Y
(fn [f]
((fn [x] (x x))
(fn [x] (f (fn [y] ((x x) y)))))))"])
(defn comment
[text]
(dom/span {:className "comment"} text))
(defn fixed
[text]
(dom/span {:className "fixed"} text))
(defn gen-readme
[]
(readme-page
"readme.html"
(dom/div
{}
(dom/div {:className "filename-heading"}
(dom/div {:className "title"} page-title))
(dom/div
{:className "textcontainer" :style {:margin "auto"}}
(dom/div {:style {:margin-top "35px"}}
(inset-center (diff2 (first example1) (second example1))))
(dom/p
{}
(section
"Abstract"
(p (dom/a {:href "https://github.com/ladderlife/autochrome"} "Autochrome (repo here)")
" uses a full parse to highlight and structurally diff Clojure source code. "
"It aims to make the experience of reviewing Clojure code just as nice as writing it. "
"It takes the form of a command-line tool which generates diffs as static HTML: ")
(term
"$ lein run " (dom/i {} "owner") " " (dom/i {} "repo") " " (dom/i {} "num") " -o diff.html"
(comment " # write a diff for a github pull request")
"\n$ lein run --token user:123abc "(dom/i {} "owner") " " (dom/i {} "repo") " " (dom/i {} "num")
(comment " # use supplied auth token for github api")
"\n$ lein run --git-dir " (dom/i {} "/your/repo/ ") (dom/i {} "old-tree") " " (dom/i {} "new-tree")
(comment " # like git diff, using specified repo")
"\n$ lein run --open ..."
(comment " # try to open the diff in a browser"))
(p "If generated from GitHub, the line numbers in Clojure diffs link back to the PR. "
"Bold symbols link to documentation."))
(section
"Features"
(p (dom/ul {:className "text"}
(dom/li {:style {:margin-bottom "30px"}} "Scope-aware highlighting (no regular expressions):"
(code-inset highlight-example))
(dom/li {:style {:margin-bottom "30px"}} "Structural diff which can cope with wrapping/stripping parens:"
(inset (diff2 (first wrap-example) (second wrap-example))))
(dom/li {:style {:margin-bottom "30px"}} "Naturally, whitespace is ignored completely: (h/t "
(dom/a {:href "http://blog.klipse.tech/lambda/2016/08/07/pure-y-combinator-clojure.html"}
"@viebel") ")"
(inset (diff2 (first ws-example) (second ws-example)))))))
(section
"Misfeatures"
(p (dom/ul {:className "text"}
(dom/li {} "Symbols can only have one annotation. (diff color overwrites highlight)")
(dom/li {} "Terrible for viewing non-clojure diffs. ")
(dom/li {} "Difficult to port to ClojureScript. ")
(dom/li {} "Uses its own custom clojure parser.")
(dom/li {} "Occasionally gets strange ideas."))))
(section
"How it works"
(p "Structural diffing is something I always wanted for Clojure. "
"When I saw "
(dom/a {:href "http://thume.ca/2017/06/17/tree-diffing/"}
"Tristan Hume's article about tree diffing")
", I was inspired to give it a shot myself using the same A* pathfinding technique he described. "
"I ended up ditching A* for plain old Dijkstra's algorithm however - "
(dom/a {:href "#alignment"} "more on that later") ". "
"Either way, in order to frame tree diffing as a pathfinding problem, you need to extend the concepts "
"of location, cost, and adjacency to tree diffs. Location is clearly needed to know where you are, "
"but in addition locations need to be comparable, so you know not to bother when you already have a better "
"path to the same place. "
"Cost is what makes some paths preferred over others. For pathfinding on a road network, this would be "
"the total distance traveled along the roads used. "
"Adjacency is what states are reachable from a particular state. For roads you might say that intersections are "
"the nodes and adjacency means there is a road connecting them. "
"In autochrome:"
(dom/ul {:className "text"}
(dom/li {} "Location is a pair of pointers into the source and target lists, "
"plus the stack of previous locations. Intuitively, the pointers represent a pair of "
"'cursors' over the tree structure. Without the stack of previous locations, "
"comparison would break, since all locations at the end of two lists would be indistinguishable "
"from the goal (the end of both root lists)")
(dom/li {} "Cost is the total size of all subtrees added and deleted, plus the number of subtree added and deleted. "
"Subtree size is 1 for empty collections, character count for text nodes, and sum size of children for branch nodes. "
"The number of subtrees changed is included in the cost so that the algorithm prefers deleting/adding entire"
"lists, rather than all their elements (since they have the same cost otherwise).")
(dom/li {} "Adjacency is a bit complicated:"
(dom/ul {}
(dom/li {} "When the source and target cursors are over identical subtrees, we always advance both cursors.")
(dom/li {} "When the source cursor is not at the end of its list, we may advance it while keeping the same "
"target cursor. This corresponds to deleting a subtree from the source list.")
(dom/li {} "Likewise for the target cursor: we advance it and keep the source cursor, corresponding to a subtree addition.")
(dom/li {} "When both cursors are over matching collection types, we can move both cursors into the lists. "
"We also need to push the next location onto the stack.")
(dom/li {} "When both cursors are nil, it means we have reached the end of both lists, and we need to "
"pop the next location in the parent sequences off the stack."))
(p "This is the basic version of adjacency that I started with. However, when implemented this way, "
"the algorithm cannot match subtrees at different levels of nesting, since the cursors always move "
"up or down together. "
"To handle changes in nesting, the cursors need to be allowed to move up and down independently, "
"like they are allowed to do within lists. This means that instead of one stack of pairs of pointers, "
"we need a pair of stacks of pointers, one per cursor. Then we need to add some state transitions: ")
(dom/ul {}
(dom/li {} "When only the source cursor is nil, pop the source stack only.")
(dom/li {} "Likewise for target cursor.")
(dom/li {} "When the source cursor is over a branch node, move it to the first child, "
"and push the next position on the source stack.")
(dom/li {} "Likewise for target cursor."))
(p "Since there are quite a lot of branch nodes, this creates a ton of extra states for the algorithm to explore. "
"So although it seems like the steps which move both cursors up/down would obsolete, since they can "
"be replicated with two single-cursor movements, they are needed so that performance is not terrible "
"on mostly identical subtrees (ie the common case). It is also helpful to make single-cursor movement cost "
"more than two-cursor movement, so that we only try a single-cursor move after matched movement fails. "
"The extra cost accounts for the fact that single-cursor movement corresponds to "
"adding or removing a set of parens."))))))
(section
"Worked Example"
(p "I don't know about you, but I'm not the type who can absorb the essence of a complicated algorithm from a wall of text as seen above. "
"So let's look at a detailed log of the states we popped from our priority queue while generating the example diff at the top of this page. "
"The states are numbered in the order in which they were processed. We will look at the goal state and each of its predecessors, "
"starting from the initial state.")))
(let [a (parse/parse-one (first example1))
b (parse/parse-one (second example1))
logs (vec (difflog/diff-log a [b]))]
(dom/div {:className "examplesection"}
(loginset (first logs)
(side-caption "The source cursor is blue, and the target cursor is purple. "
"As you can see, we start with each cursor over its entire subtree. "))
(loginset
(nth logs 1)
(side-caption "After we enter the main loop and pop the start state, we can start exploring. "
"In this state we have matched the parentheses and descended into the defn body. "
"Going into lists has cost 1, so that deleting an entire list "
"is cheaper than deleting each of its elements."))
(loginset
(nth logs 2)
(side-caption "We matched " (fixed "defn") " with " (fixed "defn") " and advanced both cursors. "
"Now we can now match " (fixed "example") " with " (fixed "example") "."))
(loginset
(nth logs 3)
(side-caption "Since matching is done with subtree hashes, we can match " (fixed "[x]")
" without going into the vector at all."))
(loginset
(nth logs 4)
(side-caption
"Now we have our first mismatch. We have a few options here:"
(dom/ol {}
(dom/li {} "Delete source (blue) subtree")
(dom/li {} "Add target (purple) subtree")
(dom/li {} "Go into both subtrees")
(dom/li {} "Go into blue subtree only")
(dom/li {} "Go into purple subtree only"))))
(loginset
(nth logs 8)
(side-caption "We explore all of those options, but eventually we choose the last. "
"Since we moved the target cursor into a list while the source cursor stayed put, "
"it follows that if we finish diffing, the parens which create that extra list must have been added, "
"so we can go ahead and paint them green, and add 2 to the cost."))
(loginset
(nth logs 11)
(side-caption "Add the " (fixed "->") ". It has size 2, but the new cost is 6. This is because "
"each addition/deletion costs 1 extra point, so that "
"minimal diffs are cheaper than equivalent diffs with more changes. "))
(loginset
(nth logs 60)
(side-caption " Delete " (fixed "(println \"hello\")") ". Note that this is state #60 while the previous "
"state was #11 - we explored a whole bunch of dead-end states in between. "
"This is because the deletion has a relatively high cost, so Dijkstra prefers to do "
"low- or no-cost movement before eventually getting around to this state."))
(loginset
(nth logs 63)
(side-caption "Match the identical maps and advance each cursor. "
"Since the map was the last element in the source defn body, the "
"source cursor has reached the end of its list, so there is nothing to highlight "
"in blue and it says " (fixed "(nil S)") " in the header."))
(loginset
(nth logs 65)
(side-caption "It may look like nothing happened, but we popped out of the left subtree only here. "
"This is an example of how movement operations get processed before any additions/deletions. "
"It's completely free to explore here, so we might as well!"))
(loginset
(nth logs 197)
(side-caption "Add " (fixed "(assoc :twice (+ x x))") ". Another costly change means another big gap in state number. "
"That was the last element in the "
"target sequence, so now we have " (fixed "(nil S)") " and " (fixed "(nil T)") ". "))
(loginset
(nth logs 200)
(side-caption "Pop out of the " (fixed "(-> ...)") "."))
(loginset
(nth logs 203)
(side-caption "Pop out of the target defn body. "
"Now that we have popped all the way out of both forms, "
"both stacks are empty and there are no more forms to diff, so we are done!"))))
(dom/div
{:className "textcontainer"
:style {:margin "auto"}
:id "alignment"}
(section
"Alignment"
(p "I had originally implemented the diff algorithm as A*, which was a lot better at finding diffs with fewer explored states. "
"What made me decide to switch to plain Dijkstra's algorithm was the problem of alignment. When multiple forms in a file "
"are changed, inserted, renamed or deleted, how do you figure out which pairs to diff?"
"A* works great when you know both the source and the target forms, but this proved difficult in practice. ")
(p "My first idea was to simply diff the entire source file with the entire target file, basically treating each file "
"as if it had [] surrounding the entire thing. This led to a lot of weird diffs; for example when you deleted "
"something and inserted something else in its place, the diff would show how to transform the deleted thing "
"into the new thing, which was confusing. "
"Top-level forms are the basic unit of clojure code, so diffs which span them are unnatural and hard to read. "
"When the change-of-nesting support was implemented, things really got out of hand.")
(p "Something had to be done. My next idea was to basically hack it by trying to match forms by their top-level text, "
"for example 'defn somefn' or 'defmethod foo :dval'. This has a lot of obvious problems, including docstrings, but "
"especially renames. It worked better than I expected but the problem was still not solved.")
(p "The solution I came up with is to diff each target form in the old file against " (dom/i {} "all") " forms in the new file. "
"This is done by adding N start states to the priority queue, instead of only one, where N is the number of candidate target forms. "
"Since A* really only makes sense in the context of single-source shortest paths, I decided to just switch to Dijkstra's algorithm, "
"which can deal just fine with multiple origins. Since the diffs are processed in order of increasing cost, we know that "
"the first complete diff we see will be the lowest-cost-possible diff of the source form with any of the target forms. "
"So we trade away single-target diff performance, but in return we get the guaranteed optimal solution to the alignment problem. ")
(p "Doing diffs this way is technically quadratic, since in the worst case it requires every source form to be diffed against every "
"target form, but there are a couple tricks that can be used to make it more palatable. "
"Most of the time, the majority of the forms in a file will be unchanged, so we can just hash everything first and match those "
"right away. That means the runtime is only quadratic with respect to the number of changed forms, which is better. "
"Second, each target form can only be matched to one source form, so we if we have to diff the first source against N targets, "
"we only need to diff the second against N-1, and so on. Still quadratic but oh well, parsing is usually slower anyway. "
"Finally, in each list of candidate targets we always include nil, representing the cost of deleting the entire source form. "
"This means no states more expensive than that are considered, which kind of controls the number of states we need to explore.")
(p "There are a couple of slow cases, but for the most part I think the gains are worth the switch to Dijkstra. "
"Probably the slowest type of change to diff is splitting a very large form into two or more smaller forms, since we will spend "
"a huge amount of time trying to figure out which smaller form is most similar to the original large form. For example, "
"If you split a 100-line function into two pieces and also make a bunch of changes, it might take like 30 seconds to diff. "
"That's not great, but you'll probably spend more than 30 seconds looking at a diff like that anyway."))))))
(clojure.core/comment
(gen-readme)
(difflog/write-difflog "difflog" (first example1) [(second example1)]))
================================================
FILE: src/autochrome/scope.clj
================================================
(ns autochrome.scope
(:require [autochrome.common :as clj-common]
[autochrome.parse :as parse]
[clojure.test :refer [deftest is are]])
(:import [java.io Writer]))
;; crude Writer monad (can't be nested artibrarily/lexically)
;; The only reason this needs to work with pseudo-writer-monad instead
;; of simply returning the results like it used to do, is because
;; you can depend on things while destructuring if you use :or.
;; This means that `restructure` has to both return a value (the bound names)
;; and also potentially emit results (:or deps). So everything had to be changed.
(def ^:dynamic *writer-output* nil)
(defn write!
"Emit a value to the output/stream/log"
[v]
(when v
(vswap! *writer-output* conj! v)))
(defmacro execute-writer
"run body and discard the result. returns vector of all values written"
[& body]
`(binding [*writer-output* (volatile! (transient []))]
~@body
(persistent! @*writer-output*)))
(defn key->bound-sym
"`{:keys [foo/bar]}` binds `bar`"
[{:keys [text]}]
(or (some->> text (re-find #".+?/(.+)") second) text))
;; mostly just to keep track of all the fields...
(defrecord Context [root? scope globals lang alias quote-depth])
(def default-context
(map->Context {:root? true
:globals (clj-common/clojure-core-scope)
:scope {}
:quote-depth 0}))
(defmethod print-method Context
[ctx ^Writer w]
(print-method (into {} ctx) w))
(defn add-to-scope
"add local binding(s) to the current context scope"
[^Context ctx name which info]
(cond
(or (nil? name) (pos? (:quote-depth ctx))) ctx
;(empty? name) (throw (ex-info "empty name" {:context (dissoc ctx :globals)}))
(sequential? name) (reduce (fn [a n] (add-to-scope a n which info)) ctx name)
(map? name) (update ctx which assoc (symbol (:text name)) info)
:else (update ctx which assoc (symbol name) info)))
(declare walk-with-scope)
(defn walk-body
"when you don't know what else to do"
[forms func ^Context ctx]
(when (nil? ctx)
(throw (ex-info "nil ctx" {:forms forms})))
(when (map? forms)
(throw (ex-info "walk-body expectes sequence of forms, use walk-with-scope for single forms")))
(doseq [form forms]
(walk-with-scope form func ctx)))
(defn restructure
[{:keys [type text delim contents] :as binding-form} func ^Context ctx]
(when binding-form
(when-not (map? binding-form) (throw (ex-info "restructure expects forms" {:not-a-form binding-form})))
(cond
(= :symbol type) (list text)
;; map destructuring
(and (= :coll type) (= \{ delim))
(mapcat
(fn [[binding-key binding-val]]
(if (not= :keyword (:type binding-key))
(restructure binding-key func ctx)
(case (:text binding-key)
":keys" (map key->bound-sym (:contents binding-val))
":strs" (map :text (:contents binding-val))
":as" (list (:text binding-val))
":or" (walk-body (take-nth 2 (rest (:contents binding-val))) func ctx)
(if (.endsWith (:text binding-key) "/keys")
(map key->bound-sym (:contents binding-val))
(throw (ex-info (str "unsupported map destructuring (" (:text binding-key) ")")
{:binding-form binding-form
:rendered (parse/render binding-form)}))))))
(partition 2 contents))
;; vector destructuring
(and (= :coll type) (= \[ delim))
(loop [bound []
[form & forms] contents]
(cond (nil? form) bound
(= form {:type :keyword :text ":as"}) (recur (conj bound (:text (first forms))) (next forms))
(= form {:type :symbol :text "&"}) (recur bound forms)
:else (recur (into bound (restructure form func ctx)) forms))))))
(defn local
[^Context ctx arg]
(add-to-scope ctx arg :scope :local))
(defn +bindings
[form func ^Context ctx]
(local ctx (restructure form func ctx)))
(defn walk-fnspec
"fnspec is like `([x] (inc x))`"
[[argv & body] func ^Context ctx]
(walk-body body func (+bindings argv func ctx)))
(defn without-meta
"gross hack so we don't get destroyed by (def ^:dynamic foo ...)"
[cts]
(filter #(not= :meta (:type %)) cts))
(defn walk-bindings*
"each binding in a let is in scope for subsequent bindings"
[bvec body func ^Context context]
(loop [[b & bs] (partition 2 (without-meta (:contents bvec)))
ctx context]
(if (nil? b)
(walk-body body func ctx)
(let [[name expr] b]
;; might as well handle these here (for, doseq, etc)
(case (:text name)
":let" (recur (concat (partition 2 (:contents expr)) bs) ctx)
(":when" ":while") (do (walk-with-scope expr func ctx)
(recur bs ctx))
;; normal let binding
(do (walk-with-scope expr func ctx)
(recur bs (+bindings name func ctx))))))))
;;; `binding` is different from `let` because the LEFT hand side
;;; can contain dependencies as well as the right
(defn walk-literal-binding-form
[bvec body func ^Context context]
(loop [[b & bs] (partition 2 (without-meta (:contents bvec)))
ctx context]
(if (nil? b)
(walk-body body func ctx)
(let [[name expr] b]
(do (walk-body [name expr] func ctx)
(recur bs (+bindings name func ctx)))))))
(defn walk-fn-form
[[first-param & more :as contents] func ^Context ctx]
(if (= :symbol (:type first-param))
(recur more func (+bindings first-param func ctx))
(cond
(= \[ (:delim first-param)) (walk-fnspec contents func ctx)
(= \( (:delim first-param)) (doseq [form more] (walk-fnspec (:contents form) func ctx))
(nil? name) (throw (ex-info "unsupported fn form?" {:contents contents}))
:else (walk-body more func ctx))))
(defn walk-defn-form
[{[_ name & body] :contents} func ^Context ctx]
;; ignore docstring (we don't care about any strings really)
(let [body (filter #(not= :string (:type %)) body)
[argv? & more] body
fnscope (+bindings name func ctx)]
(case (:delim argv?)
\[ (walk-fnspec body func fnscope)
\( (doseq [form body] (walk-fnspec (:contents form) func fnscope))
\{ (do (walk-body (:contents argv?) func fnscope)
(walk-defn-form {:contents (list* 'defn name more)} func ctx))
(throw (ex-info "wtf defn" {:name name})))))
(defn walk-defmacro-form
[form func ^Context ctx]
(walk-defn-form form func (local ctx ["&env" "&form"])))
(defn walk-defprotocol-form
[{[_ & entire-body] :contents :keys [delim] :as form} func ^Context ctx]
(let [[name & body] (filter #(not= :string (:type %)) entire-body)]
#_(walk-with-scope name func ctx)
(doseq [{[name & fnspec] :contents} body]
(walk-fnspec fnspec func (+bindings name func ctx)))))
(defn walk-defrecord-form
[{[_ & body] :contents :keys [delim] :as form} func ^Context ctx]
(let [[name fields & body] (filter #(not= :string (:type %)) body)
record-ctx (+bindings name func (+bindings fields func ctx))]
(doseq [{:keys [contents] :as elem} body]
(if contents
;; hopefully an fnspec
(walk-fnspec (rest contents) func record-ctx)
;; hopefully a protocol name
(write! (func ctx elem))))))
;; (defmethod method dispatch-val [args] body)
(defn walk-defmethod-form
[{[_ name dispatch-val & fnspec] :contents :keys [delim] :as form} func ^Context ctx]
(do (walk-with-scope name func ctx) ; defmethod depends on the defmulti
(walk-fnspec fnspec func ctx)))
(defn walk-letfn-form
[{[_ bindings & body] :contents} func ^Context ctx]
(let [names? (mapcat #(restructure (first (:contents %)) func ctx) (:contents bindings))
letfn-scope (local ctx names?)]
(doseq [form (:contents bindings)]
(walk-fn-form (rest (:contents form)) func letfn-scope))
(walk-body body func letfn-scope)))
(defn ->fq-symbol
[scope alias s]
(if-let [s-ns (some-> s (namespace) (symbol))]
(symbol
(name (or (get alias s-ns)
s-ns))
(name s))
(get scope s)))
(defn qualify-symbol
[{:keys [globals alias]} {:keys [text] :as form}]
(->fq-symbol globals alias (symbol text)))
(defn walk-case-form
[{[_ expr & cases] :contents} func ^Context ctx]
;; test constants in `case` forms are implicitly quoted
(walk-with-scope expr func ctx)
(doseq [[const expr] (partition-all 2 cases)]
(walk-with-scope (or expr const) func ctx)))
(defn form->func
"return fully-qualified symbol in funcall position of form"
[form ^Context ctx]
(let [func (first (:contents form))]
(when (and (= \( (:delim form))
(= :symbol (:type func))
(zero? (:quote-depth ctx)))
(qualify-symbol ctx func))))
(defn walk-def-form
[{[_ name & more] :contents} func ^Context ctx]
(walk-body more func ctx))
(def ^:const reader-lambda-scope
(into {} (map #(vector (symbol (str "%" %)) :implicit)
(list* "" "&" (range 1 10)))))
(defn top-level-walker-fn
"given fully-qualified function/macro name, return fn to correctly walk top-level form"
[sym]
(case sym
(clojure.core/defn
clojure.core/defn-) walk-defn-form
(clojure.core/defrecord
clojure.core/deftype
potemkin/defprotocol+) walk-defrecord-form
clojure.core/defmacro walk-defmacro-form
clojure.core/defprotocol walk-defprotocol-form
clojure.core/defmethod walk-defmethod-form
(clojure.core/def
clojure.core/defonce
clojure.test/deftest) walk-def-form
(clojure.core/comment
clojure.core/declare
clojure.core/quote) (constantly [])
nil))
(defn walk-binding-form
"try to walk a form which can have bindings - returns nil if form is not recognized as a binding form"
[{[func-pos & params :as contents] :contents :keys [delim] :as form} func ^Context ctx]
(walk-with-scope func-pos func ctx)
(let [dispatch-form (form->func form ctx)]
(case dispatch-form
(clojure.core/for clojure.core/doseq clojure.core/dotimes clojure.core/let clojure.core/loop
clojure.core/when-let clojure.core/if-let clojure.core/if-some clojure.core/when-some)
(walk-bindings* (first params) (rest params) func ctx)
(clojure.core.async/go-loop manifold.deferred/let-flow)
(do (walk-with-scope func-pos func ctx)
(walk-bindings* (first params) (rest params) func ctx))
clojure.core/recur (walk-body params func ctx)
clojure.core/fn (walk-fn-form params func ctx)
clojure.core/case (walk-case-form form func ctx)
clojure.core/letfn (walk-letfn-form form func ctx)
clojure.core/binding (walk-literal-binding-form (first params) (rest params) func ctx)
clojure.core/reify (walk-defprotocol-form form func ctx)
;; TODO proxy
(if-let [tlw (top-level-walker-fn dispatch-form)]
(tlw (update form :contents without-meta) func ctx)
(walk-body params func ctx)))))
(defn walk-with-scope
"walk an AST, calling (func context form) for every terminal/leaf form,
collecting return values in a FLAT sequence, omitting nils"
[{:keys [type text contents delim] :as form} func ^Context original-ctx]
(try
(let [ctx (assoc original-ctx :root?
(and (:root? original-ctx)
(or (= type :reader-conditional)
(= type :reader-conditional-splicing))))]
(cond
(= type :lambda)
(let [lambda-ctx (-> ctx
(update :scope merge reader-lambda-scope)
(assoc :root? false))]
;; if you do #(let ...) we need to do walk-binding-form-here
(walk-binding-form text func lambda-ctx))
(nil? contents)
(write! (func ctx form))
(= type :syntax-quote)
(walk-body contents func (update ctx :quote-depth inc))
(or (= type :unquote) (= type :unquote-splicing))
(walk-body contents func (update ctx :quote-depth dec))
:else (walk-binding-form form func ctx)))
(catch Exception e (throw (Exception. (str "walking " (parse/render form)) e)))))
(defn numeric?
[text]
(some? (re-find #"^[-+]?\d+(\.\d+)?M?$" text)))
(defn form->real-symbol
[context {:keys [text] :as form}]
(when (and (= :symbol (:type form))
(not (or (contains? #{"true" "false" "nil"} text)
;; hacks - consider syntax-quoted symbols as "real" only within macros
(and (pos? (:quote-depth context)) (nil? (get (:scope context) (symbol "&env"))))
(and (pos? (:quote-depth context)) (.endsWith text "#"))
(.startsWith text ".")
(.startsWith text "js/")
(numeric? text))))
(symbol text)))
(defn form->free-symbol
"Walking calls your fn on every leaf form, use this fn to get free symbols only"
[context {:keys [text] :as form}]
(when-let [sym (form->real-symbol context form)]
(when (not (contains? (:scope context) sym))
sym)))
================================================
FILE: src/autochrome/styles.clj
================================================
(ns autochrome.styles
(:require [garden.core :refer [css]]))
(def code-fonts
"some nice programming fonts, ordered by how much I like them"
"\"Iosevka Term\", \"Fira Code\", Inconsolata, Menlo, Monaco, Consolas, monospace")
(def styles
(css
[:body {:background "#000000"
:font-family code-fonts
:font-size "16px"}]
[:a {:text-decoration :none
:font-weight :bolder}]
[:code :pre
{:color "#ffffff"
:background "#000000"
;; pre does not inherit font from body
:font-family code-fonts
:white-space :pre
:word-spacing :normal
:word-break :normal
:word-wrap :normal
:line-height 1.24
:hyphens :none}]
[:code :a {:text-decoration :none
:font-weight :bolder
:color :inherit}]
[:pre {:margin "0px"
:overflow :auto
:border-radius "0.3em"
:font-weight :normal
:overflow-y :hidden}]
[:.gutter {:text-align :right
:padding-right "4px"
:padding-left "2px"}]
[:.code-card {:margin-buttom "16px"
:padding "6px 6px 0px 6px"
:color "#ae81ff"
:font-weight :bold}]
[:.code-card-heading {:background "linear-gradient(#632697, #000)"
:font-size "22px"
:display :flex
:justify-content :space-between}]
[:.filename-heading {:background "linear-gradient(#632697, #000)"
:font-size "22px"
:color :white}]
[:.spacer {:margin-bottom "30px"}]
[:.code-card-heading-extra {:display :flex}]
[:.container {:display :flex
:flex-direction :row}]
[:.usages {:font-size "16px"
:margin :auto}]
[:.top-comment {:margin-bottom "17px"}]
[:.ns-ref {:color "#f0c674"}]
[:.keyword {:color "#8abeb7"}]
[:.var-ref {:color "#81a2be"}]
[:.clojure-core {:font-weight :bolder :color "#81a2be"}]
[:.macro {:color "#b294bb"}]
[:.punctuation {:color "#a6a6a0"}]
[:.ns-ref {:color "#f0c674"}]
[:.string {:color "#b5bd68"}]
[:.keyword {:color "#70c0b1"}]
[:.meta-keyword {:color "#ea731c"}]
[:.java-class {:color "#de9f25"}]
[:.punctuation {:color "#a6a6a0"}]
[:.highlight {:background-color "#5d007a"}]
[:.unparsed {:background-color "#ff0000"}]
[:.added {:background-color "#225d2d"}]
[:.deleted {:background-color "rgba(200, 38, 38, 0.81)"}]
[:.deleted [:.deleted {:background-color "unset"}]]
[:.added [:.added {:background-color "unset"}]]
[:.first-seen {:text-decoration :underline}]
[:.comment {:color "#969896" :font-style :italic :font-weight :normal}]
[:.diffpane {:width "50%"}]
;; for difflog
[:.shead {:background-color "#1224b1" :border-radius "10px"}]
[:.thead {:background-color "#5d007a" :border-radius "10px"}]))
================================================
FILE: src/autochrome/tree.clj
================================================
(ns autochrome.tree
(:require [autochrome.common :as clj-common])
(:import [clojure.lang Util]))
(defn branch?
[{:keys [type] :as form}]
(or (clj-common/decoration? form)
(= type :coll)
(= type :lambda)
(= type :data-reader)
(= type :reader-conditional)
(= type :reader-conditional-splicing)
(= type :quote)))
(defn ->children
[{:keys [type] :as form}]
;; The parser is unfortunately designed so that recursing into everything
;; is a little bit... involved.
(cond
(= type :quote) (:val form)
(= type :lambda) (:contents (:text form))
:else (:contents form)))
(defn put-sizes
[szmap form]
(let [children (->children form)
size (if-not children
(if-let [t (:text form)]
(count t)
;; empty collection
1)
(let [tcost (volatile! 0)]
(loop [i 0
[c & cs] children]
(when c
(vswap! tcost + (put-sizes szmap c))
(recur (inc i) cs)))
@tcost))]
(.put szmap form size)
size))
(defn put-hashes
[hmap form]
(let [children (->children form)
size (if-not children
(if-let [t (:text form)]
(Util/hashCombine (.hashCode t) (.hashCode (:type form)))
(if (= :coll (:type form))
;; empty collection
(.hashCode (:delim form))
(if (nil? form)
0
(throw (ex-info "unhashable" {:form form})))))
(let [type-hash (Util/hashCombine (.hashCode (:type form)) (hash (:delim form)))
parent-hash (volatile! (Util/hashCombine 0x1a814d0 type-hash))]
(loop [i 0
[c & cs] children]
(when c
(vreset! parent-hash (Util/hashCombine @parent-hash (put-hashes hmap c)))
(recur (inc i) cs)))
@parent-hash))]
(.put hmap form size)
size))
================================================
FILE: src/autochrome/xref.clj
================================================
(ns autochrome.xref
(:require [autochrome.common :as clj-common]))
(def ^:const special->doc
{"set!" "https://clojure.org/reference/vars#set"
"catch" "https://clojure.org/reference/special_forms#try"
"finally" "https://clojure.org/reference/special_forms#try"})
(defn clojure-core-link
[text]
(if (clj-common/special-form? text)
(or (special->doc text)
(str "https://clojure.org/reference/special_forms#" text))
(str "https://clojuredocs.org/clojure.core/" text)))
(defn javadoc-link
([text] (or (javadoc-link "java.lang" text)
(javadoc-link "java.util" text)
(javadoc-link "java.io" text)))
([package text]
(when (Character/isUpperCase (.charAt text 0))
(try
(let [text (if (.endsWith text ".")
(.substring text 0 (dec (count text)))
text)
classname (str package "." text)]
(Class/forName classname)
(str "https://docs.oracle.com/javase/8/docs/api/"
(.replace classname "." "/")
".html"))
(catch ClassNotFoundException e nil)))))
gitextract_90iweypm/
├── .gitignore
├── LICENSE
├── README.md
├── project.clj
└── src/
└── autochrome/
├── align.clj
├── annotation.clj
├── common.clj
├── components.clj
├── core.clj
├── diff.clj
├── difflog.clj
├── github.clj
├── page.clj
├── parse.clj
├── readme.clj
├── scope.clj
├── styles.clj
├── tree.clj
└── xref.clj
Condensed preview — 19 files, each showing path, character count, and a content snippet. Download the .json file or copy for the full structured content (108K chars).
[
{
"path": ".gitignore",
"chars": 46,
"preview": "/target/*\n/.idea/*\n.nrepl-port\nautochrome.iml\n"
},
{
"path": "LICENSE",
"chars": 11514,
"preview": "Eclipse Public License - v 1.0\n\nTHE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC\nLICENSE (\"AG"
},
{
"path": "README.md",
"chars": 1110,
"preview": "# autochrome\n\nAutochrome is a program for structurally diffing and highlighting clojure source code. It generates diffs"
},
{
"path": "project.clj",
"chars": 769,
"preview": "(defproject autochrome \"0.1.0-SNAPSHOT\"\n :description \"FIXME: write description\"\n :url \"http://example.com/FIXME\"\n :l"
},
{
"path": "src/autochrome/align.clj",
"chars": 1570,
"preview": "(ns autochrome.align\n (:require [autochrome.diff :as diff])\n (:import [java.util IdentityHashMap Map]))\n\n(defn get-dif"
},
{
"path": "src/autochrome/annotation.clj",
"chars": 1889,
"preview": "(ns autochrome.annotation\n (:require [autochrome.common :as clj-common]\n [autochrome.scope :as scope]\n "
},
{
"path": "src/autochrome/common.clj",
"chars": 1054,
"preview": "(ns autochrome.common)\n\n(def ^:const special-forms\n [\"def\" \"do\" \"loop\" \"if\" \"new\" \"fn\" \"try\" \"catch\" \"throw\" \"finally\"\n"
},
{
"path": "src/autochrome/components.clj",
"chars": 6419,
"preview": "(ns autochrome.components\n (:require [autochrome.common :as clj-common :refer [special-form? open->closed]]\n "
},
{
"path": "src/autochrome/core.clj",
"chars": 1785,
"preview": "(ns autochrome.core\n (:require [autochrome.diff :as diff]\n [autochrome.github :as github]\n [autoc"
},
{
"path": "src/autochrome/diff.clj",
"chars": 6839,
"preview": "(ns autochrome.diff\n (:require [autochrome.tree :as tree])\n (:import [clojure.lang Util]\n [java.util HashMap"
},
{
"path": "src/autochrome/difflog.clj",
"chars": 2473,
"preview": "(ns autochrome.difflog\n (:require [autochrome.annotation :as ann]\n [autochrome.components :as comp]\n "
},
{
"path": "src/autochrome/github.clj",
"chars": 7806,
"preview": "(ns autochrome.github\n (:require [clj-http.client :as http]\n [clojure.java.io :as io]\n [clojure.j"
},
{
"path": "src/autochrome/page.clj",
"chars": 5686,
"preview": "(ns autochrome.page\n (:require [autochrome.align :as align]\n [autochrome.annotation :as annotation]\n "
},
{
"path": "src/autochrome/parse.clj",
"chars": 12119,
"preview": "(ns autochrome.parse\n (:require [autochrome.common :refer [open->closed closed->open]]\n [clojure.java.io :as"
},
{
"path": "src/autochrome/readme.clj",
"chars": 22783,
"preview": "(ns autochrome.readme\n (:refer-clojure :exclude [comment])\n (:require [autochrome.annotation :as annotation]\n "
},
{
"path": "src/autochrome/scope.clj",
"chars": 13326,
"preview": "(ns autochrome.scope\n (:require [autochrome.common :as clj-common]\n [autochrome.parse :as parse]\n "
},
{
"path": "src/autochrome/styles.clj",
"chars": 2882,
"preview": "(ns autochrome.styles\n (:require [garden.core :refer [css]]))\n\n(def code-fonts\n \"some nice programming fonts, ordered "
},
{
"path": "src/autochrome/tree.clj",
"chars": 2104,
"preview": "(ns autochrome.tree\n (:require [autochrome.common :as clj-common])\n (:import [clojure.lang Util]))\n\n(defn branch?\n [{"
},
{
"path": "src/autochrome/xref.clj",
"chars": 1117,
"preview": "(ns autochrome.xref\n (:require [autochrome.common :as clj-common]))\n\n(def ^:const special->doc\n {\"set!\" \"https://cloju"
}
]
About this extraction
This page contains the full source code of the ladderlife/autochrome GitHub repository, extracted and formatted as plain text for AI agents and large language models (LLMs). The extraction includes 19 files (100.9 KB), approximately 26.5k tokens. Use this with OpenClaw, Claude, ChatGPT, Cursor, Windsurf, or any other AI tool that accepts text input. You can copy the full output to your clipboard or download it as a .txt file.
Extracted by GitExtract — free GitHub repo to text converter for AI. Built by Nikandr Surkov.