{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, UndecidableInstances #-}
module Darcs.Util.Tree.Monad
( virtualTreeIO, virtualTreeMonad
, readFile, writeFile, createDirectory, rename, copy, unlink
, fileExists, directoryExists, exists, withDirectory
, currentDirectory
, tree, TreeState, TreeMonad, TreeIO, runTreeMonad
, initialState, replaceItem
, findM, findFileM, findTreeM
, TreeRO, TreeRW
) where
import Prelude hiding ( readFile, writeFile, (<$>) )
import Darcs.Util.Path
import Darcs.Util.Tree
import Control.Applicative( (<$>) )
import Control.Exception ( throw )
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
type Changed = M.Map AnchoredPath (Int64, Int64)
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
, TreeState m -> TreeItem m -> m Hash
updateHash :: TreeItem m -> m Hash
, TreeState m
-> AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)
update :: AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m) }
type TreeMonad m = RWST AnchoredPath () (TreeState m) m
type TreeIO = TreeMonad IO
class (Functor m, Monad m) => TreeRO m where
currentDirectory :: m AnchoredPath
withDirectory :: AnchoredPath -> m a -> m a
expandTo :: AnchoredPath -> m AnchoredPath
readFile :: AnchoredPath -> m BL.ByteString
exists :: AnchoredPath -> m Bool
directoryExists ::AnchoredPath -> m Bool
fileExists :: AnchoredPath -> m Bool
class TreeRO m => TreeRW m where
writeFile :: AnchoredPath -> BL.ByteString -> m ()
createDirectory :: AnchoredPath -> m ()
unlink :: AnchoredPath -> m ()
rename :: AnchoredPath -> AnchoredPath -> m ()
copy :: AnchoredPath -> AnchoredPath -> m ()
initialState :: Tree m -> (TreeItem m -> m Hash)
-> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)) -> TreeState m
initialState :: Tree m
-> (TreeItem m -> m Hash)
-> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
-> TreeState m
initialState t :: Tree m
t uh :: TreeItem m -> m Hash
uh u :: AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)
u = $WTreeState :: forall (m :: * -> *).
Tree m
-> Changed
-> Int64
-> Int64
-> (TreeItem m -> m Hash)
-> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
-> 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 = 0
, updateHash :: TreeItem m -> m Hash
updateHash = TreeItem m -> m Hash
uh
, maxage :: Int64
maxage = 0
, update :: AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)
update = AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)
u }
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 AnchoredPath () (TreeState m) m Changed
-> RWST AnchoredPath () (TreeState m) m [AnchoredPath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TreeState m -> Changed)
-> RWST AnchoredPath () (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 AnchoredPath () (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 AnchoredPath () (TreeState m) m (Tree m)
-> (Tree m -> RWST AnchoredPath () (TreeState m) m [AnchoredPath])
-> RWST AnchoredPath () (TreeState m) m [AnchoredPath]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \t :: Tree m
t -> [AnchoredPath]
-> RWST AnchoredPath () (TreeState m) m [AnchoredPath]
forall (m :: * -> *) a. Monad m => a -> m a
return [ AnchoredPath
path | (path :: AnchoredPath
path, SubTree _) <- 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
$ \st :: TreeState m
st -> TreeState m
st { changed :: Changed
changed = Changed
forall k a. Map k a
M.empty, changesize :: Int64
changesize = 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 -> TreeState m -> m (a, Tree m)
runTreeMonad' :: TreeMonad m a -> TreeState m -> m (a, Tree m)
runTreeMonad' action :: TreeMonad m a
action initial :: TreeState m
initial = do
(out :: a
out, final :: TreeState m
final, _) <- TreeMonad m a
-> AnchoredPath -> 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 ([Name] -> AnchoredPath
AnchoredPath []) TreeState m
initial
(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 -> TreeState m -> m (a, Tree m)
runTreeMonad :: TreeMonad m a -> TreeState m -> m (a, Tree m)
runTreeMonad action :: TreeMonad m a
action initial :: TreeState m
initial = 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 -> TreeState m -> m (a, Tree m)
forall (m :: * -> *) a.
Monad m =>
TreeMonad m a -> TreeState m -> m (a, Tree m)
runTreeMonad' TreeMonad m a
action' TreeState m
initial
virtualTreeMonad :: (Monad m) => TreeMonad m a -> Tree m -> m (a, Tree m)
virtualTreeMonad :: TreeMonad m a -> Tree m -> m (a, Tree m)
virtualTreeMonad action :: TreeMonad m a
action t :: Tree m
t = TreeMonad m a -> TreeState m -> m (a, Tree m)
forall (m :: * -> *) a.
Monad m =>
TreeMonad m a -> TreeState m -> m (a, Tree m)
runTreeMonad' TreeMonad m a
action (TreeState m -> m (a, Tree m)) -> TreeState m -> m (a, Tree m)
forall a b. (a -> b) -> a -> b
$
Tree m
-> (TreeItem m -> m Hash)
-> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
-> TreeState m
forall (m :: * -> *).
Tree m
-> (TreeItem m -> m Hash)
-> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
-> TreeState m
initialState Tree m
t (\_ -> Hash -> m Hash
forall (m :: * -> *) a. Monad m => a -> m a
return Hash
NoHash) (\_ x :: TreeItem m
x -> TreeItem m -> TreeMonad m (TreeItem m)
forall (m :: * -> *) a. Monad m => a -> m a
return TreeItem m
x)
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
modifyItem :: (Monad m)
=> AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
modifyItem :: AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
modifyItem path :: AnchoredPath
path item :: Maybe (TreeItem m)
item = do
AnchoredPath
path' <- (AnchoredPath -> AnchoredPath -> AnchoredPath
`catPaths` AnchoredPath
path) (AnchoredPath -> AnchoredPath)
-> RWST AnchoredPath () (TreeState m) m AnchoredPath
-> RWST AnchoredPath () (TreeState m) m AnchoredPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RWST AnchoredPath () (TreeState m) m AnchoredPath
forall (m :: * -> *). TreeRO m => m AnchoredPath
currentDirectory
Int64
age <- (TreeState m -> Int64)
-> RWST AnchoredPath () (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 AnchoredPath () (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 b :: 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
`fmap` Blob m -> m ByteString
forall (m :: * -> *). Blob m -> m ByteString
readBlob Blob m
b)
getsize _ = Int64 -> t m Int64
forall (m :: * -> *) a. Monad m => a -> m a
return 0
Int64
size <- Maybe (TreeItem m) -> RWST AnchoredPath () (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
Nothing -> Int64
size
Just (oldsize :: Int64
oldsize, _) -> 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
$ \st :: 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
+ 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 from :: AnchoredPath
from to :: 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
$ \st :: 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 (x :: AnchoredPath
x, d :: 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 from' :: [Name]
from') (AnchoredPath x :: [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
replaceItem :: (Monad m)
=> AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
replaceItem :: AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
replaceItem path :: AnchoredPath
path item :: Maybe (TreeItem m)
item = do
AnchoredPath
path' <- (AnchoredPath -> AnchoredPath -> AnchoredPath
`catPaths` AnchoredPath
path) (AnchoredPath -> AnchoredPath)
-> RWST AnchoredPath () (TreeState m) m AnchoredPath
-> RWST AnchoredPath () (TreeState m) m AnchoredPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RWST AnchoredPath () (TreeState m) m AnchoredPath
forall (m :: * -> *). TreeRO m => m AnchoredPath
currentDirectory
(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
$ \st :: 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 path :: AnchoredPath
path =
do Tree m
current <- (TreeState m -> Tree m)
-> RWST AnchoredPath () (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
Nothing -> () -> TreeMonad m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just x :: TreeItem m
x -> do TreeItem m
y <- TreeItem m -> TreeMonad m (TreeItem m)
fixHash TreeItem m
x
TreeItem m
new <- (TreeState m
-> AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
-> RWST
AnchoredPath
()
(TreeState m)
m
(AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m
-> AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)
forall (m :: * -> *).
TreeState m
-> AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)
update RWST
AnchoredPath
()
(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 con :: m ByteString
con NoHash)) = do
Hash
hash <- (TreeState m -> TreeItem m -> m Hash)
-> RWST AnchoredPath () (TreeState m) m (TreeItem m -> m Hash)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> TreeItem m -> m Hash
forall (m :: * -> *). TreeState m -> TreeItem m -> m Hash
updateHash RWST AnchoredPath () (TreeState m) m (TreeItem m -> m Hash)
-> ((TreeItem m -> m Hash)
-> RWST AnchoredPath () (TreeState m) m Hash)
-> RWST AnchoredPath () (TreeState m) m Hash
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \x :: TreeItem m -> m Hash
x -> m Hash -> RWST AnchoredPath () (TreeState m) m Hash
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Hash -> RWST AnchoredPath () (TreeState m) m Hash)
-> m Hash -> RWST AnchoredPath () (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 s :: 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 =
(TreeState m -> TreeItem m -> m Hash)
-> RWST AnchoredPath () (TreeState m) m (TreeItem m -> m Hash)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TreeState m -> TreeItem m -> m Hash
forall (m :: * -> *). TreeState m -> TreeItem m -> m Hash
updateHash RWST AnchoredPath () (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
>>= \f :: TreeItem m -> m Hash
f -> Tree m -> TreeItem m
forall (m :: * -> *). Tree m -> TreeItem m
SubTree (Tree m -> TreeItem m)
-> RWST AnchoredPath () (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 AnchoredPath () (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 x :: TreeItem m
x = TreeItem m -> TreeMonad m (TreeItem m)
forall (m :: * -> *) a. Monad m => a -> m a
return TreeItem m
x
flushSome :: (Monad m) => TreeMonad m ()
flushSome :: TreeMonad m ()
flushSome = do Int64
x <- (TreeState m -> Int64)
-> RWST AnchoredPath () (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 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
AnchoredPath () (TreeState m) m [(AnchoredPath, (Int64, Int64))]
forall (m :: * -> *) b.
Monad m =>
[(AnchoredPath, (Int64, b))]
-> RWST
AnchoredPath () (TreeState m) m [(AnchoredPath, (Int64, b))]
go ([(AnchoredPath, (Int64, Int64))]
-> RWST
AnchoredPath () (TreeState m) m [(AnchoredPath, (Int64, Int64))])
-> RWST
AnchoredPath () (TreeState m) m [(AnchoredPath, (Int64, Int64))]
-> RWST
AnchoredPath () (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 AnchoredPath () (TreeState m) m Changed
-> RWST
AnchoredPath () (TreeState m) m [(AnchoredPath, (Int64, Int64))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TreeState m -> Changed)
-> RWST AnchoredPath () (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
$ \s :: 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
AnchoredPath () (TreeState m) m [(AnchoredPath, (Int64, b))]
go [] = [(AnchoredPath, (Int64, b))]
-> RWST
AnchoredPath () (TreeState m) m [(AnchoredPath, (Int64, b))]
forall (m :: * -> *) a. Monad m => a -> m a
return []
go ((path :: AnchoredPath
path, (size :: Int64
size, _)):chs :: [(AnchoredPath, (Int64, b))]
chs) = do
Int64
x <- (\s :: Int64
s -> Int64
s Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
size) (Int64 -> Int64)
-> RWST AnchoredPath () (TreeState m) m Int64
-> RWST AnchoredPath () (TreeState m) m Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TreeState m -> Int64)
-> RWST AnchoredPath () (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
$ \s :: 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 50 then [(AnchoredPath, (Int64, b))]
-> RWST
AnchoredPath () (TreeState m) m [(AnchoredPath, (Int64, b))]
go [(AnchoredPath, (Int64, b))]
chs
else [(AnchoredPath, (Int64, b))]
-> RWST
AnchoredPath () (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
* (1024 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* 1024))
age :: (a, (a, a)) -> (a, (a, a)) -> Ordering
age (_, (_, a :: a
a)) (_, (_, b :: a
b)) = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b
instance (Monad m) => TreeRO (TreeMonad m) where
expandTo :: AnchoredPath -> TreeMonad m AnchoredPath
expandTo p :: AnchoredPath
p =
do Tree m
t <- (TreeState m -> Tree m)
-> RWST AnchoredPath () (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
AnchoredPath
p' <- (AnchoredPath -> AnchoredPath -> AnchoredPath
`catPaths` AnchoredPath
p) (AnchoredPath -> AnchoredPath)
-> TreeMonad m AnchoredPath -> TreeMonad m AnchoredPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` TreeMonad m AnchoredPath
forall r (m :: * -> *). MonadReader r m => m r
ask
Tree m
t' <- m (Tree m) -> RWST AnchoredPath () (TreeState m) m (Tree m)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Tree m) -> RWST AnchoredPath () (TreeState m) m (Tree m))
-> m (Tree m) -> RWST AnchoredPath () (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)
-> RWST AnchoredPath () (TreeState m) m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TreeState m -> TreeState m)
-> RWST AnchoredPath () (TreeState m) m ())
-> (TreeState m -> TreeState m)
-> RWST AnchoredPath () (TreeState m) m ()
forall a b. (a -> b) -> a -> b
$ \st :: TreeState m
st -> TreeState m
st { tree :: Tree m
tree = Tree m
t' }
AnchoredPath -> TreeMonad m AnchoredPath
forall (m :: * -> *) a. Monad m => a -> m a
return AnchoredPath
p'
fileExists :: AnchoredPath -> TreeMonad m Bool
fileExists p :: AnchoredPath
p =
do AnchoredPath
p' <- AnchoredPath -> TreeMonad m AnchoredPath
forall (m :: * -> *). TreeRO m => AnchoredPath -> m AnchoredPath
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 AnchoredPath () (TreeState m) m (Tree m)
-> TreeMonad m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (TreeState m -> Tree m)
-> RWST AnchoredPath () (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
directoryExists :: AnchoredPath -> TreeMonad m Bool
directoryExists p :: AnchoredPath
p =
do AnchoredPath
p' <- AnchoredPath -> TreeMonad m AnchoredPath
forall (m :: * -> *). TreeRO m => AnchoredPath -> m AnchoredPath
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 AnchoredPath () (TreeState m) m (Tree m)
-> TreeMonad m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (TreeState m -> Tree m)
-> RWST AnchoredPath () (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
exists :: AnchoredPath -> TreeMonad m Bool
exists p :: AnchoredPath
p =
do AnchoredPath
p' <- AnchoredPath -> TreeMonad m AnchoredPath
forall (m :: * -> *). TreeRO m => AnchoredPath -> m AnchoredPath
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 AnchoredPath () (TreeState m) m (Tree m)
-> TreeMonad m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (TreeState m -> Tree m)
-> RWST AnchoredPath () (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
readFile :: AnchoredPath -> TreeMonad m ByteString
readFile p :: AnchoredPath
p =
do AnchoredPath
p' <- AnchoredPath -> TreeMonad m AnchoredPath
forall (m :: * -> *). TreeRO m => AnchoredPath -> m AnchoredPath
expandTo AnchoredPath
p
Tree m
t <- (TreeState m -> Tree m)
-> RWST AnchoredPath () (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
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
$ "No such file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
forall a. Show a => a -> String
show AnchoredPath
p'
Just x :: 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)
currentDirectory :: TreeMonad m AnchoredPath
currentDirectory = TreeMonad m AnchoredPath
forall r (m :: * -> *). MonadReader r m => m r
ask
withDirectory :: AnchoredPath -> TreeMonad m a -> TreeMonad m a
withDirectory dir :: AnchoredPath
dir act :: TreeMonad m a
act = do
AnchoredPath
dir' <- AnchoredPath -> TreeMonad m AnchoredPath
forall (m :: * -> *). TreeRO m => AnchoredPath -> m AnchoredPath
expandTo AnchoredPath
dir
(AnchoredPath -> AnchoredPath) -> TreeMonad m a -> TreeMonad m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (AnchoredPath -> AnchoredPath -> AnchoredPath
forall a b. a -> b -> a
const AnchoredPath
dir') TreeMonad m a
act
instance (Monad m) => TreeRW (TreeMonad m) where
writeFile :: AnchoredPath -> ByteString -> TreeMonad m ()
writeFile p :: AnchoredPath
p con :: ByteString
con =
do AnchoredPath
_ <- AnchoredPath -> RWST AnchoredPath () (TreeState m) m AnchoredPath
forall (m :: * -> *). TreeRO m => AnchoredPath -> m AnchoredPath
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
createDirectory :: AnchoredPath -> TreeMonad m ()
createDirectory p :: AnchoredPath
p =
do AnchoredPath
_ <- AnchoredPath -> RWST AnchoredPath () (TreeState m) m AnchoredPath
forall (m :: * -> *). TreeRO m => AnchoredPath -> m AnchoredPath
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
unlink :: AnchoredPath -> TreeMonad m ()
unlink p :: AnchoredPath
p =
do AnchoredPath
_ <- AnchoredPath -> RWST AnchoredPath () (TreeState m) m AnchoredPath
forall (m :: * -> *). TreeRO m => AnchoredPath -> m AnchoredPath
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 :: AnchoredPath -> AnchoredPath -> TreeMonad m ()
rename from :: AnchoredPath
from to :: AnchoredPath
to =
do AnchoredPath
from' <- AnchoredPath -> RWST AnchoredPath () (TreeState m) m AnchoredPath
forall (m :: * -> *). TreeRO m => AnchoredPath -> m AnchoredPath
expandTo AnchoredPath
from
AnchoredPath
to' <- AnchoredPath -> RWST AnchoredPath () (TreeState m) m AnchoredPath
forall (m :: * -> *). TreeRO m => AnchoredPath -> m AnchoredPath
expandTo AnchoredPath
to
Tree m
tr <- (TreeState m -> Tree m)
-> RWST AnchoredPath () (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
$ "Error renaming: destination " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredPath -> String
forall a. Show a => a -> String
show AnchoredPath
to String -> String -> String
forall a. [a] -> [a] -> [a]
++ " exists."
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
$ 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
copy :: AnchoredPath -> AnchoredPath -> TreeMonad m ()
copy from :: AnchoredPath
from to :: AnchoredPath
to =
do AnchoredPath
from' <- AnchoredPath -> RWST AnchoredPath () (TreeState m) m AnchoredPath
forall (m :: * -> *). TreeRO m => AnchoredPath -> m AnchoredPath
expandTo AnchoredPath
from
AnchoredPath
_ <- AnchoredPath -> RWST AnchoredPath () (TreeState m) m AnchoredPath
forall (m :: * -> *). TreeRO m => AnchoredPath -> m AnchoredPath
expandTo AnchoredPath
to
Tree m
tr <- (TreeState m -> Tree m)
-> RWST AnchoredPath () (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' what :: Tree m -> AnchoredPath -> a
what t :: Tree m
t path :: 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 -> RWST AnchoredPath () (TreeState m) m AnchoredPath
forall (m :: * -> *). TreeRO m => AnchoredPath -> m AnchoredPath
expandTo (AnchoredPath -> RWST AnchoredPath () (TreeState m) m AnchoredPath)
-> (AnchoredPath -> TreeMonad m a) -> AnchoredPath -> TreeMonad m a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \p' :: AnchoredPath
p' -> (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 AnchoredPath () (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 AnchoredPath () (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