Subtree checkout option

2 files changed, 24 insertions, 1 deletions

diff --git a/src/Command/Checkout.hs b/src/Command/Checkout.hs
index 0ed062d..65857b8 100644
--- a/src/Command/Checkout.hs
+++ b/src/Command/Checkout.hs
@@ -15,6 +15,7 @@ data CheckoutCommand = CheckoutCommand CheckoutOptions (Maybe RepoName) Text
 
 data CheckoutOptions = CheckoutOptions
     { coPath :: Maybe FilePath
+    , coSubtree :: Maybe FilePath
     }
 
 instance Command CheckoutCommand where
@@ -30,12 +31,16 @@ instance Command CheckoutCommand where
     type CommandOptions CheckoutCommand = CheckoutOptions
     defaultCommandOptions _ = CheckoutOptions
         { coPath = Nothing
+        , coSubtree = Nothing
         }
 
     commandOptions _ =
         [ Option [] [ "path" ]
             (ReqArg (\val opts -> opts { coPath = Just val }) "<path>")
             "destination path"
+        , Option [] [ "subtree" ]
+            (ReqArg (\val opts -> opts { coSubtree = Just val }) "<path>")
+            "repository subtree to checkout"
         ]
 
     commandInit _ co = uncurry (CheckoutCommand co) . \case
@@ -47,5 +52,8 @@ instance Command CheckoutCommand where
 cmdCheckout :: CheckoutCommand -> CommandExec ()
 cmdCheckout (CheckoutCommand CheckoutOptions {..} name revision) = do
     repo <- maybe getDefaultRepo getRepo name
-    tree <- maybe (fail $ T.unpack $ "revision `" <> revision <> "' not found") getCommitTree =<< readCommit repo revision
+    root <- maybe (fail $ T.unpack $ "revision `" <> revision <> "' not found") getCommitTree =<< readCommit repo revision
+    tree <- case coSubtree of
+        Nothing -> return root
+        Just subtree -> maybe (fail $ "subtree `" <> subtree <> "' not found in revision `" <> T.unpack revision <> "'") return =<< getSubtree subtree root
     checkoutAt tree $ maybe "." id coPath
diff --git a/src/Repo.hs b/src/Repo.hs
index 0720179..ef95b36 100644
--- a/src/Repo.hs
+++ b/src/Repo.hs
@@ -19,6 +19,8 @@ module Repo (
     getCommitTitle,
     getCommitMessage,
 
+    getSubtree,
+
     checkoutAt,
     readCommittedFile,
 
@@ -245,6 +247,19 @@ getCommitMessage :: (MonadIO m, MonadFail m) => Commit -> m Text
 getCommitMessage = fmap commitMessage . getCommitDetails
 
 
+getSubtree :: MonadIO m => FilePath -> Tree -> m (Maybe Tree)
+getSubtree path tree = liftIO $ do
+    let GitRepo {..} = treeRepo tree
+    readProcessWithExitCode "git" [ "--git-dir=" <> gitDir, "rev-parse", "--verify", "--quiet", showTreeId (treeId tree) <> ":" <> path ] "" >>= \case
+        ( ExitSuccess, out, _ ) | tid : _ <- lines out -> do
+            return $ Just Tree
+                { treeRepo = treeRepo tree
+                , treeId = TreeId (BC.pack tid)
+                }
+        _ -> do
+            return Nothing
+
+
 checkoutAt :: (MonadIO m, MonadFail m) => Tree -> FilePath -> m ()
 checkoutAt Tree {..} dest = do
     let GitRepo {..} = treeRepo