--  Copyright (C) 2009-2011 Petr Rockai
--
--  BSD3

-- | A monadic interface to Tree mutation. The main idea is to
-- simulate IO-ish manipulation of real filesystem (that's the state part of
-- the monad), and to keep memory usage down by reasonably often dumping the
-- intermediate data to disk and forgetting it. The monad interface itself is
-- generic, and a number of actual implementations can be used. This module
-- provides just 'virtualTreeIO' that never writes any changes, but may trigger
-- filesystem reads as appropriate.
module Darcs.Util.Tree.Monad
    ( -- * 'TreeMonad'
      TreeMonad
    , TreeState(tree)
    , runTreeMonad
    , virtualTreeMonad
      -- * Specializing to 'IO'
    , TreeIO
    , virtualTreeIO
      -- * Read actions
    , readFile
    , exists
    , directoryExists
    , fileExists
      -- * Write actions
    , writeFile
    , createDirectory
    , unlink
    , rename
    , copy
      -- * Other actions
    , findM, findFileM, findTreeM
    ) where

import Darcs.Prelude hiding ( readFile, writeFile )

import Control.Exception ( throw )

import Darcs.Util.Path
import Darcs.Util.Tree

import Data.List( sortBy )
import Data.Int( Int64 )
import Data.Maybe( isNothing, isJust )

import qualified Data.ByteString.Lazy as BL
import Control.Monad.RWS.Strict
import qualified Data.Map as M

-- | Keep track of the size and age of changes to the tree.
type Changed = M.Map AnchoredPath (Int64, Int64) -- size, age

-- | Internal state of the 'TreeMonad'. Keeps track of the current 'Tree'
-- content and unsync'd changes.
data TreeState m = TreeState
  { TreeState m -> Tree m
tree :: !(Tree m)
  , TreeState m -> Changed
changed :: !Changed
  , TreeState m -> Int64
changesize :: !Int64
  , TreeState m -> Int64
maxage :: !Int64
  }

data TreeEnv m = TreeEnv
  { TreeEnv m -> TreeItem m -> m Hash
updateHash :: TreeItem m -> m Hash
  , TreeEnv m -> AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)
update :: AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)
  }

-- | A monad transformer that adds state of type 'TreeState' and an environment
-- of type 'AnchoredPath' (for the current directory).
type TreeMonad m = RWST (TreeEnv m) () (TreeState m) m

-- | 'TreeMonad' specialized to 'IO'
type TreeIO = TreeMonad IO

initialEnv :: (TreeItem m -> m Hash)
           -> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
           -> TreeEnv m
initialEnv :: (TreeItem m -> m Hash)
-> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
-> TreeEnv m
initialEnv TreeItem m -> m Hash
uh AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)
u = TreeEnv :: forall (m :: * -> *).
(TreeItem m -> m Hash)
-> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
-> TreeEnv m
TreeEnv {updateHash :: TreeItem m -> m Hash
updateHash = TreeItem m -> m Hash
uh, update :: AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)
update = AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)
u}

initialState :: Tree m -> TreeState m
initialState :: Tree m -> TreeState m
initialState Tree m
t =
  TreeState :: forall (m :: * -> *).
Tree m -> Changed -> Int64 -> Int64 -> TreeState m
TreeState {tree :: Tree m
tree = Tree m
t, changed :: Changed
changed = Changed
forall k a. Map k a
M.empty, changesize :: Int64
changesize = Int64
0, maxage :: Int64
maxage = Int64
0}

