miss-porcelain-0: src/Data/Git/EditTree.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TupleSections              #-}

{-|

Description: A monad for manipulating trees of files from git.

An 'EditTree' is a convenient representation of a 'Tree'.  The leaves of an 'EditTree' are either
the contents of a 'Blob', a sub-'EditTree', or a 'Sha1'.  This makes it easier to work with large
'Tree's, because subobjects are stored as hashes until you modify them.

-}

module Data.Git.EditTree where

import           Prelude hiding (fail)
import           Control.Monad.Fail
import           Control.Monad.State hiding (fail)
import qualified Data.ByteString       as B
import           Data.ByteString.Lazy  (ByteString)
import qualified Data.ByteString.Lazy  as BL
import           Data.Git
import           Data.Map              (Map)
import qualified Data.Map              as Map
import           System.Posix.FilePath


-- | A nice representation of a 'Tree'.
type EditTree = Map TreeEntry TreePart

-- | The leaves of an 'EditTree'---either a hash, 'Blob' data, or a subtree.
data TreePart = PartSha Sha1 | PartData ByteString | PartTree EditTree

-- | A monad for editing 'EditTree's.
newtype TreeEdit m a = TreeEdit { runTreeEdit :: StateT EditTree m a }
    deriving (Functor, Applicative, Monad, MonadState EditTree, MonadIO, MonadTrans, MonadFail)

-- | Turn the given treeish 'Sha1' into an 'EditTree' whose leaves are all hashes.
loadEditTree :: (MonadGit m, MonadFail m) => Sha1 -> m EditTree
loadEditTree r = do (Just (Tree ents)) <- findTreeish r
                    return $ fmap PartSha ents

-- | Traverse an 'EditTree', writing new objects, and return the 'Sha1' of the new 'Tree'.
writeEditTree :: MonadGit m => EditTree -> m Sha1
writeEditTree = writeTree . Tree <=< traverse partToSha
    where partToSha (PartSha  s) = return s
          partToSha (PartData b) = writeBlob $ Blob b
          partToSha (PartTree t) = writeEditTree t

-- | Run a 'TreeEdit' computation against an 'EditTree', *without* writing the new objects out.
don'tEditTree :: MonadGit m => EditTree -> TreeEdit m a -> m EditTree
don'tEditTree et te = execStateT (runTreeEdit te) et

-- | Run a 'TreeEdit' computation against an 'EditTree', writing new objects as they occur.
editTree :: MonadGit m => EditTree -> TreeEdit m a -> m EditTree
editTree et te = do et' <- don'tEditTree et te
                    _ <- writeEditTree et'
                    return et'

-- | Delete an entry from the 'EditTree'.
rm :: Monad m => TreeEntry -> TreeEdit m ()
rm = modify . Map.delete

-- | Run a 'TreeEdit' in the subtree at the given path.
cd :: (MonadFail m, MonadGit m) => RawFilePath -> TreeEdit m a -> TreeEdit m a
cd dir act = splitPathComponents dir >>= (`cd'` act)

-- | As 'cd', but with a list of path components.
cd' :: (MonadFail m, MonadGit m) => [PathComponent] -> TreeEdit m a -> TreeEdit m a
cd' [] te     = te
cd' (d:ds) te = cd1 d (cd' ds te)

-- | A one-level version of 'cd'.
cd1 :: (MonadFail m, MonadGit m) => PathComponent -> TreeEdit m a -> TreeEdit m a
cd1 d te = do old <- get
              let dir = Entry d TreeMode
              case old Map.! dir of
                PartTree et  -> put et
                PartSha  r   -> put =<< lift (loadEditTree r)
                _ -> error "cd1 exploded"
              ret <- te
              modify (\et -> Map.insert dir (PartTree et) old)
              return ret

-- | Place a new leaf with the given filename.
create :: Monad m => TreeEntry -> TreePart -> TreeEdit m ()
create name ent = modify (Map.insert name ent)

-- | Create a subtree with the given filename.
mkdir :: MonadFail m => PathComponent -> TreeEdit m ()
mkdir dir = modify (Map.insertWith (flip const) (Entry dir TreeMode) (PartTree mempty))

-- | Create a path into the tree and do some 'TreeEdit's in that location.
cdCreating :: (MonadFail m, MonadGit m) => RawFilePath -> TreeEdit m a -> TreeEdit m a
cdCreating path te = (`cdCreating'` te) =<< splitPathComponents path

-- | As 'cdCreating', but with a list of path components.
cdCreating' :: (MonadFail m, MonadGit m) => [PathComponent] -> TreeEdit m a -> TreeEdit m a
cdCreating' path te = go path
    where go [] = te
          go (d:ds) = mkdir d >> cd1 d (go ds)

-- | A shortcut to create a bunch of files at once.
createFiles :: Monad m => Map PathComponent B.ByteString -> TreeEdit m ()
createFiles m = sequence_ [create (Entry file BlobMode) $ PartData (BL.fromStrict blob)
                               | (file, blob) <- Map.toList m]