{-# LANGUAGE FlexibleContexts, GADTs, OverloadedStrings, TemplateHaskell,
             TupleSections #-}
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
module HMGit.Internal.Core (
    ObjectType (..)
  , ObjectInfo (objectId, objectData, objectPath)
  , IndexEntry (..)
  , fromContents
  , storeObject
  , loadObject
  , loadTree
  , storeTree
  , loadIndex
  , storeIndex
  , HMGitStatus (statusChanged, statusNew, statusDeleted)
  , latestBlobHashes
  , indexedBlobHashes
  , getStatus
) where

import           HMGit.Internal.Core.Runner
import           HMGit.Internal.Exceptions
import           HMGit.Internal.Parser      (IndexEntry (..), ObjectType (..),
                                             indexParser, objectParser,
                                             putIndex, runByteStringParser,
                                             treeParser)
import           HMGit.Internal.Utils       (hexStr, strictOne)

import           Codec.Compression.Zlib     (compress, decompress)
import           Control.Exception.Safe     (MonadCatch, MonadThrow, catch,
                                             catchAny, throw)
import           Control.Monad              (MonadPlus, filterM)
import           Control.Monad.Extra        (ifM)
import           Control.Monad.IO.Class     (MonadIO (..))
import           Control.Monad.Trans        (lift)
import           Crypto.Hash.SHA1           (hashlazy)
import qualified Data.Binary.Put            as BP
import qualified Data.ByteString            as B
import qualified Data.ByteString.Lazy       as BL
import qualified Data.ByteString.UTF8       as BU
import           Data.Functor               (($>), (<&>))
import           Data.List                  (isPrefixOf)
import qualified Data.Map.Lazy              as ML
import qualified Data.Set                   as S
import           Data.String                (IsString (..))
import           Data.Tuple.Extra           (dupe, first, firstM, second)
import           Path                       (Dir, File, Rel)
import qualified Path                       as P
import qualified Path.IO                    as P
import           Prelude                    hiding (init)
import           System.IO                  (hPutStrLn, stderr)
import           System.Posix.Types         (CMode (..))
import           Text.Printf                (printf)

hmGitObjectsDirLength :: Int
hmGitObjectsDirLength :: Int
hmGitObjectsDirLength = Int
2

-- | Information for built objects
data ObjectInfo = ObjectInfo {
    ObjectInfo -> ByteString
objectId   :: BU.ByteString -- ^ Object ID, SHA1 hash value
  , ObjectInfo -> ByteString
objectData :: BL.ByteString -- ^ Object data, compressed by zlib
  , ObjectInfo -> Path Abs File
objectPath :: P.Path P.Abs P.File -- ^ Object relative file path based on root of working tree
  }

formatObject :: ObjectType
    -> BL.ByteString
    -> BL.ByteString
formatObject :: ObjectType -> ByteString -> ByteString
formatObject ObjectType
objType ByteString
contents = Put -> ByteString
BP.runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$
    ByteString -> Put
BP.putByteString (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ ObjectType -> String
forall a. Show a => a -> String
show ObjectType
objType)
        Put -> Put -> Put
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Word8 -> Put
BP.putWord8 Word8
32 -- Space
        Put -> Put -> Put
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ByteString -> Put
BP.putByteString (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int64 -> String
forall a. Show a => a -> String
show (Int64 -> String) -> Int64 -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BL.length ByteString
contents)
        Put -> Put -> Put
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Word8 -> Put
BP.putWord8 Word8
0
        Put -> Put -> Put
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ByteString -> Put
BP.putLazyByteString ByteString
contents

hashToObjectPath :: MonadCatch m
    => String
    -> HMGitT m (Either (P.Path P.Abs P.Dir) (P.Path P.Abs P.File))
hashToObjectPath :: String -> HMGitT m (Either (Path Abs Dir) (Path Abs File))
hashToObjectPath String
hexSha1
    | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
hexSha1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
hmGitObjectsDirLength = m (Either (Path Abs Dir) (Path Abs File))
-> HMGitT m (Either (Path Abs Dir) (Path Abs File))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
        (m (Either (Path Abs Dir) (Path Abs File))
 -> HMGitT m (Either (Path Abs Dir) (Path Abs File)))
-> m (Either (Path Abs Dir) (Path Abs File))
-> HMGitT m (Either (Path Abs Dir) (Path Abs File))
forall a b. (a -> b) -> a -> b
$ IOError -> m (Either (Path Abs Dir) (Path Abs File))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw
        (IOError -> m (Either (Path Abs Dir) (Path Abs File)))
-> IOError -> m (Either (Path Abs Dir) (Path Abs File))
forall a b. (a -> b) -> a -> b
$ String -> IOError
invalidArgument
        (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"hash prefix must be %d or more characters"
            Int
hmGitObjectsDirLength
    | Bool
otherwise = do
        (Path Rel Dir
dir, String
fname) <- (String -> ReaderT HMGitConfig m (Path Rel Dir))
-> (String, String) -> ReaderT HMGitConfig m (Path Rel Dir, String)
forall (m :: * -> *) a a' b.
Functor m =>
(a -> m a') -> (a, b) -> m (a', b)
firstM String -> ReaderT HMGitConfig m (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
P.parseRelDir
            ((String, String) -> ReaderT HMGitConfig m (Path Rel Dir, String))
-> (String, String) -> ReaderT HMGitConfig m (Path Rel Dir, String)
forall a b. (a -> b) -> a -> b
$ Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
hmGitObjectsDirLength String
hexSha1
        ((\Path Abs Dir
x Path Rel File
y -> Path Abs File -> Either (Path Abs Dir) (Path Abs File)
forall a b. b -> Either a b
Right (Path Abs File -> Either (Path Abs Dir) (Path Abs File))
-> Path Abs File -> Either (Path Abs Dir) (Path Abs File)
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
x Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
P.</> $(P.mkRelDir "objects") Path Rel Dir -> Path Rel File -> Path Rel File
forall b t. Path b Dir -> Path Rel t -> Path b t
P.</> Path Rel Dir
dir Path Rel Dir -> Path Rel File -> Path Rel File
forall b t. Path b Dir -> Path Rel t -> Path b t
P.</> Path Rel File
y)
            (Path Abs Dir
 -> Path Rel File -> Either (Path Abs Dir) (Path Abs File))
-> ReaderT HMGitConfig m (Path Abs Dir)
-> ReaderT
     HMGitConfig
     m
     (Path Rel File -> Either (Path Abs Dir) (Path Abs File))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT HMGitConfig m (Path Abs Dir)
forall (m :: * -> *). Monad m => HMGitT m (Path Abs Dir)
hmGitDBPath
            ReaderT
  HMGitConfig
  m
  (Path Rel File -> Either (Path Abs Dir) (Path Abs File))
-> ReaderT HMGitConfig m (Path Rel File)
-> HMGitT m (Either (Path Abs Dir) (Path Abs File))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (Path Rel File) -> ReaderT HMGitConfig m (Path Rel File)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> m (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
P.parseRelFile String
fname))
            HMGitT m (Either (Path Abs Dir) (Path Abs File))
-> (PathException
    -> HMGitT m (Either (Path Abs Dir) (Path Abs File)))
-> HMGitT m (Either (Path Abs Dir) (Path Abs File))
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \e :: PathException
e@(P.InvalidRelFile String
fp) -> if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
fp
                then ReaderT HMGitConfig m (Path Abs Dir)
forall (m :: * -> *). Monad m => HMGitT m (Path Abs Dir)
hmGitDBPath ReaderT HMGitConfig m (Path Abs Dir)
-> (Path Abs Dir -> Either (Path Abs Dir) (Path Abs File))
-> HMGitT m (Either (Path Abs Dir) (Path Abs File))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Path Abs Dir -> Either (Path Abs Dir) (Path Abs File)
forall a b. a -> Either a b
Left (Path Abs Dir -> Either (Path Abs Dir) (Path Abs File))
-> (Path Abs Dir -> Path Abs Dir)
-> Path Abs Dir
-> Either (Path Abs Dir) (Path Abs File)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
P.</> ($(P.mkRelDir "objects") Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
P.</> Path Rel Dir
dir))
                else m (Either (Path Abs Dir) (Path Abs File))
-> HMGitT m (Either (Path Abs Dir) (Path Abs File))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either (Path Abs Dir) (Path Abs File))
 -> HMGitT m (Either (Path Abs Dir) (Path Abs File)))
