gitlib 2.2.0.0 → 3.0.0
raw patch · 13 files changed
+465/−335 lines, 13 filesdep +filepathdep +monad-controldep +mtldep −binarydep −data-default
Dependencies added: filepath, monad-control, mtl, resourcet, semigroups, unix
Dependencies removed: binary, data-default
Files
- Git/Blob.hs +47/−19
- Git/Commit.hs +13/−14
- Git/Commit/Push.hs +43/−3
- Git/Object.hs +15/−21
- Git/Reference.hs +7/−2
- Git/Repository.hs +22/−41
- Git/Tree.hs +12/−11
- Git/Tree/Builder.hs +43/−42
- Git/Tree/Builder/Pure.hs +18/−15
- Git/Types.hs +165/−160
- Git/Utils.hs +1/−0
- Git/Working.hs +62/−0
- gitlib.cabal +17/−7
Git/Blob.hs view
@@ -2,10 +2,14 @@ import Control.Applicative import Control.Monad+import Control.Monad.IO.Class import Control.Monad.Trans.Class+import Control.Monad.Trans.Resource import Data.ByteString as B+import qualified Data.ByteString.Lazy as BL import Data.Conduit-import qualified Data.Conduit.List as CList+import qualified Data.Conduit.List as CL+import qualified Data.Conduit.Binary as CB import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.Tagged@@ -13,38 +17,62 @@ import Data.Text.Encoding as T import Git.Types -createBlobUtf8 :: Repository m => Text -> m (BlobOid m)+createBlobUtf8 :: MonadGit r m => Text -> m (BlobOid r) createBlobUtf8 = createBlob . BlobString . T.encodeUtf8 -catBlob :: Repository m => BlobOid m -> m ByteString+catBlob :: MonadGit r m => BlobOid r -> m ByteString catBlob = lookupBlob >=> blobToByteString -catBlobUtf8 :: Repository m => BlobOid m -> m Text+catBlobLazy :: MonadGit r m => BlobOid r -> m BL.ByteString+catBlobLazy = lookupBlob >=> blobToLazyByteString++catBlobUtf8 :: MonadGit r m => BlobOid r -> m Text catBlobUtf8 = catBlob >=> return . T.decodeUtf8 -blobContentsToByteString :: Repository m => BlobContents m -> m ByteString+blobContentsToByteString :: MonadGit r m => BlobContents m -> m ByteString blobContentsToByteString (BlobString bs) = return bs+blobContentsToByteString (BlobStringLazy bs) =+ return $ B.concat (BL.toChunks bs) blobContentsToByteString (BlobStream bs) =- B.concat <$> (bs $$ CList.consume)+ B.concat <$> (bs $$ CL.consume) blobContentsToByteString (BlobSizedStream bs _) =- B.concat <$> (bs $$ CList.consume)+ B.concat <$> (bs $$ CL.consume) -blobToByteString :: Repository m => Blob m -> m ByteString+blobToByteString :: MonadGit r m => Blob r m -> m ByteString blobToByteString (Blob _ contents) = blobContentsToByteString contents -treeBlobEntries :: Repository m- => Tree m -> m [(TreeFilePath, BlobOid m, BlobKind)]-treeBlobEntries tree = do- entries <- listTreeEntries tree- return $ Prelude.foldr f [] entries+blobContentsToLazyByteString :: MonadGit r m+ => BlobContents m -> m BL.ByteString+blobContentsToLazyByteString (BlobString bs) = return $ BL.fromChunks [bs]+blobContentsToLazyByteString (BlobStringLazy bs) = return bs+blobContentsToLazyByteString (BlobStream bs) = bs $$ CB.sinkLbs+blobContentsToLazyByteString (BlobSizedStream bs _) = bs $$ CB.sinkLbs++blobToLazyByteString :: MonadGit r m => Blob r m -> m BL.ByteString+blobToLazyByteString (Blob _ contents) = blobContentsToLazyByteString contents++writeBlob :: (MonadGit r m, MonadIO m, MonadResource m)+ => FilePath -> BlobContents m -> m ()+writeBlob path (BlobString bs) = liftIO $ B.writeFile path bs+writeBlob path (BlobStringLazy bs) = CB.sourceLbs bs $$ CB.sinkFile path+writeBlob path (BlobStream str) = str $$ CB.sinkFile path+writeBlob path (BlobSizedStream str _) = str $$ CB.sinkFile path++treeBlobEntries :: MonadGit r m+ => Tree r -> m [(TreeFilePath, BlobOid r, BlobKind)]+treeBlobEntries tree = sourceTreeBlobEntries tree $$ CL.consume++sourceTreeBlobEntries+ :: MonadGit r m+ => Tree r -> Producer m (TreeFilePath, BlobOid r, BlobKind)+sourceTreeBlobEntries tree =+ sourceTreeEntries tree =$= awaitForever go where- f (fp ,BlobEntry oid k) xs = (fp, oid, k):xs- f _ xs = xs+ go (fp ,BlobEntry oid k) = yield (fp, oid, k)+ go _ = return () -copyBlob :: (Repository m, Repository (t m), MonadTrans t)- => BlobOid m- -> HashSet Text- -> t m (BlobOid (t m), HashSet Text)+copyBlob :: (MonadGit r m, MonadGit s (t m), MonadTrans t)+ => BlobOid r -> HashSet Text -> t m (BlobOid s, HashSet Text) copyBlob blobr needed = do let oid = untag blobr sha = renderOid oid
Git/Commit.hs view
@@ -17,20 +17,19 @@ import Git.Types import Prelude hiding (FilePath) -commitTreeEntry :: Repository m- => Commit m- -> TreeFilePath- -> m (Maybe (TreeEntry m))+commitTreeEntry :: MonadGit r m+ => Commit r -> TreeFilePath -> m (Maybe (TreeEntry r)) commitTreeEntry c path = flip treeEntry path =<< lookupTree (commitTree c) -copyCommitOid :: (Repository m, Repository n) => CommitOid m -> n (CommitOid n)+copyCommitOid :: (IsOid (Oid r), MonadGit s n)+ => CommitOid r -> n (CommitOid s) copyCommitOid = parseObjOid . renderObjOid -copyCommit :: (Repository m, Repository (t m), MonadTrans t)- => CommitOid m+copyCommit :: (MonadGit r m, MonadGit s (t m), MonadTrans t)+ => CommitOid r -> Maybe RefName -> HashSet Text- -> t m (CommitOid (t m), HashSet Text)+ -> t m (CommitOid s, HashSet Text) copyCommit cr mref needed = do let oid = untag cr sha = renderOid oid@@ -66,17 +65,17 @@ let x = cref2 `seq` (cref2:prefs) return $ x `seq` needed'' `seq` (x,needed'') -listCommits :: Repository m- => Maybe (CommitOid m) -- ^ A commit we may already have- -> CommitOid m -- ^ The commit we need- -> m [CommitOid m] -- ^ All the objects in between+listCommits :: MonadGit r m+ => Maybe (CommitOid r) -- ^ A commit we may already have+ -> CommitOid r -- ^ The commit we need+ -> m [CommitOid r] -- ^ All the objects in between listCommits mhave need = sourceObjects mhave need False $= CL.mapM (\(CommitObjOid c) -> return c) $$ CL.consume -traverseCommits :: Repository m => (CommitOid m -> m a) -> CommitOid m -> m [a]+traverseCommits :: MonadGit r m => (CommitOid r -> m a) -> CommitOid r -> m [a] traverseCommits f need = mapM f =<< listCommits Nothing need -traverseCommits_ :: Repository m => (CommitOid m -> m ()) -> CommitOid m -> m ()+traverseCommits_ :: MonadGit r m => (CommitOid r -> m ()) -> CommitOid r -> m () traverseCommits_ = (void .) . traverseCommits
Git/Commit/Push.hs view
@@ -1,8 +1,11 @@ module Git.Commit.Push where +import Control.Applicative import Control.Failure import Control.Monad+import Control.Monad.IO.Class import Control.Monad.Trans.Class+import Control.Monad.Trans.Control import Data.Function import qualified Data.HashSet as HashSet import Data.List@@ -14,15 +17,16 @@ import Git.Commit import Git.Object import Git.Reference+import Git.Repository import Git.Types-import Prelude hiding (FilePath)+import Prelude -- | Fast-forward push a reference between repositories using a recursive -- copy. This can be extremely slow, but always works no matter which two -- backends are being used. It should be considered a matter of last -- resort, or for objects sets that are known to be small.-pushCommit :: (Repository m, Repository (t m), MonadTrans t)- => CommitOid m -> Text -> t m (CommitOid (t m))+pushCommit :: (MonadGit r m, MonadGit s (t m), MonadTrans t)+ => CommitOid r -> Text -> t m (CommitOid s) pushCommit coid remoteRefName = do commits <- mapM copyCommitOid =<< lift (listCommits Nothing coid) mrref <- fmap Tagged `liftM` resolveReference remoteRefName@@ -41,3 +45,39 @@ -- jww (2013-04-18): This is something the user must decide to do -- updateReference_ remoteRefName (RefObj cref) return cref++copyRepository :: (MonadGit r m, MonadIO m, MonadBaseControl IO m,+ MonadGit s (t m), MonadTrans t, MonadBaseControl IO (t m))+ => RepositoryFactory (t m) m s+ -> Maybe (CommitOid r)+ -> Text+ -> FilePath+ -> Bool+ -> m ()+copyRepository factory mname refName gitDir isBare =+ withRepository' factory RepositoryOptions+ { repoPath = gitDir+ , repoIsBare = isBare+ , repoAutoCreate = True+ }+ (maybe (return ()) go mname)+ where+ go coid = do+ -- jww (2013-04-24): We don't need do download every object back to+ -- the first commit, but only the commits (and their objects) back to+ -- and including the common ancestor. The question is, how do we+ -- determine the common ancestor before we've fetched all the contents+ -- of at least one side?+ cref <- pushCommit coid refName++ -- This will always be a fast-forward, since temp.git is empty. The+ -- resulting HEAD will have the refname as the ref we want to push to+ -- or pull from, and no others.+ updateReference refName (RefObj (untag cref))+ updateReference "HEAD" (RefSymbolic refName)++ mref <- fmap renderOid <$> resolveReference refName+ unless (maybe False (renderObjOid coid ==) mref) $+ failure (BackendError $+ "Could not resolve destination reference '"+ <> refName <> "'in project")
Git/Object.hs view
@@ -9,42 +9,36 @@ import Git.Types import Prelude hiding (FilePath) -listObjects :: Repository m- => Maybe (CommitOid m) -- ^ A commit we may already have- -> CommitOid m -- ^ The commit we need+listObjects :: MonadGit r m+ => Maybe (CommitOid r) -- ^ A commit we may already have+ -> CommitOid r -- ^ The commit we need -> Bool -- ^ Include commit trees also?- -> m [ObjectOid m] -- ^ All the objects in between+ -> m [ObjectOid r] -- ^ All the objects in between listObjects mhave need alsoTrees = sourceObjects mhave need alsoTrees $$ CL.consume -traverseObjects :: Repository m => (ObjectOid m -> m a) -> CommitOid m -> m [a]+traverseObjects :: MonadGit r m => (ObjectOid r -> m a) -> CommitOid r -> m [a] traverseObjects f need = mapM f =<< listObjects Nothing need False -traverseObjects_ :: Repository m => (ObjectOid m -> m ()) -> CommitOid m -> m ()+traverseObjects_ :: MonadGit r m => (ObjectOid r -> m ()) -> CommitOid r -> m () traverseObjects_ = (void .) . traverseObjects -- | Given a list of objects (commit and top-level trees) return by -- 'listObjects', expand it to include all subtrees and blobs as well. -- Ordering is preserved.-expandTreeObjects :: Repository m => Conduit (ObjectOid m) m (ObjectOid m)-expandTreeObjects = whileJust_ await $ \obj -> case obj of+expandTreeObjects :: MonadGit r m => Conduit (ObjectOid r) m (ObjectOid r)+expandTreeObjects = awaitForever $ \obj -> case obj of TreeObjOid toid -> do yield $ TreeObjOid toid tr <- lift $ lookupTree toid- ents <- lift $ listTreeEntries tr- forM_ ents $ \ent -> case ent of- (_, BlobEntry oid _) -> yield $ BlobObjOid oid- (_, TreeEntry oid) -> yield $ TreeObjOid oid- _ -> return ()+ sourceTreeEntries tr+ =$= awaitForever (\ent -> case ent of+ (_, BlobEntry oid _) -> yield $ BlobObjOid oid+ (_, TreeEntry oid) -> yield $ TreeObjOid oid+ _ -> return ()) _ -> yield obj- where- whileJust_ p f = do- x <- p- case x of- Nothing -> return ()- Just x' -> f x' >> whileJust_ p f -listAllObjects :: Repository m- => Maybe (CommitOid m) -> CommitOid m -> m [ObjectOid m]+listAllObjects :: MonadGit r m+ => Maybe (CommitOid r) -> CommitOid r -> m [ObjectOid r] listAllObjects mhave need = sourceObjects mhave need True $= expandTreeObjects $$ CL.consume
Git/Reference.hs view
@@ -1,12 +1,17 @@ module Git.Reference where import Git.Types+import Data.Conduit+import Data.Conduit.List as CL -resolveReference :: Repository m => RefName -> m (Maybe (Oid m))+listReferences :: MonadGit r m => m [RefName]+listReferences = sourceReferences $$ CL.consume++resolveReference :: MonadGit r m => RefName -> m (Maybe (Oid r)) resolveReference name = do mref <- lookupReference name maybe (return Nothing) referenceToOid mref -referenceToOid :: Repository m => RefTarget m -> m (Maybe (Oid m))+referenceToOid :: MonadGit r m => RefTarget r -> m (Maybe (Oid r)) referenceToOid (RefObj oid) = return $ Just oid referenceToOid (RefSymbolic name) = resolveReference name
Git/Repository.hs view
@@ -1,24 +1,22 @@ module Git.Repository where -import qualified Control.Exception.Lifted as Exc-import Control.Monad-import Control.Monad.IO.Class-import Data.Conduit-import Git.Types-import System.Directory-import System.Mem+import Control.Exception.Lifted+import Control.Monad+import Control.Monad.IO.Class+import Data.Conduit+import Git.Types+import System.Directory -withNewRepository :: (Repository t, MonadGit t,- MonadBaseControl IO m, MonadIO m)- => RepositoryFactory t m c- -> FilePath -> t a -> m a+withNewRepository :: (MonadGit r n, MonadBaseControl IO n, MonadIO m)+ => RepositoryFactory n m r+ -> FilePath -> n a -> m a withNewRepository factory path action = do liftIO $ do exists <- doesDirectoryExist path when exists $ removeDirectoryRecursive path -- we want exceptions to leave the repo behind- a <- withRepository' factory (defaultOptions factory)+ a <- withRepository' factory RepositoryOptions { repoPath = path , repoIsBare = True , repoAutoCreate = True@@ -30,12 +28,12 @@ return a -withNewRepository' :: (Repository t, MonadGit t,+withNewRepository' :: (MonadGit r n, MonadBaseControl IO n, MonadBaseControl IO m, MonadIO m)- => RepositoryFactory t m c -> FilePath -> t a -> m a+ => RepositoryFactory n m r -> FilePath -> n a -> m a withNewRepository' factory path action =- Exc.bracket_ recover recover $- withRepository' factory (defaultOptions factory)+ bracket_ recover recover $+ withRepository' factory RepositoryOptions { repoPath = path , repoIsBare = True , repoAutoCreate = True@@ -45,30 +43,13 @@ exists <- doesDirectoryExist path when exists $ removeDirectoryRecursive path -withBackendDo :: (MonadIO m, MonadBaseControl IO m)- => RepositoryFactory t m a -> m b -> m b-withBackendDo fact f = do- startupBackend fact- Exc.finally f (liftIO performGC >> shutdownBackend fact)--withRepository' :: (Repository t,- MonadBaseControl IO m, MonadIO m)- => RepositoryFactory t m c- -> RepositoryOptions- -> t a- -> m a-withRepository' factory opts action =- Exc.bracket- (openRepository factory opts)- (closeRepository factory)- (flip (runRepository factory) action)+withRepository' :: (MonadGit r n, MonadBaseControl IO n, MonadIO m)+ => RepositoryFactory n m r -> RepositoryOptions -> n a -> m a+withRepository' factory opts action = do+ repo <- openRepository factory opts+ runRepository factory repo $ action `finally` closeRepository -withRepository :: (Repository t,- MonadBaseControl IO m, MonadIO m)- => RepositoryFactory t m c- -> FilePath- -> t a- -> m a+withRepository :: (MonadGit r n, MonadBaseControl IO n, MonadIO m)+ => RepositoryFactory n m r -> FilePath -> n a -> m a withRepository factory path =- withRepository' factory- (defaultOptions factory) { repoPath = path }+ withRepository' factory defaultRepositoryOptions { repoPath = path }
Git/Tree.hs view
@@ -3,6 +3,8 @@ import Control.Failure import Control.Monad import Control.Monad.Trans.Class+import Data.Conduit+import qualified Data.Conduit.List as CL import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.Monoid@@ -12,10 +14,11 @@ import Git.Tree.Builder import Git.Types -copyTreeEntry :: (Repository m, Repository (t m), MonadTrans t)- => TreeEntry m- -> HashSet Text- -> t m (TreeEntry (t m), HashSet Text)+listTreeEntries :: MonadGit r m => Tree r -> m [(TreeFilePath, TreeEntry r)]+listTreeEntries tree = sourceTreeEntries tree $$ CL.consume++copyTreeEntry :: (MonadGit r m, MonadGit s (t m), MonadTrans t)+ => TreeEntry r -> HashSet Text -> t m (TreeEntry s, HashSet Text) copyTreeEntry (BlobEntry oid kind) needed = do (b,needed') <- copyBlob oid needed unless (renderObjOid oid == renderObjOid b) $@@ -27,10 +30,8 @@ return (CommitEntry (Tagged coid), needed) copyTreeEntry (TreeEntry _) _ = error "This should never be called" -copyTree :: (Repository m, Repository (t m), MonadTrans t)- => TreeOid m- -> HashSet Text- -> t m (TreeOid (t m), HashSet Text)+copyTree :: (MonadGit r m, MonadGit s (t m), MonadTrans t)+ => TreeOid r -> HashSet Text -> t m (TreeOid s, HashSet Text) copyTree tr needed = do let oid = untag tr sha = renderOid oid@@ -47,10 +48,10 @@ else return (Tagged oid2, needed) where- doCopyTreeEntry :: (Repository m, Repository (t m), MonadTrans t)+ doCopyTreeEntry :: (MonadGit r m, MonadGit s (t m), MonadTrans t) => HashSet Text- -> (TreeFilePath, TreeEntry m)- -> TreeT (t m) (HashSet Text)+ -> (TreeFilePath, TreeEntry r)+ -> TreeT s (t m) (HashSet Text) doCopyTreeEntry set (_, TreeEntry {}) = return set doCopyTreeEntry set (fp, ent) = do (ent2,set') <- lift $ copyTreeEntry ent set
Git/Tree/Builder.hs view
@@ -39,57 +39,57 @@ import Data.Word import Git.Types -data ModifyTreeResult m = TreeEntryNotFound+data ModifyTreeResult r = TreeEntryNotFound | TreeEntryDeleted- | TreeEntryPersistent (TreeEntry m)- | TreeEntryMutated (TreeEntry m)+ | TreeEntryPersistent (TreeEntry r)+ | TreeEntryMutated (TreeEntry r) -fromModifyTreeResult :: ModifyTreeResult m -> Maybe (TreeEntry m)+fromModifyTreeResult :: ModifyTreeResult r -> Maybe (TreeEntry r) fromModifyTreeResult TreeEntryNotFound = Nothing fromModifyTreeResult TreeEntryDeleted = Nothing fromModifyTreeResult (TreeEntryPersistent x) = Just x fromModifyTreeResult (TreeEntryMutated x) = Just x -toModifyTreeResult :: (TreeEntry m -> ModifyTreeResult m)- -> Maybe (TreeEntry m)- -> ModifyTreeResult m+toModifyTreeResult :: (TreeEntry r -> ModifyTreeResult r)+ -> Maybe (TreeEntry r)+ -> ModifyTreeResult r toModifyTreeResult _ Nothing = TreeEntryNotFound toModifyTreeResult f (Just x) = f x -newtype TreeT m a = TreeT { runTreeT :: StateT (TreeBuilder m) m a }+newtype TreeT r m a = TreeT { runTreeT :: StateT (TreeBuilder r m) m a } -instance Functor m => Functor (TreeT m) where+instance Functor m => Functor (TreeT r m) where fmap f (TreeT t) = TreeT (fmap f t) -instance Monad m => Monad (TreeT m) where+instance Monad m => Monad (TreeT r m) where return x = TreeT (return x) TreeT x >>= f = TreeT (x >>= runTreeT . f) -instance (Functor m, Monad m) => Applicative (TreeT m) where+instance (Functor m, Monad m) => Applicative (TreeT r m) where pure = return (<*>) = ap -instance (Functor m, MonadPlus m) => Alternative (TreeT m) where+instance (Functor m, MonadPlus m) => Alternative (TreeT r m) where empty = mzero (<|>) = mplus -instance (MonadPlus m) => MonadPlus (TreeT m) where+instance (MonadPlus m) => MonadPlus (TreeT r m) where mzero = TreeT mzero m `mplus` n = TreeT $ runTreeT m `mplus` runTreeT n -instance (MonadFix m) => MonadFix (TreeT m) where+instance (MonadFix m) => MonadFix (TreeT r m) where mfix f = TreeT $ mfix $ \ ~a -> runTreeT (f a) -instance MonadTrans TreeT where+instance MonadTrans (TreeT r) where lift m = TreeT $ lift m -instance (MonadIO m) => MonadIO (TreeT m) where+instance (MonadIO m) => MonadIO (TreeT r m) where liftIO = lift . liftIO -getBuilder :: Monad m => TreeT m (TreeBuilder m)+getBuilder :: Monad m => TreeT r m (TreeBuilder r m) getBuilder = TreeT get -putBuilder :: Monad m => TreeBuilder m -> TreeT m ()+putBuilder :: Monad m => TreeBuilder r m -> TreeT r m () putBuilder = TreeT . put data BuilderAction = GetEntry | PutEntry | DropEntry@@ -103,12 +103,12 @@ -- -- This is a complex algorithm which has been rewritten many times, so I -- will try to guide you through it as best I can.-queryTreeBuilder :: Repository m- => TreeBuilder m+queryTreeBuilder :: MonadGit r m+ => TreeBuilder r m -> TreeFilePath -> BuilderAction- -> (Maybe (TreeEntry m) -> ModifyTreeResult m)- -> m (TreeBuilder m, Maybe (TreeEntry m))+ -> (Maybe (TreeEntry r) -> ModifyTreeResult r)+ -> m (TreeBuilder r m, Maybe (TreeEntry r)) queryTreeBuilder builder path kind f = do (mtb, mtresult) <- walk (BuilderUnchanged builder) (splitDirectories path) return (fromBuilderMod mtb, fromModifyTreeResult mtresult)@@ -200,8 +200,8 @@ -- | Write out a tree to its repository. If it has already been written, -- nothing will happen.-writeTreeBuilder :: Repository m- => TreeBuilder m -> m (TreeBuilder m, TreeOid m)+writeTreeBuilder :: MonadGit r m+ => TreeBuilder r m -> m (TreeBuilder r m, TreeOid r) writeTreeBuilder builder = do (bm, mtref) <- go (BuilderUnchanged builder) tref <- case mtref of@@ -235,70 +235,71 @@ Just tref -> mtbPutEntry tb tb k (TreeEntry tref) return $ bm <> bm' -getEntry :: Repository m => TreeFilePath -> TreeT m (Maybe (TreeEntry m))+getEntry :: MonadGit r m => TreeFilePath -> TreeT r m (Maybe (TreeEntry r)) getEntry path = do tb <- getBuilder snd <$> lift (queryTreeBuilder tb path GetEntry (toModifyTreeResult TreeEntryPersistent)) -putEntry :: Repository m => TreeFilePath -> TreeEntry m -> TreeT m ()+putEntry :: MonadGit r m => TreeFilePath -> TreeEntry r -> TreeT r m () putEntry path ent = do tb <- getBuilder tb' <- fst <$> lift (queryTreeBuilder tb path PutEntry (const (TreeEntryMutated ent))) putBuilder tb' -dropEntry :: Repository m => TreeFilePath -> TreeT m ()+dropEntry :: MonadGit r m => TreeFilePath -> TreeT r m () dropEntry path = do tb <- getBuilder tb' <- fst <$> lift (queryTreeBuilder tb path DropEntry (const TreeEntryDeleted)) putBuilder tb' -putBlob' :: Repository m => TreeFilePath -> BlobOid m -> BlobKind -> TreeT m ()+putBlob' :: MonadGit r m+ => TreeFilePath -> BlobOid r -> BlobKind -> TreeT r m () putBlob' path b kind = putEntry path (BlobEntry b kind) -putBlob :: Repository m => TreeFilePath -> BlobOid m -> TreeT m ()+putBlob :: MonadGit r m => TreeFilePath -> BlobOid r -> TreeT r m () putBlob path b = putBlob' path b PlainBlob -putTree :: Repository m => TreeFilePath -> TreeOid m -> TreeT m ()+putTree :: MonadGit r m => TreeFilePath -> TreeOid r -> TreeT r m () putTree path t = putEntry path (TreeEntry t) -putCommit :: Repository m => TreeFilePath -> CommitOid m -> TreeT m ()+putCommit :: MonadGit r m => TreeFilePath -> CommitOid r -> TreeT r m () putCommit path c = putEntry path (CommitEntry c) -doWithTree :: Repository m => Maybe (Tree m) -> TreeT m a -> m (a, TreeOid m)-doWithTree mtr act =- fst <$> (runStateT (runTreeT go) =<< newTreeBuilder mtr)+doWithTree :: MonadGit r m => Maybe (Tree r) -> TreeT r m a -> m (a, TreeOid r)+doWithTree rtr act =+ fst <$> (runStateT (runTreeT go) =<< newTreeBuilder rtr) where go = liftM2 (,) act currentTreeOid -withTree :: Repository m => Tree m -> TreeT m a -> m (a, TreeOid m)+withTree :: MonadGit r m => Tree r -> TreeT r m a -> m (a, TreeOid r) withTree tr = doWithTree (Just tr) -withTreeOid :: Repository m => TreeOid m -> TreeT m a -> m (a, TreeOid m)+withTreeOid :: MonadGit r m => TreeOid r -> TreeT r m a -> m (a, TreeOid r) withTreeOid oid action = do tree <- lookupTree oid doWithTree (Just tree) action -mutateTree :: Repository m => Tree m -> TreeT m a -> m (TreeOid m)+mutateTree :: MonadGit r m => Tree r -> TreeT r m a -> m (TreeOid r) mutateTree tr action = snd <$> withTree tr action -mutateTreeOid :: Repository m => TreeOid m -> TreeT m a -> m (TreeOid m)+mutateTreeOid :: MonadGit r m => TreeOid r -> TreeT r m a -> m (TreeOid r) mutateTreeOid tr action = snd <$> withTreeOid tr action -currentTreeOid :: Repository m => TreeT m (TreeOid m)+currentTreeOid :: MonadGit r m => TreeT r m (TreeOid r) currentTreeOid = do tb <- getBuilder (tb', toid) <- lift $ writeTreeBuilder tb putBuilder tb' return toid -currentTree :: Repository m => TreeT m (Tree m)+currentTree :: MonadGit r m => TreeT r m (Tree r) currentTree = lift . lookupTree =<< currentTreeOid -withNewTree :: Repository m => TreeT m a -> m (a, TreeOid m)+withNewTree :: MonadGit r m => TreeT r m a -> m (a, TreeOid r) withNewTree = doWithTree Nothing -createTree :: Repository m => TreeT m a -> m (TreeOid m)+createTree :: MonadGit r m => TreeT r m a -> m (TreeOid r) createTree action = snd <$> withNewTree action
Git/Tree/Builder/Pure.hs view
@@ -4,40 +4,43 @@ ) where import Control.Applicative-import Data.Monoid import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap+import Data.Monoid+import Data.Traversable import Git+import Prelude hiding (mapM) -type EntryHashMap m = HashMap TreeFilePath (TreeEntry m)+type EntryHashMap r = HashMap TreeFilePath (TreeEntry r) -- | Create a new, empty tree. -- -- Since empty trees cannot exist in Git, attempting to write out an empty -- tree is a no-op.-newPureTreeBuilder :: Repository m- => (Tree m -> m (EntryHashMap m))- -> (EntryHashMap m -> m (TreeOid m))- -> Maybe (Tree m)- -> m (TreeBuilder m)+newPureTreeBuilder :: MonadGit r m+ => (Tree r -> m (EntryHashMap r))+ -> (EntryHashMap r -> m (TreeOid r))+ -> Maybe (Tree r)+ -> m (TreeBuilder r m) newPureTreeBuilder reader writer mtree = do entMap <- case mtree of Nothing -> return HashMap.empty Just tree -> reader tree+ toid <- mapM treeOid mtree return $ makePureBuilder- (treeOid <$> mtree)+ toid mempty (newPureTreeBuilder reader writer) entMap writer -makePureBuilder :: Repository m- => Maybe (TreeOid m)- -> HashMap TreeFilePath (TreeBuilder m)- -> (Maybe (Tree m) -> m (TreeBuilder m))- -> EntryHashMap m- -> (EntryHashMap m -> m (TreeOid m))- -> TreeBuilder m+makePureBuilder :: MonadGit r m+ => Maybe (TreeOid r)+ -> HashMap TreeFilePath (TreeBuilder r m)+ -> (Maybe (Tree r) -> m (TreeBuilder r m))+ -> EntryHashMap r+ -> (EntryHashMap r -> m (TreeOid r))+ -> TreeBuilder r m makePureBuilder baseTree upds newBuilder entMap writer = TreeBuilder { mtbBaseTreeOid = baseTree , mtbPendingUpdates = upds
Git/Types.hs view
@@ -3,23 +3,23 @@ import Control.Applicative import qualified Control.Exception.Lifted as Exc import Control.Failure-import Control.Monad.IO.Class-import qualified Data.Binary as Bin+import Control.Monad+import Control.Monad.Trans.Class import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Lazy as BL import Data.Conduit-import Data.Default+import qualified Data.Conduit.List as CL import Data.HashMap.Strict (HashMap) import Data.Hashable import Data.Map (Map)-import Data.Monoid+import Data.Semigroup import Data.Tagged import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time import Data.Typeable---import System.Posix.ByteString.FilePath type RawFilePath = ByteString @@ -27,66 +27,68 @@ { hasSymbolicReferences :: !Bool } deriving Show -type MonadGit m = (Failure GitException m, Applicative m,- MonadIO m, MonadBaseControl IO m)--type RefName = Text-type CommitAuthor = Text-type CommitEmail = Text+type RefName = Text+type CommitAuthor = Text+type CommitEmail = Text type CommitMessage = Text-type TreeFilePath = RawFilePath+type TreeFilePath = RawFilePath -- | 'Repository' is the central point of contact between user code and Git -- data objects. Every object must belong to some repository.-class (Applicative m, Monad m, Failure GitException m, IsOid (Oid m))- => Repository m where- type Oid m :: *- data Tree m :: *- data Options m :: *+class (Applicative m, Monad m, Failure GitException m,+ IsOid (Oid r), Show (Oid r), Eq (Oid r), Ord (Oid r))+ => MonadGit r m | m -> r where+ type Oid r :: *+ data Tree r :: *+ data Options r :: * facts :: m RepositoryFacts- parseOid :: Text -> m (Oid m)+ parseOid :: Text -> m (Oid r)++ getRepository :: m r+ closeRepository :: m () deleteRepository :: m () -- References- createReference :: RefName -> RefTarget m -> m ()- lookupReference :: RefName -> m (Maybe (RefTarget m))- updateReference :: RefName -> RefTarget m -> m ()+ createReference :: RefName -> RefTarget r -> m ()+ lookupReference :: RefName -> m (Maybe (RefTarget r))+ updateReference :: RefName -> RefTarget r -> m () deleteReference :: RefName -> m ()- listReferences :: m [RefName]+ sourceReferences :: Producer m RefName -- Object lookup- lookupCommit :: CommitOid m -> m (Commit m)- lookupTree :: TreeOid m -> m (Tree m)- lookupBlob :: BlobOid m -> m (Blob m)- lookupTag :: TagOid m -> m (Tag m)- lookupObject :: Oid m -> m (Object m)- existsObject :: Oid m -> m Bool- sourceObjects :: Maybe (CommitOid m) -- ^ A commit we may already have- -> CommitOid m -- ^ The commit we need+ lookupObject :: Oid r -> m (Object r m)+ existsObject :: Oid r -> m Bool+ sourceObjects :: Maybe (CommitOid r) -- ^ A commit we may already have+ -> CommitOid r -- ^ The commit we need -> Bool -- ^ Include commit trees also?- -> Producer m (ObjectOid m) -- ^ All the objects in between+ -> Producer m (ObjectOid r) -- ^ All the objects in between + lookupCommit :: CommitOid r -> m (Commit r)+ lookupTree :: TreeOid r -> m (Tree r)+ lookupBlob :: BlobOid r -> m (Blob r m)+ lookupTag :: TagOid r -> m (Tag r)+ -- Working with trees- newTreeBuilder :: Maybe (Tree m) -> m (TreeBuilder m)+ newTreeBuilder :: Maybe (Tree r) -> m (TreeBuilder r m) - treeOid :: Tree m -> TreeOid m- treeEntry :: Tree m -> TreeFilePath -> m (Maybe (TreeEntry m))- listTreeEntries :: Tree m -> m [(TreeFilePath, TreeEntry m)]+ treeOid :: Tree r -> m (TreeOid r)+ treeEntry :: Tree r -> TreeFilePath -> m (Maybe (TreeEntry r))+ sourceTreeEntries :: Tree r -> Producer m (TreeFilePath, TreeEntry r) diffContentsWithTree :: Source m (Either TreeFilePath ByteString)- -> Tree m -> Producer m ByteString+ -> Tree r -> Producer m ByteString -- Creating other objects- hashContents :: BlobContents m -> m (BlobOid m)- createBlob :: BlobContents m -> m (BlobOid m)- createCommit :: [CommitOid m] -> TreeOid m+ hashContents :: BlobContents m -> m (BlobOid r)+ createBlob :: BlobContents m -> m (BlobOid r)+ createCommit :: [CommitOid r] -> TreeOid r -> Signature -> Signature -> CommitMessage -> Maybe RefName- -> m (Commit m)- createTag :: CommitOid m -> Signature -> CommitMessage -> Text -> m (Tag m)+ -> m (Commit r)+ createTag :: CommitOid r -> Signature -> CommitMessage -> Text -> m (Tag r) -- -- Pack files- -- buildPackFile :: FilePath -> [Either (CommitOid m) (TreeOid m)]+ -- buildPackFile :: FilePath -> [Either (CommitOid r) (TreeOid r)] -- -> m FilePath -- buildPackFile _ _ = -- failure (BackendError "Backend does not support building pack files")@@ -108,41 +110,36 @@ , repoAutoCreate :: !Bool } -instance Default RepositoryOptions where- def = RepositoryOptions "" True True+defaultRepositoryOptions :: RepositoryOptions+defaultRepositoryOptions = RepositoryOptions "" False False -data RepositoryFactory t m c- = RepositoryFactory- { openRepository :: RepositoryOptions -> m c- , runRepository :: forall a. c -> t a -> m a- , closeRepository :: c -> m ()- , getRepository :: t c- , defaultOptions :: !RepositoryOptions- , startupBackend :: m ()- , shutdownBackend :: m ()+data RepositoryFactory n m r = RepositoryFactory+ { openRepository :: RepositoryOptions -> m r+ , runRepository :: forall a. r -> n a -> m a } {- $oids -}-class (Eq o, Ord o, Show o) => IsOid o where+class IsOid o where renderOid :: o -> Text renderOid = renderObjOid . Tagged+ renderObjOid :: Tagged a o -> Text renderObjOid = renderOid . untag -type BlobOid m = Tagged (Blob m) (Oid m)-type TreeOid m = Tagged (Tree m) (Oid m)-type CommitOid m = Tagged (Commit m) (Oid m)-type TagOid m = Tagged (Tag m) (Oid m)+type BlobOid r = Tagged r (Oid r)+type TreeOid r = Tagged (Tree r) (Oid r)+type CommitOid r = Tagged (Commit r) (Oid r)+type TagOid r = Tagged (Tag r) (Oid r) -data ObjectOid m = BlobObjOid !(BlobOid m)- | TreeObjOid !(TreeOid m)- | CommitObjOid !(CommitOid m)- | TagObjOid !(TagOid m)+data ObjectOid r = BlobObjOid !(BlobOid r)+ | TreeObjOid !(TreeOid r)+ | CommitObjOid !(CommitOid r)+ | TagObjOid !(TagOid r) -parseObjOid :: Repository m => forall o. Text -> m (Tagged o (Oid m))+parseObjOid :: MonadGit r m => forall o. Text -> m (Tagged o (Oid r)) parseObjOid sha = Tagged <$> parseOid sha -copyOid :: (Repository m, Repository n) => Oid m -> n (Oid n)+copyOid :: (MonadGit r m, MonadGit s n) => Oid r -> n (Oid s) copyOid = parseOid . renderOid newtype SHA = SHA { getSHA :: ByteString } deriving (Eq, Ord, Read)@@ -162,24 +159,23 @@ instance Show SHA where show = T.unpack . shaToText -instance Bin.Binary SHA where- put (SHA t) = Bin.put t- get = SHA <$> Bin.get- instance Hashable SHA where hashWithSalt salt (SHA bs) = hashWithSalt salt bs {- $blobs -}-data Blob m = Blob { blobOid :: !(BlobOid m)- , blobContents :: !(BlobContents m) }+data Blob r m = Blob+ { blobOid :: !(BlobOid r)+ , blobContents :: !(BlobContents m)+ } type ByteSource m = Producer m ByteString data BlobContents m = BlobString !ByteString+ | BlobStringLazy !BL.ByteString | BlobStream !(ByteSource m) | BlobSizedStream !(ByteSource m) !Int -data BlobKind = PlainBlob | ExecutableBlob | SymlinkBlob | UnknownBlob+data BlobKind = PlainBlob | ExecutableBlob | SymlinkBlob deriving (Show, Eq, Enum) instance Eq (BlobContents m) where@@ -187,125 +183,132 @@ _ == _ = False {- $trees -}-data TreeEntry m = BlobEntry { blobEntryOid :: !(BlobOid m)+data TreeEntry r = BlobEntry { blobEntryOid :: !(BlobOid r) , blobEntryKind :: !BlobKind }- | TreeEntry { treeEntryOid :: !(TreeOid m) }- | CommitEntry { commitEntryOid :: !(CommitOid m) }+ | TreeEntry { treeEntryOid :: !(TreeOid r) }+ | CommitEntry { commitEntryOid :: !(CommitOid r) } -instance Repository m => Show (TreeEntry m) where- show (BlobEntry oid _) = "<BlobEntry " ++ T.unpack (renderObjOid oid)- show (TreeEntry oid) = "<TreeEntry " ++ T.unpack (renderObjOid oid)- show (CommitEntry oid) = "<CommitEntry " ++ T.unpack (renderObjOid oid)+-- instance Show (TreeEntry r) where+-- show (BlobEntry oid _) = "<BlobEntry " ++ show oid ++ ">"+-- show (TreeEntry oid) = "<TreeEntry " ++ show oid ++ ">"+-- show (CommitEntry oid) = "<CommitEntry " ++ show oid ++ ">" -treeEntryToOid :: Repository m => TreeEntry m -> Oid m+treeEntryToOid :: MonadGit r m => TreeEntry r -> Oid r treeEntryToOid (BlobEntry boid _) = untag boid treeEntryToOid (TreeEntry toid) = untag toid treeEntryToOid (CommitEntry coid) = untag coid -data TreeBuilder m = TreeBuilder- { mtbBaseTreeOid :: Maybe (TreeOid m)- , mtbPendingUpdates :: HashMap TreeFilePath (TreeBuilder m)- , mtbNewBuilder :: Maybe (Tree m) -> m (TreeBuilder m)- , mtbWriteContents :: TreeBuilder m -> m (ModifiedBuilder m, TreeOid m)- , mtbLookupEntry :: TreeFilePath -> m (Maybe (TreeEntry m))+data TreeBuilder r m = TreeBuilder+ { mtbBaseTreeOid :: Maybe (TreeOid r)+ , mtbPendingUpdates :: HashMap TreeFilePath (TreeBuilder r m)+ , mtbNewBuilder :: Maybe (Tree r) -> m (TreeBuilder r m)+ , mtbWriteContents :: TreeBuilder r m -> m (ModifiedBuilder r m, TreeOid r)+ , mtbLookupEntry :: TreeFilePath -> m (Maybe (TreeEntry r)) , mtbEntryCount :: m Int- , mtbPutEntry :: TreeBuilder m -> TreeFilePath -> TreeEntry m- -> m (ModifiedBuilder m)- , mtbDropEntry :: TreeBuilder m -> TreeFilePath- -> m (ModifiedBuilder m)+ , mtbPutEntry :: TreeBuilder r m -> TreeFilePath -> TreeEntry r+ -> m (ModifiedBuilder r m)+ , mtbDropEntry :: TreeBuilder r m -> TreeFilePath+ -> m (ModifiedBuilder r m) } -data ModifiedBuilder m = ModifiedBuilder (TreeBuilder m)- | BuilderUnchanged (TreeBuilder m)+data ModifiedBuilder r m = ModifiedBuilder (TreeBuilder r m)+ | BuilderUnchanged (TreeBuilder r m) -instance Monoid (ModifiedBuilder m) where+instance Semigroup (ModifiedBuilder r m) where+ BuilderUnchanged _ <> BuilderUnchanged b2 = BuilderUnchanged b2+ ModifiedBuilder b1 <> BuilderUnchanged _ = ModifiedBuilder b1+ BuilderUnchanged _ <> ModifiedBuilder b2 = ModifiedBuilder b2+ ModifiedBuilder _ <> ModifiedBuilder b2 = ModifiedBuilder b2++instance Monoid (ModifiedBuilder r m) where mempty = BuilderUnchanged (error "ModifiedBuilder is a semigroup")- BuilderUnchanged _ `mappend` BuilderUnchanged b2 = BuilderUnchanged b2- ModifiedBuilder b1 `mappend` BuilderUnchanged _ = ModifiedBuilder b1- BuilderUnchanged _ `mappend` ModifiedBuilder b2 = ModifiedBuilder b2- ModifiedBuilder _ `mappend` ModifiedBuilder b2 = ModifiedBuilder b2+ x `mappend` y = x <> y -fromBuilderMod :: ModifiedBuilder m -> TreeBuilder m+fromBuilderMod :: ModifiedBuilder r m -> TreeBuilder r m fromBuilderMod (BuilderUnchanged tb) = tb fromBuilderMod (ModifiedBuilder tb) = tb {- $commits -}-data Commit m = Commit- { commitOid :: !(CommitOid m)- , commitParents :: ![CommitOid m]- , commitTree :: !(TreeOid m)+data Commit r = Commit+ { commitOid :: !(CommitOid r)+ , commitParents :: ![CommitOid r]+ , commitTree :: !(TreeOid r) , commitAuthor :: !Signature , commitCommitter :: !Signature , commitLog :: !CommitMessage , commitEncoding :: !Text } -lookupCommitParents :: Repository m => Commit m -> m [Commit m]-lookupCommitParents = mapM lookupCommit . commitParents+sourceCommitParents :: MonadGit r m => Commit r -> Producer m (Commit r)+sourceCommitParents commit =+ forM_ (commitParents commit) $ yield <=< lift . lookupCommit +lookupCommitParents :: MonadGit r m => Commit r -> m [Commit r]+lookupCommitParents commit = sourceCommitParents commit $$ CL.consume+ data Signature = Signature { signatureName :: !CommitAuthor , signatureEmail :: !CommitEmail , signatureWhen :: !ZonedTime } deriving Show -instance Default Signature where- def = Signature- { signatureName = T.empty- , signatureEmail = T.empty- , signatureWhen = ZonedTime- { zonedTimeToLocalTime = LocalTime- { localDay = ModifiedJulianDay 0- , localTimeOfDay = TimeOfDay 0 0 0- }- , zonedTimeZone = utc+defaultSignature :: Signature+defaultSignature = Signature+ { signatureName = T.empty+ , signatureEmail = T.empty+ , signatureWhen = ZonedTime+ { zonedTimeToLocalTime = LocalTime+ { localDay = ModifiedJulianDay 0+ , localTimeOfDay = TimeOfDay 0 0 0 }+ , zonedTimeZone = utc }+ } {- $tags -}-data Tag m = Tag- { tagOid :: !(TagOid m)- , tagCommit :: !(CommitOid m)+data Tag r = Tag+ { tagOid :: !(TagOid r)+ , tagCommit :: !(CommitOid r) } {- $objects -}-data Object m = BlobObj !(Blob m)- | TreeObj !(Tree m)- | CommitObj !(Commit m)- | TagObj !(Tag m)+data Object r m = BlobObj !(Blob r m)+ | TreeObj !(Tree r)+ | CommitObj !(Commit r)+ | TagObj !(Tag r) -objectOid :: Repository m => Object m -> Oid m-objectOid (BlobObj obj) = untag (blobOid obj)-objectOid (TreeObj obj) = untag (treeOid obj)-objectOid (CommitObj obj) = untag (commitOid obj)-objectOid (TagObj obj) = untag (tagOid obj)+objectOid :: MonadGit r m => Object r m -> m (Oid r)+objectOid (BlobObj obj) = return $ untag (blobOid obj)+objectOid (TreeObj obj) = untag <$> treeOid obj+objectOid (CommitObj obj) = return $ untag (commitOid obj)+objectOid (TagObj obj) = return $ untag (tagOid obj) -loadObject :: Repository m => ObjectOid m -> m (Object m)+loadObject :: MonadGit r m => ObjectOid r -> m (Object r m) loadObject (BlobObjOid oid) = BlobObj <$> lookupBlob oid loadObject (TreeObjOid oid) = TreeObj <$> lookupTree oid loadObject (CommitObjOid oid) = CommitObj <$> lookupCommit oid loadObject (TagObjOid oid) = TagObj <$> lookupTag oid -objectToObjOid :: Repository m => Object m -> ObjectOid m-objectToObjOid (BlobObj obj) = BlobObjOid (blobOid obj)-objectToObjOid (TreeObj obj) = TreeObjOid (treeOid obj)-objectToObjOid (CommitObj obj) = CommitObjOid (commitOid obj)-objectToObjOid (TagObj obj) = TagObjOid (tagOid obj)+objectToObjOid :: MonadGit r m => Object r m -> m (ObjectOid r)+objectToObjOid (BlobObj obj) = return $ BlobObjOid (blobOid obj)+objectToObjOid (TreeObj obj) = TreeObjOid <$> treeOid obj+objectToObjOid (CommitObj obj) = return $ CommitObjOid (commitOid obj)+objectToObjOid (TagObj obj) = return $ TagObjOid (tagOid obj) -untagObjOid :: Repository m => ObjectOid m -> Oid m+untagObjOid :: ObjectOid r -> Oid r untagObjOid (BlobObjOid oid) = untag oid untagObjOid (TreeObjOid oid) = untag oid untagObjOid (CommitObjOid oid) = untag oid untagObjOid (TagObjOid oid) = untag oid {- $references -}-data RefTarget m = RefObj !(Oid m) | RefSymbolic !RefName+data RefTarget (r :: *) = RefObj !(Oid r) | RefSymbolic !RefName -instance Repository m => Show (RefTarget m) where- show (RefObj oid) = "RefObj#" ++ T.unpack (renderOid oid)- show (RefSymbolic name) = "RefSymbolic#" ++ T.unpack name+-- instance Show (RefTarget r) where+-- show (RefObj oid) = "RefObj#" ++ T.unpack (renderOid oid)+-- show (RefSymbolic name) = "RefSymbolic#" ++ T.unpack name -commitRefTarget :: Commit m -> RefTarget m+commitRefTarget :: Commit r -> RefTarget r commitRefTarget = RefObj . untag . commitOid {- $merges -}@@ -356,37 +359,38 @@ mergeStatus TypeChanged Deleted = LeftTypeChangedRightDeleted mergeStatus TypeChanged TypeChanged = BothTypeChanged -data MergeResult m+data MergeResult r = MergeSuccess- { mergeCommit :: CommitOid m+ { mergeCommit :: CommitOid r } | MergeConflicted- { mergeCommit :: CommitOid m- , mergeHeadLeft :: CommitOid m- , mergeHeadRight :: CommitOid m+ { mergeCommit :: CommitOid r+ , mergeHeadLeft :: CommitOid r+ , mergeHeadRight :: CommitOid r , mergeConflicts ::- Map TreeFilePath (ModificationKind, ModificationKind)+ Map TreeFilePath (ModificationKind, ModificationKind) } -copyMergeResult :: (Repository m, MonadGit m, Repository n, MonadGit n)- => MergeResult m -> n (MergeResult n)+copyMergeResult :: (MonadGit r m, IsOid (Oid s))+ => MergeResult s -> m (MergeResult r) copyMergeResult (MergeSuccess mc) =- MergeSuccess <$> (Tagged <$> parseOid (renderObjOid mc))+ MergeSuccess <$> parseObjOid (renderObjOid mc) copyMergeResult (MergeConflicted hl hr mc cs) =- MergeConflicted <$> (Tagged <$> parseOid (renderObjOid hl))- <*> (Tagged <$> parseOid (renderObjOid hr))- <*> (Tagged <$> parseOid (renderObjOid mc))+ MergeConflicted <$> parseObjOid (renderObjOid hl)+ <*> parseObjOid (renderObjOid hr)+ <*> parseObjOid (renderObjOid mc) <*> pure cs -instance Repository m => Show (MergeResult m) where- show (MergeSuccess mc) = "MergeSuccess (" ++ show mc ++ ")"- show (MergeConflicted mc hl hr cs) =- "MergeResult"- ++ "\n { mergeCommit = " ++ show mc- ++ "\n , mergeHeadLeft = " ++ show hl- ++ "\n , mergeHeadRight = " ++ show hr- ++ "\n , mergeConflicts = " ++ show cs- ++ "\n }"+-- instance Show (MergeResult r) where+-- show (MergeSuccess mc) =+-- "MergeSuccess (" ++ T.unpack (renderObjOid mc) ++ ")"+-- show (MergeConflicted mc hl hr cs) =+-- "MergeResult"+-- ++ "\n { mergeCommit = " ++ T.unpack (renderObjOid mc)+-- ++ "\n , mergeHeadLeft = " ++ T.unpack (renderObjOid hl)+-- ++ "\n , mergeHeadRight = " ++ T.unpack (renderObjOid hr)+-- ++ "\n , mergeConflicts = " ++ show cs+-- ++ "\n }" {- $exceptions -} -- | There is a separate 'GitException' for each possible failure when@@ -406,6 +410,7 @@ | DiffTreeToIndexFailed Text | IndexAddFailed TreeFilePath Text | IndexCreateFailed Text+ | PathEncodingError Text | PushNotFastForward Text | TranslationException Text | TreeCreateFailed Text@@ -418,14 +423,14 @@ | TreeCannotTraverseCommit | TreeEntryLookupFailed TreeFilePath | TreeUpdateFailed- | TreeWalkFailed+ | TreeWalkFailed Text | TreeEmptyCreateFailed | CommitCreateFailed | CommitLookupFailed Text | ReferenceCreateFailed RefName | ReferenceDeleteFailed RefName | RefCannotCreateFromPartialOid- | ReferenceListingFailed+ | ReferenceListingFailed Text | ReferenceLookupFailed RefName | ObjectLookupFailed Text Int | ObjectRefRequiresFullOid
+ Git/Utils.hs view
@@ -0,0 +1,1 @@+module Git.Utils where
+ Git/Working.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE CPP #-}++module Git.Working where++import Control.Applicative+import Control.Failure+import Control.Monad.IO.Class+import Control.Monad.Trans.Resource+import Data.Conduit+import Data.Conduit.List as CL+import Data.Text as T+import Data.Semigroup+import Git.Blob+import Git.Types+import System.Directory+import System.FilePath+#if !mingw32_HOST_OS+import System.Posix.Files+#endif++checkoutFiles :: (MonadGit r m, MonadBaseControl IO m, MonadIO m,+ MonadResource m)+ => FilePath+ -> Tree r+ -> (TreeFilePath -> Either String FilePath)+ -> Bool+ -> m ()+checkoutFiles destPath tree decode cloneSubmodules =+ sourceTreeEntries tree $$ CL.mapM_ $ \(path, entry) ->+ case (destPath </>) <$> decode path of+ Left e -> decodeError path e+ Right fullPath -> do+ liftIO $ createDirectoryIfMissing True (takeDirectory fullPath)+ case entry of+ TreeEntry {} -> return ()+ BlobEntry oid kind -> checkoutBlob oid kind fullPath+ CommitEntry oid+ -- jww (2013-12-26): Recursively clone submodules?+ | cloneSubmodules -> cloneSubmodule oid fullPath+ | otherwise -> liftIO $ createDirectory fullPath+ where+ decodeError path e = failure $ PathEncodingError $+ "Could not decode path " <> T.pack (show path) <> ":" <> T.pack e++ checkoutBlob oid kind fullPath = do+ Blob _ contents <- lookupBlob oid+ case kind of+#if !mingw32_HOST_OS+ SymlinkBlob -> do+ target <- blobContentsToByteString contents+ case decode target of+ Left e -> decodeError target e+ Right targetPath ->+ liftIO $ createSymbolicLink targetPath fullPath+#endif+ _ -> do -- PlainBlob | ExecutableBlob+ -- jww (2013-12-26): There is no way to know what a tree's+ -- path has been encoded as.+ writeBlob fullPath contents++ cloneSubmodule =+ error "jww (2013-12-29): Cloning submodule is not yet implemented"
gitlib.cabal view
@@ -1,5 +1,5 @@ Name: gitlib-Version: 2.2.0.0+Version: 3.0.0 Synopsis: API library for working with Git repositories License-file: LICENSE License: MIT@@ -41,37 +41,47 @@ build-depends: base >= 3 && < 5 , base16-bytestring >= 0.1.1.5- , binary >= 0.5.1.0 , bytestring >= 0.9.2.1 , conduit >= 1.0.0 , containers >= 0.4.2.1- , data-default >= 0.5.0 , directory >= 1.1.0.2 , failure >= 0.2.0.1+ , filepath >= 1.3.0.0 , hashable >= 1.1.2.5 , lifted-base >= 0.2+ , monad-control >= 0.3.2.1+ , mtl >= 2.1.2+ , resourcet >= 0.4.8+ , semigroups >= 0.11 , tagged >= 0.2.3.1 , text >= 0.11.2 , time >= 1.4 , transformers >= 0.3.0.0 , unordered-containers >= 0.2.3.0+ if !os(mingw32)+ build-depends:+ unix >= 2.5.1.1 exposed-modules: Git- Git.Types Git.Blob- Git.Tree- Git.Tree.Builder- Git.Tree.Builder.Pure Git.Commit Git.Commit.Push Git.Object Git.Reference Git.Repository+ Git.Tree+ Git.Tree.Builder+ Git.Tree.Builder.Pure Git.Tutorial+ Git.Types+ Git.Utils+ Git.Working default-extensions: ConstraintKinds DeriveDataTypeable FlexibleContexts+ FunctionalDependencies+ MultiParamTypeClasses OverloadedStrings RankNTypes TypeFamilies