flush :: Monad m => TreeMonad m ()
flush :: TreeMonad m ()
flush = do [AnchoredPath]
changed' <- ((AnchoredPath, (Int64, Int64)) -> AnchoredPath)
-> [(AnchoredPath, (Int64, Int64))] -> [AnchoredPath]
forall a b. (a -> b) -> [a] -> [b]
map (AnchoredPath, (Int64, Int64)) -> AnchoredPath
forall a b. (a, b) -> a
fst ([(AnchoredPath, (Int64, Int64))] -> [AnchoredPath])
-> (Changed -> [(AnchoredPath, (Int64, Int64))])
-> Changed
-> [AnchoredPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Changed -> [(AnchoredPath, (Int64, Int64))]
forall k a. Map k a -> [(k, a)]
M.toList (Changed -> [AnchoredPath])
-> RWST (TreeEnv m) () (TreeState m) m Changed
-> RWST (TreeEnv m) () (TreeState m) m [AnchoredPath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TreeState m -> Changed)
-> RWST (TreeEnv m) () (TreeState m) m Changed
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> Changed
forall (m :: * -> *). TreeState m -> Changed
changed
           [AnchoredPath]
dirs' <- (TreeState m -> Tree m)
-> RWST (TreeEnv m) () (TreeState m) m (Tree m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> Tree m
forall (m :: * -> *). TreeState m -> Tree m
tree RWST (TreeEnv m) () (TreeState m) m (Tree m)
-> (Tree m -> RWST (TreeEnv m) () (TreeState m) m [AnchoredPath])
-> RWST (TreeEnv m) () (TreeState m) m [AnchoredPath]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Tree m
t -> [AnchoredPath]
-> RWST (TreeEnv m) () (TreeState m) m [AnchoredPath]
forall (m :: * -> *) a. Monad m => a -> m a
return [ AnchoredPath
path | (AnchoredPath
path, SubTree Tree m
_) <- Tree m -> [(AnchoredPath, TreeItem m)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree m
t ]
           (TreeState m -> TreeState m) -> TreeMonad m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TreeState m -> TreeState m) -> TreeMonad m ())
-> (TreeState m -> TreeState m) -> TreeMonad m ()
forall a b. (a -> b) -> a -> b
$ \TreeState m
st -> TreeState m
st { changed :: Changed
changed = Changed
forall k a. Map k a
M.empty, changesize :: Int64
changesize = Int64
0 }
           [AnchoredPath]
-> (AnchoredPath -> TreeMonad m ()) -> TreeMonad m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([AnchoredPath]
changed' [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]
forall a. [a] -> [a] -> [a]
++ [AnchoredPath]
dirs' [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]
forall a. [a] -> [a] -> [a]
++ [[Name] -> AnchoredPath
AnchoredPath []]) AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
flushItem

runTreeMonad' :: Monad m => TreeMonad m a -> TreeEnv m -> TreeState m -> m (a, Tree m)
runTreeMonad' :: TreeMonad m a -> TreeEnv m -> TreeState m -> m (a, Tree m)
runTreeMonad' TreeMonad m a
action TreeEnv m
initEnv TreeState m
initState = do
  (a
out, TreeState m
final, ()
_) <- TreeMonad m a -> TreeEnv m -> TreeState m -> m (a, TreeState m, ())
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST TreeMonad m a
action TreeEnv m
initEnv TreeState m
initState
  (a, Tree m) -> m (a, Tree m)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
out, TreeState m -> Tree m
forall (m :: * -> *). TreeState m -> Tree m
tree TreeState m
final)

runTreeMonad :: Monad m
             => TreeMonad m a
             -> Tree m
             -> (TreeItem m -> m Hash)
             -> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
             -> m (a, Tree m)
runTreeMonad :: TreeMonad m a
-> Tree m
-> (TreeItem m -> m Hash)
-> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
-> m (a, Tree m)
runTreeMonad TreeMonad m a
action Tree m
t TreeItem m -> m Hash
uh AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)
u = do
  let action' :: TreeMonad m a
action' = do a
x <- TreeMonad m a
action
                   TreeMonad m ()
forall (m :: * -> *). Monad m => TreeMonad m ()
flush
                   a -> TreeMonad m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  TreeMonad m a -> TreeEnv m -> TreeState m -> m (a, Tree m)
forall (m :: * -> *) a.
Monad m =>
TreeMonad m a -> TreeEnv m -> TreeState m -> m (a, Tree m)
runTreeMonad' TreeMonad m a
action' ((TreeItem m -> m Hash)
-> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
-> TreeEnv m
forall (m :: * -> *).
(TreeItem m -> m Hash)
-> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
-> TreeEnv m
initialEnv TreeItem m -> m Hash
uh AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)
u) (Tree m -> TreeState m
forall (m :: * -> *). Tree m -> TreeState m
initialState Tree m
t)

-- | Run a 'TreeMonad' action without storing any changes. This is useful for
-- running monadic tree mutations for obtaining the resulting 'Tree' (as opposed
-- to their effect of writing a modified tree to disk). The actions can do both
-- read and write -- reads are passed through to the actual filesystem, but the
-- writes are held in memory in the form of a modified 'Tree'.
virtualTreeMonad :: Monad m => TreeMonad m a -> Tree m -> m (a, Tree m)
virtualTreeMonad :: TreeMonad m a -> Tree m -> m (a, Tree m)
virtualTreeMonad TreeMonad m a
action Tree m
t =
  TreeMonad m a
-> Tree m
-> (TreeItem m -> m Hash)
-> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
-> m (a, Tree m)
forall (m :: * -> *) a.
Monad m =>
TreeMonad m a
-> Tree m
-> (TreeItem m -> m Hash)
-> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
-> m (a, Tree m)
runTreeMonad TreeMonad m a
action Tree m
t (\TreeItem m
_ -> Hash -> m Hash
forall (m :: * -> *) a. Monad m => a -> m a
return Hash
NoHash) (\AnchoredPath
_ TreeItem m
x -> TreeItem m -> TreeMonad m (TreeItem m)
forall (m :: * -> *) a. Monad m => a -> m a
return TreeItem m
x)

-- | 'virtualTreeMonad' specialized to 'IO'
virtualTreeIO :: TreeIO a -> Tree IO -> IO (a, Tree IO)
virtualTreeIO :: TreeIO a -> Tree IO -> IO (a, Tree IO)
virtualTreeIO = TreeIO a -> Tree IO -> IO (a, Tree IO)
forall (m :: * -> *) a.
Monad m =>
TreeMonad m a -> Tree m -> m (a, Tree m)
virtualTreeMonad

-- | Modifies an item in the current Tree. This action keeps an account of the
-- modified data, in changed and changesize, for subsequent flush
-- operations. Any modifications (as in "modifyTree") are allowed.
modifyItem :: Monad m
            => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
modifyItem :: AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
modifyItem AnchoredPath
path Maybe (TreeItem m)
item = do
  Int64
