Initial commit
This commit is contained in:
commit
52224382bc
1 changed files with 181 additions and 0 deletions
181
git-graph.el
Normal file
181
git-graph.el
Normal file
|
|
@ -0,0 +1,181 @@
|
||||||
|
;;; git-graph.el --- Generate git-style graphs using graphviz -*- lexical-binding: t -*-
|
||||||
|
|
||||||
|
;; Copyright (c) 2015 Correl Roush <correl@gmail.com>
|
||||||
|
|
||||||
|
;;; License:
|
||||||
|
|
||||||
|
;; This program is free software; you can redistribute it and/or modify
|
||||||
|
;; it under the terms of the GNU General Public License as published by
|
||||||
|
;; the Free Software Foundation; either version 3, or (at your option)
|
||||||
|
;; any later version.
|
||||||
|
;;
|
||||||
|
;; This program is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
;; GNU General Public License for more details.
|
||||||
|
;;
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with GNU Emacs; see the file COPYING. If not, write to the
|
||||||
|
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||||
|
;; Boston, MA 02110-1301, USA.
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'dash)
|
||||||
|
|
||||||
|
(defun git-graph/make-node (id &optional parents options)
|
||||||
|
(list id parents options))
|
||||||
|
|
||||||
|
(defun git-graph/node-id (node)
|
||||||
|
(nth 0 node))
|
||||||
|
|
||||||
|
(defun git-graph/node-parents (node)
|
||||||
|
(nth 1 node))
|
||||||
|
|
||||||
|
(defun git-graph/node-group (node)
|
||||||
|
(cdr (assoc 'group (nth 2 node))))
|
||||||
|
|
||||||
|
(defun git-graph/node-label (node)
|
||||||
|
(cdr (assoc 'label (nth 2 node))))
|
||||||
|
|
||||||
|
(defun git-graph/+ (a b)
|
||||||
|
(append a
|
||||||
|
(-remove (lambda (node)
|
||||||
|
(assoc (git-graph/node-id node) a))
|
||||||
|
b)))
|
||||||
|
|
||||||
|
(defun git-graph/to-graphviz (id nodes)
|
||||||
|
(string-join
|
||||||
|
(list
|
||||||
|
(concat "digraph " id " {")
|
||||||
|
"bgcolor=\"transparent\";"
|
||||||
|
"rankdir=\"LR\";"
|
||||||
|
"node[width=0.15,height=0.15,shape=point,fontsize=8.0];"
|
||||||
|
"edge[weight=2,arrowhead=none];"
|
||||||
|
(string-join
|
||||||
|
(-map #'git-graph/to-graphviz-node nodes)
|
||||||
|
"\n")
|
||||||
|
(string-join
|
||||||
|
(-uniq (-flatten (-map #'git-graph/to-graphviz-edges nodes)))
|
||||||
|
"\n")
|
||||||
|
"}")
|
||||||
|
"\n"))
|
||||||
|
|
||||||
|
(defun git-graph/to-graphviz-pretty (id nodes)
|
||||||
|
(with-temp-buffer
|
||||||
|
(graphviz-dot-mode)
|
||||||
|
(insert (git-graph/to-graphviz id nodes))
|
||||||
|
(indent-region (point-min) (point-max))
|
||||||
|
(buffer-string)))
|
||||||
|
|
||||||
|
(defun git-graph/to-graphviz-node-id (id)
|
||||||
|
(format "\"%s\"" id))
|
||||||
|
|
||||||
|
(defun git-graph/to-graphviz-node (node)
|
||||||
|
(let ((node-id (git-graph/to-graphviz-node-id (git-graph/node-id node))))
|
||||||
|
(concat node-id
|
||||||
|
(git-graph/to-graphviz-node--attributes node)
|
||||||
|
";")))
|
||||||
|
|
||||||
|
(defun git-graph/to-graphviz-node--attributes (node)
|
||||||
|
(let ((attributes (git-graph/to-graphviz-node--compute-attributes node)))
|
||||||
|
(and attributes
|
||||||
|
(concat "["
|
||||||
|
(mapconcat (lambda (pair)
|
||||||
|
(format "%s=\"%s\""
|
||||||
|
(car pair) (cdr pair)))
|
||||||
|
attributes
|
||||||
|
", ")
|
||||||
|
"]"))))
|
||||||
|
|
||||||
|
(defun git-graph/to-graphviz-node--compute-attributes (node)
|
||||||
|
(-filter #'identity
|
||||||
|
(append (and (git-graph/node-group node)
|
||||||
|
(list (cons 'group (git-graph/node-group node))))
|
||||||
|
(and (git-graph/node-label node)
|
||||||
|
(list (cons 'shape 'box)
|
||||||
|
(cons 'label (git-graph/node-label node)))))))
|
||||||
|
|
||||||
|
(defun git-graph/to-graphviz-edges (node)
|
||||||
|
(let ((node-id (git-graph/node-id node))
|
||||||
|
(parents (git-graph/node-parents node)))
|
||||||
|
(-map (lambda (parent)
|
||||||
|
(git-graph/to-graphviz-edge node-id parent))
|
||||||
|
parents)))
|
||||||
|
|
||||||
|
(defun git-graph/to-graphviz-edge (from to)
|
||||||
|
(concat
|
||||||
|
(git-graph/to-graphviz-node-id to)
|
||||||
|
" -> "
|
||||||
|
(git-graph/to-graphviz-node-id from)
|
||||||
|
";"))
|
||||||
|
|
||||||
|
(defun git-graph/group-topo (nodelist)
|
||||||
|
(reverse
|
||||||
|
(car
|
||||||
|
(-reduce-from
|
||||||
|
(lambda (acc node)
|
||||||
|
(let* ((grouped-nodes (car acc))
|
||||||
|
(group-stack (cdr acc))
|
||||||
|
(node-id (git-graph/node-id node))
|
||||||
|
(group-from-stack (--if-let (assoc node-id group-stack)
|
||||||
|
(cdr it)))
|
||||||
|
(group (or group-from-stack node-id))
|
||||||
|
(parents (git-graph/node-parents node))
|
||||||
|
(first-parent (first parents)))
|
||||||
|
(if group-from-stack
|
||||||
|
(pop group-stack))
|
||||||
|
(if (and first-parent (not (assoc first-parent group-stack)))
|
||||||
|
(push (cons first-parent group) group-stack))
|
||||||
|
(cons (cons (git-graph/make-node node-id
|
||||||
|
parents
|
||||||
|
`((group . ,group)
|
||||||
|
(label . ,(git-graph/node-label node))))
|
||||||
|
grouped-nodes)
|
||||||
|
group-stack)))
|
||||||
|
nil
|
||||||
|
nodelist))))
|
||||||
|
|
||||||
|
(defun git-graph/git-execute (repo-url command &rest args)
|
||||||
|
(with-temp-buffer
|
||||||
|
(shell-command (format "git -C \"%s\" %s"
|
||||||
|
repo-url
|
||||||
|
(string-join (cons command args)
|
||||||
|
" "))
|
||||||
|
t)
|
||||||
|
(buffer-string)))
|
||||||
|
|
||||||
|
(defun git-graph/git-rev-list (repo-url head)
|
||||||
|
(-map (lambda (line) (split-string line))
|
||||||
|
(split-string (git-graph/git-execute
|
||||||
|
repo-url
|
||||||
|
"rev-list" "--topo-order" "--parents" head)
|
||||||
|
"\n" t)))
|
||||||
|
|
||||||
|
(defun git-graph/git-label (repo-url rev)
|
||||||
|
(let ((name (string-trim
|
||||||
|
(git-graph/git-execute repo-url
|
||||||
|
"name-rev" "--name-only" rev))))
|
||||||
|
(unless (s-contains? "~" name)
|
||||||
|
name)))
|
||||||
|
|
||||||
|
(defun git-graph/git-graph-head (repo-url head)
|
||||||
|
(git-graph/group-topo
|
||||||
|
(-map (lambda (rev-with-parents)
|
||||||
|
(let* ((rev (car rev-with-parents))
|
||||||
|
(parents (cdr rev-with-parents))
|
||||||
|
(label (git-graph/git-label repo-url rev)))
|
||||||
|
(git-graph/make-node rev parents
|
||||||
|
`((label . ,label)))))
|
||||||
|
(git-graph/git-rev-list repo-url head))))
|
||||||
|
|
||||||
|
(defun git-graph/git-load (repo-url heads)
|
||||||
|
(-reduce #'git-graph/+
|
||||||
|
(-map (lambda (head)
|
||||||
|
(git-graph/git-graph-head repo-url head))
|
||||||
|
heads)))
|
||||||
|
|
||||||
|
(provide 'git-graph)
|
||||||
|
;;; git-graph.el ends here
|
||||||
Loading…
Reference in a new issue