--  Copyright (C) 2009-2011 Petr Rockai
--
--  BSD3
{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, UndecidableInstances #-}

-- | An experimental 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
    ( 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) -- size, age

-- | Internal state of the 'TreeIO' monad. Keeps track of the current Tree
-- content, unsync'd changes and a current working directory (of the monad).
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) }

-- | A 'TreeIO' monad. A sort of like IO but it keeps a 'TreeState' around as well,
-- which is a sort of virtual filesystem. Depending on how you obtained your
-- 'TreeIO', the actions in your virtual filesystem get somehow reflected in the
-- actual real filesystem. For 'virtualTreeIO', nothing happens in real
-- filesystem, however with 'plainTreeIO', the plain tree will be updated every
-- now and then, and with 'hashedTreeIO' a darcs-style hashed tree will get
-- updated.
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
    -- | Grab content of a file in the current Tree at the given path.
    readFile :: AnchoredPath -> m BL.ByteString
    -- | Check for existence of a node (file or directory, doesn't matter).
    exists :: AnchoredPath -> m Bool
    -- | Check for existence of a directory.
    directoryExists ::AnchoredPath -> m Bool
    -- | Check for existence of a file.
    fileExists :: AnchoredPath -> m Bool

class TreeRO m => TreeRW m where
    -- | 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 :: 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

-- | Run a TreeIO 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 a form of 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 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

-- | 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 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

-- | 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 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 () -- vanished, do nothing
       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


-- | 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 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 -- 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

    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