age <- (TreeState m -> Int64) -> RWST (TreeEnv m) () (TreeState m) m Int64
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> Int64
forall (m :: * -> *). TreeState m -> Int64
maxage
  Changed
changed' <- (TreeState m -> Changed)
-> RWST (TreeEnv m) () (TreeState m) m Changed
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> Changed
forall (m :: * -> *). TreeState m -> Changed
changed
  let getsize :: Maybe (TreeItem m) -> t m Int64
getsize (Just (File Blob m
b)) = m Int64 -> t m Int64
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ByteString -> Int64
BL.length (ByteString -> Int64) -> m ByteString -> m Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blob m -> m ByteString
forall (m :: * -> *). Blob m -> m ByteString
readBlob Blob m
b)
      getsize Maybe (TreeItem m)
_ = Int64 -> t m Int64
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
0
  Int64
size <- Maybe (TreeItem m) -> RWST (TreeEnv m) () (TreeState m) m Int64
forall (t :: (* -> *) -> * -> *) (m :: * -> *).
(MonadTrans t, Monad m, Monad (t m)) =>
Maybe (TreeItem m) -> t m Int64
getsize Maybe (TreeItem m)
item
  let change :: Int64
change = case AnchoredPath -> Changed -> Maybe (Int64, Int64)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AnchoredPath
path Changed
changed' of
        Maybe (Int64, Int64)
Nothing -> Int64
size
        Just (Int64
oldsize, Int64
_) -> Int64
size Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
oldsize

  (TreeState m -> TreeState m) -> TreeMonad m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TreeState m -> TreeState m) -> TreeMonad m ())
-> (TreeState m -> TreeState m) -> TreeMonad m ()
forall a b. (a -> b) -> a -> b
$ \TreeState m
st -> TreeState m
st { tree :: Tree m
tree = Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m
forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m
modifyTree (TreeState m -> Tree m
forall (m :: * -> *). TreeState m -> Tree m
tree TreeState m
st) AnchoredPath
path Maybe (TreeItem m)
item
                     , changed :: Changed
changed = AnchoredPath -> (Int64, Int64) -> Changed -> Changed
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert AnchoredPath
path (Int64
size, Int64
age) (TreeState m -> Changed
forall (m :: * -> *). TreeState m -> Changed
changed TreeState m
st)
                     , maxage :: Int64
maxage = Int64
age Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1
                     , changesize :: Int64
changesize = TreeState m -> Int64
forall (m :: * -> *). TreeState m -> Int64
changesize TreeState m
st Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
change }

renameChanged :: Monad m
              => AnchoredPath -> AnchoredPath -> TreeMonad m ()
renameChanged :: AnchoredPath -> AnchoredPath -> TreeMonad m ()
renameChanged AnchoredPath
from AnchoredPath
to = (TreeState m -> TreeState m) -> TreeMonad m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TreeState m -> TreeState m) -> TreeMonad m ())
-> (TreeState m -> TreeState m) -> TreeMonad m ()
forall a b. (a -> b) -> a -> b
$ \TreeState m
st -> TreeState m
st {changed :: Changed
changed = Changed -> Changed
forall a. Map AnchoredPath a -> Map AnchoredPath a
rename' (Changed -> Changed) -> Changed -> Changed
forall a b. (a -> b) -> a -> b
$ TreeState m -> Changed
forall (m :: * -> *). TreeState m -> Changed
changed TreeState m
st}
  where
    rename' :: Map AnchoredPath a -> Map AnchoredPath a