-> m (Either (Path Abs Dir) (Path Abs File))
-> HMGitT m (Either (Path Abs Dir) (Path Abs File))
forall a b. (a -> b) -> a -> b
$ PathException -> m (Either (Path Abs Dir) (Path Abs File))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw PathException
e

-- | Create object ID, path, zlib compressed data from object type and content
fromContents :: MonadCatch m
    => ObjectType
    -> BL.ByteString
    -> HMGitT m ObjectInfo
fromContents :: ObjectType -> ByteString -> HMGitT m ObjectInfo
fromContents ObjectType
objType ByteString
contents = String -> HMGitT m (Either (Path Abs Dir) (Path Abs File))
forall (m :: * -> *).
MonadCatch m =>
String -> HMGitT m (Either (Path Abs Dir) (Path Abs File))
hashToObjectPath (ByteString -> String
forall mono.
(MonoFoldable mono, PrintfArg (Element mono)) =>
mono -> String
hexStr ByteString
objId)
    HMGitT m (Either (Path Abs Dir) (Path Abs File))
-> (Either (Path Abs Dir) (Path Abs File) -> HMGitT m ObjectInfo)
-> HMGitT m ObjectInfo
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Path Abs Dir -> HMGitT m ObjectInfo)
-> (Path Abs File -> HMGitT m ObjectInfo)
-> Either (Path Abs Dir) (Path Abs File)
-> HMGitT m ObjectInfo
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
        (HMGitT m ObjectInfo -> Path Abs Dir -> HMGitT m ObjectInfo
forall a b. a -> b -> a
const (HMGitT m ObjectInfo -> Path Abs Dir -> HMGitT m ObjectInfo)
-> HMGitT m ObjectInfo -> Path Abs Dir -> HMGitT m ObjectInfo
forall a b. (a -> b) -> a -> b
$ BugException -> HMGitT m ObjectInfo
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (BugException -> HMGitT m ObjectInfo)
-> BugException -> HMGitT m ObjectInfo
forall a b. (a -> b) -> a -> b
$ String -> BugException
BugException String
"fromContents: hashToObjectPath must give the Abs file")
        (ObjectInfo -> HMGitT m ObjectInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ObjectInfo -> HMGitT m ObjectInfo)
-> (Path Abs File -> ObjectInfo)
-> Path Abs File
-> HMGitT m ObjectInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Path Abs File -> ObjectInfo
ObjectInfo ByteString
objId (ByteString -> ByteString
compress ByteString
objFormat))
    where
        objFormat :: ByteString
objFormat = ObjectType -> ByteString -> ByteString
formatObject ObjectType
objType ByteString
contents
        objId :: ByteString
