Implement topsort for commits and apply to graph

src/Data/Git/Local.hs

@@ -16,7 +16,15 @@
 -- | Git repo tools using the @hit@ package.
 module Data.Git.Local
     ( loadCommits
+    , NodeLabel
+    , EdgeLabel
+    , CommitGraph
+    , rootN
     , loadCommitGraphByRef
+    , loadCommitGraphByNameMaybe
+    , loadCommitGraphByName
+    , loadCommitsTopsort
+    , loadCommitsTopsortList
     )
 where
 
@@ -25,14 +33,20 @@ import Prelude
 import Control.Monad.IO.Class
 import Data.Foldable (foldl', foldlM)
 import Data.Git.Ref (Ref, toBinary)
-import Data.Git.Repository (getCommit)
+import Data.Git.Repository (getCommit, resolveRevision)
+import Data.Git.Revision (Revision (..))
 import Data.Git.Storage (Git)
 import Data.Git.Types (Commit (..))
-import Data.Graph.Inductive.Graph (Graph (mkGraph))
+import Data.Graph.Inductive.Graph (Graph (mkGraph), Node)
+import Data.Graph.Inductive.PatriciaTree (Gr)
 import Data.Hashable (Hashable (..))
+import Data.Ord (Down (..))
 
+import qualified Data.DList as D
 import qualified Data.HashMap.Strict as M
 
+import Data.Graph.Inductive.Local
+
 instance Hashable Ref where
     hashWithSalt salt = hashWithSalt salt . toBinary
     hash = hash . toBinary
@@ -83,18 +97,29 @@ loadCommits git func val ref mcmt = readCommitMaybe ref mcmt >>= go val ref
         --ps <- mapM readRefCommit rs
         --foldlM (step (r, c)) v rs
 
+-- | Each node in the commit graph represents a commit.
 type NodeLabel = (Ref, Commit)
 
-type EdgeLabel = ()
+-- | Edges are tagged by numbers defining the order of parents of a commit. For
+-- each commit, the out-edges pointing to its parents are numbered according to
+-- the order in which the parents were specified in the 'commitParents' field.
+--
+-- The 'Down' wrapper reverses the comparison (the 'Ord' instance), so that
+-- merged-from branches are inserted earlier into the sorted list than
+-- merged-to branches.
+type EdgeLabel = Down Int
 
 type CommitGraph g = g NodeLabel EdgeLabel
 
+-- | The node number of the root node in loaded commit graphs.
+rootN :: Node
+rootN = 1
+
 -- | 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
+    let visit (_rChild, _cChild) rParent v@(nextNode, commits) =
-        visit (_rChild, _cChild) rParent v@(nextNode, commits) =
             if rParent `M.member` commits
                 then return (v, Nothing)
                 else do
@@ -107,7 +132,54 @@ loadCommitGraphByRef git ref = do
         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
+        mkEdge n l (r, e) = (n, nodeOf r, e) : l
-        mkEdges l (c, n) = foldl' (mkEdge n) l $ commitParents c
+        edgeNums = map Down [1..]
+        mkEdges l (c, n) = foldl' (mkEdge n) l $ zip (commitParents c) edgeNums
         edges = M.foldl' mkEdges [] commits'
     return $ mkGraph nodes edges
+
+-- | Like 'loadCommitGraphByRef', but lets you specify a named ref, such as a
+-- branch or tag name. Returns 'Nothing' if ref isn't found.
+loadCommitGraphByNameMaybe ::
+    Graph g => Git -> String -> IO (Maybe (CommitGraph g))
+loadCommitGraphByNameMaybe git name = do
+    mref <- resolveRevision git $ Revision name []
+    case mref of
+        Nothing  -> return Nothing
+        Just ref -> Just <$> loadCommitGraphByRef git ref
+
+-- | Like 'loadCommitGraphByNameMaybe', but throws an exception if the ref name
+-- can't be resolved.
+loadCommitGraphByName :: Graph g => Git -> String -> IO (CommitGraph g)
+loadCommitGraphByName git name = do
+    mg <- loadCommitGraphByNameMaybe git name
+    case mg of
+        Nothing -> error ""
+        Just g  -> return g
+
+-- | Load a commit graph and topsort the commits. The resulting list starts
+-- with the last commit in the repo and ends with the initial commit.
+loadCommitsTopsort
+    :: (ResultList l, Functor l)
+    => Git
+    -> String
+    -> IO (l (Ref, Commit))
+loadCommitsTopsort git name = do
+    let load :: IO (CommitGraph Gr)
+        load = loadCommitGraphByName git name
+    graph <- load
+    let mnodes = topsortUnmixOrder graph (NodeStack [rootN])
+        nodes = case mnodes of
+            Nothing -> error "commit graph contains a cycle"
+            Just ns -> ns
+    return $ fmap (nodeLabel graph) nodes
+
+instance ResultList D.DList where
+    emptyList = D.empty
+    appendItem = flip D.snoc
+
+-- | Runs 'loadCommitsTopsort' with a 'D.DList', then converts to list and
+-- returns it. At least at the time of writing, DList mapping and folding goes
+-- through a regular list anyway.
+loadCommitsTopsortList :: Git -> String -> IO [(Ref, Commit)]
+loadCommitsTopsortList git name = D.toList <$> loadCommitsTopsort git name

src/Data/Graph/Inductive/Local.hs

@@ -15,10 +15,14 @@
 
 -- | Graph tools for use with the @fgl@ package.
 module Data.Graph.Inductive.Local
-    ( NodeSet (..)
+    ( nodeLabel
+    , NodeSet (..)
     , TraversalOrder (..)
     , ResultList (..)
     , topsortKahn
+    , NodeStack (..)
+    , topsortUnmix
+    , topsortUnmixOrder
     )
 where
 
@@ -28,6 +32,14 @@ import Data.Foldable (foldl')
 import Data.Graph.Inductive.Graph
 import Data.List (sortBy)
 
+-- | Find the label for a 'Node', assuming you know the node exists in the
+-- graph. If the node isn't found, an exception is thrown.
+nodeLabel :: Graph g => g a b -> Node -> a
+nodeLabel g n =
+    case lab g n of
+        Nothing -> error "node not found in graph"
+        Just l  -> l
+
 -- | A graph node container to be used with Kanh's topsort algorithm.
 class NodeSet s where
     -- | Take a graph node and a container, insert the node into it and return
@@ -131,3 +143,34 @@ topsortKahn graph set order = f graph set emptyList
                     children = map fst $ sort $ lsuc g n
                     (g', s'') = foldl' (visit n) (g, s') children
                 in  f g' s'' l'
+
+newtype NodeStack = NodeStack [Node]
+
+instance NodeSet NodeStack where
+    insertNode n (NodeStack l) = NodeStack $ n : l
+    extractNode (NodeStack l) =
+        case l of
+            []     -> Nothing
+            (n:ns) -> Just (n, NodeStack ns)
+
+-- | Topologically sort commits so that parallel lines of work, e.g. a master
+-- branch and a short topic branch merged into it, don't get their commits
+-- mixed in the sorted order.
+topsortUnmix
+    :: (DynGraph g, ResultList l)
+    => g a b
+    -> NodeStack
+    -> TraversalOrder b
+    -> Maybe (l Node)
+topsortUnmix = topsortKahn
+
+-- | Adds an additioal constraint to 'topsortUnmix': When traversing a node's
+-- outgoing edges, do so using the 'Ord' instance of the labels of the edges.
+topsortUnmixOrder
+    :: (Ord b, DynGraph g, ResultList l)
+    => g a b
+    -> NodeStack
+    -> Maybe (l Node)
+topsortUnmixOrder graph stack =
+    let order (_, i) (_, j) = compare i j
+    in  topsortUnmix graph stack (SortedOrder order)

vervis.cabal

@@ -97,6 +97,7 @@ library
                      , containers
                      , data-default
                      , directory                     >= 1.1        && < 1.3
+                     , dlist
                      , esqueleto
                      , fast-logger                   >= 2.2        && < 2.5
                      , fgl