rename' = [(AnchoredPath, a)] -> Map AnchoredPath a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(AnchoredPath, a)] -> Map AnchoredPath a)
-> (Map AnchoredPath a -> [(AnchoredPath, a)])
-> Map AnchoredPath a
-> Map AnchoredPath a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AnchoredPath, a) -> (AnchoredPath, a))
-> [(AnchoredPath, a)] -> [(AnchoredPath, a)]
forall a b. (a -> b) -> [a] -> [b]
map (AnchoredPath, a) -> (AnchoredPath, a)
forall b. (AnchoredPath, b) -> (AnchoredPath, b)
renameone ([(AnchoredPath, a)] -> [(AnchoredPath, a)])
-> (Map AnchoredPath a -> [(AnchoredPath, a)])
-> Map AnchoredPath a
-> [(AnchoredPath, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map AnchoredPath a -> [(AnchoredPath, a)]
forall k a. Map k a -> [(k, a)]
M.toList
    renameone :: (AnchoredPath, b) -> (AnchoredPath, b)
renameone (AnchoredPath
x, b
d)
      | AnchoredPath
from AnchoredPath -> AnchoredPath -> Bool
`isPrefix` AnchoredPath
x = (AnchoredPath
to AnchoredPath -> AnchoredPath -> AnchoredPath
`catPaths` AnchoredPath -> AnchoredPath -> AnchoredPath
relative AnchoredPath
from AnchoredPath
x, b
d)
      | Bool
otherwise = (AnchoredPath
x, b
d)
    relative :: AnchoredPath -> AnchoredPath -> AnchoredPath
relative (AnchoredPath [Name]
from') (AnchoredPath [Name]
x) =
      [Name] -> AnchoredPath
AnchoredPath ([Name] -> AnchoredPath) -> [Name] -> AnchoredPath
forall a b. (a -> b) -> a -> b
$ Int -> [Name] -> [Name]
forall a. Int -> [a] -> [a]
drop ([Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Name]
from') [Name]
x

-- | Replace an item with a new version without modifying the content of the
-- tree. This does not do any change tracking. Ought to be only used from a
-- 'sync' implementation for a particular storage format. The presumed use-case
-- is that an existing in-memory Blob is replaced with a one referring to an
-- on-disk file.
replaceItem :: Monad m
            => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
replaceItem :: AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
replaceItem AnchoredPath
path Maybe (TreeItem m)
item = do
  (TreeState m -> TreeState m) -> TreeMonad m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TreeState m -> TreeState m) -> TreeMonad m ())
-> (TreeState m -> TreeState m) -> TreeMonad m ()
forall a b. (a -> b) -> a -> b
$ \TreeState m
st -> TreeState m
st { tree :: Tree m
tree = Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m
forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m
modifyTree (TreeState m -> Tree m
forall (m :: * -> *). TreeState m -> Tree m
tree TreeState m
st) AnchoredPath
path Maybe (TreeItem m)
item }

flushItem :: forall m. Monad m => AnchoredPath -> TreeMonad m ()
flushItem :: AnchoredPath -> TreeMonad m ()
flushItem AnchoredPath
path =
  do Tree m
current <- (TreeState m -> Tree m)
-> RWST (TreeEnv m) () (TreeState m) m (Tree m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> Tree m
forall (m :: * -> *). TreeState m -> Tree m
tree
     case Tree m -> AnchoredPath -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree m
current AnchoredPath
path of
       Maybe (TreeItem m)
Nothing -> () -> TreeMonad m ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- vanished, do nothing
       Just TreeItem m
x -> do TreeItem m
y <- TreeItem m -> TreeMonad m (TreeItem m)
fixHash TreeItem m
x
                    TreeItem m
new <- (TreeEnv m
 -> AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
-> RWST
     (TreeEnv m)
     ()
     (TreeState m)
     m
     (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TreeEnv m -> AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)
forall (m :: * -> *).
TreeEnv m -> AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)
update RWST
  (TreeEnv m)
  ()
  (TreeState m)
  m
  (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
-> ((AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
    -> TreeMonad m (TreeItem m))
-> TreeMonad m (TreeItem m)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((TreeItem m -> TreeMonad m (TreeItem m))
-> TreeItem m -> TreeMonad m (TreeItem m)
forall a b. (a -> b) -> a -> b
$ TreeItem m
y) ((TreeItem m -> TreeMonad m (TreeItem m))
 -> TreeMonad m (TreeItem m))
-> ((AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
    -> TreeItem m -> TreeMonad m (TreeItem m))
-> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
-> TreeMonad m (TreeItem m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
-> AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)
forall a b. (a -> b) -> a -> b
$ AnchoredPath
path)
                    AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
forall (m :: * -> *).
Monad m =>
AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
replaceItem AnchoredPath
path (TreeItem m -> Maybe (TreeItem m)
forall a. a -> Maybe a
Just TreeItem m
new)
    where fixHash :: TreeItem m -> TreeMonad m (TreeItem m)
          fixHash :: TreeItem m -> TreeMonad m (TreeItem m)
fixHash f :: TreeItem m
f@(File (Blob m ByteString
con Hash
NoHash)) = do
            Hash
hash <- (TreeEnv m -> TreeItem m -> m Hash)
-> RWST (TreeEnv m) () (TreeState m) m (TreeItem m -> m Hash)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TreeEnv m -> TreeItem m -> m Hash
forall (m :: * -> *). TreeEnv m -> TreeItem m -> m Hash
updateHash RWST (TreeEnv m) () (TreeState m) m (TreeItem m -> m Hash)
-> ((TreeItem m -> m Hash)
    -> RWST (TreeEnv m) () (TreeState m) m Hash)
-> RWST (TreeEnv m) () (TreeState m) m Hash
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TreeItem m -> m Hash
x -> m Hash -> RWST (TreeEnv m) () (TreeState m) m Hash
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Hash -> RWST (TreeEnv m) () (TreeState m) m Hash)
-> m Hash -> RWST (TreeEnv m) () (TreeState m) m Hash
forall a b. (a -> b) -> a -> b
$ TreeItem m -> m Hash
x TreeItem m
f
            TreeItem m -> TreeMonad m (TreeItem m)
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeItem m -> TreeMonad m (TreeItem m))
-> TreeItem m -> TreeMonad m (TreeItem m)
forall a b. (a -> b) -> a -> b
$ Blob m -> TreeItem m
forall (m :: * -> *). Blob m -> TreeItem m
File (Blob m -> TreeItem m) -> Blob m -> TreeItem m
forall a b. (a -> b) -> a -> b
$ m ByteString -> Hash -> Blob m
forall (m :: * -> *). m ByteString -> Hash -> Blob m
Blob m ByteString
con Hash
hash
          fixHash (SubTree Tree m
s) | Tree m -> Hash
forall (m :: * -> *). Tree m -> Hash
treeHash Tree m
s Hash -> Hash -> Bool
forall a. Eq a => a -> a -> Bool
== Hash
NoHash =
            (TreeEnv m -> TreeItem m -> m Hash)
-> RWST (TreeEnv m) () (TreeState m) m (TreeItem m -> m Hash)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TreeEnv m -> TreeItem m -> m Hash
forall (m :: * -> *). TreeEnv m -> TreeItem m -> m Hash
updateHash RWST (TreeEnv m) () (TreeState m) m (TreeItem m -> m Hash)
-> ((TreeItem m -> m Hash) -> TreeMonad m (TreeItem m))
-> TreeMonad m (TreeItem m)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TreeItem m -> m Hash
f -> Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree (Tree m -> TreeItem m)
-> RWST (TreeEnv m) () (TreeState m) m (Tree m)
-> TreeMonad m (TreeItem m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Tree m) -> RWST (TreeEnv m) () (TreeState m) m (Tree m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ((TreeItem m -> m Hash) -> Tree m -> m (Tree m)
forall (m :: * -> *).
Monad m =>
(TreeItem m -> m Hash) -> Tree m -> m (Tree m)
addMissingHashes TreeItem m -> m Hash
f Tree m
s)
          fixHash TreeItem m
x = TreeItem m -> TreeMonad m (TreeItem m)
forall (m :: * -> *) a. Monad m => a -> m a
return TreeItem m
x


-- | If buffers are becoming large, sync, otherwise do nothing.
flushSome :: Monad m => TreeMonad m ()
flushSome :: TreeMonad m ()
flushSome = do Int64
x <- (TreeState m -> Int64) -> RWST (TreeEnv m) () (TreeState m) m Int64
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> Int64
forall (m :: * -> *). TreeState m -> Int64
changesize
               Bool -> TreeMonad m () -> TreeMonad m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
x Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64 -> Int64
megs Int64
100) (TreeMonad m () -> TreeMonad m ())
-> TreeMonad m () -> TreeMonad m ()
forall a b. (a -> b) -> a -> b
$ do
                 [(AnchoredPath, (Int64, Int64))]
remaining <- [(AnchoredPath, (Int64, Int64))]
-> RWST
     (TreeEnv m) () (TreeState m) m [(AnchoredPath, (Int64, Int64))]
forall (m :: * -> *) b.
Monad m =>
[(AnchoredPath, (Int64, b))]
-> RWST (TreeEnv m) () (TreeState m) m [(AnchoredPath, (Int64, b))]
go ([(AnchoredPath, (Int64, Int64))]
 -> RWST
      (TreeEnv m) () (TreeState m) m [(AnchoredPath, (Int64, Int64))])
-> RWST
     (TreeEnv m) () (TreeState m) m [(AnchoredPath, (Int64, Int64))]
-> RWST
     (TreeEnv m) () (TreeState m) m [(AnchoredPath, (Int64, Int64))]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((AnchoredPath, (Int64, Int64))
 -> (AnchoredPath, (Int64, Int64)) -> Ordering)
-> [(AnchoredPath, (Int64, Int64))]
-> [(AnchoredPath, (Int64, Int64))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (AnchoredPath, (Int64, Int64))
-> (AnchoredPath, (Int64, Int64)) -> Ordering
forall a a a a a. Ord a => (a, (a, a)) -> (a, (a, a)) -> Ordering
age ([(AnchoredPath, (Int64, Int64))]
 -> [(AnchoredPath, (Int64, Int64))])
-> (Changed -> [(AnchoredPath, (Int64, Int64))])
-> Changed
-> [(AnchoredPath, (Int64, Int64))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Changed -> [(AnchoredPath, (Int64, Int64))]
forall k a. Map k a -> [(k, a)]
M.toList (Changed -> [(AnchoredPath, (Int64, Int64))])
-> RWST (TreeEnv m) () (TreeState m) m Changed
-> RWST
     (TreeEnv m) () (TreeState m) m [(AnchoredPath, (Int64, Int64))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TreeState m -> Changed)
-> RWST (TreeEnv m) () (TreeState m) m Changed
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> Changed
forall (m :: * -> *). TreeState m -> Changed
changed
                 (TreeState m -> TreeState m) -> TreeMonad m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TreeState m -> TreeState m) -> TreeMonad m ())
-> (TreeState m -> TreeState m) -> TreeMonad m ()
forall a b. (a -> b) -> a -> b
$ \TreeState m
s -> TreeState m
s { changed :: Changed
changed = [(AnchoredPath, (Int64, Int64))] -> Changed
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(AnchoredPath, (Int64, Int64))]
remaining }
  where go :: [(AnchoredPath, (Int64, b))]
-> RWST (TreeEnv m) () (TreeState m) m [(AnchoredPath, (Int64, b))]
go [] = [(AnchoredPath, (Int64, b))]
-> RWST (TreeEnv m) () (TreeState m) m [(AnchoredPath, (Int64, b))]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        go ((AnchoredPath
path, (Int64
size, b
_)):[(AnchoredPath, (Int64, b))]
chs) = do
          Int64
x <- Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
subtract Int64
size (Int64 -> Int64)
-> RWST (TreeEnv m) () (TreeState m) m Int64
-> RWST (TreeEnv m) () (TreeState m) m Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TreeState m -> Int64) -> RWST (TreeEnv m) () (TreeState m) m Int64
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> Int64
forall (m :: * -> *). TreeState m -> Int64
changesize
          AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