objId = ByteString -> ByteString
hashlazy ByteString
objFormat

-- | Create an object to HMGit database
storeObject :: (MonadIO m, MonadCatch m)
    => ObjectType
    -> BL.ByteString
    -> HMGitT m B.ByteString
storeObject :: ObjectType -> ByteString -> HMGitT m ByteString
storeObject ObjectType
objType ByteString
contents = do
    ObjectInfo
objInfo <- ObjectType -> ByteString -> HMGitT m ObjectInfo
forall (m :: * -> *).
MonadCatch m =>
ObjectType -> ByteString -> HMGitT m ObjectInfo
fromContents ObjectType
objType ByteString
contents
    Bool -> Path Abs Dir -> ReaderT HMGitConfig m ()
forall (m :: * -> *) b. MonadIO m => Bool -> Path b Dir -> m ()
P.createDirIfMissing Bool
True (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
P.parent (Path Abs File -> Path Abs Dir) -> Path Abs File -> Path Abs Dir
forall a b. (a -> b) -> a -> b
$ ObjectInfo -> Path Abs File
objectPath ObjectInfo
objInfo)
        ReaderT HMGitConfig m ()
-> ReaderT HMGitConfig m () -> ReaderT HMGitConfig m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO () -> ReaderT HMGitConfig m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> ByteString -> IO ()
BL.writeFile (Path Abs File -> String
forall b t. Path b t -> String
P.toFilePath (Path Abs File -> String) -> Path Abs File -> String
forall a b. (a -> b) -> a -> b
$ ObjectInfo -> Path Abs File
objectPath ObjectInfo
objInfo) (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ObjectInfo -> ByteString
objectData ObjectInfo
objInfo)
        ReaderT HMGitConfig m () -> ByteString -> HMGitT m ByteString
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ObjectInfo -> ByteString
objectId ObjectInfo
objInfo

-- | Read an object from HMGit database by Object ID
loadObject :: (MonadIO m, MonadCatch m, MonadPlus m)
    => String
    -> HMGitT m (ObjectType, BL.ByteString)
loadObject :: String -> HMGitT m (ObjectType, ByteString)
loadObject String
sha1 = do
    Path Abs File
fname <- String -> HMGitT m (Either (Path Abs Dir) (Path Abs File))
forall (m :: * -> *).
MonadCatch m =>
String -> HMGitT m (Either (Path Abs Dir) (Path Abs File))
hashToObjectPath String
sha1
        HMGitT m (Either (Path Abs Dir) (Path Abs File))
-> (Either (Path Abs Dir) (Path Abs File)
    -> ReaderT HMGitConfig m (Path Abs File))
-> ReaderT HMGitConfig m (Path Abs File)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Path Abs Dir -> String -> ReaderT HMGitConfig m (Path Abs File))
-> (Path Abs Dir, String) -> ReaderT HMGitConfig m (Path Abs File)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Path Abs Dir -> String -> ReaderT HMGitConfig m (Path Abs File)
findTarget ((Path Abs Dir, String) -> ReaderT HMGitConfig m (Path Abs File))
-> (Either (Path Abs Dir) (Path Abs File)
    -> (Path Abs Dir, String))
