module Git.Tree where import Conduit import Control.Monad import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.Monoid import Data.Tagged import Data.Text (Text) import Git.Blob import Git.Tree.Builder import Git.Types listTreeEntries :: MonadGit r m => Tree r -> m [(TreeFilePath, TreeEntry r)] listTreeEntries :: Tree r -> m [(TreeFilePath, TreeEntry r)] listTreeEntries Tree r tree = ConduitT () Void m [(TreeFilePath, TreeEntry r)] -> m [(TreeFilePath, TreeEntry r)] forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r runConduit (ConduitT () Void m [(TreeFilePath, TreeEntry r)] -> m [(TreeFilePath, TreeEntry r)]) -> ConduitT () Void m [(TreeFilePath, TreeEntry r)] -> m [(TreeFilePath, TreeEntry r)] forall a b. (a -> b) -> a -> b $ Tree r -> ConduitT () (TreeFilePath, TreeEntry r) m () forall r (m :: * -> *) i. MonadGit r m => Tree r -> ConduitT i (TreeFilePath, TreeEntry r) m () sourceTreeEntries Tree r tree ConduitT () (TreeFilePath, TreeEntry r) m () -> ConduitM (TreeFilePath, TreeEntry r) Void m [(TreeFilePath, TreeEntry r)] -> ConduitT () Void m [(TreeFilePath, TreeEntry r)] forall (m :: * -> *) a b c r. Monad m => ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r .| ConduitM (TreeFilePath, TreeEntry r) Void m [(TreeFilePath, TreeEntry r)] forall (m :: * -> *) a o. Monad m => ConduitT a o m [a] sinkList copyTreeEntry :: (MonadGit r m, MonadGit s (t m), MonadTrans t) => TreeEntry r -> HashSet Text -> t m (TreeEntry s, HashSet Text) copyTreeEntry :: TreeEntry r -> HashSet Text -> t m (TreeEntry s, HashSet Text) copyTreeEntry (BlobEntry BlobOid r oid BlobKind kind) HashSet Text needed = do (Tagged s (Oid s) b,HashSet Text needed') <- BlobOid r -> HashSet Text -> t m (Tagged s (Oid s), HashSet Text) forall r (m :: * -> *) s (t :: (* -> *) -> * -> *). (MonadGit r m, MonadGit s (t m), MonadTrans t) => BlobOid r -> HashSet Text -> t m (BlobOid s, HashSet Text) copyBlob BlobOid r oid HashSet Text needed Bool -> t m () -> t m () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless (BlobOid r -> Text forall o a. IsOid o => Tagged a o -> Text renderObjOid BlobOid r oid Text -> Text -> Bool forall a. Eq a => a -> a -> Bool == Tagged s (Oid s) -> Text forall o a. IsOid o => Tagged a o -> Text renderObjOid Tagged s (Oid s) b) (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 blob: " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> BlobOid r -> Text forall o a. IsOid o => Tagged a o -> Text renderObjOid BlobOid r oid Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Text " /= " Text -> Text -> Text forall a. Semigroup a => a -> a -> a <> Tagged s (Oid s) -> Text forall o a. IsOid o => Tagged a o -> Text renderObjOid Tagged s (Oid s) b (TreeEntry s, HashSet Text) -> t m (TreeEntry s, HashSet Text) forall (m :: * -> *) a. Monad m => a -> m a return (Tagged s (Oid s) -> BlobKind -> TreeEntry s forall r. BlobOid r -> BlobKind -> TreeEntry r BlobEntry Tagged s (Oid s) b BlobKind kind, HashSet Text needed') copyTreeEntry (CommitEntry CommitOid r oid) HashSet Text needed = do Oid s coid <- Text -> t m (Oid s) forall r (m :: * -> *). MonadGit r m => Text -> m (Oid r) parseOid (CommitOid r -> Text forall o a. IsOid o => Tagged a o -> Text renderObjOid CommitOid r oid) (TreeEntry s, HashSet Text) -> t m (TreeEntry s, HashSet Text) forall (m :: * -> *) a. Monad m => a -> m a return (CommitOid s -> TreeEntry s forall r. CommitOid r -> TreeEntry r CommitEntry (Oid s -> CommitOid s forall k (s :: k) b. b -> Tagged s b Tagged Oid s coid), HashSet Text needed) copyTreeEntry (TreeEntry TreeOid r _) HashSet Text _ = [Char] -> t m (TreeEntry s, HashSet Text) forall a. HasCallStack => [Char] -> a error [Char] "This should never be called" copyTree :: (MonadGit r m, MonadGit s (t m), MonadTrans t) => TreeOid r -> HashSet Text -> t m (TreeOid s, HashSet Text) copyTree :: TreeOid r -> HashSet Text -> t m (TreeOid s, HashSet Text) copyTree TreeOid r tr HashSet Text needed = do let oid :: Oid r oid = TreeOid r -> Oid r forall k (s :: k) b. Tagged s b -> b untag TreeOid r tr sha :: Text sha = Oid r -> Text forall o. IsOid o => o -> Text renderOid Oid r oid Oid s oid2 <- Text -> t m (Oid s) forall r (m :: * -> *). MonadGit r m => Text -> m (Oid r) parseOid (Oid r -> Text forall o. IsOid o => o -> Text renderOid Oid r oid) if Text -> HashSet Text -> Bool forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool HashSet.member Text sha HashSet Text needed then do Tree r tree <- m (Tree r) -> t m (Tree r) forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (m (Tree r) -> t m (Tree r)) -> m (Tree r) -> t m (Tree r) forall a b. (a -> b) -> a -> b $ TreeOid r -> m (Tree r) forall r (m :: * -> *). MonadGit r m => TreeOid r -> m (Tree r) lookupTree TreeOid r tr [(TreeFilePath, TreeEntry r)] entries <- m [(TreeFilePath, TreeEntry r)] -> t m [(TreeFilePath, TreeEntry r)] forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (m [(TreeFilePath, TreeEntry r)] -> t m [(TreeFilePath, TreeEntry r)]) -> m [(TreeFilePath, TreeEntry r)] -> t m [(TreeFilePath, TreeEntry r)] forall a b. (a -> b) -> a -> b $ Tree r -> m [(TreeFilePath, TreeEntry r)] forall r (m :: * -> *). MonadGit r m => Tree r -> m [(TreeFilePath, TreeEntry r)] listTreeEntries Tree r tree (HashSet Text needed', TreeOid s tref) <- TreeT s (t m) (HashSet Text) -> t m (HashSet Text, TreeOid s) forall r (m :: * -> *) a. MonadGit r m => TreeT r m a -> m (a, TreeOid r) withNewTree (TreeT s (t m) (HashSet Text) -> t m (HashSet Text, TreeOid s)) -> TreeT s (t m) (HashSet Text) -> t m (HashSet Text, TreeOid s) forall a b. (a -> b) -> a -> b $ (HashSet Text -> (TreeFilePath, TreeEntry r) -> TreeT s (t m) (HashSet Text)) -> HashSet Text -> [(TreeFilePath, TreeEntry r)] -> TreeT s (t m) (HashSet Text) forall (t :: * -> *) (m :: * -> *) b a. (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b foldM HashSet Text -> (TreeFilePath, TreeEntry r) -> TreeT s (t m) (HashSet Text) forall r (m :: * -> *) s (t :: (* -> *) -> * -> *). (MonadGit r m, MonadGit s (t m), MonadTrans t) => HashSet Text -> (TreeFilePath, TreeEntry r) -> TreeT s (t m) (HashSet Text) doCopyTreeEntry HashSet Text needed [(TreeFilePath, TreeEntry r)] entries let 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' (TreeOid s, HashSet Text) -> t m (TreeOid s, HashSet Text) forall (m :: * -> *) a. Monad m => a -> m a return ((TreeOid s, HashSet Text) -> t m (TreeOid s, HashSet Text)) -> (TreeOid s, HashSet Text) -> t m (TreeOid s, HashSet Text) forall a b. (a -> b) -> a -> b $ TreeOid s tref TreeOid s -> (TreeOid s, HashSet Text) -> (TreeOid s, HashSet Text) `seq` HashSet Text x HashSet Text -> (TreeOid s, HashSet Text) -> (TreeOid s, HashSet Text) `seq` (TreeOid s tref, HashSet Text x) else (TreeOid s, HashSet Text) -> t m (TreeOid s, HashSet Text) forall (m :: * -> *) a. Monad m => a -> m a return (Oid s -> TreeOid s forall k (s :: k) b. b -> Tagged s b Tagged Oid s oid2, HashSet Text needed) where doCopyTreeEntry :: (MonadGit r m, MonadGit s (t m), MonadTrans t) => HashSet Text -> (TreeFilePath, TreeEntry r) -> TreeT s (t m) (HashSet Text) doCopyTreeEntry :: HashSet Text -> (TreeFilePath, TreeEntry r) -> TreeT s (t m) (HashSet Text) doCopyTreeEntry HashSet Text set (TreeFilePath _, TreeEntry {}) = HashSet Text -> TreeT s (t m) (HashSet Text) forall (m :: * -> *) a. Monad m => a -> m a return HashSet Text set doCopyTreeEntry HashSet Text set (TreeFilePath fp, TreeEntry r ent) = do (TreeEntry s ent2,HashSet Text set') <- t m (TreeEntry s, HashSet Text) -> TreeT s (t m) (TreeEntry s, HashSet Text) forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (t m (TreeEntry s, HashSet Text) -> TreeT s (t m) (TreeEntry s, HashSet Text)) -> t m (TreeEntry s, HashSet Text) -> TreeT s (t m) (TreeEntry s, HashSet Text) forall a b. (a -> b) -> a -> b $ TreeEntry r -> HashSet Text -> t m (TreeEntry s, HashSet Text) forall r (m :: * -> *) s (t :: (* -> *) -> * -> *). (MonadGit r m, MonadGit s (t m), MonadTrans t) => TreeEntry r -> HashSet Text -> t m (TreeEntry s, HashSet Text) copyTreeEntry TreeEntry r ent HashSet Text set TreeFilePath -> TreeEntry s -> TreeT s (t m) () forall r (m :: * -> *). MonadGit r m => TreeFilePath -> TreeEntry r -> TreeT r m () putEntry TreeFilePath fp TreeEntry s ent2 HashSet Text -> TreeT s (t m) (HashSet Text) forall (m :: * -> *) a. Monad m => a -> m a return HashSet Text set'