flushItem AnchoredPath
path
          (TreeState m -> TreeState m) -> TreeMonad m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TreeState m -> TreeState m) -> TreeMonad m ())
-> (TreeState m -> TreeState m) -> TreeMonad m ()
forall a b. (a -> b) -> a -> b
$ \TreeState m
s -> TreeState m
s { changesize :: Int64
changesize = Int64
x }
          if  Int64
x Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64 -> Int64
megs Int64
50  then [(AnchoredPath, (Int64, b))]
-> RWST (TreeEnv m) () (TreeState m) m [(AnchoredPath, (Int64, b))]
go [(AnchoredPath, (Int64, b))]
chs
                           else [(AnchoredPath, (Int64, b))]
-> RWST (TreeEnv m) () (TreeState m) m [(AnchoredPath, (Int64, b))]
forall (m :: * -> *) a. Monad m => a -> m a
return [(AnchoredPath, (Int64, b))]
chs
        megs :: Int64 -> Int64
megs = (Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* (Int64
1024 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
1024))
        age :: (a, (a, a)) -> (a, (a, a)) -> Ordering
age (a
_, (a
_, a
a)) (a
_, (a
_, a
b)) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b

-- read only actions

expandTo :: Monad m => AnchoredPath -> TreeMonad m ()
expandTo :: AnchoredPath -> TreeMonad m ()
expandTo AnchoredPath
p =
    do Tree m