-> Either (Path Abs Dir) (Path Abs File)
-> ReaderT HMGitConfig m (Path Abs File)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path Abs Dir -> (Path Abs Dir, String))
-> (Path Abs File -> (Path Abs Dir, String))
-> Either (Path Abs Dir) (Path Abs File)
-> (Path Abs Dir, String)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (,String
forall a. Monoid a => a
mempty) ((Path Abs File -> Path Abs Dir)
-> (Path Abs File, String) -> (Path Abs Dir, String)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
P.parent ((Path Abs File, String) -> (Path Abs Dir, String))
-> (Path Abs File -> (Path Abs File, String))
-> Path Abs File
-> (Path Abs Dir, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path Abs File -> String)
-> (Path Abs File, Path Abs File) -> (Path Abs File, String)
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second (Path Rel File -> String
forall b t. Path b t -> String
P.toFilePath (Path Rel File -> String)
-> (Path Abs File -> Path Rel File) -> Path Abs File -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
P.filename) ((Path Abs File, Path Abs File) -> (Path Abs File, String))
-> (Path Abs File -> (Path Abs File, Path Abs File))
-> Path Abs File
-> (Path Abs File, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> (Path Abs File, Path Abs File)
forall a. a -> (a, a)
dupe)
    IO ByteString -> ReaderT HMGitConfig m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
BL.readFile (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
P.toFilePath Path Abs File
fname)
        ReaderT HMGitConfig m ByteString
-> (ByteString -> HMGitT m (ObjectType, ByteString))
-> HMGitT m (ObjectType, ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parsec ParseException ByteString (ObjectType, ByteString)
-> Path Abs File -> ByteString -> HMGitT m (ObjectType, ByteString)
forall (m :: * -> *) e s a b t.
(MonadThrow m, Show e, ShowErrorComponent e, Typeable e,
 VisualStream s, TraversableStream s, Typeable s, Show s,
 Show (Token s)) =>
Parsec e s a -> Path b t -> s -> m a
runByteStringParser Parsec ParseException ByteString (ObjectType, ByteString)
objectParser Path Abs File
fname (ByteString -> HMGitT m (ObjectType, ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> HMGitT m (ObjectType, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
decompress
    where
        findTarget :: Path Abs Dir -> String -> ReaderT HMGitConfig m (Path Abs File)
findTarget Path Abs Dir
dir String
fname = ReaderT HMGitConfig m (Path Abs File)
-> (SomeException -> ReaderT HMGitConfig m (Path Abs File))
-> ReaderT HMGitConfig m (Path Abs File)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
catchAny (Path Abs Dir -> String -> ReaderT HMGitConfig m (Path Abs File)
forall (f :: * -> *) b.
(MonadIO f, MonadPlus f, MonadThrow f) =>
Path b Dir -> String -> f (Path b File)
findTargetObject Path Abs Dir
dir String
fname) ((SomeException -> ReaderT HMGitConfig m (Path Abs File))
 -> ReaderT HMGitConfig m (Path Abs File))
-> (SomeException -> ReaderT HMGitConfig m (Path Abs File))
-> ReaderT HMGitConfig m (Path Abs File)
forall a b. (a -> b) -> a -> b
$ ReaderT HMGitConfig m (Path Abs File)
-> SomeException -> ReaderT HMGitConfig m (Path Abs File)
forall a b. a -> b -> a
const
            (ReaderT HMGitConfig m (Path Abs File)
 -> SomeException -> ReaderT HMGitConfig m (Path Abs File))
-> ReaderT HMGitConfig m (Path Abs File)
-> SomeException
-> ReaderT HMGitConfig m (Path Abs File)
forall a b. (a -> b) -> a -> b
$ m (Path Abs File) -> ReaderT HMGitConfig m (Path Abs File)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
            (m (Path Abs File) -> ReaderT HMGitConfig m (Path Abs File))
-> m (Path Abs File) -> ReaderT HMGitConfig m (Path Abs File)
forall a b. (a -> b) -> a -> b
$ IOError -> m (Path Abs File)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw
            (IOError -> m (Path Abs File)) -> IOError -> m (Path Abs File)
forall a b. (a -> b) -> a -> b
$ String -> String -> IOError
noSuchThing
                (String -> String -> Int -> String -> String
forall r. PrintfType r => String -> r
printf String
"objects %s not found or multiple object (%d) with prefix %s"
                    String
sha1 (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
sha1) String
sha1)
                (Path Abs Dir -> String
forall b t. Path b t -> String
P.toFilePath Path Abs Dir
dir String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fname)

        findTargetObject :: Path b Dir -> String -> f (Path b File)
findTargetObject Path b Dir
dir String
fname = Path b Dir -> f ([Path Rel Dir], [Path Rel File])
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Rel Dir], [Path Rel File])
P.listDirRel Path b Dir
dir
            f ([Path Rel Dir], [Path Rel File])
-> (([Path Rel Dir], [Path Rel File]) -> f (Path Rel File))
-> f (Path Rel File)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Path Rel File] -> f (Path Rel File)
forall (m :: * -> *) a. (MonadPlus m, MonadThrow m) => [a] -> m a
strictOne ([Path Rel File] -> f (Path Rel File))
-> (([Path Rel Dir], [Path Rel File]) -> [Path Rel File])
-> ([Path Rel Dir], [Path Rel File])
-> f (Path Rel File)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path Rel File -> Bool) -> [Path Rel File] -> [Path Rel File]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
fname (String -> Bool)
-> (Path Rel File -> String) -> Path Rel File -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel File -> String
forall b t. Path b t -> String
P.toFilePath) ([Path Rel File] -> [Path Rel File])
-> (([Path Rel Dir], [Path Rel File]) -> [Path Rel File])
-> ([Path Rel Dir], [Path Rel File])
-> [Path Rel File]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Path Rel Dir], [Path Rel File]) -> [Path Rel File]
forall a b. (a, b) -> b
snd
            f (Path Rel File)
-> (Path Rel File -> Path b File) -> f (Path b File)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Path b Dir
dir Path b Dir -> Path Rel File -> Path b File
forall b t. Path b Dir -> Path Rel t -> Path b t
P.</>)

-- | Read a tree from raw data
loadTree :: MonadThrow m
    => BL.ByteString
    -> HMGitT m [(CMode, P.Path P.Rel P.File, String)]
loadTree :: ByteString -> HMGitT m [(CMode, Path Rel File, String)]
loadTree ByteString
body = HMGitT m Int
forall (m :: * -> *). Monad m => HMGitT m Int
hmGitTreeLim
    HMGitT m Int
-> (Int -> HMGitT m [(CMode, Path Rel File, String)])
-> HMGitT m [(CMode, Path Rel File, String)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Parsec ParseException ByteString [(CMode, Path Rel File, String)]
 -> ByteString -> HMGitT m [(CMode, Path Rel File, String)])
-> ByteString
-> Parsec
     ParseException ByteString [(CMode, Path Rel File, String)]
-> HMGitT m [(CMode, Path Rel File, String)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Parsec ParseException ByteString [(CMode, Path Rel File, String)]
-> Path Rel File
-> ByteString
-> HMGitT m [(CMode, Path Rel File, String)]
forall (m :: * -> *) e s a b t.
(MonadThrow m, Show e, ShowErrorComponent e, Typeable e,
 VisualStream s, TraversableStream s, Typeable s, Show s,
 Show (Token s)) =>
Parsec e s a -> Path b t -> s -> m a
`runByteStringParser` $(P.mkRelFile "index")) ByteString
body
     (Parsec ParseException ByteString [(CMode, Path Rel File, String)]
 -> HMGitT m [(CMode, Path Rel File, String)])
-> (Int
    -> Parsec
         ParseException ByteString [(CMode, Path Rel File, String)])
