From 7a76703d25622d453b965e912d091fa90afaded9 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@rel4tion.org>
Date: Mon, 29 Feb 2016 21:42:37 +0000
Subject: [PATCH] Implement loading a commit graph

---
 src/Data/Git/Local.hs | 51 +++++++++++++++++++++++++++++++++++++++----
 vervis.cabal          |  3 ++-
 2 files changed, 49 insertions(+), 5 deletions(-)

diff --git a/src/Data/Git/Local.hs b/src/Data/Git/Local.hs
index 67f68fc..49c9f4b 100644
--- a/src/Data/Git/Local.hs
+++ b/src/Data/Git/Local.hs
@@ -15,18 +15,27 @@
 
 -- | Git repo tools using the @hit@ package.
 module Data.Git.Local
-    (
+    ( loadCommits
+    , loadCommitGraphByRef
     )
 where
 
 import Prelude
 
 import Control.Monad.IO.Class
-import Data.Foldable (foldlM)
-import Data.Git.Ref (Ref)
+import Data.Foldable (foldl', foldlM)
+import Data.Git.Ref (Ref, toBinary)
 import Data.Git.Repository (getCommit)
 import Data.Git.Storage (Git)
 import Data.Git.Types (Commit (..))
+import Data.Graph.Inductive.Graph (Graph (mkGraph))
+import Data.Hashable (Hashable (..))
+
+import qualified Data.HashMap.Strict as M
+
+instance Hashable Ref where
+    hashWithSalt salt = hashWithSalt salt . toBinary
+    hash = hash . toBinary
 
 -- | Load the entire graph of commits which are ancestors of the given ref
 -- (and that ref itself). Fold the commit structure into a value of type @a@
@@ -52,10 +61,15 @@ loadCommits
     -- ^ Initial value
     -> Ref
     -- ^ Hash of the commit whose ancestor graph should be loaded
+    -> Maybe Commit
+    -- ^ If you already read the commit for the ref passed as the previous
+    -- parameter, pass the commit here to avoid repeated loading of it.
+    -- Otherwise, pass 'Nothing' and it will be read from the repo.
     -> m a
-loadCommits git func val ref = readCommit ref >>= go val ref
+loadCommits git func val ref mcmt = readCommitMaybe ref mcmt >>= go val ref
     where
     readCommit = liftIO . getCommit git
+    readCommitMaybe r = maybe (readCommit r) return
     --readRefCommit r = do
     --    c <- readCommit r
     --    return (r, c)
@@ -68,3 +82,32 @@ loadCommits git func val ref = readCommit ref >>= go val ref
         --let rs = commitParents c
         --ps <- mapM readRefCommit rs
         --foldlM (step (r, c)) v rs
+
+type NodeLabel = (Ref, Commit)
+
+type EdgeLabel = ()
+
+type CommitGraph g = g NodeLabel EdgeLabel
+
+-- | Use 'loadCommits' to build a directed acyclic graph of commits. There is a
+-- single root node, which is the ref passed to this function.
+loadCommitGraphByRef :: Graph g => Git -> Ref -> IO (CommitGraph g)
+loadCommitGraphByRef git ref = do
+    let rootN = 1
+        visit (_rChild, _cChild) rParent v@(nextNode, commits) =
+            if rParent `M.member` commits
+                then return (v, Nothing)
+                else do
+                    cParent <- getCommit git rParent
+                    let commits' = M.insert rParent (cParent, nextNode) commits
+                    return ((nextNode + 1, commits'), Just cParent)
+    cmt <- getCommit git ref
+    (_, commits) <- loadCommits git visit (rootN + 1, M.empty) ref (Just cmt)
+    let commits' = M.insert ref (cmt, rootN) commits
+        nodeOf r = maybe (error "ref has no node") snd $ M.lookup r commits'
+        mkNode l r (c, n) = (n, (r, c)) : l
+        nodes = M.foldlWithKey' mkNode [] commits'
+        mkEdge n l r = (n, nodeOf r, ()) : l
+        mkEdges l (c, n) = foldl' (mkEdge n) l $ commitParents c
+        edges = M.foldl' mkEdges [] commits'
+    return $ mkGraph nodes edges
diff --git a/vervis.cabal b/vervis.cabal
index f057cfe..78217e1 100644
--- a/vervis.cabal
+++ b/vervis.cabal
@@ -102,6 +102,7 @@ library
                      , fgl
                      , file-embed
                      , filepath
+                     , hashable
                      , hit
                      , hjsmin                        >= 0.1        && < 0.2
                      , hourglass
@@ -119,7 +120,7 @@ library
                      , time
                      , transformers
                      , unordered-containers
-                     , vector
+                     --, vector
                      , wai
                      , wai-extra                     >= 3.0        && < 3.1
                      , wai-logger                    >= 2.2        && < 2.3