t <- (TreeState m -> Tree m)
-> RWST (TreeEnv m) () (TreeState m) m (Tree m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> Tree m
forall (m :: * -> *). TreeState m -> Tree m
tree
       Tree m
t' <- m (Tree m) -> RWST (TreeEnv m) () (TreeState m) m (Tree m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Tree m) -> RWST (TreeEnv m) () (TreeState m) m (Tree m))
-> m (Tree m) -> RWST (TreeEnv m) () (TreeState m) m (Tree m)
forall a b. (a -> b) -> a -> b
$ Tree m -> AnchoredPath -> m (Tree m)
forall (m :: * -> *).
Monad m =>
Tree m -> AnchoredPath -> m (Tree m)
expandPath Tree m
t AnchoredPath
p
       (TreeState m -> TreeState m) -> TreeMonad m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TreeState m -> TreeState m) -> TreeMonad m ())
-> (TreeState m -> TreeState m) -> TreeMonad m ()
forall a b. (a -> b) -> a -> b
$ \TreeState m
st -> TreeState m
st { tree :: Tree m
tree = Tree m
t' }

-- | Check for existence of a file.
fileExists :: Monad m => AnchoredPath -> TreeMonad m Bool
fileExists :: AnchoredPath -> TreeMonad m Bool
fileExists AnchoredPath
p =
    do AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
expandTo AnchoredPath
p
       (Maybe (Blob m) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Blob m) -> Bool)
-> (Tree m -> Maybe (Blob m)) -> Tree m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree m -> AnchoredPath -> Maybe (Blob m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Blob m)
`findFile` AnchoredPath
p)) (Tree m -> Bool)
-> RWST (TreeEnv m) () (TreeState m) m (Tree m) -> TreeMonad m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TreeState m -> Tree m)
-> RWST (TreeEnv m) () (TreeState m) m (Tree m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> Tree m
forall (m :: * -> *). TreeState m -> Tree m
tree

-- | Check for existence of a directory.
directoryExists :: Monad m => AnchoredPath -> TreeMonad m Bool
directoryExists :: AnchoredPath -> TreeMonad m Bool
directoryExists AnchoredPath
p =
    do AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
expandTo AnchoredPath
p
       (Maybe (Tree m) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Tree m) -> Bool)