-> Int
-> HMGitT m [(CMode, Path Rel File, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> Parsec
     ParseException ByteString [(CMode, Path Rel File, String)]
treeParser

-- | Create a tree object to HMGit database
-- __NOTE__: Currently only supports a single, top-level directory
storeTree :: (MonadIO m, MonadCatch m) => HMGitT m B.ByteString
storeTree :: HMGitT m ByteString
storeTree = HMGitT m [IndexEntry]
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
HMGitT m [IndexEntry]
loadIndex
    HMGitT m [IndexEntry]
-> ([IndexEntry] -> HMGitT m [IndexEntry]) -> HMGitT m [IndexEntry]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IndexEntry -> ReaderT HMGitConfig m Bool)
-> [IndexEntry] -> HMGitT m [IndexEntry]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM IndexEntry -> ReaderT HMGitConfig m Bool
forall (m :: * -> *). MonadIO m => IndexEntry -> m Bool
predUnsupported
    HMGitT m [IndexEntry]
-> ([IndexEntry] -> HMGitT m ByteString) -> HMGitT m ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ObjectType -> ByteString -> HMGitT m ByteString
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
ObjectType -> ByteString -> HMGitT m ByteString
storeObject ObjectType
Tree (ByteString -> HMGitT m ByteString)
-> ([IndexEntry] -> ByteString)
-> [IndexEntry]
-> HMGitT m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IndexEntry -> ByteString) -> [IndexEntry] -> ByteString
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Put -> ByteString
BP.runPut (Put -> ByteString)
-> (IndexEntry -> Put) -> IndexEntry -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndexEntry -> Put
putter)
    where
        predUnsupported :: IndexEntry -> m Bool
predUnsupported IndexEntry
e
            | Char
'/' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Path Rel File -> String
forall b t. Path b t -> String
P.toFilePath (IndexEntry -> Path Rel File
iePath IndexEntry
e) =
                IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr
                    (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"warning: sorry, currently only supports a single, top-level directory, so %s is ignored."
                        (Path Rel File -> String
forall b t. Path b t -> String
P.toFilePath (Path Rel File -> String) -> Path Rel File -> String
forall a b. (a -> b) -> a -> b
$ IndexEntry -> Path Rel File
iePath IndexEntry
e)) IO () -> Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False
            | Bool
otherwise = Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        putter :: IndexEntry -> Put
putter IndexEntry
e = ByteString -> Put
BP.putLazyByteString (String -> ByteString
forall a. IsString a => String -> a
fromString (String -> Word32 -> String -> String
forall r. PrintfType r => String -> r
printf String
"%o %s\0" (IndexEntry -> Word32
ieMode IndexEntry
e) (Path Rel File -> String
forall b t. Path b t -> String
P.toFilePath (Path Rel File -> String) -> Path Rel File -> String
forall a b. (a -> b) -> a -> b
$ IndexEntry -> Path Rel File
iePath IndexEntry
e)))
            Put -> Put -> Put
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ByteString -> Put
BP.putLazyByteString (IndexEntry -> ByteString
ieSha1 IndexEntry
e)

-- | Read index entries
loadIndex :: (MonadIO m, MonadThrow m) => HMGitT m [IndexEntry]
loadIndex :: HMGitT m [IndexEntry]
loadIndex = do
    Path Abs File
fname <- HMGitT m (Path Abs File)
forall (m :: * -> *). Monad m => HMGitT m (Path Abs File)
hmGitIndexPath
    ReaderT HMGitConfig m Bool
-> HMGitT m [IndexEntry]
-> HMGitT m [IndexEntry]
-> HMGitT m [IndexEntry]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Bool -> Bool
not (Bool -> Bool)
-> ReaderT HMGitConfig m Bool -> ReaderT HMGitConfig m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs File -> ReaderT HMGitConfig m Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
P.doesFileExist Path Abs File
fname) ([IndexEntry] -> HMGitT m [IndexEntry]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) (HMGitT m [IndexEntry] -> HMGitT m [IndexEntry])
-> HMGitT m [IndexEntry] -> HMGitT m [IndexEntry]
forall a b. (a -> b) -> a -> b
$
        IO ByteString -> ReaderT HMGitConfig m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
BL.readFile (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
P.toFilePath Path Abs File
fname)
            ReaderT HMGitConfig m ByteString
-> (ByteString -> HMGitT m [IndexEntry]) -> HMGitT m [IndexEntry]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parsec ParseException ByteString [IndexEntry]
-> Path Abs File -> ByteString -> HMGitT m [IndexEntry]
forall (m :: * -> *) e s a b t.
(MonadThrow m, Show e, ShowErrorComponent e, Typeable e,
 VisualStream s, TraversableStream s, Typeable s, Show s,
 Show (Token s)) =>
Parsec e s a -> Path b t -> s -> m a
runByteStringParser Parsec ParseException ByteString [IndexEntry]
indexParser Path Abs File
fname

-- | Write index entries
storeIndex :: (MonadIO m, Foldable t)
    => t IndexEntry
    -> HMGitT m ()
storeIndex :: t IndexEntry -> HMGitT m ()
storeIndex t IndexEntry
es = HMGitT m (Path Abs File)
forall (m :: * -> *). Monad m => HMGitT m (Path Abs File)
hmGitIndexPath
    HMGitT m (Path Abs File)
-> (Path Abs File -> HMGitT m ()) -> HMGitT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> HMGitT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> HMGitT m ())
-> (Path Abs File -> IO ()) -> Path Abs File -> HMGitT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ByteString -> IO ()) -> ByteString -> String -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> ByteString -> IO ()
B.writeFile (ByteString
idxData ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
digest) (String -> IO ())
-> (Path Abs File -> String) -> Path Abs File -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> String
forall b t. Path b t -> String
P.toFilePath
    where
        digest :: ByteString
