gitlib-cmdline 1.2.1 → 1.3.1

raw patch · 2 files changed

+202/−267 lines, 2 filesdep −gitlib-utilsdep ~gitlibdep ~gitlib-cmdlinedep ~gitlib-testPVP ok

version bump matches the API change (PVP)

Dependencies removed: gitlib-utils

Dependency ranges changed: gitlib, gitlib-cmdline, gitlib-test

API changes (from Hackage documentation)

Files

• Git/CmdLine.hs +197/−260
• gitlib-cmdline.cabal +5/−7

@@ -27,7 +27,6 @@ import           Data.Function import           Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap-import           Data.IORef import           Data.List as L import qualified Data.Map as Map import           Data.Maybe@@ -46,7 +45,6 @@ import qualified Filesystem as F import qualified Filesystem.Path.CurrentOS as F import qualified Git-import qualified Git.Utils as Git import           Prelude hiding (FilePath) import           Shelly hiding (trace) import           System.Exit@@ -73,51 +71,42 @@ fromStrict = TL.fromStrict #endif -type BlobOid m    = Git.BlobOid (CmdLineRepository m)-type TreeOid m    = Git.TreeOid (CmdLineRepository m)-type CommitOid m  = Git.CommitOid (CmdLineRepository m)-type TagOid m     = Git.TagOid (CmdLineRepository m)+type BlobOid m         = Git.BlobOid (CmdLineRepository m)+type TreeOid m         = Git.TreeOid (CmdLineRepository m)+type CommitOid m       = Git.CommitOid (CmdLineRepository m)+type TagOid m          = Git.TagOid (CmdLineRepository m) -type Blob m       = Git.Blob (CmdLineRepository m)-type Tree m       = Git.Tree (CmdLineRepository m)-type TreeEntry m  = Git.TreeEntry (CmdLineRepository m)-type Commit m     = Git.Commit (CmdLineRepository m)-type Tag m        = Git.Tag (CmdLineRepository m)+type Blob m            = Git.Blob (CmdLineRepository m)+type Tree m            = Git.Tree (CmdLineRepository m)+type TreeEntry m       = Git.TreeEntry (CmdLineRepository m)+type Commit m          = Git.Commit (CmdLineRepository m)+type Tag m             = Git.Tag (CmdLineRepository m) -type TreeRef m    = Git.TreeRef (CmdLineRepository m)-type CommitRef m  = Git.CommitRef (CmdLineRepository m)-type CommitName m = Git.CommitName (CmdLineRepository m)+type TreeRef m         = Git.TreeRef (CmdLineRepository m)+type CommitRef m       = Git.CommitRef (CmdLineRepository m)+type CommitName m      = Git.CommitName (CmdLineRepository m) -type Reference m  = Git.Reference (CmdLineRepository m) (Commit m)-type Object m     = Git.Object (CmdLineRepository m)+type Reference m       = Git.Reference (CmdLineRepository m) (Commit m)+type Object m          = Git.Object (CmdLineRepository m)+type TreeBuilder m     = Git.TreeBuilder (CmdLineRepository m)+type ModifiedBuilder m = Git.ModifiedBuilder (CmdLineRepository m)  instance Git.MonadGit m => Git.Repository (CmdLineRepository m) where-    type Oid (CmdLineRepository m)  =-#if MIN_VERSION_shelly(1, 0, 0)-        Git.OidText-#else-        Git.OidTextL-#endif-    type TreeKind (CmdLineRepository m) = Git.PersistentTree-    type Tree (CmdLineRepository m) = HashMapTree m-+    type Oid (CmdLineRepository m) = Git.SHA+    data Tree (CmdLineRepository m) = CmdLineTree (TreeOid m)     data Options (CmdLineRepository m) = Options      facts = return Git.RepositoryFacts         { Git.hasSymbolicReferences = True } -#if MIN_VERSION_shelly(1, 0, 0)-    parseOid = Git.parseOidText-#else-    parseOid = Git.parseOidTextL-#endif+    parseOid = Git.textToSha -    lookupRef        = cliLookupRef-    createRef        = cliUpdateRef-    updateRef        = cliUpdateRef-    deleteRef        = cliDeleteRef-    resolveRef       = cliResolveRef-    allRefs          = cliAllRefs+    lookupReference  = cliLookupRef+    createReference  = cliUpdateRef+    updateReference  = cliUpdateRef+    deleteReference  = cliDeleteRef+    resolveReference = cliResolveRef+    allReferences    = cliAllRefs     lookupCommit     = cliLookupCommit     lookupTree       = cliLookupTree     lookupBlob       = cliLookupBlob@@ -128,30 +117,23 @@     traverseCommits  = cliTraverseCommits     missingObjects   = cliMissingObjects     traverseObjects  = error "Not defined: CmdLineRepository.traverseObjects"-    newTree          = cliNewTree-    cloneTree        = cliCloneTree+    newTreeBuilder   = cliNewTreeBuilder+    getTreeEntry     = cliTreeEntry     traverseEntries  = cliTraverseEntries-    unsafeUpdateTree = cliModifyTree-    writeTree        = cliWriteTree+    treeOid          = \(CmdLineTree toid) -> toid     hashContents     = cliHashContents     createBlob       = cliCreateBlob     createCommit     = cliCreateCommit     createTag        = cliCreateTag--    remoteFetch     = error "Not defined: CmdLineRepository.remoteFetch"-+    remoteFetch      = error "Not defined: CmdLineRepository.remoteFetch"     deleteRepository =         cliGet >>= liftIO . F.removeTree . Git.repoPath . repoOptions  git :: [TL.Text] -> Sh TL.Text-git args = do-    -- liftIO $ putStrLn $ "CmdLine: git " ++ show args-    run "git" args+git = run "git"  git_ :: [TL.Text] -> Sh ()-git_ args = do-    -- liftIO $ putStrLn $ "CmdLine: git " ++ show args-    run_ "git" args+git_ = run_ "git"  doRunGit :: Git.MonadGit m          => (FilePath -> [TL.Text] -> Sh a) -> [TL.Text] -> Sh ()@@ -160,8 +142,6 @@     repo <- cliGet     shellyNoDir $ silently $ do         act-        -- liftIO $ putStrLn $ "CmdLine: git "-        --     ++ show (["--git-dir", repoPath repo] <> args)         f "git" $ ["--git-dir", repoPath repo] <> args  runGit :: Git.MonadGit m@@ -219,7 +199,7 @@                          . toStrict <$> lastStderr     case merr of         Nothing  -> do-            mcref <- Git.resolveRef remoteRefName+            mcref <- Git.resolveReference remoteRefName             case mcref of                 Nothing   -> failure (Git.BackendError $ "git push failed")                 Just cref -> return cref@@ -239,7 +219,7 @@                           (Git.MergeResult (CmdLineRepository m)) cliPullCommitDirectly remoteNameOrURI remoteRefName user email msshCmd = do     repo     <- cliGet-    leftHead <- Git.resolveRef "HEAD"+    leftHead <- Git.resolveReference "HEAD"      eres <- shellyNoDir $ silently $ errExit False $ do         case msshCmd of@@ -307,7 +287,7 @@         git_ [ "--git-dir", repoPath repo, "add", toTextIgnore fp ]      getOid name = do-        mref <- Git.resolveRef name+        mref <- Git.resolveReference name         case mref of             Nothing  -> failure (Git.BackendError $                                  T.append "Reference missing: " name)@@ -341,23 +321,11 @@         (Just x, Just y)     -> (x, y)         (Nothing, Nothing)   -> error "Both merge items cannot be Unchanged" -#if MIN_VERSION_shelly(1, 0, 0)-type Oid = Git.OidText--mkOid :: T.Text -> Git.OidText-mkOid = Git.OidText--getOid :: Git.OidText -> T.Text-getOid = Git.getOidT-#else-type Oid = Git.OidTextL--mkOid :: TL.Text -> Git.OidTextL-mkOid = Git.OidTextL+mkOid :: Monad m => TL.Text -> m Git.SHA+mkOid = Git.textToSha . toStrict -getOid :: Git.OidTextL -> TL.Text-getOid = Git.getOidTL-#endif+getOid :: Git.SHA -> TL.Text+getOid = fromStrict . Git.shaToText  cliLookupBlob :: Git.MonadGit m               => BlobOid m -> CmdLineRepository m (Blob m)@@ -384,11 +352,7 @@              <> ["-w" | persist] <> ["--stdin"])             bs     if r == ExitSuccess-        then return . Tagged-                    . mkOid-                    . fromStrict-                    . T.init-                    . T.decodeUtf8 $ out+        then Tagged <$> (mkOid . fromStrict . T.init . T.decodeUtf8 $ out)         else failure Git.BlobCreateFailed  cliHashContents :: Git.MonadGit m@@ -401,7 +365,7 @@               -> CmdLineRepository m (BlobOid m) cliCreateBlob b = cliDoCreateBlob b True -cliExistsObject :: Git.MonadGit m => Oid -> CmdLineRepository m Bool+cliExistsObject :: Git.MonadGit m => Git.SHA -> CmdLineRepository m Bool cliExistsObject (getOid -> sha) = do     repo <- cliGet     shellyNoDir $ silently $ errExit False $ do@@ -444,148 +408,96 @@     go x = failure (Git.BackendError $                     "Unexpected output from git-log: " <> T.pack (show x)) -data HashMapTree m t = HashMapTree-    { cliTreeOid      :: IORef (Maybe (TreeOid m))-    , cliTreeContents :: IORef (HashMap Text (TreeEntry m))-    }--cliMakeTree :: IORef (Maybe (TreeOid m))-            -> IORef (HashMap Text (TreeEntry m))-            -> Tree m Git.PersistentTree-cliMakeTree oid contents = HashMapTree oid contents+type EntryHashMap m = HashMap Text (TreeEntry m) -cliNewTree :: Git.MonadGit m-           => CmdLineRepository m (Tree m Git.PersistentTree)-cliNewTree = cliMakeTree <$> liftIO (newIORef Nothing)-                         <*> liftIO (newIORef HashMap.empty)+cliMakeTree :: Git.MonadGit m+            => EntryHashMap m -> TreeBuilder m+cliMakeTree entMap = mempty <> Git.TreeBuilder+    { Git.mtbBaseTreeRef    = Nothing+    , Git.mtbPendingUpdates = mempty+    , Git.mtbNewBuilder    = cliNewTreeBuilder+    , Git.mtbWriteContents = \tb -> (,) <$> pure (Git.BuilderUnchanged tb)+                                        <*> cliWriteBuilder entMap+    , Git.mtbLookupEntry   = cliLookupBuilderEntry entMap+    , Git.mtbEntryCount    = cliBuilderEntryCount entMap+    , Git.mtbPutEntry      = flip cliPutEntry entMap+    , Git.mtbDropEntry     = flip cliDropEntry entMap+    } -cliCloneTree :: Git.MonadGit m-             => Tree m Git.PersistentTree-             -> CmdLineRepository m (Tree m Git.PersistentTree)-cliCloneTree (HashMapTree oid contents) =-    cliMakeTree <$> liftIO (newIORef =<< readIORef oid)-                <*> liftIO (newIORef =<< readIORef contents)+-- | Create a new, empty tree.+--+--   Since empty trees cannot exist in Git, attempting to write out an empty+--   tree is a no-op.+cliNewTreeBuilder :: Git.MonadGit m+                  => Maybe (Tree m) -> CmdLineRepository m (TreeBuilder m)+cliNewTreeBuilder mtree = do+    entMap <- case mtree of+        Nothing   -> return HashMap.empty+        Just tree -> go (Git.treeOid tree)+    return $ (cliMakeTree entMap) { Git.mtbBaseTreeRef = Git.treeRef <$> mtree } -cliModifyTree :: Git.MonadGit m-              => Tree m Git.PersistentTree-              -> FilePath-              -> Bool-              -> (Maybe (TreeEntry m)-                  -> Git.ModifyTreeResult (CmdLineRepository m))-              -> CmdLineRepository m (Tree m Git.PersistentTree, Maybe (TreeEntry m))-cliModifyTree t path createIfNotExist f =-    fmap Git.fromModifyTreeResult-        <$> doModifyTree t (Git.splitPath path) createIfNotExist   where-    -- Lookup the current name in this tree.  If it doesn't exist, and there-    -- are more names in the path and 'createIfNotExist' is True, create a new-    -- Tree and descend into it.  Otherwise, if it exists we'll have @Just-    -- (TreeEntry {})@, and if not we'll have Nothing.-    doModifyTree tr [] _ =-        return (tr, Git.TreeEntryPersistent . Git.TreeEntry . Git.Known $ tr)-    doModifyTree tr (name:names) createIfNotExist = do-        y' <- doLookupTreeEntry tr [name]-        y  <- if isNothing y' && createIfNotExist && not (null names)-              then Just . Git.TreeEntry . Git.Known <$> Git.newTree-              else return y'-        go tr name names y+    go (Tagged (getOid -> sha)) = do+        contents <- runGit ["ls-tree", "-z", sha]+        -- Even though the tree entries are separated by \NUL, for whatever+        -- reason @git ls-tree@ also outputs a newline at the end.+        HashMap.fromList+            <$> mapM cliParseLsTree (L.init (TL.splitOn "\NUL" contents)) -    -- If there are no further names in the path, call the transformer-    -- function, f.  It receives a @Maybe TreeEntry@ to indicate if there was-    -- a previous entry at this path.  It should return a 'Left' value to-    -- propagate out a user-defined error, or a @Maybe TreeEntry@ to indicate-    -- whether the entry at this path should be deleted or replaced with-    -- something new.-    ---    -- NOTE: There is no provision for leaving the entry unchanged!  It is-    -- assumed to always be changed, as we have no reliable method of testing-    -- object equality that is not O(n).-    go tr name [] y = do-        let ze = f y-        liftIO $ modifyIORef (cliTreeContents tr) $ case ze of-            Git.TreeEntryNotFound     -> id-            Git.TreeEntryPersistent _ -> id-            Git.TreeEntryDeleted      -> HashMap.delete name-            Git.TreeEntryMutated z'   -> HashMap.insert name z'-        return (tr, ze)+cliParseLsTree :: Git.MonadGit m+               => TL.Text -> CmdLineRepository m (Text, TreeEntry m)+cliParseLsTree line =+    let [prefix,path] = TL.splitOn "\t" line+        [mode,kind,sha] = TL.words prefix+    in liftM2 (,) (return (toStrict path)) $ case kind of+        "blob"   -> do+            oid <- Tagged <$> mkOid sha+            return $ Git.BlobEntry oid $ case mode of+                "100644" -> Git.PlainBlob+                "100755" -> Git.ExecutableBlob+                "120000" -> Git.SymlinkBlob+                _        -> Git.UnknownBlob+        "commit" -> Git.CommitEntry . Tagged <$> mkOid sha+        "tree"   -> Git.TreeEntry . Tagged <$> mkOid sha+        _ -> failure (Git.BackendError "This cannot happen") -    go tr _ _ Nothing                  = return (tr, Git.TreeEntryNotFound)-    go _ _ _ (Just Git.BlobEntry {})   = failure Git.TreeCannotTraverseBlob-    go _ _ _ (Just Git.CommitEntry {}) = failure Git.TreeCannotTraverseCommit+cliPutEntry :: Git.MonadGit m+            => TreeBuilder m -> EntryHashMap m -> Text -> TreeEntry m+            -> CmdLineRepository m (ModifiedBuilder m)+cliPutEntry tb entMap key ent =+    return . Git.ModifiedBuilder $+        tb <> cliMakeTree (HashMap.insert key ent entMap) -    -- If there are further names in the path, descend them now.  If-    -- 'createIfNotExist' was False and there is no 'Tree' under the current-    -- name, or if we encountered a 'Blob' when a 'Tree' was required, throw-    -- an exception to avoid colliding with user-defined 'Left' values.-    go tr name names (Just (Git.TreeEntry st')) = do-        st <- Git.resolveTreeRef st'-        (st'', ze) <- doModifyTree st names createIfNotExist-        case ze of-            Git.TreeEntryNotFound     -> return ()-            Git.TreeEntryPersistent _ -> return ()-            Git.TreeEntryDeleted      -> postUpdate tr st'' name-            Git.TreeEntryMutated _    -> postUpdate tr st'' name-        return (tr, ze)+cliDropEntry :: Git.MonadGit m+             => TreeBuilder m -> EntryHashMap m -> Text+             -> CmdLineRepository m (ModifiedBuilder m)+cliDropEntry tb entMap key =+    return . Git.ModifiedBuilder $+        tb <> cliMakeTree (HashMap.delete key entMap) -    -- Lookup the current name in this tree.  If it doesn't exist, and there-    -- are more names in the path and 'createIfNotExist' is True, create a new-    -- Tree and descend into it.  Otherwise, if it exists we'll have @Just-    -- (TreeEntry {})@, and if not we'll have Nothing.-    doLookupTreeEntry tr [] = return (Just (Git.treeEntry tr))-    doLookupTreeEntry tr (name:names) = do-      y <- liftIO $ HashMap.lookup name <$> readIORef (cliTreeContents tr)-      if null names-          then return y-          else case y of-              Just (Git.BlobEntry {})   -> failure Git.TreeCannotTraverseBlob-              Just (Git.CommitEntry {}) -> failure Git.TreeCannotTraverseCommit-              Just (Git.TreeEntry st)   -> do-                  st' <- Git.resolveTreeRef st-                  doLookupTreeEntry st' names-              _ -> return Nothing+cliLookupBuilderEntry :: Git.MonadGit m+                      => EntryHashMap m -> Text+                      -> CmdLineRepository m (Maybe (TreeEntry m))+cliLookupBuilderEntry entMap key = return $ HashMap.lookup key entMap -    postUpdate tr st name = liftIO $ do-        modifyIORef (cliTreeOid tr) (const Nothing)-        stc <- readIORef (cliTreeContents st)-        modifyIORef (cliTreeContents tr) $-            if HashMap.null stc-            then HashMap.delete name-            else HashMap.insert name (Git.treeEntry st)+cliBuilderEntryCount :: Git.MonadGit m+                     => EntryHashMap m -> CmdLineRepository m Int+cliBuilderEntryCount entMap = return $ HashMap.size entMap -cliLookupTree :: Git.MonadGit m-              => TreeOid m -> CmdLineRepository m (Tree m Git.PersistentTree)-cliLookupTree oid@(Tagged (getOid -> sha)) = do-    contents <- runGit ["ls-tree", "-z", sha]-    oidRef   <- liftIO $ newIORef (Just oid)-    -- Even though the tree entries are separated by \NUL, for whatever reason-    -- @git ls-tree@ also outputs a newline at the end.-    contentsRef <- liftIO $ newIORef $ HashMap.fromList $-                   map parseLine (L.init (TL.splitOn "\NUL" contents))-    return $ cliMakeTree oidRef contentsRef-  where-    parseLine line =-        let [prefix,path] = TL.splitOn "\t" line-            [mode,kind,sha] = TL.words prefix-        in (toStrict path,-            case kind of-            "blob"   -> Git.BlobEntry (Tagged (mkOid sha)) $-                        case mode of-                            "100644" -> Git.PlainBlob-                            "100755" -> Git.ExecutableBlob-                            "120000" -> Git.SymlinkBlob-                            _        -> Git.UnknownBlob-            "commit" -> Git.CommitEntry (Tagged (mkOid sha))-            "tree"   -> Git.TreeEntry (Git.ByOid (Tagged (mkOid sha)))-            _ -> error "This cannot happen")+cliTreeEntryCount :: Git.MonadGit m => Tree m -> CmdLineRepository m Int+cliTreeEntryCount t =+    L.length . L.init . TL.splitOn "\NUL"+        <$> runGit [ "ls-tree", "-z"+                   , fromStrict (Git.renderObjOid (Git.treeOid t)) ] -cliWriteTree :: Git.MonadGit m-             => Tree m Git.PersistentTree -> CmdLineRepository m (TreeOid m)-cliWriteTree tree = do-    contents <- liftIO $ readIORef (cliTreeContents tree)-    rendered <- mapM renderLine (HashMap.toList contents)+cliWriteBuilder :: Git.MonadGit m+                => EntryHashMap m+                -> CmdLineRepository m (TreeRef m)+cliWriteBuilder entMap = do+    rendered <- mapM renderLine (HashMap.toList entMap)     oid      <- doRunGit run ["mktree", "-z", "--missing"]                 $ setStdin $ TL.append (TL.intercalate "\NUL" rendered) "\NUL"-    return (Tagged (mkOid (TL.init oid)))+    Git.ByOid . Tagged <$> mkOid (TL.init oid)   where     renderLine (path, Git.BlobEntry (Tagged (getOid -> sha)) kind) =         return $ TL.concat [ case kind of@@ -598,38 +510,53 @@         return $ TL.concat [ "160000 commit "                            , fromStrict (Git.renderObjOid coid), "\t"                            , fromStrict path ]-    renderLine (path, Git.TreeEntry tref) = do-        treeOid <- Git.treeRefOid tref+    renderLine (path, Git.TreeEntry toid) = do         return $ TL.concat             [ "040000 tree "-            , fromStrict (Git.renderObjOid treeOid), "\t"+            , fromStrict (Git.renderObjOid toid), "\t"             , fromStrict path ] +cliLookupTree :: Git.MonadGit m => TreeOid m -> CmdLineRepository m (Tree m)+cliLookupTree oid@(Tagged (getOid -> sha)) = do+    repo <- cliGet+    ec <- shellyNoDir $ silently $ errExit False $ do+        git_ $ [ "--git-dir", repoPath repo, "cat-file", "-t", sha ]+        lastExitCode+    if ec == 0+        then return $ CmdLineTree oid+        else failure (Git.ObjectLookupFailed (toStrict sha) 40)++cliTreeEntry :: Git.MonadGit m => Tree m -> FilePath+             -> CmdLineRepository m (Maybe (TreeEntry m))+cliTreeEntry tree fp = do+    repo <- cliGet+    mentryLines <- shellyNoDir $ silently $ errExit False $ do+        contents <- git $ [ "--git-dir", repoPath repo+                          , "ls-tree", "-z"+                          , fromStrict (Git.renderObjOid (Git.treeOid tree))+                          , "--", toTextIgnore fp ]+        ec <- lastExitCode+        return $ if ec == 0+                 then Just $ L.init (TL.splitOn "\NUL" contents)+                 else Nothing+    case mentryLines of+        Nothing -> return Nothing+        Just entryLines -> do+            entries <- mapM cliParseLsTree entryLines+            return $ case entries of+                []        -> Nothing+                ((_,x):_) -> Just x+ cliTraverseEntries :: Git.MonadGit m                    => (FilePath -> TreeEntry m -> CmdLineRepository m b)-                   -> Tree m Git.PersistentTree+                   -> Tree m                    -> CmdLineRepository m [b] cliTraverseEntries f tree = do-    Tagged (getOid -> sha) <- Git.writeTree tree-    contents <- runGit ["ls-tree", "-t", "-r", "-z", sha]-    -- Even though the tree entries are separated by \NUL, for whatever reason-    -- @git ls-tree@ also outputs a newline at the end.-    mapM (uncurry f) $ map parseLine (L.init (TL.splitOn "\NUL" contents))-  where-    parseLine line =-        let [prefix,path] = TL.splitOn "\t" line-            [mode,kind,sha] = TL.words prefix-        in (fromText path,-            case kind of-            "blob"   -> Git.BlobEntry (Tagged (mkOid sha)) $-                        case mode of-                            "100644" -> Git.PlainBlob-                            "100755" -> Git.ExecutableBlob-                            "120000" -> Git.SymlinkBlob-                            _        -> Git.UnknownBlob-            "commit" -> Git.CommitEntry (Tagged (mkOid sha))-            "tree"   -> Git.TreeEntry (Git.ByOid (Tagged (mkOid sha)))-            _ -> error "This cannot happen")+    contents <- runGit [ "ls-tree", "-t", "-r", "-z"+                       , fromStrict (Git.renderObjOid (Git.treeOid tree)) ]+    mapM (uncurry go <=< cliParseLsTree) (L.init (TL.splitOn "\NUL" contents))+ where+   go = f . fromText . fromStrict  parseCliTime :: String -> ZonedTime parseCliTime = fromJust . parseTime defaultTimeLocale "%s %z"@@ -645,30 +572,32 @@ cliLookupCommit (Tagged (getOid -> sha)) = do     output <- doRunGit run ["cat-file", "--batch"]                   $ setStdin (TL.append sha "\n")-    case parse parseOutput "" (TL.unpack output) of+    result <- runParserT parseOutput () "" (TL.unpack output)+    case result of         Left e  -> failure $ Git.CommitLookupFailed (T.pack (show e))         Right c -> return c   where+    parseOutput :: Monad m => ParsecT String () (CmdLineRepository m) (Commit a)     parseOutput = do-        coid       <- Tagged . mkOid . TL.pack-                      <$> manyTill alphaNum space+        coid       <- manyTill alphaNum space         _          <- string "commit " *> manyTill digit newline-        treeOid    <- string "tree " *>-                      (Tagged . mkOid . TL.pack-                       <$> manyTill anyChar newline)-        parentOids <- many (string "parent " *>-                            (Tagged . mkOid . TL.pack-                             <$> manyTill anyChar newline))+        treeOid    <- string "tree " *> manyTill anyChar newline+        parentOids <- many (string "parent " *> manyTill anyChar newline)         author     <- parseSignature "author"         committer  <- parseSignature "committer"         message    <- newline *> many anyChar++        coid'  <- lift $ Tagged `liftM` mkOid (TL.pack coid)+        toid'  <- lift $ Tagged `liftM` mkOid (TL.pack treeOid)+        poids' <- lift $ mapM (liftM Tagged . mkOid . TL.pack) parentOids+         return Git.Commit-            { Git.commitOid       = coid+            { Git.commitOid       = coid'             , Git.commitAuthor    = author             , Git.commitCommitter = committer             , Git.commitLog       = T.pack (init message)-            , Git.commitTree      = Git.ByOid treeOid-            , Git.commitParents   = map Git.ByOid parentOids+            , Git.commitTree      = Git.ByOid toid'+            , Git.commitParents   = map Git.ByOid poids'             , Git.commitEncoding  = "utf-8"             } @@ -680,12 +609,16 @@             <*> (parseCliTime <$> manyTill anyChar newline)  cliCreateCommit :: Git.MonadGit m-                => [CommitRef m] -> TreeRef m-                -> Git.Signature -> Git.Signature -> Text -> Maybe Text+                => [CommitRef m]+                -> TreeRef m+                -> Git.Signature+                -> Git.Signature+                -> Text+                -> Maybe Text                 -> CmdLineRepository m (Commit m)-cliCreateCommit parents tree author committer message ref = do-    treeOid <- Git.treeRefOid tree-    let parentOids = map Git.commitRefOid parents+cliCreateCommit parents tref author committer message ref = do+    let treeOid    = Git.treeRefOid tref+        parentOids = map Git.commitRefOid parents     oid <- doRunGit run            (["commit-tree"]             <> [fromStrict (Git.renderObjOid treeOid)]@@ -703,8 +636,9 @@                       ]                 setStdin (fromStrict message) +    coid <- Tagged <$> mkOid (TL.init oid)     let commit = Git.Commit-            { Git.commitOid       = Tagged (mkOid (TL.init oid))+            { Git.commitOid       = coid             , Git.commitAuthor    = author             , Git.commitCommitter = committer             , Git.commitLog       = message@@ -738,10 +672,11 @@                            $ TL.lines rev                  else Nothing -nameAndShaToRef :: TL.Text -> TL.Text -> Reference m+nameAndShaToRef :: Git.MonadGit m+                => TL.Text -> TL.Text -> CmdLineRepository m (Reference m) nameAndShaToRef name sha =-    Git.Reference (toStrict name)-                  (Git.RefObj (Git.ByOid (Tagged (mkOid sha))))+    Git.Reference <$> pure (toStrict name)+                  <*> (Git.RefObj . Git.ByOid . Tagged <$> mkOid sha)  cliLookupRef :: Git.MonadGit m              => Text -> CmdLineRepository m (Maybe (Reference m))@@ -749,8 +684,8 @@     xs <- cliShowRef (Just refName)     let name = fromStrict refName         ref  = maybe Nothing (lookup name) xs-    return $ maybe Nothing (Just . uncurry nameAndShaToRef .-                            \sha -> (name,sha)) ref+    maybe (return Nothing)+        (fmap Just . uncurry nameAndShaToRef . \sha -> (name,sha)) ref  cliUpdateRef :: Git.MonadGit m              => Text -> Git.RefTarget (CmdLineRepository m) (Commit m)@@ -771,9 +706,9 @@            => CmdLineRepository m [Reference m] cliAllRefs = do     mxs <- cliShowRef Nothing-    return $ case mxs of-        Nothing -> []-        Just xs -> map (uncurry nameAndShaToRef) xs+    case mxs of+        Nothing -> return []+        Just xs -> mapM (uncurry nameAndShaToRef) xs  cliResolveRef :: Git.MonadGit m               => Text -> CmdLineRepository m (Maybe (CommitRef m))@@ -784,9 +719,9 @@                    , "rev-parse", "--quiet", "--verify"                    , fromStrict refName ]         ec  <- lastExitCode-        return $ if ec == 0-            then Just (Git.ByOid (Tagged (mkOid (TL.init rev))))-            else Nothing+        if ec == 0+            then Just . Git.ByOid . Tagged <$> mkOid (TL.init rev)+            else return Nothing  -- cliLookupTag :: TagOid -> CmdLineRepository Tag -- cliLookupTag oid = undefined@@ -804,7 +739,8 @@           <> TL.pack (formatTime defaultTimeLocale "%s %z"                       (Git.signatureWhen tagger))         , ""] <> TL.lines (fromStrict msg)-    return $ Git.Tag (Tagged (mkOid (TL.init tsha))) (Git.ByOid oid)+    Git.Tag <$> (Tagged <$> mkOid (TL.init tsha))+            <*> pure (Git.ByOid oid)  data Repository = Repository     { repoOptions :: Git.RepositoryOptions@@ -882,7 +818,8 @@     case F.toText path of         Left e -> failure (Git.BackendError e)         Right p -> do-            when (not exists && Git.repoAutoCreate opts) $+            when (not exists && Git.repoAutoCreate opts) $ do+                liftIO $ F.createTree (fromText (fromStrict p))                 shellyNoDir $ silently $                     git_ $ ["--git-dir", fromStrict p]                         <> ["--bare" | Git.repoIsBare opts]

@@ -1,5 +1,5 @@ Name:                gitlib-cmdline-Version:             1.2.1+Version:             1.3.1 Synopsis:            Gitlib repository backend that uses the git command-line tool. Description:         Gitlib repository backend that uses the git command-line tool. License-file:        LICENSE@@ -20,8 +20,7 @@   ghc-options: -Wall   build-depends:       base >= 3 && < 5-    , gitlib               >= 1.1.0-    , gitlib-utils         >= 1.1.0+    , gitlib               >= 1.3.1     , bytestring           >= 0.9.2.1     , conduit              >= 0.5.5     , containers           >= 0.4.2.1@@ -50,10 +49,9 @@   hs-source-dirs: test   build-depends:       base >=3-    , gitlib             >= 1.1.0-    , gitlib-utils       >= 1.1.0-    , gitlib-test        >= 1.1.0-    , gitlib-cmdline     >= 1.1.0+    , gitlib             >= 1.3.1+    , gitlib-test        >= 1.3.1+    , gitlib-cmdline     >= 1.3.1     , HUnit              >= 1.2.5     , hspec              >= 1.4.4     , hspec-expectations >= 0.3