module Git.Commit where
import Conduit
import Control.Monad
import Data.Function
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Tagged
import Data.Text (Text)
import Git.Tree
import Git.Types
import Prelude hiding (FilePath)
commitTreeEntry :: MonadGit r m
=> Commit r -> TreeFilePath -> m (Maybe (TreeEntry r))
commitTreeEntry :: Commit r -> TreeFilePath -> m (Maybe (TreeEntry r))
commitTreeEntry Commit r
c TreeFilePath
path = (Tree r -> TreeFilePath -> m (Maybe (TreeEntry r)))
-> TreeFilePath -> Tree r -> m (Maybe (TreeEntry r))
forall a b c. (a -> b -> c) -> b -> a -> c
flip Tree r -> TreeFilePath -> m (Maybe (TreeEntry r))
forall r (m :: * -> *).
MonadGit r m =>
Tree r -> TreeFilePath -> m (Maybe (TreeEntry r))
treeEntry TreeFilePath
path (Tree r -> m (Maybe (TreeEntry r)))
-> m (Tree r) -> m (Maybe (TreeEntry r))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TreeOid r -> m (Tree r)
forall r (m :: * -> *). MonadGit r m => TreeOid r -> m (Tree r)
lookupTree (Commit r -> TreeOid r
forall r. Commit r -> TreeOid r
commitTree Commit r
c)
copyCommitOid :: (IsOid (Oid r), MonadGit s n)
=> CommitOid r -> n (CommitOid s)
copyCommitOid :: CommitOid r -> n (CommitOid s)
copyCommitOid = Text -> n (CommitOid s)
forall r (m :: * -> *) o.
MonadGit r m =>
Text -> m (Tagged o (Oid r))
parseObjOid (Text -> n (CommitOid s))
-> (CommitOid r -> Text) -> CommitOid r -> n (CommitOid s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommitOid r -> Text
forall o a. IsOid o => Tagged a o -> Text
renderObjOid
copyCommit :: (MonadGit r m, MonadGit s (t m), MonadTrans t)
=> CommitOid r
-> Maybe RefName
-> HashSet Text
-> t m (CommitOid s, HashSet Text)
copyCommit :: CommitOid r
-> Maybe Text -> HashSet Text -> t m (CommitOid s, HashSet Text)
copyCommit CommitOid r
cr Maybe Text
mref HashSet Text
needed = do
let oid :: Oid r
oid = CommitOid r -> Oid r
forall k (s :: k) b. Tagged s b -> b
untag CommitOid r
cr
sha :: Text
sha = Oid r -> Text
forall o. IsOid o => o -> Text
renderOid Oid r
oid
Commit r
commit <- m (Commit r) -> t m (Commit r)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Commit r) -> t m (Commit r)) -> m (Commit r) -> t m (Commit r)
forall a b. (a -> b) -> a -> b
$ CommitOid r -> m (Commit r)
forall r (m :: * -> *). MonadGit r m => CommitOid r -> m (Commit r)
lookupCommit CommitOid r
cr
Oid s
oid2 <- Text -> t m (Oid s)
forall r (m :: * -> *). MonadGit r m => Text -> m (Oid r)
parseOid Text
sha
if Text -> HashSet Text -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
HashSet.member Text
sha HashSet Text
needed
then do
let parents :: [CommitOid r]
parents = Commit r -> [CommitOid r]
forall r. Commit r -> [CommitOid r]
commitParents Commit r
commit
([CommitOid s]
parentRefs,HashSet Text
needed') <- (([CommitOid s], HashSet Text)
-> CommitOid r -> t m ([CommitOid s], HashSet Text))
-> ([CommitOid s], HashSet Text)
-> [CommitOid r]
-> t m ([CommitOid s], HashSet Text)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ([CommitOid s], HashSet Text)
-> CommitOid r -> t m ([CommitOid s], HashSet Text)
forall r (m :: * -> *) s (t :: (* -> *) -> * -> *).
(MonadGit r m, MonadGit s (t m), MonadTrans t) =>
([Tagged (Commit s) (Oid s)], HashSet Text)
-> Tagged (Commit r) (Oid r)
-> t m ([Tagged (Commit s) (Oid s)], HashSet Text)
copyParent ([],HashSet Text
needed) [CommitOid r]
parents
(Tagged (Tree s) (Oid s)
tr,HashSet Text
needed'') <- TreeOid r
-> HashSet Text -> t m (Tagged (Tree s) (Oid s), HashSet Text)
forall r (m :: * -> *) s (t :: (* -> *) -> * -> *).
(MonadGit r m, MonadGit s (t m), MonadTrans t) =>
TreeOid r -> HashSet Text -> t m (TreeOid s, HashSet Text)
copyTree (Commit r -> TreeOid r
forall r. Commit r -> TreeOid r
commitTree Commit r
commit) HashSet Text
needed'
Bool -> t m () -> t m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TreeOid r -> Text
forall o a. IsOid o => Tagged a o -> Text
renderObjOid (Commit r -> TreeOid r
forall r. Commit r -> TreeOid r
commitTree Commit r
commit) Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Tagged (Tree s) (Oid s) -> Text
forall o a. IsOid o => Tagged a o -> Text
renderObjOid Tagged (Tree s) (Oid s)
tr) (t m () -> t m ()) -> t m () -> t m ()
forall a b. (a -> b) -> a -> b
$
GitException -> t m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (GitException -> t m ()) -> GitException -> t m ()
forall a b. (a -> b) -> a -> b
$ Text -> GitException
BackendError (Text -> GitException) -> Text -> GitException
forall a b. (a -> b) -> a -> b
$ Text
"Error copying tree: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TreeOid r -> Text
forall o a. IsOid o => Tagged a o -> Text
renderObjOid (Commit r -> TreeOid r
forall r. Commit r -> TreeOid r
commitTree Commit r
commit)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" /= " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Tagged (Tree s) (Oid s) -> Text
forall o a. IsOid o => Tagged a o -> Text
renderObjOid Tagged (Tree s) (Oid s)
tr
Commit s
commit' <- [CommitOid s]
-> Tagged (Tree s) (Oid s)
-> Signature
-> Signature
-> Text
-> Maybe Text
-> t m (Commit s)
forall r (m :: * -> *).
MonadGit r m =>
[CommitOid r]
-> TreeOid r
-> Signature
-> Signature
-> Text
-> Maybe Text
-> m (Commit r)
createCommit ([CommitOid s] -> [CommitOid s]
forall a. [a] -> [a]
reverse [CommitOid s]
parentRefs) Tagged (Tree s) (Oid s)
tr
(Commit r -> Signature
forall r. Commit r -> Signature
commitAuthor Commit r
commit)
(Commit r -> Signature
forall r. Commit r -> Signature
commitCommitter Commit r
commit)
(Commit r -> Text
forall r. Commit r -> Text
commitLog Commit r
commit)
Maybe Text
mref
let coid :: CommitOid s
coid = Commit s -> CommitOid s
forall r. Commit r -> CommitOid r
commitOid Commit s
commit'
x :: HashSet Text
x = Text -> HashSet Text -> HashSet Text
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HashSet.delete Text
sha HashSet Text
needed''
(CommitOid s, HashSet Text) -> t m (CommitOid s, HashSet Text)
forall (m :: * -> *) a. Monad m => a -> m a
return ((CommitOid s, HashSet Text) -> t m (CommitOid s, HashSet Text))
-> (CommitOid s, HashSet Text) -> t m (CommitOid s, HashSet Text)
forall a b. (a -> b) -> a -> b
$ CommitOid s
coid CommitOid s
-> (CommitOid s, HashSet Text) -> (CommitOid s, HashSet Text)
`seq` HashSet Text
x HashSet Text
-> (CommitOid s, HashSet Text) -> (CommitOid s, HashSet Text)
`seq` (CommitOid s
coid, HashSet Text
x)
else (CommitOid s, HashSet Text) -> t m (CommitOid s, HashSet Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Oid s -> CommitOid s
forall k (s :: k) b. b -> Tagged s b
Tagged Oid s
oid2, HashSet Text
needed)
where
copyParent :: ([Tagged (Commit s) (Oid s)], HashSet Text)
-> Tagged (Commit r) (Oid r)
-> t m ([Tagged (Commit s) (Oid s)], HashSet Text)
copyParent ([Tagged (Commit s) (Oid s)]
prefs,HashSet Text
needed') Tagged (Commit r) (Oid r)
cref = do
(Tagged (Commit s) (Oid s)
cref2,HashSet Text
needed'') <- Tagged (Commit r) (Oid r)
-> Maybe Text
-> HashSet Text
-> t m (Tagged (Commit s) (Oid s), HashSet Text)
forall r (m :: * -> *) s (t :: (* -> *) -> * -> *).
(MonadGit r m, MonadGit s (t m), MonadTrans t) =>
CommitOid r
-> Maybe Text -> HashSet Text -> t m (CommitOid s, HashSet Text)
copyCommit Tagged (Commit r) (Oid r)
cref Maybe Text
forall a. Maybe a
Nothing HashSet Text
needed'
Bool -> t m () -> t m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Tagged (Commit r) (Oid r) -> Text
forall o a. IsOid o => Tagged a o -> Text
renderObjOid Tagged (Commit r) (Oid r)
cref Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Tagged (Commit s) (Oid s) -> Text
forall o a. IsOid o => Tagged a o -> Text
renderObjOid Tagged (Commit s) (Oid s)
cref2) (t m () -> t m ()) -> t m () -> t m ()
forall a b. (a -> b) -> a -> b
$
GitException -> t m ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (GitException -> t m ()) -> GitException -> t m ()
forall a b. (a -> b) -> a -> b
$ Text -> GitException
BackendError (Text -> GitException) -> Text -> GitException
forall a b. (a -> b) -> a -> b
$ Text
"Error copying commit: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Tagged (Commit r) (Oid r) -> Text
forall o a. IsOid o => Tagged a o -> Text
renderObjOid Tagged (Commit r) (Oid r)
cref Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" /= " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Tagged (Commit s) (Oid s) -> Text
forall o a. IsOid o => Tagged a o -> Text
renderObjOid Tagged (Commit s) (Oid s)
cref2
let x :: [Tagged (Commit s) (Oid s)]
x = Tagged (Commit s) (Oid s)
cref2 Tagged (Commit s) (Oid s)
-> [Tagged (Commit s) (Oid s)] -> [Tagged (Commit s) (Oid s)]
`seq` (Tagged (Commit s) (Oid s)
cref2Tagged (Commit s) (Oid s)
-> [Tagged (Commit s) (Oid s)] -> [Tagged (Commit s) (Oid s)]
forall a. a -> [a] -> [a]
:[Tagged (Commit s) (Oid s)]
prefs)
([Tagged (Commit s) (Oid s)], HashSet Text)
-> t m ([Tagged (Commit s) (Oid s)], HashSet Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (([Tagged (Commit s) (Oid s)], HashSet Text)
-> t m ([Tagged (Commit s) (Oid s)], HashSet Text))
-> ([Tagged (Commit s) (Oid s)], HashSet Text)
-> t m ([Tagged (Commit s) (Oid s)], HashSet Text)
forall a b. (a -> b) -> a -> b
$ [Tagged (Commit s) (Oid s)]
x [Tagged (Commit s) (Oid s)]
-> ([Tagged (Commit s) (Oid s)], HashSet Text)
-> ([Tagged (Commit s) (Oid s)], HashSet Text)
`seq` HashSet Text
needed'' HashSet Text
-> ([Tagged (Commit s) (Oid s)], HashSet Text)
-> ([Tagged (Commit s) (Oid s)], HashSet Text)
`seq` ([Tagged (Commit s) (Oid s)]
x,HashSet Text
needed'')
listCommits :: MonadGit r m
=> Maybe (CommitOid r)
-> CommitOid r
-> m [CommitOid r]
listCommits :: Maybe (CommitOid r) -> CommitOid r -> m [CommitOid r]
listCommits Maybe (CommitOid r)
mhave CommitOid r
need =
ConduitT () Void m [CommitOid r] -> m [CommitOid r]
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void m [CommitOid r] -> m [CommitOid r])
-> ConduitT () Void m [CommitOid r] -> m [CommitOid r]
forall a b. (a -> b) -> a -> b
$ Maybe (CommitOid r)
-> CommitOid r -> Bool -> ConduitT () (ObjectOid r) m ()
forall r (m :: * -> *) i.
MonadGit r m =>
Maybe (CommitOid r)
-> CommitOid r -> Bool -> ConduitT i (ObjectOid r) m ()
sourceObjects Maybe (CommitOid r)
mhave CommitOid r
need Bool
False
ConduitT () (ObjectOid r) m ()
-> ConduitM (ObjectOid r) Void m [CommitOid r]
-> ConduitT () Void m [CommitOid r]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (ObjectOid r -> m (CommitOid r))
-> ConduitT (ObjectOid r) (CommitOid r) m ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
mapMC (\(CommitObjOid CommitOid r
c) -> CommitOid r -> m (CommitOid r)
forall (m :: * -> *) a. Monad m => a -> m a
return CommitOid r
c)
ConduitT (ObjectOid r) (CommitOid r) m ()
-> ConduitM (CommitOid r) Void m [CommitOid r]
-> ConduitM (ObjectOid r) Void m [CommitOid r]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM (CommitOid r) Void m [CommitOid r]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
sinkList
traverseCommits :: MonadGit r m => (CommitOid r -> m a) -> CommitOid r -> m [a]
traverseCommits :: (CommitOid r -> m a) -> CommitOid r -> m [a]
traverseCommits CommitOid r -> m a
f CommitOid r
need = (CommitOid r -> m a) -> [CommitOid r] -> m [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CommitOid r -> m a
f ([CommitOid r] -> m [a]) -> m [CommitOid r] -> m [a]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (CommitOid r) -> CommitOid r -> m [CommitOid r]
forall r (m :: * -> *).
MonadGit r m =>
Maybe (CommitOid r) -> CommitOid r -> m [CommitOid r]
listCommits Maybe (CommitOid r)
forall a. Maybe a
Nothing CommitOid r
need
traverseCommits_ :: MonadGit r m => (CommitOid r -> m ()) -> CommitOid r -> m ()
traverseCommits_ :: (CommitOid r -> m ()) -> CommitOid r -> m ()
traverseCommits_ = (m [()] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [()] -> m ()) -> (CommitOid r -> m [()]) -> CommitOid r -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((CommitOid r -> m [()]) -> CommitOid r -> m ())
-> ((CommitOid r -> m ()) -> CommitOid r -> m [()])
-> (CommitOid r -> m ())
-> CommitOid r
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CommitOid r -> m ()) -> CommitOid r -> m [()]
forall r (m :: * -> *) a.
MonadGit r m =>
(CommitOid r -> m a) -> CommitOid r -> m [a]
traverseCommits