module Darcs.Util.Tree.Monad
(
TreeMonad
, TreeState(tree)
, runTreeMonad
, virtualTreeMonad
, TreeIO
, virtualTreeIO
, readFile
, exists
, directoryExists
, fileExists
, writeFile
, createDirectory
, unlink
, rename
, copy
, findM, findFileM, findTreeM
) where
import Darcs.Prelude hiding ( readFile, writeFile )
import Darcs.Util.Path ( AnchoredPath, anchoredRoot, displayPath, movedirfilename )
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 ( forM_, when, unless )
import Control.Monad.Catch ( MonadThrow(..) )
import Control.Monad.RWS.Strict (RWST, runRWST, ask, gets, lift, modify)
import qualified Data.Map as M
import System.IO.Error ( ioeSetErrorString, mkIOError )
import GHC.IO.Exception ( IOErrorType(..) )
type Changed = M.Map AnchoredPath (Int64, Int64)
data TreeState m = TreeState
{ forall (m :: * -> *). TreeState m -> Tree m
tree :: !(Tree m)
, forall (m :: * -> *). TreeState m -> Changed
changed :: !Changed
, forall (m :: * -> *). TreeState m -> Int64
changesize :: !Int64
, forall (m :: * -> *). TreeState m -> Int64
maxage :: !Int64
}
type DumpItem m = AnchoredPath -> TreeItem m -> m (TreeItem m)
type TreeMonad m = RWST (DumpItem m) () (TreeState m) m
type TreeIO = TreeMonad IO
initialState :: Tree m -> TreeState m
initialState :: forall (m :: * -> *). Tree m -> TreeState m
initialState Tree m
t =
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 :: forall (m :: * -> *). Monad m => 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 (DumpItem m) () (TreeState m) m Changed
-> RWST (DumpItem m) () (TreeState m) m [AnchoredPath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TreeState m -> Changed)
-> RWST (DumpItem 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 (DumpItem 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 (DumpItem m) () (TreeState m) m (Tree m)
-> (Tree m -> RWST (DumpItem m) () (TreeState m) m [AnchoredPath])
-> RWST (DumpItem m) () (TreeState m) m [AnchoredPath]
forall a b.
RWST (DumpItem m) () (TreeState m) m a
-> (a -> RWST (DumpItem m) () (TreeState m) m b)
-> RWST (DumpItem m) () (TreeState m) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Tree m
t -> [AnchoredPath]
-> RWST (DumpItem m) () (TreeState m) m [AnchoredPath]
forall a. a -> RWST (DumpItem m) () (TreeState m) m a
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 = M.empty, 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]
++ [AnchoredPath
anchoredRoot]) AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
flushItem
runTreeMonad' :: Monad m => TreeMonad m a -> DumpItem m -> TreeState m -> m (a, Tree m)
runTreeMonad' :: forall (m :: * -> *) a.
Monad m =>
TreeMonad m a -> DumpItem m -> TreeState m -> m (a, Tree m)
runTreeMonad' TreeMonad m a
action DumpItem m
initEnv TreeState m
initState = do
(a
out, TreeState m
final, ()
_) <- TreeMonad m a
-> DumpItem 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 DumpItem m
initEnv TreeState m
initState
(a, Tree m) -> m (a, Tree m)
forall a. a -> m a
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 -> DumpItem m -> m (a, Tree m)
runTreeMonad :: forall (m :: * -> *) a.
Monad m =>
TreeMonad m a -> Tree m -> DumpItem m -> m (a, Tree m)
runTreeMonad TreeMonad m a
action Tree m
t DumpItem m
dump = 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 a. a -> RWST (DumpItem m) () (TreeState m) m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
TreeMonad m a -> DumpItem m -> TreeState m -> m (a, Tree m)
forall (m :: * -> *) a.
Monad m =>
TreeMonad m a -> DumpItem m -> TreeState m -> m (a, Tree m)
runTreeMonad' TreeMonad m a
action' DumpItem m
dump (Tree m -> TreeState m
forall (m :: * -> *). Tree m -> TreeState m
initialState Tree m
t)
virtualTreeMonad :: Monad m => TreeMonad m a -> Tree m -> m (a, Tree m)
virtualTreeMonad :: forall (m :: * -> *) a.
Monad m =>
TreeMonad m a -> Tree m -> m (a, Tree m)
virtualTreeMonad TreeMonad m a
action Tree m
t = TreeMonad m a -> Tree m -> DumpItem m -> m (a, Tree m)
forall (m :: * -> *) a.
Monad m =>
TreeMonad m a -> Tree m -> DumpItem m -> m (a, Tree m)
runTreeMonad TreeMonad m a
action Tree m
t ((TreeItem m -> m (TreeItem m)) -> DumpItem m
forall a b. a -> b -> a
const TreeItem m -> m (TreeItem m)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return)
virtualTreeIO :: TreeIO a -> Tree IO -> IO (a, Tree IO)
virtualTreeIO :: forall a. TreeIO a -> Tree IO -> IO (a, Tree IO)
virtualTreeIO = TreeMonad IO 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 :: forall (m :: * -> *).
Monad m =>
AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
modifyItem AnchoredPath
path Maybe (TreeItem m)
item = do
Int64
age <- (TreeState m -> Int64)
-> RWST (DumpItem 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 (DumpItem 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 (m :: * -> *) a. Monad m => m a -> t m a
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 a. a -> t m a
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
0
Int64
size <- Maybe (TreeItem m) -> RWST (DumpItem 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 = modifyTree (tree st) path item
, changed = M.insert path (size, age) (changed st)
, maxage = age + 1
, changesize = changesize st + change }
renameChanged :: Monad m
=> AnchoredPath -> AnchoredPath -> TreeMonad m ()
renameChanged :: forall (m :: * -> *).
Monad m =>
AnchoredPath -> AnchoredPath -> TreeMonad m ()
renameChanged AnchoredPath
from AnchoredPath
to = (TreeState m -> TreeState m)
-> RWST (DumpItem m) () (TreeState m) m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((TreeState m -> TreeState m)
-> RWST (DumpItem m) () (TreeState m) m ())
-> (TreeState m -> TreeState m)
-> RWST (DumpItem m) () (TreeState m) m ()
forall a b. (a -> b) -> a -> b
$ \TreeState m
st -> TreeState m
st {changed = rename' $ changed st}
where
rename' :: Map AnchoredPath a -> Map AnchoredPath a
rename' = (AnchoredPath -> AnchoredPath)
-> Map AnchoredPath a -> Map AnchoredPath a
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (AnchoredPath -> AnchoredPath -> AnchoredPath -> AnchoredPath
movedirfilename AnchoredPath
from AnchoredPath
to)
replaceItem :: Monad m
=> AnchoredPath -> TreeItem m -> TreeMonad m ()
replaceItem :: forall (m :: * -> *).
Monad m =>
AnchoredPath -> TreeItem m -> TreeMonad m ()
replaceItem AnchoredPath
path 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 = modifyTree (tree st) path (Just item) }
flushItem :: forall m . Monad m => AnchoredPath -> TreeMonad m ()
flushItem :: forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
flushItem AnchoredPath
path = do
Tree m
current <- (TreeState m -> Tree m)
-> RWST (DumpItem 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
DumpItem m
dumpItem <- RWST (DumpItem m) () (TreeState m) m (DumpItem m)
forall r (m :: * -> *). MonadReader r m => m r
ask
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 a. a -> RWST (DumpItem m) () (TreeState m) m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just TreeItem m
item -> m (TreeItem m) -> RWST (DumpItem m) () (TreeState m) m (TreeItem m)
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (DumpItem m) () (TreeState m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DumpItem m
dumpItem AnchoredPath
path TreeItem m
item) RWST (DumpItem m) () (TreeState m) m (TreeItem m)
-> (TreeItem m -> TreeMonad m ()) -> TreeMonad m ()
forall a b.
RWST (DumpItem m) () (TreeState m) m a
-> (a -> RWST (DumpItem m) () (TreeState m) m b)
-> RWST (DumpItem m) () (TreeState m) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AnchoredPath -> TreeItem m -> TreeMonad m ()
forall (m :: * -> *).
Monad m =>
AnchoredPath -> TreeItem m -> TreeMonad m ()
replaceItem AnchoredPath
path
flushSome :: Monad m => TreeMonad m ()
flushSome :: forall (m :: * -> *). Monad m => TreeMonad m ()
flushSome = do Int64
x <- (TreeState m -> Int64)
-> RWST (DumpItem 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
(DumpItem m) () (TreeState m) m [(AnchoredPath, (Int64, Int64))]
forall {m :: * -> *} {b}.
Monad m =>
[(AnchoredPath, (Int64, b))]
-> RWST
(DumpItem m) () (TreeState m) m [(AnchoredPath, (Int64, b))]
go ([(AnchoredPath, (Int64, Int64))]
-> RWST
(DumpItem m) () (TreeState m) m [(AnchoredPath, (Int64, Int64))])
-> RWST
(DumpItem m) () (TreeState m) m [(AnchoredPath, (Int64, Int64))]
-> RWST
(DumpItem 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 (DumpItem m) () (TreeState m) m Changed
-> RWST
(DumpItem m) () (TreeState m) m [(AnchoredPath, (Int64, Int64))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TreeState m -> Changed)
-> RWST (DumpItem 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 = M.fromList remaining }
where go :: [(AnchoredPath, (Int64, b))]
-> RWST
(DumpItem m) () (TreeState m) m [(AnchoredPath, (Int64, b))]
go [] = [(AnchoredPath, (Int64, b))]
-> RWST
(DumpItem m) () (TreeState m) m [(AnchoredPath, (Int64, b))]
forall a. a -> RWST (DumpItem m) () (TreeState m) m a
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 (DumpItem m) () (TreeState m) m Int64
-> RWST (DumpItem m) () (TreeState m) m Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TreeState m -> Int64)
-> RWST (DumpItem 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 = x }
if Int64
x Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64 -> Int64
megs Int64
50 then [(AnchoredPath, (Int64, b))]
-> RWST
(DumpItem m) () (TreeState m) m [(AnchoredPath, (Int64, b))]
go [(AnchoredPath, (Int64, b))]
chs
else [(AnchoredPath, (Int64, b))]
-> RWST
(DumpItem m) () (TreeState m) m [(AnchoredPath, (Int64, b))]
forall a. a -> RWST (DumpItem m) () (TreeState m) m a
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
expandTo :: Monad m => AnchoredPath -> TreeMonad m ()
expandTo :: forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
expandTo AnchoredPath
p =
do Tree m
t <- (TreeState m -> Tree m)
-> RWST (DumpItem 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 (DumpItem m) () (TreeState m) m (Tree m)
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (DumpItem m) () (TreeState m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Tree m) -> RWST (DumpItem m) () (TreeState m) m (Tree m))
-> m (Tree m) -> RWST (DumpItem 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 = t' }
findItem :: Monad m => AnchoredPath -> TreeMonad m (Maybe (TreeItem m))
findItem :: forall (m :: * -> *).
Monad m =>
AnchoredPath -> TreeMonad m (Maybe (TreeItem m))
findItem AnchoredPath
path = do
AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
expandTo AnchoredPath
path
Tree m
tr <- (TreeState m -> Tree m)
-> RWST (DumpItem 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
Maybe (TreeItem m) -> TreeMonad m (Maybe (TreeItem m))
forall a. a -> RWST (DumpItem m) () (TreeState m) m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (TreeItem m) -> TreeMonad m (Maybe (TreeItem m)))
-> Maybe (TreeItem m) -> TreeMonad m (Maybe (TreeItem m))
forall a b. (a -> b) -> a -> b
$ Tree m -> AnchoredPath -> Maybe (TreeItem m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (TreeItem m)
find Tree m
tr AnchoredPath
path
fileExists :: Monad m => AnchoredPath -> TreeMonad m Bool
fileExists :: forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m Bool
fileExists AnchoredPath
p = do
Maybe (TreeItem m)
item <- AnchoredPath -> TreeMonad m (Maybe (TreeItem m))
forall (m :: * -> *).
Monad m =>
AnchoredPath -> TreeMonad m (Maybe (TreeItem m))
findItem AnchoredPath
p
case Maybe (TreeItem m)
item of
Just (File{}) -> Bool -> TreeMonad m Bool
forall a. a -> RWST (DumpItem m) () (TreeState m) m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Maybe (TreeItem m)
_ -> Bool -> TreeMonad m Bool
forall a. a -> RWST (DumpItem m) () (TreeState m) m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
directoryExists :: Monad m => AnchoredPath -> TreeMonad m Bool
directoryExists :: forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m Bool
directoryExists AnchoredPath
p = do
Maybe (TreeItem m)
item <- AnchoredPath -> TreeMonad m (Maybe (TreeItem m))
forall (m :: * -> *).
Monad m =>
AnchoredPath -> TreeMonad m (Maybe (TreeItem m))
findItem AnchoredPath
p
case Maybe (TreeItem m)
item of
Just (SubTree{}) -> Bool -> TreeMonad m Bool
forall a. a -> RWST (DumpItem m) () (TreeState m) m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Maybe (TreeItem m)
_ -> Bool -> TreeMonad m Bool
forall a. a -> RWST (DumpItem m) () (TreeState m) m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
exists :: MonadThrow m => AnchoredPath -> TreeMonad m Bool
exists :: forall (m :: * -> *).
MonadThrow m =>
AnchoredPath -> TreeMonad m Bool
exists AnchoredPath
p = Maybe (TreeItem m) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (TreeItem m) -> Bool)
-> RWST (DumpItem m) () (TreeState m) m (Maybe (TreeItem m))
-> RWST (DumpItem m) () (TreeState m) m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnchoredPath
-> RWST (DumpItem m) () (TreeState m) m (Maybe (TreeItem m))
forall (m :: * -> *).
Monad m =>
AnchoredPath -> TreeMonad m (Maybe (TreeItem m))
findItem AnchoredPath
p
readFile :: MonadThrow m => AnchoredPath -> TreeMonad m BL.ByteString
readFile :: forall (m :: * -> *).
MonadThrow m =>
AnchoredPath -> TreeMonad m ByteString
readFile AnchoredPath
p = do
Maybe (TreeItem m)
f <- AnchoredPath -> TreeMonad m (Maybe (TreeItem m))
forall (m :: * -> *).
Monad m =>
AnchoredPath -> TreeMonad m (Maybe (TreeItem m))
findItem AnchoredPath
p
case Maybe (TreeItem m)
f of
Just (File Blob m
x) -> m ByteString -> TreeMonad m ByteString
forall (m :: * -> *) a.
Monad m =>
m a -> RWST (DumpItem m) () (TreeState m) m a
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)
Just TreeItem m
_ ->
IOError -> TreeMonad m ByteString
forall e a.
(HasCallStack, Exception e) =>
e -> RWST (DumpItem m) () (TreeState m) m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (IOError -> TreeMonad m ByteString)
-> IOError -> TreeMonad m ByteString
forall a b. (a -> b) -> a -> b
$
(IOError -> String -> IOError) -> String -> IOError -> IOError
forall a b c. (a -> b -> c) -> b -> a -> c
flip IOError -> String -> IOError
ioeSetErrorString String
"is a directory" (IOError -> IOError) -> IOError -> IOError
forall a b. (a -> b) -> a -> b
$
IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
InappropriateType String
"readFile" Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just (AnchoredPath -> String
displayPath AnchoredPath
p))
Maybe (TreeItem m)
Nothing ->
IOError -> TreeMonad m ByteString
forall e a.
(HasCallStack, Exception e) =>
e -> RWST (DumpItem m) () (TreeState m) m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (IOError -> TreeMonad m ByteString)
-> IOError -> TreeMonad m ByteString
forall a b. (a -> b) -> a -> b
$
IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
NoSuchThing String
"readFile" Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just (AnchoredPath -> String
displayPath AnchoredPath
p))
writeFile :: MonadThrow m => AnchoredPath -> BL.ByteString -> TreeMonad m ()
writeFile :: forall (m :: * -> *).
MonadThrow m =>
AnchoredPath -> ByteString -> TreeMonad m ()
writeFile AnchoredPath
p ByteString
con = do
Maybe (TreeItem m)
item <- AnchoredPath -> TreeMonad m (Maybe (TreeItem m))
forall (m :: * -> *).
Monad m =>
AnchoredPath -> TreeMonad m (Maybe (TreeItem m))
findItem AnchoredPath
p
case Maybe (TreeItem m)
item of
Just (SubTree Tree m
_) ->
IOError -> TreeMonad m ()
forall e a.
(HasCallStack, Exception e) =>
e -> RWST (DumpItem m) () (TreeState m) m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (IOError -> TreeMonad m ()) -> IOError -> TreeMonad m ()
forall a b. (a -> b) -> a -> b
$
(IOError -> String -> IOError) -> String -> IOError -> IOError
forall a b c. (a -> b -> c) -> b -> a -> c
flip IOError -> String -> IOError
ioeSetErrorString String
"is a directory" (IOError -> IOError) -> IOError -> IOError
forall a b. (a -> b) -> a -> b
$
IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
InappropriateType String
"writeFile" Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just (AnchoredPath -> String
displayPath AnchoredPath
p))
Maybe (TreeItem m)
_ ->
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 -> Maybe Hash -> Blob m
forall (m :: * -> *). m ByteString -> Maybe Hash -> Blob m
Blob (ByteString -> m ByteString
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
con) Maybe Hash
forall a. Maybe a
Nothing
createDirectory :: Monad m => AnchoredPath -> TreeMonad m ()
createDirectory :: forall (m :: * -> *). Monad m => 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
unlink :: Monad m => AnchoredPath -> TreeMonad m ()
unlink :: forall (m :: * -> *). Monad m => 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 :: MonadThrow m => AnchoredPath -> AnchoredPath -> TreeMonad m ()
rename :: forall (m :: * -> *).
MonadThrow m =>
AnchoredPath -> AnchoredPath -> TreeMonad m ()
rename AnchoredPath
from AnchoredPath
to = do
Maybe (TreeItem m)
item <- AnchoredPath -> TreeMonad m (Maybe (TreeItem m))
forall (m :: * -> *).
Monad m =>
AnchoredPath -> TreeMonad m (Maybe (TreeItem m))
findItem AnchoredPath
from
Maybe (TreeItem m)
found_to <- AnchoredPath -> TreeMonad m (Maybe (TreeItem m))
forall (m :: * -> *).
Monad m =>
AnchoredPath -> TreeMonad m (Maybe (TreeItem m))
findItem AnchoredPath
to
Bool -> TreeMonad m () -> TreeMonad m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe (TreeItem m) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (TreeItem m)
item) (TreeMonad m () -> TreeMonad m ())
-> TreeMonad m () -> TreeMonad m ()
forall a b. (a -> b) -> a -> b
$
IOError -> TreeMonad m ()
forall e a.
(HasCallStack, Exception e) =>
e -> RWST (DumpItem m) () (TreeState m) m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (IOError -> TreeMonad m ()) -> IOError -> TreeMonad m ()
forall a b. (a -> b) -> a -> b
$
IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
NoSuchThing String
"rename" Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just (AnchoredPath -> String
displayPath 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)
found_to) (TreeMonad m () -> TreeMonad m ())
-> TreeMonad m () -> TreeMonad m ()
forall a b. (a -> b) -> a -> b
$
IOError -> TreeMonad m ()
forall e a.
(HasCallStack, Exception e) =>
e -> RWST (DumpItem m) () (TreeState m) m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (IOError -> TreeMonad m ()) -> IOError -> TreeMonad m ()
forall a b. (a -> b) -> a -> b
$
IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
AlreadyExists String
"rename" Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just (AnchoredPath -> String
displayPath AnchoredPath
to))
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 :: MonadThrow m => AnchoredPath -> AnchoredPath -> TreeMonad m ()
copy :: forall (m :: * -> *).
MonadThrow m =>
AnchoredPath -> AnchoredPath -> TreeMonad m ()
copy AnchoredPath
from AnchoredPath
to = do
AnchoredPath -> TreeMonad m ()
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m ()
expandTo AnchoredPath
to
Maybe (TreeItem m)
item <- AnchoredPath -> TreeMonad m (Maybe (TreeItem m))
forall (m :: * -> *).
Monad m =>
AnchoredPath -> TreeMonad m (Maybe (TreeItem m))
findItem AnchoredPath
from
Bool -> TreeMonad m () -> TreeMonad m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (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
$
IOError -> TreeMonad m ()
forall e a.
(HasCallStack, Exception e) =>
e -> RWST (DumpItem m) () (TreeState m) m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (IOError -> TreeMonad m ()) -> IOError -> TreeMonad m ()
forall a b. (a -> b) -> a -> b
$
IOErrorType -> String -> Maybe Handle -> Maybe String -> IOError
mkIOError IOErrorType
NoSuchThing String
"copy" Maybe Handle
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just (AnchoredPath -> String
displayPath AnchoredPath
from))
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' :: forall (m :: * -> *) a.
Monad m =>
(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 a b.
RWST (DumpItem m) () (TreeState m) m a
-> RWST (DumpItem m) () (TreeState m) m b
-> RWST (DumpItem m) () (TreeState m) m b
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 (DumpItem 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 (DumpItem 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 :: forall (m :: * -> *).
Monad m =>
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 :: forall (m :: * -> *).
Monad m =>
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 :: forall (m :: * -> *).
Monad m =>
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