digest = ByteString -> ByteString
hashlazy (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict ByteString
idxData
        idxData :: ByteString
idxData = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
BP.runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ t IndexEntry -> Put
forall (t :: * -> *). Foldable t => t IndexEntry -> Put
putIndex t IndexEntry
es

-- | Calculates the latest, or current,
-- hash of the working tree and returns a map of its path and hash value.
--
-- __NOTE__: Currently `latestBlobHashes` does not support gitignore and submodule,
-- so we are embedding content to ignore directly in the code.
-- Comments HACK below are the relevant part.
latestBlobHashes :: (MonadIO m, MonadCatch m)
    => HMGitT m (ML.Map (P.Path P.Rel P.File) String)
latestBlobHashes :: HMGitT m (Map (Path Rel File) String)
latestBlobHashes = HMGitT m (Path Abs Dir)
forall (m :: * -> *). Monad m => HMGitT m (Path Abs Dir)
hmGitRoot
    HMGitT m (Path Abs Dir)
-> (Path Abs Dir
    -> ReaderT HMGitConfig m [(Path Rel File, String)])
-> ReaderT HMGitConfig m [(Path Rel File, String)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe
  (Path Rel Dir
   -> [Path Rel Dir]
   -> [Path Rel File]
   -> ReaderT HMGitConfig m (WalkAction Rel))
-> (Path Rel Dir
    -> [Path Rel Dir]
    -> [Path Rel File]
    -> ReaderT HMGitConfig m [(Path Rel File, String)])
-> Path Abs Dir
-> ReaderT HMGitConfig m [(Path Rel File, String)]
forall (m :: * -> *) o b.
(MonadIO m, Monoid o) =>
Maybe
  (Path Rel Dir
   -> [Path Rel Dir] -> [Path Rel File] -> m (WalkAction Rel))
-> (Path Rel Dir -> [Path Rel Dir] -> [Path Rel File] -> m o)
-> Path b Dir
-> m o
P.walkDirAccumRel ((Path Rel Dir
 -> [Path Rel Dir]
 -> [Path Rel File]
 -> ReaderT HMGitConfig m (WalkAction Rel))
-> Maybe
     (Path Rel Dir
      -> [Path Rel Dir]
      -> [Path Rel File]
      -> ReaderT HMGitConfig m (WalkAction Rel))
forall a. a -> Maybe a
Just Path Rel Dir
-> [Path Rel Dir]
-> [Path Rel File]
-> ReaderT HMGitConfig m (WalkAction Rel)
forall (m :: * -> *) p p.
MonadThrow m =>
Path Rel Dir -> p -> p -> ReaderT HMGitConfig m (WalkAction Rel)
dirPred) Path Rel Dir
-> [Path Rel Dir]
-> [Path Rel File]
-> ReaderT HMGitConfig m [(Path Rel File, String)]
forall (m :: * -> *) p t.
(MonadIO m, MonadCatch m) =>
Path Rel Dir
-> p
-> [Path Rel t]
-> ReaderT HMGitConfig m [(Path Rel t, String)]
dirAccum
    ReaderT HMGitConfig m [(Path Rel File, String)]
-> ([(Path Rel File, String)] -> Map (Path Rel File) String)
-> HMGitT m (Map (Path Rel File) String)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [(Path Rel File, String)] -> Map (Path Rel File) String
forall k a. Ord k => [(k, a)] -> Map k a
ML.fromList
    where
        dirPred :: Path Rel Dir -> p -> p -> ReaderT HMGitConfig m (WalkAction Rel)
dirPred Path Rel Dir
d p
_ p
_
            | $(P.mkRelDir "./") Path Rel Dir -> Path Rel Dir -> Bool
forall a. Eq a => a -> a -> Bool
== Path Rel Dir
d = do
                Path Rel Dir
dbDir <- HMGitT m String
forall (m :: * -> *). Monad m => HMGitT m String
hmGitDBName HMGitT m String
-> (String -> ReaderT HMGitConfig m (Path Rel Dir))
-> ReaderT HMGitConfig m (Path Rel Dir)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ReaderT HMGitConfig m (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
P.parseRelDir
                WalkAction Rel -> ReaderT HMGitConfig m (WalkAction Rel)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WalkAction Rel -> ReaderT HMGitConfig m (WalkAction Rel))
-> WalkAction Rel -> ReaderT HMGitConfig m (WalkAction Rel)
forall a b. (a -> b) -> a -> b
$ [Path Rel Dir] -> WalkAction Rel
forall b. [Path b Dir] -> WalkAction b
P.WalkExclude [
                    Path Rel Dir
dbDir
                  , $(P.mkRelDir ".stack-work") -- HACK
                  ]
            | $(P.mkRelDir "test") Path Rel Dir -> Path Rel Dir -> Bool
forall a. Eq a => a -> a -> Bool
== Path Rel Dir
d = WalkAction Rel -> ReaderT HMGitConfig m (WalkAction Rel)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WalkAction Rel -> ReaderT HMGitConfig m (WalkAction Rel))
-> WalkAction Rel -> ReaderT HMGitConfig m (WalkAction Rel)
forall a b. (a -> b) -> a -> b
$ [Path Rel Dir] -> WalkAction Rel
forall b. [Path b Dir] -> WalkAction b
P.WalkExclude [ -- HACK
                $(P.mkRelDir "external")
              ]
            | Bool
otherwise = WalkAction Rel -> ReaderT HMGitConfig m (WalkAction Rel)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WalkAction Rel -> ReaderT HMGitConfig m (WalkAction Rel))
-> WalkAction Rel -> ReaderT HMGitConfig m (WalkAction Rel)
forall a b. (a -> b) -> a -> b
$ [Path Rel Dir] -> WalkAction Rel
forall b. [Path b Dir] -> WalkAction b
P.WalkExclude []

        dirAccum :: Path Rel Dir
