vervis/src/Data/Git/Local.hs

{- This file is part of Vervis.
 -
 - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

-- | Git repo tools using the @hit@ package.
module Data.Git.Local
    ( loadCommits
    , NodeLabel
    , EdgeLabel
    , CommitGraph
    , rootN
    , loadCommitGraphByRef
    , loadCommitGraphByNameMaybe
    , loadCommitGraphByName
    , loadCommitsTopsort
    , loadCommitsTopsortList
    )
where

import Prelude

import Control.Monad.IO.Class
import Data.Foldable (foldl', foldlM)
import Data.Git.Ref (Ref, toBinary)
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), 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

-- | 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@
-- inside monad @m@.
--
-- This is a low-level function which operates on a commit tree, i.e. the same
-- ref may be visited more than once (if it has more than one child commit).
-- You can use the provided flexibility to implement graph algorithms over the
-- commits, or build a graph using some graph library and use that library's
-- tools for further processing.
loadCommits
    :: MonadIO m
    => Git
    -- ^ Open git repository context
    -> ((Ref, Commit) -> Ref -> a -> m (a, Maybe Commit))
    -- ^ Given a child commit, one of its parent commits and an @a@ value,
    -- generate an updated @a@ value. The second returned value determines
    -- whether traversal should proceed to the parent of the parent commit. If
    -- you return 'Nothing', it won't. If you load the parent commit (e.g. with
    -- 'getCommit') and return 'Just' it, traversal will proceed to its
    -- parents.
    -> a
    -- ^ 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 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)
    step p v r = do
        (v', mc) <- func p r v
        case mc of
            Nothing -> return v'
            Just c  -> go v' r c
    go v r c = foldlM (step (r, c)) v $ commitParents c
        --let rs = commitParents c
        --ps <- mapM readRefCommit rs
        --foldlM (step (r, c)) v rs

-- | Each node in the commit graph represents a commit.
type NodeLabel = (Ref, Commit)

-- | 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 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, 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 "no such ref"
        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