-> (Tree m -> Maybe (Tree m)) -> Tree m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree m -> AnchoredPath -> Maybe (Tree m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Tree m)
`findTree` AnchoredPath
p)) (Tree m -> Bool)
-> RWST (TreeEnv m) () (TreeState m) m (Tree m) -> TreeMonad m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TreeState m -> Tree m)
-> RWST (TreeEnv m) () (TreeState m) m (Tree m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> Tree m
forall (m :: * -> *). TreeState m -> Tree m
tree

-- | Check for existence of a node (file or directory, doesn't matter).
exists :: Monad m => AnchoredPath -> TreeMonad m Bool
exists :: AnchoredPath -> TreeMonad m Bool
exists AnchoredPath
p =
    do AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
expandTo AnchoredPath
p
       Maybe (TreeItem m) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (TreeItem m) -> Bool)
-> (Tree m -> Maybe (TreeItem m)) -> Tree m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree m -> AnchoredPath -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
`find` AnchoredPath
p) (Tree m -> Bool)
-> RWST (TreeEnv m) () (TreeState m) m (Tree m) -> TreeMonad m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TreeState m -> Tree m)
-> RWST (TreeEnv m) () (TreeState m) m (Tree m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> Tree m
forall (m :: * -> *). TreeState m -> Tree m
tree

-- | Grab content of a file in the current Tree at the given path.
readFile :: Monad m => AnchoredPath -> TreeMonad m BL.ByteString
readFile :: AnchoredPath -> TreeMonad m ByteString
readFile AnchoredPath
p =
    do AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
expandTo AnchoredPath
p
       Tree m
t <- (TreeState m -> Tree m)
-> RWST (TreeEnv m) () (TreeState m) m (Tree m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> Tree m
forall (m :: * -> *). TreeState m -> Tree m
tree
       let f :: Maybe (Blob m)
f = Tree m -> AnchoredPath -> Maybe (Blob m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Blob m)
findFile Tree m
t AnchoredPath
p
       case Maybe (Blob m)
f of
         Maybe (Blob m)
Nothing -> IOError -> TreeMonad m ByteString
forall a e. Exception e => e -> a
throw (IOError -> TreeMonad m ByteString)
-> IOError -> TreeMonad m ByteString
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ String
"No such file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
p
         Just Blob m
x -> m ByteString -> TreeMonad m ByteString
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Blob m -> m ByteString
forall (m :: * -> *). Blob m -> m ByteString
readBlob Blob m
x)

-- | Change content of a file at a given path. The change will be
-- eventually flushed to disk, but might be buffered for some time.
writeFile :: Monad m => AnchoredPath -> BL.ByteString -> TreeMonad m ()
writeFile :: AnchoredPath -> ByteString -> TreeMonad m ()
writeFile AnchoredPath
p ByteString
con =
    do AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
expandTo AnchoredPath
p
       AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
forall (m :: * -> *).
Monad m =>
AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
modifyItem AnchoredPath
p (TreeItem m -> Maybe (TreeItem m)
forall a. a -> Maybe a
Just TreeItem m
blob)
       TreeMonad m ()
forall (m :: * -> *). Monad m => TreeMonad m ()
flushSome
    where blob :: TreeItem m
blob = Blob m -> TreeItem m
forall (m :: * -> *). Blob m -> TreeItem m
File (Blob m -> TreeItem m) -> Blob m -> TreeItem m
forall a b. (a -> b) -> a -> b
$ m ByteString -> Hash -> Blob m
forall (m :: * -> *). m ByteString -> Hash -> Blob m
Blob (ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
con) Hash
hash
          hash :: Hash
hash = Hash
NoHash -- we would like to say "sha256 con" here, but due
                        -- to strictness of Hash in Blob, this would often
                        -- lead to unnecessary computation which would then
                        -- be discarded anyway; we rely on the sync
                        -- implementation to fix up any NoHash occurrences

-- | Create a directory.
createDirectory :: Monad m => AnchoredPath -> TreeMonad m ()
createDirectory :: AnchoredPath -> TreeMonad m ()
createDirectory AnchoredPath
p =
    do AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
expandTo AnchoredPath
p
       AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
forall (m :: * -> *).
Monad m =>
AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
modifyItem AnchoredPath
p (Maybe (TreeItem m) -> TreeMonad m ())
-> Maybe (TreeItem m) -> TreeMonad m ()
forall a b. (a -> b) -> a -> b
$ TreeItem m -> Maybe (TreeItem m)
forall a. a -> Maybe a
Just (TreeItem m -> Maybe (TreeItem m))
-> TreeItem m -> Maybe (TreeItem m)
forall a b. (a -> b) -> a -> b
$ Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree Tree m
forall (m :: * -> *). Tree m
emptyTree

-- | Remove the item at a path.
unlink :: Monad m => AnchoredPath -> TreeMonad m ()
unlink :: AnchoredPath -> TreeMonad m ()
unlink AnchoredPath
p =
    do AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
expandTo AnchoredPath
p
       AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
forall (m :: * -> *).
Monad m =>
AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
modifyItem AnchoredPath
p Maybe (TreeItem m)
forall a. Maybe a
Nothing

-- | Rename the item at a path.
rename :: Monad m => AnchoredPath -> AnchoredPath -> TreeMonad m ()
rename :: AnchoredPath -> AnchoredPath -> TreeMonad m ()
rename AnchoredPath
from AnchoredPath
to =
    do AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
expandTo AnchoredPath
from
       AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
expandTo AnchoredPath
to
       Tree m
tr <- (TreeState m -> Tree m)
-> RWST (TreeEnv m) () (TreeState m) m (Tree m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> Tree m
forall (m :: * -> *). TreeState m -> Tree m
tree
       let item :: Maybe (TreeItem m)
item = Tree m -> AnchoredPath -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree m
tr AnchoredPath
from
           found_to :: Maybe (TreeItem m)
found_to = Tree m -> AnchoredPath -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree m
tr AnchoredPath
to
       Bool -> TreeMonad m () -> TreeMonad m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe (TreeItem m) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (TreeItem m)
found_to) (TreeMonad m () -> TreeMonad m ())
-> TreeMonad m () -> TreeMonad m ()
forall a b. (a -> b) -> a -> b
$
              IOError -> TreeMonad m ()
forall a e. Exception e => e -> a
throw (IOError -> TreeMonad m ()) -> IOError -> TreeMonad m ()
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ String
"Error renaming: destination " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
to String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" exists."
       if Maybe (TreeItem m) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (TreeItem m)
item then do
              AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
forall (m :: * -> *).
Monad m =>
AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
modifyItem AnchoredPath
from Maybe (TreeItem m)
forall a. Maybe a
Nothing
              AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
forall (m :: * -> *).
Monad m =>
AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
modifyItem AnchoredPath
to Maybe (TreeItem m)
item
              AnchoredPath -> AnchoredPath -> TreeMonad m ()
forall (m :: * -> *).
Monad m =>
AnchoredPath -> AnchoredPath -> TreeMonad m ()
renameChanged AnchoredPath
from AnchoredPath
to
       else
        IOError -> TreeMonad m ()
forall a e. Exception e => e -> a
throw (IOError -> TreeMonad m ()) -> IOError -> TreeMonad m ()
forall a b. (a -> b) -> a -> b
$ String -> IOError
userError (String -> IOError) -> String -> IOError
forall a b. (a -> b) -> a -> b
$ String
"Error renaming: source " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
displayPath AnchoredPath
from String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not exist."

-- | Copy an item from some path to another path.
copy :: Monad m => AnchoredPath -> AnchoredPath -> TreeMonad m ()
copy :: AnchoredPath -> AnchoredPath -> TreeMonad m ()
copy AnchoredPath
from AnchoredPath
to =
    do AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
expandTo AnchoredPath
from
       AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
expandTo AnchoredPath
to
       Tree m
tr <- (TreeState m -> Tree m)
-> RWST (TreeEnv m) () (TreeState m) m (Tree m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> Tree m
forall (m :: * -> *). TreeState m -> Tree m
tree
       let item :: Maybe (TreeItem m)
item = Tree m -> AnchoredPath -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree m
tr AnchoredPath
from
       Bool -> TreeMonad m () -> TreeMonad m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe (TreeItem m) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (TreeItem m)
item) (TreeMonad m () -> TreeMonad m ())
-> TreeMonad m () -> TreeMonad m ()
forall a b. (a -> b) -> a -> b
$ AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
forall (m :: * -> *).
Monad m =>
AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
modifyItem AnchoredPath
to Maybe (TreeItem m)
item

findM' :: forall m a . Monad m
       => (Tree m -> AnchoredPath -> a) -> Tree m -> AnchoredPath -> m a
findM' :: (Tree m -> AnchoredPath -> a) -> Tree m -> AnchoredPath -> m a
findM' Tree m -> AnchoredPath -> a
what Tree m
t AnchoredPath
path = (a, Tree m) -> a
forall a b. (a, b) -> a
fst ((a, Tree m) -> a) -> m (a, Tree m) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TreeMonad m a -> Tree m -> m (a, Tree m)
forall (m :: * -> *) a.
Monad m =>
TreeMonad m a -> Tree m -> m (a, Tree m)
virtualTreeMonad (AnchoredPath -> TreeMonad m a
look AnchoredPath
path) Tree m
t
  where look :: AnchoredPath -> TreeMonad m a
        look :: AnchoredPath -> TreeMonad m a
look AnchoredPath
p = AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
expandTo AnchoredPath
p TreeMonad m () -> TreeMonad m a -> TreeMonad m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Tree m -> AnchoredPath -> a) -> AnchoredPath -> Tree m -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Tree m -> AnchoredPath -> a
what AnchoredPath
p (Tree m -> a)
-> RWST (TreeEnv m) () (TreeState m) m (Tree m) -> TreeMonad m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TreeState m -> Tree m)
-> RWST (TreeEnv m) () (TreeState m) m (Tree m)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> Tree m
forall (m :: * -> *). TreeState m -> Tree m
tree

