module Data.Git.Graph
( NodeLabel
, EdgeLabel
, CommitGraph
, loadCommitGraph
, loadCommitGraphPT
, Depth
, commitDepths
, filterDepth
, partitionDepth
, isHealthy
, isShallow
, isExcluded
)
where
import Control.Monad.IO.Class
import Data.Foldable (foldl', foldlM)
import Data.Git.Named (RefName (..))
import Data.Git.Ref (Ref, toBinary)
import Data.Git.Repository (getCommit, resolveRevision, branchList, tagList)
import Data.Git.Revision (Revision (..))
import Data.Git.Storage (Git)
import Data.Git.Types (Commit (..))
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.PatriciaTree (Gr)
import Data.Graph.Inductive.Query.BFS (leveln)
import Data.Hashable (Hashable (..))
import Data.HashMap.Lazy (HashMap)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Ord (Down (..))
import qualified Data.HashMap.Lazy as M
import qualified Data.Set as S
import Data.Git.Graph.Util
type NodeLabel = (ObjId, Commit)
type EdgeLabel = Down Int
type CommitGraph g = g NodeLabel EdgeLabel
loadCommitGraph :: Graph g => Git -> [ObjId] -> IO (CommitGraph g)
loadCommitGraph git refs = do
let visit (_rChild, _cChild) rParent v@(nextNode, commits) =
if rParent `M.member` commits
then return (v, Nothing)
else do
cParent <- getCommit git $ unObjId rParent
let commits' = M.insert rParent (cParent, nextNode) commits
return ((nextNode + 1, commits'), Just cParent)
cmts <- traverse (getCommit git . unObjId) refs
let pairs = zip refs $ map Just cmts
firstNode = 1
(next, commits) <- loadCommitsMulti git visit (firstNode, M.empty) pairs
let sources = zip3 refs cmts [next..]
alter cmt node Nothing = Just (cmt, node)
alter _ _ j@(Just _) = j
f cs (ref, cmt, node) = M.alter (alter cmt node) ref cs
commits' = foldl' f commits sources
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, e) = (n, nodeOf r, e) : l
edgeNums = map Down [1..]
parents = map ObjId . commitParents
mkEdges l (c, n) = foldl' (mkEdge n) l $ zip (parents c) edgeNums
edges = M.foldl' mkEdges [] commits'
return $ mkGraph nodes edges
loadCommitGraphPT :: Git -> [ObjId] -> IO (CommitGraph Gr)
loadCommitGraphPT = loadCommitGraph
type Depth = Int
commitDepths :: Graph g => CommitGraph g -> [(Node, Depth)]
commitDepths g =
let orphans = filter ((== 0) . indeg g) $ nodes g
in leveln (zip orphans (repeat 1)) g
getDepth' :: HashMap Node Depth -> Node -> Depth
getDepth' depths node =
case M.lookup node depths of
Nothing -> error "node not found in depth map"
Just d -> d
getLabel' :: Graph g => g a b -> Node -> a
getLabel' g n =
case lab g n of
Nothing -> error "node not found in graph"
Just l -> l
parentRefs :: Graph g => CommitGraph g -> Node -> [ObjId]
parentRefs g n = map ObjId $ commitParents $ snd $ getLabel' g n
filterDepth :: DynGraph g => Depth -> CommitGraph g -> CommitGraph g
filterDepth dmax g = subgraph [n | (n, d) <- commitDepths g, d <= dmax] g
partitionDepth
:: Graph g
=> CommitGraph g
-> HashMap Node Depth
-> Depth
-> ([LNode NodeLabel], [LNode NodeLabel], [LNode NodeLabel])
partitionDepth g depths thresh =
let getDepth = getDepth' depths
f (healthy, shallow, excluded) l@(n, (_r, c)) =
let d = getDepth n
in if d > thresh
then (healthy, shallow, l : excluded)
else
let parentsN = suc g n
parentsC = commitParents c
allHere = length parentsN == length parentsC
inThresh p = getDepth p <= thresh
in if allHere && all inThresh parentsN
then (l : healthy , shallow , excluded)
else (healthy , l : shallow , excluded)
in foldl f ([], [], []) $ labNodes g
isHealthy
:: Graph g
=> CommitGraph g
-> HashMap Node Depth
-> Depth
-> Node
-> Bool
isHealthy g depths thresh node =
let inThresh n = getDepth' depths n <= thresh
parents = suc g node
in inThresh node &&
length parents == length (parentRefs g node) &&
all inThresh parents
isShallow
:: Graph g
=> CommitGraph g
-> HashMap Node Depth
-> Depth
-> Node
-> Bool
isShallow g depths thresh node =
let inThresh n = getDepth' depths n <= thresh
parents = suc g node
in inThresh node &&
not ( length parents == length (parentRefs g node) &&
all inThresh parents
)
isExcluded
:: Graph g
=> CommitGraph g
-> HashMap Node Depth
-> Depth
-> Node
-> Bool
isExcluded _g depths thresh node = getDepth' depths node > thresh