-> p
-> [Path Rel t]
-> ReaderT HMGitConfig m [(Path Rel t, String)]
dirAccum Path Rel Dir
d p
_ [Path Rel t]
files = [Path Rel t] -> [String] -> [(Path Rel t, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Path Rel t -> Path Rel t) -> [Path Rel t] -> [Path Rel t]
forall a b. (a -> b) -> [a] -> [b]
map (Path Rel Dir
d Path Rel Dir -> Path Rel t -> Path Rel t
forall b t. Path b Dir -> Path Rel t -> Path b t
P.</>) [Path Rel t]
files)
            ([String] -> [(Path Rel t, String)])
-> ReaderT HMGitConfig m [String]
-> ReaderT HMGitConfig m [(Path Rel t, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Path Rel t -> ReaderT HMGitConfig m String)
-> [Path Rel t] -> ReaderT HMGitConfig m [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
                (\Path Rel t
f -> (HMGitT m (Path Abs Dir)
forall (m :: * -> *). Monad m => HMGitT m (Path Abs Dir)
hmGitRoot HMGitT m (Path Abs Dir)
-> (Path Abs Dir -> Path Abs t)
-> ReaderT HMGitConfig m (Path Abs t)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Path Abs Dir -> Path Rel t -> Path Abs t
forall b t. Path b Dir -> Path Rel t -> Path b t
P.</> (Path Rel Dir
d Path Rel Dir -> Path Rel t -> Path Rel t
forall b t. Path b Dir -> Path Rel t -> Path b t
P.</> Path Rel t
f)))
                    ReaderT HMGitConfig m (Path Abs t)
-> (Path Abs t -> ReaderT HMGitConfig m ByteString)
-> ReaderT HMGitConfig m ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO ByteString -> ReaderT HMGitConfig m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> ReaderT HMGitConfig m ByteString)
-> (Path Abs t -> IO ByteString)
-> Path Abs t
-> ReaderT HMGitConfig m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ByteString
BL.readFile (String -> IO ByteString)
-> (Path Abs t -> String) -> Path Abs t -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs t -> String
forall b t. Path b t -> String
P.toFilePath
                    ReaderT HMGitConfig m ByteString
-> (ByteString -> ReaderT HMGitConfig m ObjectInfo)
-> ReaderT HMGitConfig m ObjectInfo
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ObjectType -> ByteString -> ReaderT HMGitConfig m ObjectInfo
forall (m :: * -> *).
MonadCatch m =>
ObjectType -> ByteString -> HMGitT m ObjectInfo
fromContents ObjectType
Blob
                    ReaderT HMGitConfig m ObjectInfo
-> (ObjectInfo -> String) -> ReaderT HMGitConfig m String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ByteString -> String
forall mono.
(MonoFoldable mono, PrintfArg (Element mono)) =>
mono -> String
hexStr (ByteString -> String)
-> (ObjectInfo -> ByteString) -> ObjectInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectInfo -> ByteString
objectId)
                [Path Rel t]
files

-- | Returns a map of blob file paths and hashes that are
-- already part of the repository.
-- This is a pair with `latestBlobHashes`.
indexedBlobHashes :: (MonadIO m, MonadCatch m)
    => HMGitT m (ML.Map (P.Path P.Rel P.File) String)
