diff --git a/src/Data/Git/Local.hs b/src/Data/Git/Local.hs index 49c9f4b..9e64a5b 100644 --- a/src/Data/Git/Local.hs +++ b/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 - visit (_rChild, _cChild) rParent v@(nextNode, commits) = + let 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 - mkEdges l (c, n) = foldl' (mkEdge n) l $ commitParents c + mkEdge n l (r, e) = (n, nodeOf r, e) : l + 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 diff --git a/src/Data/Graph/Inductive/Local.hs b/src/Data/Graph/Inductive/Local.hs index aa5816f..ecf3c38 100644 --- a/src/Data/Graph/Inductive/Local.hs +++ b/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) diff --git a/vervis.cabal b/vervis.cabal index 78217e1..f4a6c65 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -97,6 +97,7 @@ library , containers , data-default , directory >= 1.1 && < 1.3 + , dlist , esqueleto , fast-logger >= 2.2 && < 2.5 , fgl