mirror of
https://github.com/correl/correl.github.io.git
synced 2024-12-28 19:19:17 +00:00
144 lines
4.8 KiB
EmacsLisp
144 lines
4.8 KiB
EmacsLisp
|
|
;;; git-graph.el --- Generate git-style graphs using graphviz
|
|
|
|
;; 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-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-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
|