indexedBlobHashes :: HMGitT m (Map (Path Rel File) String)
indexedBlobHashes = ReaderT HMGitConfig m Bool
-> HMGitT m (Map (Path Rel File) String)
-> HMGitT m (Map (Path Rel File) String)
-> HMGitT m (Map (Path Rel File) String)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (HMGitT m (Path Abs File)
forall (m :: * -> *). Monad m => HMGitT m (Path Abs File)
hmGitIndexPath HMGitT m (Path Abs File)
-> (Path Abs File -> ReaderT HMGitConfig m Bool)
-> ReaderT HMGitConfig m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Path Abs File -> ReaderT HMGitConfig m Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
P.doesFileExist ReaderT HMGitConfig m Bool
-> (Bool -> Bool) -> ReaderT HMGitConfig m Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Bool
not)
   (Map (Path Rel File) String -> HMGitT m (Map (Path Rel File) String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map (Path Rel File) String
forall k a. Map k a
ML.empty)
 (HMGitT m (Map (Path Rel File) String)
 -> HMGitT m (Map (Path Rel File) String))
-> HMGitT m (Map (Path Rel File) String)
-> HMGitT m (Map (Path Rel File) String)
forall a b. (a -> b) -> a -> b
$ HMGitT m [IndexEntry]
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
HMGitT m [IndexEntry]
loadIndex
    HMGitT m [IndexEntry]
-> ([IndexEntry] -> Map (Path Rel File) String)
-> HMGitT m (Map (Path Rel File) String)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [(Path Rel File, String)] -> Map (Path Rel File) String
forall k a. Ord k => [(k, a)] -> Map k a
ML.fromList
        ([(Path Rel File, String)] -> Map (Path Rel File) String)
-> ([IndexEntry] -> [(Path Rel File, String)])
-> [IndexEntry]
-> Map (Path Rel File) String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IndexEntry -> (Path Rel File, String))
-> [IndexEntry] -> [(Path Rel File, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((IndexEntry -> String)
-> (Path Rel File, IndexEntry) -> (Path Rel File, String)
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second (ByteString -> String
forall mono.
(MonoFoldable mono, PrintfArg (Element mono)) =>
mono -> String
hexStr (ByteString -> String)
-> (IndexEntry -> ByteString) -> IndexEntry -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (IndexEntry -> ByteString) -> IndexEntry -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndexEntry -> ByteString
ieSha1) ((Path Rel File, IndexEntry) -> (Path Rel File, String))
-> (IndexEntry -> (Path Rel File, IndexEntry))
-> IndexEntry
-> (Path Rel File, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IndexEntry -> Path Rel File)
-> (IndexEntry, IndexEntry) -> (Path Rel File, IndexEntry)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first IndexEntry -> Path Rel File
iePath ((IndexEntry, IndexEntry) -> (Path Rel File, IndexEntry))
-> (IndexEntry -> (IndexEntry, IndexEntry))
-> IndexEntry
-> (Path Rel File, IndexEntry)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndexEntry -> (IndexEntry, IndexEntry)
forall a. a -> (a, a)
dupe)

-- | Data representing status
data HMGitStatus = HMGitStatus {
    HMGitStatus -> Set (Path Rel File)
statusChanged :: S.Set (P.Path P.Rel P.File)
  , HMGitStatus -> Set (Path Rel File)
statusNew     :: S.Set (P.Path P.Rel P.File)
  , HMGitStatus -> Set (Path Rel File)
statusDeleted :: S.Set (P.Path P.Rel P.File)
  }
  deriving Int -> HMGitStatus -> String -> String
[HMGitStatus] -> String -> String
HMGitStatus -> String
(Int -> HMGitStatus -> String -> String)
-> (HMGitStatus -> String)
-> ([HMGitStatus] -> String -> String)
-> Show HMGitStatus
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [HMGitStatus] -> String -> String
$cshowList :: [HMGitStatus] -> String -> String
show :: HMGitStatus -> String
$cshow :: HMGitStatus -> String
showsPrec :: Int -> HMGitStatus -> String -> String
$cshowsPrec :: Int -> HMGitStatus -> String -> String
Show

-- | Get status
getStatus :: (MonadIO m, MonadCatch m) => HMGitT m HMGitStatus
getStatus :: HMGitT m HMGitStatus
getStatus = do
    Map (Path Rel File) String
latest <- HMGitT m (Map (Path Rel File) String)
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
HMGitT m (Map (Path Rel File) String)
latestBlobHashes
    Map (Path Rel File) String
indexed <- HMGitT m (Map (Path Rel File) String)
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
HMGitT m (Map (Path Rel File) String)
indexedBlobHashes
    HMGitStatus -> HMGitT m HMGitStatus
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HMGitStatus -> HMGitT m HMGitStatus)
-> HMGitStatus -> HMGitT m HMGitStatus
forall a b. (a -> b) -> a -> b
$ HMGitStatus :: Set (Path Rel File)
-> Set (Path Rel File) -> Set (Path Rel File) -> HMGitStatus
HMGitStatus {
        statusChanged :: Set (Path Rel File)
statusChanged = Map (Path Rel File) String -> Set (Path Rel File)
forall k a. Map k a -> Set k
ML.keysSet
            (Map (Path Rel File) String -> Set (Path Rel File))
-> Map (Path Rel File) String -> Set (Path Rel File)
forall a b. (a -> b) -> a -> b
$ (String -> Bool)
-> Map (Path Rel File) String -> Map (Path Rel File) String
forall a k. (a -> Bool) -> Map k a -> Map k a
ML.filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null)
            (Map (Path Rel File) String -> Map (Path Rel File) String)
-> Map (Path Rel File) String -> Map (Path Rel File) String
forall a b. (a -> b) -> a -> b
$ (String -> String -> String)
-> Map (Path Rel File) String
-> Map (Path Rel File) String
-> Map (Path Rel File) String
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
ML.intersectionWith (\String
l String
r -> if String
l String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
r then String
r else String
forall a. Monoid a => a
mempty) Map (Path Rel File) String
latest Map (Path Rel File) String
indexed
      , statusNew :: Set (Path Rel File)
statusNew = Map (Path Rel File) String -> Set (Path Rel File)
forall k a. Map k a -> Set k
ML.keysSet
            (Map (Path Rel File) String -> Set (Path Rel File))
-> Map (Path Rel File) String -> Set (Path Rel File)
forall a b. (a -> b) -> a -> b
$ Map (Path Rel File) String
latest Map (Path Rel File) String
-> Map (Path Rel File) String -> Map (Path Rel File) String
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`ML.difference` Map (Path Rel File) String
indexed
      , statusDeleted :: Set (Path Rel File)
statusDeleted = Map (Path Rel File) String -> Set (Path Rel File)
forall k a. Map k a -> Set k
ML.keysSet
            (Map (Path Rel File) String -> Set (Path Rel File))
-> Map (Path Rel File) String -> Set (Path Rel File)
forall a b. (a -> b) -> a -> b
$ Map (Path Rel File) String
indexed Map (Path Rel File) String
-> Map (Path Rel File) String -> Map (Path Rel File) String
forall k a b. Ord k => Map k a -> Map k b -> Map k a
`ML.difference` Map (Path Rel File) String
latest
      }