findM :: Monad m => Tree m -> AnchoredPath -> m (Maybe (TreeItem m))
findM :: Tree m -> AnchoredPath -> m (Maybe (TreeItem m))
findM = (Tree m -> AnchoredPath -> Maybe (TreeItem m))
-> Tree m -> AnchoredPath -> m (Maybe (TreeItem m))
forall (m :: * -> *) a.
Monad m =>
(Tree m -> AnchoredPath -> a) -> Tree m -> AnchoredPath -> m a
findM' Tree m -> AnchoredPath -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find

findTreeM :: Monad m => Tree m -> AnchoredPath -> m (Maybe (Tree m))
findTreeM :: Tree m -> AnchoredPath -> m (Maybe (Tree m))
findTreeM = (Tree m -> AnchoredPath -> Maybe (Tree m))
-> Tree m -> AnchoredPath -> m (Maybe (Tree m))
forall (m :: * -> *) a.
Monad m =>
(Tree m -> AnchoredPath -> a) -> Tree m -> AnchoredPath -> m a
findM' Tree m -> AnchoredPath -> Maybe (Tree m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Tree m)
findTree

findFileM :: Monad m => Tree m -> AnchoredPath -> m (Maybe (Blob m))
findFileM :: Tree m -> AnchoredPath -> m (Maybe (Blob m))
findFileM = (Tree m -> AnchoredPath -> Maybe (Blob m))
-> Tree m -> AnchoredPath -> m (Maybe (Blob m))
forall (m :: * -> *) a.
Monad m =>
(Tree m -> AnchoredPath -> a) -> Tree m -> AnchoredPath -> m a
findM' Tree m -> AnchoredPath -> Maybe (Blob m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Blob m)
findFile