module Data.Git.Phoenix.Extraction where

import Data.ByteString.Lazy.Char8 qualified as L8
import Data.Git.Phoenix.App
    ( PhoenixExtractConf(destGitDir, uberDir), PhoenixExtractM )
import Data.Git.Phoenix.CmdArgs ( ShaPrefix )
import Data.Git.Phoenix.Commit ( extractParent, extractTreeHash )
import Data.Git.Phoenix.Io
    ( writeBinaryFile,
      hPutLbs,
      saveCompressedBs,
      withCompressed,
      withCompressedH )
import Data.Git.Phoenix.Object
    ( classifyGitObject,
      toCommitSha,
      GitObjType(CommitType, BlobType, TreeType, CollidedHash),
      GitObjTypeG(Tree, Commit),
      GitPath(..) )
import Data.Git.Phoenix.Prelude
import Data.Git.Phoenix.Repo ( initGitRepo )
import Data.Git.Phoenix.Sha ( shaToPath )
import Data.Git.Phoenix.ShaCollision ( uniqBs )
import Data.Git.Phoenix.Tree ( extractTree )


readCommitObject :: forall m. PhoenixExtractM m => GitPath Commit -> m (Maybe (GitPath Commit), GitPath Tree)
readCommitObject :: forall (m :: * -> *).
PhoenixExtractM m =>
GitPath 'Commit -> m (Maybe (GitPath 'Commit), GitPath 'Tree)
readCommitObject GitPath 'Commit
gop = FilePath -> m (Maybe (GitPath 'Commit), GitPath 'Tree)
go (FilePath -> m (Maybe (GitPath 'Commit), GitPath 'Tree))
-> (Tagged InDir FilePath -> FilePath)
-> Tagged InDir FilePath
-> m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath -> FilePath
</> GitPath 'Commit -> FilePath
forall (t :: GitObjTypeG). GitPath t -> FilePath
toFp GitPath 'Commit
gop) (FilePath -> FilePath)
-> (Tagged InDir FilePath -> FilePath)
-> Tagged InDir FilePath
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tagged InDir FilePath -> FilePath
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged InDir FilePath
 -> m (Maybe (GitPath 'Commit), GitPath 'Tree))
-> m (Tagged InDir FilePath)
-> m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (PhoenixExtractConf -> Tagged InDir FilePath)
-> m (Tagged InDir FilePath)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PhoenixExtractConf -> Tagged InDir FilePath
uberDir
  where
    goCommit :: forall s. Bs s -> LazyT s m (Maybe (GitPath Commit), GitPath Tree)
    goCommit :: forall {k} (s :: k).
Bs s -> LazyT s m (Maybe (GitPath 'Commit), GitPath 'Tree)
goCommit Bs s
bs =
      Bs s -> LazyT s m (Bs s, Bs s)
forall {k} (m :: * -> *) (s :: k).
Monad m =>
Bs s -> LazyT s m (Bs s, Bs s)
extractTreeHash {- fix traceEmbrace to uncomment this snippet: $ $(tr "eee/bs") -} Bs s
bs LazyT s m (Bs s, Bs s)
-> ((Bs s, Bs s)
    -> LazyT s m (Maybe (GitPath 'Commit), GitPath 'Tree))
-> LazyT s m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall a b. LazyT s m a -> (a -> LazyT s m b) -> LazyT s m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (Bs s
"", Bs s
_) -> FilePath -> LazyT s m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall a. FilePath -> LazyT s m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> LazyT s m (Maybe (GitPath 'Commit), GitPath 'Tree))
-> FilePath -> LazyT s m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall a b. (a -> b) -> a -> b
$ GitPath 'Commit -> FilePath
forall b a. (Show a, IsString b) => a -> b
show GitPath 'Commit
gop FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" does not have tree field"
        (Bs s
treeComit, Bs s
bs') -> do
          gitDir <- Tagged OutDir FilePath -> FilePath
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged OutDir FilePath -> FilePath)
-> LazyT s m (Tagged OutDir FilePath) -> LazyT s m FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PhoenixExtractConf -> Tagged OutDir FilePath)
-> LazyT s m (Tagged OutDir FilePath)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PhoenixExtractConf -> Tagged OutDir FilePath
destGitDir
          saveCompressedBs (gitDir </> ".git" </> "objects" </> toFp gop) =<< toLbs bs
          extractParent bs' >>= \case
            (Bs s
"", Bs s
_) -> (Maybe (GitPath 'Commit)
forall a. Maybe a
Nothing, ) (GitPath 'Tree -> (Maybe (GitPath 'Commit), GitPath 'Tree))
-> (LByteString -> GitPath 'Tree)
-> LByteString
-> (Maybe (GitPath 'Commit), GitPath 'Tree)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> GitPath 'Tree
forall (a :: GitObjTypeG). FilePath -> GitPath a
shaToPath (FilePath -> GitPath 'Tree)
-> (LByteString -> FilePath) -> LByteString -> GitPath 'Tree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LByteString -> FilePath
L8.unpack (LByteString -> (Maybe (GitPath 'Commit), GitPath 'Tree))
-> LazyT s m LByteString
-> LazyT s m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bs s -> LazyT s m LByteString
forall {k} (m :: * -> *) (s :: k).
Monad m =>
Bs s -> LazyT s m LByteString
toLbs Bs s
treeComit
            (!Bs s
ph, Bs s
_) -> (,)
                        (Maybe (GitPath 'Commit)
 -> GitPath 'Tree -> (Maybe (GitPath 'Commit), GitPath 'Tree))
-> LazyT s m (Maybe (GitPath 'Commit))
-> LazyT
     s m (GitPath 'Tree -> (Maybe (GitPath 'Commit), GitPath 'Tree))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GitPath 'Commit -> Maybe (GitPath 'Commit)
forall a. a -> Maybe a
Just (GitPath 'Commit -> Maybe (GitPath 'Commit))
-> (LByteString -> GitPath 'Commit)
-> LByteString
-> Maybe (GitPath 'Commit)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> GitPath 'Commit
forall (a :: GitObjTypeG). FilePath -> GitPath a
shaToPath (FilePath -> GitPath 'Commit)
-> (LByteString -> FilePath) -> LByteString -> GitPath 'Commit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LByteString -> FilePath
L8.unpack (LByteString -> Maybe (GitPath 'Commit))
-> LazyT s m LByteString -> LazyT s m (Maybe (GitPath 'Commit))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bs s -> LazyT s m LByteString
forall {k} (m :: * -> *) (s :: k).
Monad m =>
Bs s -> LazyT s m LByteString
toLbs Bs s
ph)
                        LazyT
  s m (GitPath 'Tree -> (Maybe (GitPath 'Commit), GitPath 'Tree))
-> LazyT s m (GitPath 'Tree)
-> LazyT s m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall a b. LazyT s m (a -> b) -> LazyT s m a -> LazyT s m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ( $(tr "/treeComit") (GitPath 'Tree -> GitPath 'Tree)
-> (LByteString -> GitPath 'Tree) -> LByteString -> GitPath 'Tree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> GitPath 'Tree
forall (a :: GitObjTypeG). FilePath -> GitPath a
shaToPath (FilePath -> GitPath 'Tree)
-> (LByteString -> FilePath) -> LByteString -> GitPath 'Tree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LByteString -> FilePath
L8.unpack (LByteString -> GitPath 'Tree)
-> LazyT s m LByteString -> LazyT s m (GitPath 'Tree)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bs s -> LazyT s m LByteString
forall {k} (m :: * -> *) (s :: k).
Monad m =>
Bs s -> LazyT s m LByteString
toLbs Bs s
treeComit)
    go :: FilePath -> m (Maybe (GitPath 'Commit), GitPath 'Tree)
go FilePath
absGop = do
      lr <-
        FilePath
-> (forall (s :: ZonkAny 0).
    Tagged Compressed (Bs s)
    -> Bs s
    -> LazyT
         s
         m
         (Either
            (Tagged Compressed LByteString)
            (Maybe (GitPath 'Commit), GitPath 'Tree)))
-> m (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall {k} a (m :: * -> *).
(NFData a, MonadUnliftIO m, HasInHandlesSem m) =>
FilePath
-> (forall (s :: k).
    Tagged Compressed (Bs s) -> Bs s -> LazyT s m a)
-> m a
withCompressedH FilePath
absGop ((forall (s :: ZonkAny 0).
  Tagged Compressed (Bs s)
  -> Bs s
  -> LazyT
       s
       m
       (Either
          (Tagged Compressed LByteString)
          (Maybe (GitPath 'Commit), GitPath 'Tree)))
 -> m (Either
         (Tagged Compressed LByteString)
         (Maybe (GitPath 'Commit), GitPath 'Tree)))
-> (forall (s :: ZonkAny 0).
    Tagged Compressed (Bs s)
    -> Bs s
    -> LazyT
         s
         m
         (Either
            (Tagged Compressed LByteString)
            (Maybe (GitPath 'Commit), GitPath 'Tree)))
-> m (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall a b. (a -> b) -> a -> b
$ \Tagged Compressed (Bs s)
cbs Bs s
bs ->
          Bs s -> LazyT s m (Maybe GitObjType)
forall {k} (m :: * -> *) (s :: k).
Monad m =>
Bs s -> LazyT s m (Maybe GitObjType)
classifyGitObject Bs s
bs LazyT s m (Maybe GitObjType)
-> (Maybe GitObjType
    -> LazyT
         s
         m
         (Either
            (Tagged Compressed LByteString)
            (Maybe (GitPath 'Commit), GitPath 'Tree)))
-> LazyT
     s
     m
     (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall a b. LazyT s m a -> (a -> LazyT s m b) -> LazyT s m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just GitObjType
BlobType -> FilePath
-> LazyT
     s
     m
     (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall a. FilePath -> LazyT s m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath
 -> LazyT
      s
      m
      (Either
         (Tagged Compressed LByteString)
         (Maybe (GitPath 'Commit), GitPath 'Tree)))
-> FilePath
-> LazyT
     s
     m
     (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall a b. (a -> b) -> a -> b
$ GitPath 'Commit -> FilePath
forall b a. (Show a, IsString b) => a -> b
show GitPath 'Commit
gop FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" is Git blob but expected Git commit"
            Just GitObjType
TreeType -> FilePath
-> LazyT
     s
     m
     (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall a. FilePath -> LazyT s m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath
 -> LazyT
      s
      m
      (Either
         (Tagged Compressed LByteString)
         (Maybe (GitPath 'Commit), GitPath 'Tree)))
-> FilePath
-> LazyT
     s
     m
     (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall a b. (a -> b) -> a -> b
$ GitPath 'Commit -> FilePath
forall b a. (Show a, IsString b) => a -> b
show GitPath 'Commit
gop FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" is Git tree but expected Git commit"
            Just GitObjType
CommitType -> (Maybe (GitPath 'Commit), GitPath 'Tree)
-> Either
     (Tagged Compressed LByteString)
     (Maybe (GitPath 'Commit), GitPath 'Tree)
forall a b. b -> Either a b
Right ((Maybe (GitPath 'Commit), GitPath 'Tree)
 -> Either
      (Tagged Compressed LByteString)
      (Maybe (GitPath 'Commit), GitPath 'Tree))
-> LazyT s m (Maybe (GitPath 'Commit), GitPath 'Tree)
-> LazyT
     s
     m
     (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bs s -> LazyT s m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall {k} (s :: k).
Bs s -> LazyT s m (Maybe (GitPath 'Commit), GitPath 'Tree)
goCommit Bs s
bs
            Just GitObjType
CollidedHash -> Tagged Compressed LByteString
-> Either
     (Tagged Compressed LByteString)
     (Maybe (GitPath 'Commit), GitPath 'Tree)
forall a b. a -> Either a b
Left (Tagged Compressed LByteString
 -> Either
      (Tagged Compressed LByteString)
      (Maybe (GitPath 'Commit), GitPath 'Tree))
-> LazyT s m (Tagged Compressed LByteString)
-> LazyT
     s
     m
     (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tagged Compressed (LazyT s m LByteString)
-> LazyT s m (Tagged Compressed LByteString)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
Tagged Compressed (f a) -> f (Tagged Compressed a)
sequenceA ((Bs s -> LazyT s m LByteString)
-> Tagged Compressed (Bs s)
-> Tagged Compressed (LazyT s m LByteString)
forall a b. (a -> b) -> Tagged Compressed a -> Tagged Compressed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bs s -> LazyT s m LByteString
forall {k} (m :: * -> *) (s :: k).
Monad m =>
Bs s -> LazyT s m LByteString
toLbs Tagged Compressed (Bs s)
cbs)
            Maybe GitObjType
Nothing -> FilePath
-> LazyT
     s
     m
     (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall a. FilePath -> LazyT s m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath
 -> LazyT
      s
      m
      (Either
         (Tagged Compressed LByteString)
         (Maybe (GitPath 'Commit), GitPath 'Tree)))
-> FilePath
-> LazyT
     s
     m
     (Either
        (Tagged Compressed LByteString)
        (Maybe (GitPath 'Commit), GitPath 'Tree))
forall a b. (a -> b) -> a -> b
$ GitPath 'Commit -> FilePath
forall b a. (Show a, IsString b) => a -> b
show GitPath 'Commit
gop FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" is not a Git commit object"
      case lr of
        Right (Maybe (GitPath 'Commit), GitPath 'Tree)
cmt -> (Maybe (GitPath 'Commit), GitPath 'Tree)
-> m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (GitPath 'Commit), GitPath 'Tree)
cmt
        Left Tagged Compressed LByteString
cbs -> do
            uniPath <- GitPath 'Commit
-> Tagged Compressed LByteString -> GitObjType -> m FilePath
forall (m :: * -> *) (x :: GitObjTypeG).
PhoenixExtractM m =>
GitPath x
-> Tagged Compressed LByteString -> GitObjType -> m FilePath
uniqBs GitPath 'Commit
gop Tagged Compressed LByteString
cbs GitObjType
CommitType
            withCompressed uniPath $ \Bs s
ubs ->
              Bs s -> LazyT s m (Maybe GitObjType)
forall {k} (m :: * -> *) (s :: k).
Monad m =>
Bs s -> LazyT s m (Maybe GitObjType)
classifyGitObject Bs s
ubs LazyT s m (Maybe GitObjType)
-> (Maybe GitObjType
    -> LazyT s m (Maybe (GitPath 'Commit), GitPath 'Tree))
-> LazyT s m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall a b. LazyT s m a -> (a -> LazyT s m b) -> LazyT s m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Just GitObjType
CommitType -> Bs s -> LazyT s m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall {k} (s :: k).
Bs s -> LazyT s m (Maybe (GitPath 'Commit), GitPath 'Tree)
goCommit Bs s
ubs
                Maybe GitObjType
ops -> FilePath -> LazyT s m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall a. FilePath -> LazyT s m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> LazyT s m (Maybe (GitPath 'Commit), GitPath 'Tree))
-> FilePath -> LazyT s m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall a b. (a -> b) -> a -> b
$ FilePath
"Uniq BS of " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> GitPath 'Commit -> FilePath
forall b a. (Show a, IsString b) => a -> b
show GitPath 'Commit
gop FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" is not commit but " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Maybe GitObjType -> FilePath
forall b a. (Show a, IsString b) => a -> b
show Maybe GitObjType
ops

extractCommit :: PhoenixExtractM m => GitPath Commit -> m ()
extractCommit :: forall (m :: * -> *). PhoenixExtractM m => GitPath 'Commit -> m ()
extractCommit GitPath 'Commit
ohp = do
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO $(trIo "/ohp")
  (mParHash, treeHash) <- GitPath 'Commit -> m (Maybe (GitPath 'Commit), GitPath 'Tree)
forall (m :: * -> *).
PhoenixExtractM m =>
GitPath 'Commit -> m (Maybe (GitPath 'Commit), GitPath 'Tree)
readCommitObject GitPath 'Commit
ohp
  extractTree $ $(tw "/") treeHash
  mapM_ extractCommit mParHash

extractCommitChainAsRepo :: PhoenixExtractM m => Tagged ShaPrefix String -> m ()
extractCommitChainAsRepo :: forall (m :: * -> *).
PhoenixExtractM m =>
Tagged ShaPrefix FilePath -> m ()
extractCommitChainAsRepo (Tagged FilePath
rootCommit) = do
  (Tagged udr) <- (PhoenixExtractConf -> Tagged InDir FilePath)
-> m (Tagged InDir FilePath)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PhoenixExtractConf -> Tagged InDir FilePath
uberDir
  completePath (udr </> (toFp $ shaToPath rootCommit)) >>= \case
    [FilePath
up] -> do
      gitDir <- Tagged OutDir FilePath -> FilePath
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged OutDir FilePath -> FilePath)
-> m (Tagged OutDir FilePath) -> m FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PhoenixExtractConf -> Tagged OutDir FilePath)
-> m (Tagged OutDir FilePath)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks PhoenixExtractConf -> Tagged OutDir FilePath
destGitDir
      initGitRepo gitDir
      let uc = FilePath -> GitPath 'Commit
forall (a :: GitObjTypeG). FilePath -> GitPath a
GitPath (FilePath -> GitPath 'Commit)
-> (FilePath -> FilePath) -> FilePath -> GitPath 'Commit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. $(tw "/udr up") (FilePath -> GitPath 'Commit) -> FilePath -> GitPath 'Commit
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath
makeRelative FilePath
udr FilePath
up
      extractCommit uc
      writeBinaryFile
        (gitDir </> ".git" </> "refs" </> "heads" </> "master")
        WriteMode
        (`hPutLbs` toCommitSha uc)
    [] -> FilePath -> m ()
forall a. FilePath -> m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"No commit matching prefix: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> FilePath
forall b a. (Show a, IsString b) => a -> b
show FilePath
rootCommit
    [FilePath]
ambiP -> FilePath -> m ()
forall a. FilePath -> m a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Commit prefix is ambioguous:\n " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\n" [FilePath]
ambiP

completePath :: MonadUnliftIO m => FilePath -> m [FilePath]
completePath :: forall (m :: * -> *). MonadUnliftIO m => FilePath -> m [FilePath]
completePath FilePath
fp = do
  m Bool -> m [FilePath] -> m [FilePath] -> m [FilePath]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (FilePath -> m Bool
forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesFileExist FilePath
fp) ([FilePath] -> m [FilePath]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath
fp]) (m [FilePath] -> m [FilePath]) -> m [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ do
    m Bool -> m [FilePath] -> m [FilePath] -> m [FilePath]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (FilePath -> m Bool
forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesDirectoryExist FilePath
fp)
      (FilePath -> ([FilePath] -> [FilePath]) -> m [FilePath]
forall {m :: * -> *}.
MonadIO m =>
FilePath -> ([FilePath] -> [FilePath]) -> m [FilePath]
completeNonEmptyDir FilePath
fp [FilePath] -> [FilePath]
forall a. a -> a
id) (m [FilePath] -> m [FilePath]) -> m [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ do
        case FilePath -> (FilePath, FilePath)
splitFileName FilePath
fp of
          (FilePath
dp, FilePath
fpre) ->
            FilePath -> ([FilePath] -> [FilePath]) -> m [FilePath]
forall {m :: * -> *}.
MonadIO m =>
FilePath -> ([FilePath] -> [FilePath]) -> m [FilePath]
completeNonEmptyDir FilePath
dp ((FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath
fpre FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`))
  where
    completeNonEmptyDir :: FilePath -> ([FilePath] -> [FilePath]) -> m [FilePath]
completeNonEmptyDir FilePath
dp [FilePath] -> [FilePath]
fnf =
      FilePath -> m [FilePath]
forall (m :: * -> *). MonadIO m => FilePath -> m [FilePath]
listDirectory FilePath
dp m [FilePath] -> ([FilePath] -> m [FilePath]) -> m [FilePath]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\case [] -> [FilePath] -> m [FilePath]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath
dp] ; [FilePath]
o -> [FilePath] -> m [FilePath]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath] -> m [FilePath]) -> [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath
dp FilePath -> FilePath -> FilePath
</>) [FilePath]
o) ([FilePath] -> m [FilePath])
-> ([FilePath] -> [FilePath]) -> [FilePath] -> m [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> [FilePath]
fnf