@@ -1,21 +1,28 @@

-(in-package :fwoar.cl-git)

+(defpackage :co.fwoar.cl-git.graph

+  (:use :cl :fwoar.cl-git)

+  (:export ))

+(in-package :co.fwoar.cl-git.graph)

 (defclass git-graph ()

   ((%repo :initarg :repo :reader repo)

    (%depth :initarg :depth :reader depth)

+   (%stops :initarg :stops :reader stops :initform ())

    (%branches :reader branches)

    (%node-cache :reader node-cache :initform (make-hash-table :test 'equal))

    (%edge-cache :reader edge-cache :initform (make-hash-table :test 'equal))))

 (defmethod initialize-instance :after ((object git-graph) &key)

-  (setf (slot-value object '%branches)

-        (fw.lu:alist-string-hash-table

-         (funcall (data-lens:over

-                   (<>1 (data-lens:applying #'cons)

-                        (data-lens:transform-head

-                         (serapeum:op (subseq _1 0 (min (length _1) 7))))

-                        #'reverse))

-                  (branches (repo object))))))

+  (setf

+   (slot-value object '%branches)

+   (fw.lu:alist-string-hash-table

+    (funcall (data-lens:over

+              (data-lens:<>1 (data-lens:applying #'cons)

+                             (data-lens:transform-head

+                              (serapeum:op (subseq _1 0

+                                                   (min (length _1)

+                                                        8))))

+                             #'reverse))

+             (fwoar.cl-git::branches (repo object))))))

 (defun git-graph (repo)

   (fw.lu:new 'git-graph repo))

@@ -23,43 +30,51 @@

 (defun get-commit-parents (repository commit)

   #+lispworks

   (declare (notinline mismatch serapeum:string-prefix-p))

-  (map 'list 

-       (serapeum:op (second (partition #\space _)))

-       (remove-if-not (lambda (it)

-                        (serapeum:string-prefix-p "parent" it))

-                      (nth-value 1 (parse-commit

-                                    (split-object

-                                     (chipz:decompress nil (chipz:make-dstate 'chipz:zlib)

-                                                       (loose-object repository

-                                                                     commit))))))))

+  (when commit

+    (co.fwoar.git:with-repository (repository)

+      (alexandria:when-let*

+          ((ref (fwoar.cl-git:ensure-ref commit))

+           (direct-obj (fwoar.cl-git::extract-object

+                        ref))

+           (obj (etypecase direct-obj

+                  (fwoar.cl-git::delta

+                   (fwoar.cl-git::-extract-object-of-type

+                    :commit

+                    (fwoar.cl-git::trace-bases

+                     (fwoar.cl-git::packed-ref-pack

+                      ref)

+                     direct-obj)

+                    fwoar.cl-git::*git-repository*

+                    :hash (fwoar.cl-git::ref-hash ref)))

+                  (fwoar.cl-git::git-object

+                   direct-obj)))

+           (parents (fwoar.cl-git:component

+                     :parents

+                     obj)))

+        (when parents

+          parents)))))

 (defmethod cl-dot:graph-object-node ((graph git-graph) (commit string))

-  (alexandria:ensure-gethash commit

-                             (node-cache graph)

-                             (make-instance 'cl-dot:node

-                                            :attributes `(:label ,(gethash #1=(subseq commit 0 7)

-                                                                           (branches graph)

-                                                                           #1#)))))

+  (alexandria:ensure-gethash

+   commit

+   (node-cache graph)

+   (make-instance 'cl-dot:node

+                  :attributes `(:label ,(gethash #1=(subseq commit 0 8)

+                                                 (branches graph)

+                                                 #1#)))))

-(defmethod cl-dot:graph-object-points-to ((graph git-graph) (commit string))

-  #+nil

-  (loop

-    for cur = (list commit) then parents

-    for parents = (let ((f (get-commit-parents (repo graph) (car cur))))

-                    f)

-    until (or (not parents)

-              (cdr parents))

-    finally (return (or parents

-                        (when (not (equal commit (car cur)))

-                          cur))))

-

-  (funcall (data-lens:<>1 (data-lens:over (serapeum:op

-                                            (setf (gethash (list commit _1)

-                                                           (edge-cache graph))

-                                                  t)

-                                            _1))

-                          (data-lens:exclude (serapeum:op

-                                               (gethash (list commit _1)

-                                                        (edge-cache graph))))

-                          (data-lens:over (serapeum:op (subseq _ 0 7))))

-           (get-commit-parents (repo graph) commit)))

+(defmethod cl-dot:graph-object-points-to

+    ((graph git-graph) (commit string))

+  (unless (member commit (stops graph)

+                  :test 'serapeum:string-prefix-p)

+    (funcall (data-lens:<>1

+              (data-lens:over (serapeum:op

+                                (setf (gethash (list commit _1)

+                                               (edge-cache graph))

+                                      t)

+                                _1))

+              (data-lens:exclude (serapeum:op

+                                   (gethash (list commit _1)

+                                            (edge-cache graph))))

+              (data-lens:over (serapeum:op (subseq _ 0 8))))

+             (get-commit-parents (repo graph) commit))))