module Darcs.UI.Commands.Util.Tree
(
treeHas
, treeHasDir
, treeHasFile
, treeHasAnycase
) where
import Prelude ()
import Darcs.Prelude
import Control.Monad ( forM )
import Control.Monad.State.Strict( gets )
import Data.Maybe ( fromMaybe )
import qualified Darcs.Util.Tree.Monad as TM
( TreeMonad, withDirectory, fileExists, directoryExists
, virtualTreeMonad, currentDirectory, exists, tree )
import Darcs.Util.Tree ( Tree, listImmediate, findTree )
import Darcs.Util.Path
( AnchoredPath(..), floatPath, eqAnycase )
treeHasAnycase :: Monad m
=> Tree m
-> FilePath
-> m Bool
treeHasAnycase :: Tree m -> FilePath -> m Bool
treeHasAnycase tree :: Tree m
tree path :: FilePath
path =
(Bool, Tree m) -> Bool
forall a b. (a, b) -> a
fst ((Bool, Tree m) -> Bool) -> m (Bool, Tree m) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` TreeMonad m Bool -> Tree m -> m (Bool, Tree m)
forall (m :: * -> *) a.
Monad m =>
TreeMonad m a -> Tree m -> m (a, Tree m)
TM.virtualTreeMonad (AnchoredPath -> TreeMonad m Bool
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m Bool
existsAnycase (AnchoredPath -> TreeMonad m Bool)
-> AnchoredPath -> TreeMonad m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> AnchoredPath
floatPath FilePath
path) Tree m
tree
existsAnycase :: Monad m
=> AnchoredPath
-> TM.TreeMonad m Bool
existsAnycase :: AnchoredPath -> TreeMonad m Bool
existsAnycase (AnchoredPath []) = Bool -> TreeMonad m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
existsAnycase (AnchoredPath (x :: Name
x:xs :: [Name]
xs)) = do
AnchoredPath
wd <- RWST AnchoredPath () (TreeState m) m AnchoredPath
forall (m :: * -> *). TreeRO m => m AnchoredPath
TM.currentDirectory
Tree m
tree <- Tree m -> Maybe (Tree m) -> Tree m
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Tree m
forall a. FilePath -> a
bug "invalid path passed to existsAnycase") (Maybe (Tree m) -> Tree m)
-> RWST AnchoredPath () (TreeState m) m (Maybe (Tree m))
-> RWST AnchoredPath () (TreeState m) m (Tree m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
(TreeState m -> Maybe (Tree m))
-> RWST AnchoredPath () (TreeState m) m (Maybe (Tree m))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Tree m -> AnchoredPath -> Maybe (Tree m))
-> AnchoredPath -> Tree m -> Maybe (Tree m)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Tree m -> AnchoredPath -> Maybe (Tree m)
forall (m :: * -> *). Tree m -> AnchoredPath -> Maybe (Tree m)
findTree AnchoredPath
wd (Tree m -> Maybe (Tree m))
-> (TreeState m -> Tree m) -> TreeState m -> Maybe (Tree m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeState m -> Tree m
forall (m :: * -> *). TreeState m -> Tree m
TM.tree)
let subs :: [AnchoredPath]
subs = [ [Name] -> AnchoredPath
AnchoredPath [Name
n] | (n :: Name
n, _) <- Tree m -> [(Name, TreeItem m)]
forall (m :: * -> *). Tree m -> [(Name, TreeItem m)]
listImmediate Tree m
tree,
Name -> Name -> Bool
eqAnycase Name
n Name
x ]
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool)
-> RWST AnchoredPath () (TreeState m) m [Bool] -> TreeMonad m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [AnchoredPath]
-> (AnchoredPath -> TreeMonad m Bool)
-> RWST AnchoredPath () (TreeState m) m [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [AnchoredPath]
subs (\path :: AnchoredPath
path -> do
Bool
file <- AnchoredPath -> TreeMonad m Bool
forall (m :: * -> *). TreeRO m => AnchoredPath -> m Bool
TM.fileExists AnchoredPath
path
if Bool
file then Bool -> TreeMonad m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else AnchoredPath -> TreeMonad m Bool -> TreeMonad m Bool
forall (m :: * -> *) a. TreeRO m => AnchoredPath -> m a -> m a
TM.withDirectory AnchoredPath
path (AnchoredPath -> TreeMonad m Bool
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m Bool
existsAnycase (AnchoredPath -> TreeMonad m Bool)
-> AnchoredPath -> TreeMonad m Bool
forall a b. (a -> b) -> a -> b
$ [Name] -> AnchoredPath
AnchoredPath [Name]
xs))
treeHas :: Monad m => Tree m -> FilePath -> m Bool
treeHas :: Tree m -> FilePath -> m Bool
treeHas tree :: Tree m
tree path :: FilePath
path = (Bool, Tree m) -> Bool
forall a b. (a, b) -> a
fst ((Bool, Tree m) -> Bool) -> m (Bool, Tree m) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` TreeMonad m Bool -> Tree m -> m (Bool, Tree m)
forall (m :: * -> *) a.
Monad m =>
TreeMonad m a -> Tree m -> m (a, Tree m)
TM.virtualTreeMonad (AnchoredPath -> TreeMonad m Bool
forall (m :: * -> *). TreeRO m => AnchoredPath -> m Bool
TM.exists (AnchoredPath -> TreeMonad m Bool)
-> AnchoredPath -> TreeMonad m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> AnchoredPath
floatPath FilePath
path) Tree m
tree
treeHasDir :: Monad m => Tree m -> FilePath -> m Bool
treeHasDir :: Tree m -> FilePath -> m Bool
treeHasDir tree :: Tree m
tree path :: FilePath
path = (Bool, Tree m) -> Bool
forall a b. (a, b) -> a
fst ((Bool, Tree m) -> Bool) -> m (Bool, Tree m) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` TreeMonad m Bool -> Tree m -> m (Bool, Tree m)
forall (m :: * -> *) a.
Monad m =>
TreeMonad m a -> Tree m -> m (a, Tree m)
TM.virtualTreeMonad (AnchoredPath -> TreeMonad m Bool
forall (m :: * -> *). TreeRO m => AnchoredPath -> m Bool
TM.directoryExists (AnchoredPath -> TreeMonad m Bool)
-> AnchoredPath -> TreeMonad m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> AnchoredPath
floatPath FilePath
path) Tree m
tree
treeHasFile :: Monad m => Tree m -> FilePath -> m Bool
treeHasFile :: Tree m -> FilePath -> m Bool
treeHasFile tree :: Tree m
tree path :: FilePath
path = (Bool, Tree m) -> Bool
forall a b. (a, b) -> a
fst ((Bool, Tree m) -> Bool) -> m (Bool, Tree m) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` TreeMonad m Bool -> Tree m -> m (Bool, Tree m)
forall (m :: * -> *) a.
Monad m =>
TreeMonad m a -> Tree m -> m (a, Tree m)
TM.virtualTreeMonad (AnchoredPath -> TreeMonad m Bool
forall (m :: * -> *). TreeRO m => AnchoredPath -> m Bool
TM.fileExists (AnchoredPath -> TreeMonad m Bool)
-> AnchoredPath -> TreeMonad m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> AnchoredPath
floatPath FilePath
path) Tree m
tree