{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Internal part of the mock file system
--
-- Intended for qualified import
--
-- > import           System.FS.Sim.FsTree (FsTree)
-- > import qualified System.FS.Sim.FsTree as FS
module System.FS.Sim.FsTree (
    -- * FsTree type and indexing functions
    FsTree (..)
  , FsTreeError (..)
  , example
    -- * Construction
  , empty
    -- * Indexing
  , getDir
  , getFile
  , index
    -- * File system operations
  , createDirIfMissing
  , createDirWithParents
  , openFile
  , removeDirRecursive
  , removeFile
  , renameFile
  , replace
    -- * Path-listing
  , find
    -- * Pretty-printing
  , pretty
  ) where

import           Data.Functor.Const
import           Data.List.NonEmpty (NonEmpty (..))
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import           Data.Maybe (fromMaybe)
import           Data.Text (Text)
import qualified Data.Text as Text
import           Data.Tree
import           GHC.Generics (Generic)
import           GHC.Stack

import           System.FS.API.Types

{-------------------------------------------------------------------------------
  FsTree type and general indexing functions
-------------------------------------------------------------------------------}

-- | Simple in-memory representation of a file system
data FsTree a = File !a | Folder !(Folder a)
  deriving (Int -> FsTree a -> ShowS
[FsTree a] -> ShowS
FsTree a -> String
(Int -> FsTree a -> ShowS)
-> (FsTree a -> String) -> ([FsTree a] -> ShowS) -> Show (FsTree a)
forall a. Show a => Int -> FsTree a -> ShowS
forall a. Show a => [FsTree a] -> ShowS
forall a. Show a => FsTree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> FsTree a -> ShowS
showsPrec :: Int -> FsTree a -> ShowS
$cshow :: forall a. Show a => FsTree a -> String
show :: FsTree a -> String
$cshowList :: forall a. Show a => [FsTree a] -> ShowS
showList :: [FsTree a] -> ShowS
Show, FsTree a -> FsTree a -> Bool
(FsTree a -> FsTree a -> Bool)
-> (FsTree a -> FsTree a -> Bool) -> Eq (FsTree a)
forall a. Eq a => FsTree a -> FsTree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => FsTree a -> FsTree a -> Bool
== :: FsTree a -> FsTree a -> Bool
$c/= :: forall a. Eq a => FsTree a -> FsTree a -> Bool
/= :: FsTree a -> FsTree a -> Bool
Eq, (forall x. FsTree a -> Rep (FsTree a) x)
-> (forall x. Rep (FsTree a) x -> FsTree a) -> Generic (FsTree a)
forall x. Rep (FsTree a) x -> FsTree a
forall x. FsTree a -> Rep (FsTree a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (FsTree a) x -> FsTree a
forall a x. FsTree a -> Rep (FsTree a) x
$cfrom :: forall a x. FsTree a -> Rep (FsTree a) x
from :: forall x. FsTree a -> Rep (FsTree a) x
$cto :: forall a x. Rep (FsTree a) x -> FsTree a
to :: forall x. Rep (FsTree a) x -> FsTree a
Generic, (forall a b. (a -> b) -> FsTree a -> FsTree b)
-> (forall a b. a -> FsTree b -> FsTree a) -> Functor FsTree
forall a b. a -> FsTree b -> FsTree a
forall a b. (a -> b) -> FsTree a -> FsTree b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> FsTree a -> FsTree b
fmap :: forall a b. (a -> b) -> FsTree a -> FsTree b
$c<$ :: forall a b. a -> FsTree b -> FsTree a
<$ :: forall a b. a -> FsTree b -> FsTree a
Functor)

type Folder a = Map Text (FsTree a)

-- | Example
example :: Monoid a => FsTree a
example :: forall a. Monoid a => FsTree a
example =
    Folder a -> FsTree a
forall a. Folder a -> FsTree a
Folder (Folder a -> FsTree a) -> Folder a -> FsTree a
forall a b. (a -> b) -> a -> b
$ [(Text, FsTree a)] -> Folder a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
        (Text
"usr", Folder a -> FsTree a
forall a. Folder a -> FsTree a
Folder (Folder a -> FsTree a) -> Folder a -> FsTree a
forall a b. (a -> b) -> a -> b
$ [(Text, FsTree a)] -> Folder a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
            (Text
"local", Folder a -> FsTree a
forall a. Folder a -> FsTree a
Folder (Folder a -> FsTree a) -> Folder a -> FsTree a
forall a b. (a -> b) -> a -> b
$ [(Text, FsTree a)] -> Folder a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
                (Text
"bin", Folder a -> FsTree a
forall a. Folder a -> FsTree a
Folder Folder a
forall a. Monoid a => a
mempty)
              ])
          ])
      , (Text
"var", Folder a -> FsTree a
forall a. Folder a -> FsTree a
Folder (Folder a -> FsTree a) -> Folder a -> FsTree a
forall a b. (a -> b) -> a -> b
$ [(Text, FsTree a)] -> Folder a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
            (Text
"log",  Folder a -> FsTree a
forall a. Folder a -> FsTree a
Folder Folder a
forall a. Monoid a => a
mempty)
          , (Text
"mail", Folder a -> FsTree a
forall a. Folder a -> FsTree a
Folder Folder a
forall a. Monoid a => a
mempty)
          , (Text
"run",  Folder a -> FsTree a
forall a. Folder a -> FsTree a
Folder Folder a
forall a. Monoid a => a
mempty)
          , (Text
"tmp",  Folder a -> FsTree a
forall a. Folder a -> FsTree a
Folder (Folder a -> FsTree a) -> Folder a -> FsTree a
forall a b. (a -> b) -> a -> b
$ [(Text, FsTree a)] -> Folder a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [
                (Text
"foo.txt", a -> FsTree a
forall a. a -> FsTree a
File a
forall a. Monoid a => a
mempty)
              ])
          ])
      ]

-- | File access error
data FsTreeError =
    -- | A path @../a/..@ where @a@ is a file rather than a dir
    --
    -- We record both the full path and the invalid suffix.
    FsExpectedDir FsPath (NonEmpty Text)

    -- | A path @../a/..@ where @a@ is a dir rather than a file
    --
    -- No suffix is specified (it /must/ be the last part of the file)
  | FsExpectedFile FsPath

    -- | A path @../a/..@ or @../a@ where directory or file @a@ is missing
    --
    -- We record both the full path and the missing suffix.
  | FsMissing FsPath (NonEmpty Text)

    -- | A file was opened with the O_EXCL flag, but it already existed.
  | FsExists FsPath
  deriving (Int -> FsTreeError -> ShowS
[FsTreeError] -> ShowS
FsTreeError -> String
(Int -> FsTreeError -> ShowS)
-> (FsTreeError -> String)
-> ([FsTreeError] -> ShowS)
-> Show FsTreeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FsTreeError -> ShowS
showsPrec :: Int -> FsTreeError -> ShowS
$cshow :: FsTreeError -> String
show :: FsTreeError -> String
$cshowList :: [FsTreeError] -> ShowS
showList :: [FsTreeError] -> ShowS
Show)

setFsTreeErrorPath :: FsPath -> FsTreeError -> FsTreeError
setFsTreeErrorPath :: FsPath -> FsTreeError -> FsTreeError
setFsTreeErrorPath FsPath
fp (FsExpectedDir  FsPath
_ NonEmpty Text
suffix) = FsPath -> NonEmpty Text -> FsTreeError
FsExpectedDir  FsPath
fp NonEmpty Text
suffix
setFsTreeErrorPath FsPath
fp (FsExpectedFile FsPath
_)        = FsPath -> FsTreeError
FsExpectedFile FsPath
fp
setFsTreeErrorPath FsPath
fp (FsMissing      FsPath
_ NonEmpty Text
suffix) = FsPath -> NonEmpty Text -> FsTreeError
FsMissing      FsPath
fp NonEmpty Text
suffix
setFsTreeErrorPath FsPath
fp (FsExists FsPath
_)              = FsPath -> FsTreeError
FsExists       FsPath
fp

{-------------------------------------------------------------------------------
  Altering
-------------------------------------------------------------------------------}

-- | Most general indexing function
alterF :: forall f a. Functor f
       => FsPath                                -- ^ Path to look for
       -> (FsTreeError -> f (Maybe (FsTree a))) -- ^ Action on error
       -> (FsTree a    -> f (Maybe (FsTree a))) -- ^ Alter the tree when found
       -> (FsTree a    -> f (FsTree a))
alterF :: forall (f :: * -> *) a.
Functor f =>
FsPath
-> (FsTreeError -> f (Maybe (FsTree a)))
-> (FsTree a -> f (Maybe (FsTree a)))
-> FsTree a
-> f (FsTree a)
alterF FsPath
fp FsTreeError -> f (Maybe (FsTree a))
onErr FsTree a -> f (Maybe (FsTree a))
f = (Maybe (FsTree a) -> FsTree a)
-> f (Maybe (FsTree a)) -> f (FsTree a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FsTree a -> Maybe (FsTree a) -> FsTree a
forall a. a -> Maybe a -> a
fromMaybe FsTree a
forall a. FsTree a
empty) (f (Maybe (FsTree a)) -> f (FsTree a))
-> (FsTree a -> f (Maybe (FsTree a))) -> FsTree a -> f (FsTree a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> FsTree a -> f (Maybe (FsTree a))
go (FsPath -> [Text]
fsPathToList FsPath
fp)
  where
    go :: [Text] -> FsTree a -> f (Maybe (FsTree a))
    go :: [Text] -> FsTree a -> f (Maybe (FsTree a))
go []     FsTree a
t          = FsTree a -> f (Maybe (FsTree a))
f FsTree a
t
    go (Text
p:[Text]
ps) (File   a
_) = FsTreeError -> f (Maybe (FsTree a))
onErr (FsPath -> NonEmpty Text -> FsTreeError
FsExpectedDir FsPath
fp (Text
p Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:| [Text]
ps))
    go (Text
p:[Text]
ps) (Folder Folder a
m) = FsTree a -> Maybe (FsTree a)
forall a. a -> Maybe a
Just (FsTree a -> Maybe (FsTree a))
-> (Folder a -> FsTree a) -> Folder a -> Maybe (FsTree a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Folder a -> FsTree a
forall a. Folder a -> FsTree a
Folder (Folder a -> Maybe (FsTree a))
-> f (Folder a) -> f (Maybe (FsTree a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe (FsTree a) -> f (Maybe (FsTree a)))
-> Text -> Folder a -> f (Folder a)
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
M.alterF Maybe (FsTree a) -> f (Maybe (FsTree a))
f' Text
p Folder a
m
      where
        f' :: Maybe (FsTree a) -> f (Maybe (FsTree a))
        f' :: Maybe (FsTree a) -> f (Maybe (FsTree a))
f' Maybe (FsTree a)
Nothing  = FsTreeError -> f (Maybe (FsTree a))
onErr (FsPath -> NonEmpty Text -> FsTreeError
FsMissing FsPath
fp (Text
p Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:| [Text]
ps))
        f' (Just FsTree a
t) = [Text] -> FsTree a -> f (Maybe (FsTree a))
go [Text]
ps FsTree a
t

alterDir :: forall f a. Functor f
         => FsPath
         -> (FsTreeError -> f (FsTree a)) -- ^ Action on error
         -> f (Folder a)                  -- ^ If directory does not exist
         -> (Folder a -> f (Folder a))    -- ^ If directory exists
         -> (FsTree a -> f (FsTree a))
alterDir :: forall (f :: * -> *) a.
Functor f =>
FsPath
-> (FsTreeError -> f (FsTree a))
-> f (Folder a)
-> (Folder a -> f (Folder a))
-> FsTree a
-> f (FsTree a)
alterDir FsPath
p FsTreeError -> f (FsTree a)
onErr f (Folder a)
onNotExists Folder a -> f (Folder a)
onExists =
    FsPath
-> (FsTreeError -> f (Maybe (FsTree a)))
-> f (Maybe (Folder a))
-> (Folder a -> f (Maybe (Folder a)))
-> FsTree a
-> f (FsTree a)
forall (f :: * -> *) a.
Functor f =>
FsPath
-> (FsTreeError -> f (Maybe (FsTree a)))
-> f (Maybe (Folder a))
-> (Folder a -> f (Maybe (Folder a)))
-> FsTree a
-> f (FsTree a)
alterDirMaybe FsPath
p
      ((FsTree a -> Maybe (FsTree a))
-> f (FsTree a) -> f (Maybe (FsTree a))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FsTree a -> Maybe (FsTree a)
forall a. a -> Maybe a
Just (f (FsTree a) -> f (Maybe (FsTree a)))
-> (FsTreeError -> f (FsTree a))
-> FsTreeError
-> f (Maybe (FsTree a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsTreeError -> f (FsTree a)
onErr)
      ((Folder a -> Maybe (Folder a))
-> f (Folder a) -> f (Maybe (Folder a))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Folder a -> Maybe (Folder a)
forall a. a -> Maybe a
Just f (Folder a)
onNotExists)
      ((Folder a -> Maybe (Folder a))
-> f (Folder a) -> f (Maybe (Folder a))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Folder a -> Maybe (Folder a)
forall a. a -> Maybe a
Just (f (Folder a) -> f (Maybe (Folder a)))
-> (Folder a -> f (Folder a)) -> Folder a -> f (Maybe (Folder a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Folder a -> f (Folder a)
onExists)

-- | alterDirMaybe might remove a directory
alterDirMaybe :: forall f a. Functor f
              => FsPath
              -> (FsTreeError -> f (Maybe (FsTree a))) -- ^ Action on error
              -> f (Maybe (Folder a))                  -- ^ If directory does not exist
              -> (Folder a -> f (Maybe (Folder a)))    -- ^ If directory exists
              -> (FsTree a -> f (FsTree a))
alterDirMaybe :: forall (f :: * -> *) a.
Functor f =>
FsPath
-> (FsTreeError -> f (Maybe (FsTree a)))
-> f (Maybe (Folder a))
-> (Folder a -> f (Maybe (Folder a)))
-> FsTree a
-> f (FsTree a)
alterDirMaybe FsPath
p FsTreeError -> f (Maybe (FsTree a))
onErr f (Maybe (Folder a))
onNotExists Folder a -> f (Maybe (Folder a))
onExists = FsPath
-> (FsTreeError -> f (Maybe (FsTree a)))
-> (FsTree a -> f (Maybe (FsTree a)))
-> FsTree a
-> f (FsTree a)
forall (f :: * -> *) a.
Functor f =>
FsPath
-> (FsTreeError -> f (Maybe (FsTree a)))
-> (FsTree a -> f (Maybe (FsTree a)))
-> FsTree a
-> f (FsTree a)
alterF FsPath
p FsTreeError -> f (Maybe (FsTree a))
onErr' FsTree a -> f (Maybe (FsTree a))
f
  where
    onErr' :: FsTreeError -> f (Maybe (FsTree a))
    onErr' :: FsTreeError -> f (Maybe (FsTree a))
onErr' (FsMissing FsPath
_ (Text
_ :| [])) = (Folder a -> FsTree a) -> Maybe (Folder a) -> Maybe (FsTree a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Folder a -> FsTree a
forall a. Folder a -> FsTree a
Folder (Maybe (Folder a) -> Maybe (FsTree a))
-> f (Maybe (Folder a)) -> f (Maybe (FsTree a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Maybe (Folder a))
onNotExists
    onErr' FsTreeError
err                     = FsTreeError -> f (Maybe (FsTree a))
onErr FsTreeError
err

    f :: FsTree a -> f (Maybe (FsTree a))
    f :: FsTree a -> f (Maybe (FsTree a))
f (Folder Folder a
m) = (Folder a -> FsTree a) -> Maybe (Folder a) -> Maybe (FsTree a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Folder a -> FsTree a
forall a. Folder a -> FsTree a
Folder (Maybe (Folder a) -> Maybe (FsTree a))
-> f (Maybe (Folder a)) -> f (Maybe (FsTree a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Folder a -> f (Maybe (Folder a))
onExists Folder a
m
    f (File   a
_) = FsTreeError -> f (Maybe (FsTree a))
onErr (FsTreeError -> f (Maybe (FsTree a)))
-> FsTreeError -> f (Maybe (FsTree a))
forall a b. (a -> b) -> a -> b
$ FsPath -> NonEmpty Text -> FsTreeError
FsExpectedDir FsPath
p (HasCallStack => FsPath -> Text
FsPath -> Text
pathLast FsPath
p Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:| [])

alterFileMaybe :: forall f a. Functor f
               => FsPath
               -> (FsTreeError -> f (Maybe (FsTree a))) -- ^ Action on error
               -> f (Maybe a)                           -- ^ If file does not exist
               -> (a -> f (Maybe a))                    -- ^ If file exists
               -> (FsTree a -> f (FsTree a))
alterFileMaybe :: forall (f :: * -> *) a.
Functor f =>
FsPath
-> (FsTreeError -> f (Maybe (FsTree a)))
-> f (Maybe a)
-> (a -> f (Maybe a))
-> FsTree a
-> f (FsTree a)
alterFileMaybe FsPath
p FsTreeError -> f (Maybe (FsTree a))
onErr f (Maybe a)
onNotExists a -> f (Maybe a)
onExists = FsPath
-> (FsTreeError -> f (Maybe (FsTree a)))
-> (FsTree a -> f (Maybe (FsTree a)))
-> FsTree a
-> f (FsTree a)
forall (f :: * -> *) a.
Functor f =>
FsPath
-> (FsTreeError -> f (Maybe (FsTree a)))
-> (FsTree a -> f (Maybe (FsTree a)))
-> FsTree a
-> f (FsTree a)
alterF FsPath
p FsTreeError -> f (Maybe (FsTree a))
onErr' FsTree a -> f (Maybe (FsTree a))
f
  where
    onErr' :: FsTreeError -> f (Maybe (FsTree a))
    onErr' :: FsTreeError -> f (Maybe (FsTree a))
onErr' (FsMissing FsPath
_ (Text
_ :| [])) = (a -> FsTree a) -> Maybe a -> Maybe (FsTree a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> FsTree a
forall a. a -> FsTree a
File (Maybe a -> Maybe (FsTree a))
-> f (Maybe a) -> f (Maybe (FsTree a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Maybe a)
onNotExists
    onErr' FsTreeError
err                     = FsTreeError -> f (Maybe (FsTree a))
onErr FsTreeError
err

    f :: FsTree a -> f (Maybe (FsTree a))
    f :: FsTree a -> f (Maybe (FsTree a))
f (File   a
a) = (a -> FsTree a) -> Maybe a -> Maybe (FsTree a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> FsTree a
forall a. a -> FsTree a
File (Maybe a -> Maybe (FsTree a))
-> f (Maybe a) -> f (Maybe (FsTree a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f (Maybe a)
onExists a
a
    f (Folder Folder a
_) = FsTreeError -> f (Maybe (FsTree a))
onErr (FsTreeError -> f (Maybe (FsTree a)))
-> FsTreeError -> f (Maybe (FsTree a))
forall a b. (a -> b) -> a -> b
$ FsPath -> FsTreeError
FsExpectedFile FsPath
p

alterFile :: forall f a. Functor f
          => FsPath
          -> (FsTreeError -> f (FsTree a)) -- ^ Action on error
          -> f a                           -- ^ If file does not exist
          -> (a -> f a)                    -- ^ If file exists
          -> (FsTree a -> f (FsTree a))
alterFile :: forall (f :: * -> *) a.
Functor f =>
FsPath
-> (FsTreeError -> f (FsTree a))
-> f a
-> (a -> f a)
-> FsTree a
-> f (FsTree a)
alterFile FsPath
p FsTreeError -> f (FsTree a)
onErr f a
onNotExists a -> f a
onExists =
    FsPath
-> (FsTreeError -> f (Maybe (FsTree a)))
-> f (Maybe a)
-> (a -> f (Maybe a))
-> FsTree a
-> f (FsTree a)
forall (f :: * -> *) a.
Functor f =>
FsPath
-> (FsTreeError -> f (Maybe (FsTree a)))
-> f (Maybe a)
-> (a -> f (Maybe a))
-> FsTree a
-> f (FsTree a)
alterFileMaybe FsPath
p ((FsTree a -> Maybe (FsTree a))
-> f (FsTree a) -> f (Maybe (FsTree a))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FsTree a -> Maybe (FsTree a)
forall a. a -> Maybe a
Just (f (FsTree a) -> f (Maybe (FsTree a)))
-> (FsTreeError -> f (FsTree a))
-> FsTreeError
-> f (Maybe (FsTree a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsTreeError -> f (FsTree a)
onErr) ((a -> Maybe a) -> f a -> f (Maybe a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just f a
onNotExists)
      ((a -> Maybe a) -> f a -> f (Maybe a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (f a -> f (Maybe a)) -> (a -> f a) -> a -> f (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f a
onExists)


{-------------------------------------------------------------------------------
  Construction
-------------------------------------------------------------------------------}

empty :: FsTree a
empty :: forall a. FsTree a
empty = Folder a -> FsTree a
forall a. Folder a -> FsTree a
Folder Folder a
forall k a. Map k a
M.empty

{-------------------------------------------------------------------------------
  Auxiliary: paths
-------------------------------------------------------------------------------}

pathLast :: HasCallStack => FsPath -> Text
pathLast :: HasCallStack => FsPath -> Text
pathLast FsPath
fp = case FsPath -> Maybe (FsPath, Text)
fsPathSplit FsPath
fp of
                Maybe (FsPath, Text)
Nothing     -> String -> Text
forall a. HasCallStack => String -> a
error String
"pathLast: empty path"
                Just (FsPath
_, Text
p) -> Text
p

pathInits :: FsPath -> [FsPath]
pathInits :: FsPath -> [FsPath]
pathInits = [FsPath] -> [FsPath]
forall a. [a] -> [a]
reverse ([FsPath] -> [FsPath])
-> (FsPath -> [FsPath]) -> FsPath -> [FsPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsPath -> [FsPath]
go
  where
    go :: FsPath -> [FsPath]
    go :: FsPath -> [FsPath]
go FsPath
fp = FsPath
fp FsPath -> [FsPath] -> [FsPath]
forall a. a -> [a] -> [a]
: case FsPath -> Maybe (FsPath, Text)
fsPathSplit FsPath
fp of
                   Maybe (FsPath, Text)
Nothing       -> []
                   Just (FsPath
fp', Text
_) -> FsPath -> [FsPath]
go FsPath
fp'

{-------------------------------------------------------------------------------
  Indexing
-------------------------------------------------------------------------------}

-- | Index the FsTree by the given FsPath.
index :: FsPath -> FsTree a -> Either FsTreeError (FsTree a)
index :: forall a. FsPath -> FsTree a -> Either FsTreeError (FsTree a)
index FsPath
fp = Const (Either FsTreeError (FsTree a)) (FsTree a)
-> Either FsTreeError (FsTree a)
forall {k} a (b :: k). Const a b -> a
getConst (Const (Either FsTreeError (FsTree a)) (FsTree a)
 -> Either FsTreeError (FsTree a))
-> (FsTree a -> Const (Either FsTreeError (FsTree a)) (FsTree a))
-> FsTree a
-> Either FsTreeError (FsTree a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsPath
-> (FsTreeError
    -> Const (Either FsTreeError (FsTree a)) (Maybe (FsTree a)))
-> (FsTree a
    -> Const (Either FsTreeError (FsTree a)) (Maybe (FsTree a)))
-> FsTree a
-> Const (Either FsTreeError (FsTree a)) (FsTree a)
forall (f :: * -> *) a.
Functor f =>
FsPath
-> (FsTreeError -> f (Maybe (FsTree a)))
-> (FsTree a -> f (Maybe (FsTree a)))
-> FsTree a
-> f (FsTree a)
alterF FsPath
fp (Either FsTreeError (FsTree a)
-> Const (Either FsTreeError (FsTree a)) (Maybe (FsTree a))
forall {k} a (b :: k). a -> Const a b
Const (Either FsTreeError (FsTree a)
 -> Const (Either FsTreeError (FsTree a)) (Maybe (FsTree a)))
-> (FsTreeError -> Either FsTreeError (FsTree a))
-> FsTreeError
-> Const (Either FsTreeError (FsTree a)) (Maybe (FsTree a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsTreeError -> Either FsTreeError (FsTree a)
forall a b. a -> Either a b
Left) (Either FsTreeError (FsTree a)
-> Const (Either FsTreeError (FsTree a)) (Maybe (FsTree a))
forall {k} a (b :: k). a -> Const a b
Const (Either FsTreeError (FsTree a)
 -> Const (Either FsTreeError (FsTree a)) (Maybe (FsTree a)))
-> (FsTree a -> Either FsTreeError (FsTree a))
-> FsTree a
-> Const (Either FsTreeError (FsTree a)) (Maybe (FsTree a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsTree a -> Either FsTreeError (FsTree a)
forall a b. b -> Either a b
Right)

getFile :: FsPath -> FsTree a -> Either FsTreeError a
getFile :: forall a. FsPath -> FsTree a -> Either FsTreeError a
getFile FsPath
fp =
    Const (Either FsTreeError a) (FsTree a) -> Either FsTreeError a
forall {k} a (b :: k). Const a b -> a
getConst (Const (Either FsTreeError a) (FsTree a) -> Either FsTreeError a)
-> (FsTree a -> Const (Either FsTreeError a) (FsTree a))
-> FsTree a
-> Either FsTreeError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsPath
-> (FsTreeError -> Const (Either FsTreeError a) (FsTree a))
-> Const (Either FsTreeError a) a
-> (a -> Const (Either FsTreeError a) a)
-> FsTree a
-> Const (Either FsTreeError a) (FsTree a)
forall (f :: * -> *) a.
Functor f =>
FsPath
-> (FsTreeError -> f (FsTree a))
-> f a
-> (a -> f a)
-> FsTree a
-> f (FsTree a)
alterFile FsPath
fp (Either FsTreeError a -> Const (Either FsTreeError a) (FsTree a)
forall {k} a (b :: k). a -> Const a b
Const (Either FsTreeError a -> Const (Either FsTreeError a) (FsTree a))
-> (FsTreeError -> Either FsTreeError a)
-> FsTreeError
-> Const (Either FsTreeError a) (FsTree a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsTreeError -> Either FsTreeError a
forall a b. a -> Either a b
Left) Const (Either FsTreeError a) a
forall {b} {b}. Const (Either FsTreeError b) b
errNotExist (Either FsTreeError a -> Const (Either FsTreeError a) a
forall {k} a (b :: k). a -> Const a b
Const (Either FsTreeError a -> Const (Either FsTreeError a) a)
-> (a -> Either FsTreeError a)
-> a
-> Const (Either FsTreeError a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either FsTreeError a
forall a b. b -> Either a b
Right)
  where
    errNotExist :: Const (Either FsTreeError b) b
errNotExist = Either FsTreeError b -> Const (Either FsTreeError b) b
forall {k} a (b :: k). a -> Const a b
Const (Either FsTreeError b -> Const (Either FsTreeError b) b)
-> (FsTreeError -> Either FsTreeError b)
-> FsTreeError
-> Const (Either FsTreeError b) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsTreeError -> Either FsTreeError b
forall a b. a -> Either a b
Left (FsTreeError -> Const (Either FsTreeError b) b)
-> FsTreeError -> Const (Either FsTreeError b) b
forall a b. (a -> b) -> a -> b
$ FsPath -> NonEmpty Text -> FsTreeError
FsMissing FsPath
fp (HasCallStack => FsPath -> Text
FsPath -> Text
pathLast FsPath
fp Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:| [])

getDir :: FsPath -> FsTree a -> Either FsTreeError (Folder a)
getDir :: forall a. FsPath -> FsTree a -> Either FsTreeError (Folder a)
getDir FsPath
fp =
    Const (Either FsTreeError (Folder a)) (FsTree a)
-> Either FsTreeError (Folder a)
forall {k} a (b :: k). Const a b -> a
getConst (Const (Either FsTreeError (Folder a)) (FsTree a)
 -> Either FsTreeError (Folder a))
-> (FsTree a -> Const (Either FsTreeError (Folder a)) (FsTree a))
-> FsTree a
-> Either FsTreeError (Folder a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsPath
-> (FsTreeError
    -> Const (Either FsTreeError (Folder a)) (FsTree a))
-> Const (Either FsTreeError (Folder a)) (Folder a)
-> (Folder a -> Const (Either FsTreeError (Folder a)) (Folder a))
-> FsTree a
-> Const (Either FsTreeError (Folder a)) (FsTree a)
forall (f :: * -> *) a.
Functor f =>
FsPath
-> (FsTreeError -> f (FsTree a))
-> f (Folder a)
-> (Folder a -> f (Folder a))
-> FsTree a
-> f (FsTree a)
alterDir FsPath
fp (Either FsTreeError (Folder a)
-> Const (Either FsTreeError (Folder a)) (FsTree a)
forall {k} a (b :: k). a -> Const a b
Const (Either FsTreeError (Folder a)
 -> Const (Either FsTreeError (Folder a)) (FsTree a))
-> (FsTreeError -> Either FsTreeError (Folder a))
-> FsTreeError
-> Const (Either FsTreeError (Folder a)) (FsTree a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsTreeError -> Either FsTreeError (Folder a)
forall a b. a -> Either a b
Left) Const (Either FsTreeError (Folder a)) (Folder a)
forall {b} {b}. Const (Either FsTreeError b) b
errNotExist (Either FsTreeError (Folder a)
-> Const (Either FsTreeError (Folder a)) (Folder a)
forall {k} a (b :: k). a -> Const a b
Const (Either FsTreeError (Folder a)
 -> Const (Either FsTreeError (Folder a)) (Folder a))
-> (Folder a -> Either FsTreeError (Folder a))
-> Folder a
-> Const (Either FsTreeError (Folder a)) (Folder a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Folder a -> Either FsTreeError (Folder a)
forall a b. b -> Either a b
Right)
  where
    errNotExist :: Const (Either FsTreeError b) b
errNotExist = Either FsTreeError b -> Const (Either FsTreeError b) b
forall {k} a (b :: k). a -> Const a b
Const (Either FsTreeError b -> Const (Either FsTreeError b) b)
-> (FsTreeError -> Either FsTreeError b)
-> FsTreeError
-> Const (Either FsTreeError b) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsTreeError -> Either FsTreeError b
forall a b. a -> Either a b
Left (FsTreeError -> Const (Either FsTreeError b) b)
-> FsTreeError -> Const (Either FsTreeError b) b
forall a b. (a -> b) -> a -> b
$ FsPath -> NonEmpty Text -> FsTreeError
FsMissing FsPath
fp (HasCallStack => FsPath -> Text
FsPath -> Text
pathLast FsPath
fp Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:| [])

{-------------------------------------------------------------------------------
  Specific file system functions
-------------------------------------------------------------------------------}

-- | Open a file: create it if necessary or throw an error if it existed
-- already wile we were supposed to create it from scratch (when passed
-- 'MustBeNew').
openFile :: Monoid a
         => FsPath -> AllowExisting -> FsTree a -> Either FsTreeError (FsTree a)
openFile :: forall a.
Monoid a =>
FsPath
-> AllowExisting -> FsTree a -> Either FsTreeError (FsTree a)
openFile FsPath
fp AllowExisting
ex = FsPath
-> (FsTreeError -> Either FsTreeError (FsTree a))
-> Either FsTreeError a
-> (a -> Either FsTreeError a)
-> FsTree a
-> Either FsTreeError (FsTree a)
forall (f :: * -> *) a.
Functor f =>
FsPath
-> (FsTreeError -> f (FsTree a))
-> f a
-> (a -> f a)
-> FsTree a
-> f (FsTree a)
alterFile FsPath
fp FsTreeError -> Either FsTreeError (FsTree a)
forall a b. a -> Either a b
Left (a -> Either FsTreeError a
forall a b. b -> Either a b
Right a
forall a. Monoid a => a
mempty) ((a -> Either FsTreeError a)
 -> FsTree a -> Either FsTreeError (FsTree a))
-> (a -> Either FsTreeError a)
-> FsTree a
-> Either FsTreeError (FsTree a)
forall a b. (a -> b) -> a -> b
$ \a
a -> case AllowExisting
ex of
    AllowExisting
AllowExisting -> a -> Either FsTreeError a
forall a b. b -> Either a b
Right a
a
    AllowExisting
MustBeNew     -> FsTreeError -> Either FsTreeError a
forall a b. a -> Either a b
Left (FsPath -> FsTreeError
FsExists FsPath
fp)

-- | Replace the contents of the specified file (which must exist)
replace :: FsPath -> a -> FsTree a -> Either FsTreeError (FsTree a)
replace :: forall a. FsPath -> a -> FsTree a -> Either FsTreeError (FsTree a)
replace FsPath
fp a
new =
    FsPath
-> (FsTreeError -> Either FsTreeError (FsTree a))
-> Either FsTreeError a
-> (a -> Either FsTreeError a)
-> FsTree a
-> Either FsTreeError (FsTree a)
forall (f :: * -> *) a.
Functor f =>
FsPath
-> (FsTreeError -> f (FsTree a))
-> f a
-> (a -> f a)
-> FsTree a
-> f (FsTree a)
alterFile FsPath
fp FsTreeError -> Either FsTreeError (FsTree a)
forall a b. a -> Either a b
Left Either FsTreeError a
forall {b}. Either FsTreeError b
errNotExist (\a
_old -> a -> Either FsTreeError a
forall a b. b -> Either a b
Right a
new)
  where
    errNotExist :: Either FsTreeError b
errNotExist = FsTreeError -> Either FsTreeError b
forall a b. a -> Either a b
Left (FsPath -> NonEmpty Text -> FsTreeError
FsMissing FsPath
fp (HasCallStack => FsPath -> Text
FsPath -> Text
pathLast FsPath
fp Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:| []))

-- | Create a directory if it does not already exist
createDirIfMissing :: FsPath -> FsTree a -> Either FsTreeError (FsTree a)
createDirIfMissing :: forall a. FsPath -> FsTree a -> Either FsTreeError (FsTree a)
createDirIfMissing FsPath
fp = FsPath
-> (FsTreeError -> Either FsTreeError (FsTree a))
-> Either FsTreeError (Folder a)
-> (Folder a -> Either FsTreeError (Folder a))
-> FsTree a
-> Either FsTreeError (FsTree a)
forall (f :: * -> *) a.
Functor f =>
FsPath
-> (FsTreeError -> f (FsTree a))
-> f (Folder a)
-> (Folder a -> f (Folder a))
-> FsTree a
-> f (FsTree a)
alterDir FsPath
fp FsTreeError -> Either FsTreeError (FsTree a)
forall a b. a -> Either a b
Left (Folder a -> Either FsTreeError (Folder a)
forall a b. b -> Either a b
Right Folder a
forall k a. Map k a
M.empty) Folder a -> Either FsTreeError (Folder a)
forall a b. b -> Either a b
Right

-- | Create a directory and its parents if they do not already exist
createDirWithParents :: FsPath -> FsTree a -> Either FsTreeError (FsTree a)
createDirWithParents :: forall a. FsPath -> FsTree a -> Either FsTreeError (FsTree a)
createDirWithParents FsPath
fp =
      -- Report full path in the error, not the prefix at the point of failure
      (FsTreeError -> Either FsTreeError (FsTree a))
-> (FsTree a -> Either FsTreeError (FsTree a))
-> Either FsTreeError (FsTree a)
-> Either FsTreeError (FsTree a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FsTreeError -> Either FsTreeError (FsTree a)
forall a b. a -> Either a b
Left (FsTreeError -> Either FsTreeError (FsTree a))
-> (FsTreeError -> FsTreeError)
-> FsTreeError
-> Either FsTreeError (FsTree a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsPath -> FsTreeError -> FsTreeError
setFsTreeErrorPath FsPath
fp) FsTree a -> Either FsTreeError (FsTree a)
forall a b. b -> Either a b
Right
    (Either FsTreeError (FsTree a) -> Either FsTreeError (FsTree a))
-> (FsTree a -> Either FsTreeError (FsTree a))
-> FsTree a
-> Either FsTreeError (FsTree a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FsPath -> FsTree a -> Either FsTreeError (FsTree a))
-> [FsPath] -> FsTree a -> Either FsTreeError (FsTree a)
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> m b) -> [a] -> b -> m b
repeatedlyM FsPath -> FsTree a -> Either FsTreeError (FsTree a)
forall a. FsPath -> FsTree a -> Either FsTreeError (FsTree a)
createDirIfMissing (FsPath -> [FsPath]
pathInits FsPath
fp)
  where
    repeatedlyM :: Monad m => (a -> b -> m b) -> ([a] -> b -> m b)
    repeatedlyM :: forall (m :: * -> *) a b.
Monad m =>
(a -> b -> m b) -> [a] -> b -> m b
repeatedlyM = (b -> [a] -> m b) -> [a] -> b -> m b
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((b -> [a] -> m b) -> [a] -> b -> m b)
-> ((a -> b -> m b) -> b -> [a] -> m b)
-> (a -> b -> m b)
-> [a]
-> b
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> a -> m b) -> b -> [a] -> m b
forall (m :: * -> *) a b.
Monad m =>
(b -> a -> m b) -> b -> [a] -> m b
foldlM' ((b -> a -> m b) -> b -> [a] -> m b)
-> ((a -> b -> m b) -> b -> a -> m b)
-> (a -> b -> m b)
-> b
-> [a]
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b -> m b) -> b -> a -> m b
forall a b c. (a -> b -> c) -> b -> a -> c
flip

    foldlM' :: forall m a b. Monad m => (b -> a -> m b) -> b -> [a] -> m b
    foldlM' :: forall (m :: * -> *) a b.
Monad m =>
(b -> a -> m b) -> b -> [a] -> m b
foldlM' b -> a -> m b
f = b -> [a] -> m b
go
      where
        go :: b -> [a] -> m b
        go :: b -> [a] -> m b
go !b
acc []     = b -> m b
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
acc
        go !b
acc (a
x:[a]
xs) = b -> a -> m b
f b
acc a
x m b -> (b -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
acc' -> b -> [a] -> m b
go b
acc' [a]
xs

-- | Remove a directory (which must exist) and its contents
removeDirRecursive :: FsPath -> FsTree a -> Either FsTreeError (FsTree a)
removeDirRecursive :: forall a. FsPath -> FsTree a -> Either FsTreeError (FsTree a)
removeDirRecursive FsPath
fp =
    FsPath
-> (FsTreeError -> Either FsTreeError (Maybe (FsTree a)))
-> Either FsTreeError (Maybe (Folder a))
-> (Folder a -> Either FsTreeError (Maybe (Folder a)))
-> FsTree a
-> Either FsTreeError (FsTree a)
forall (f :: * -> *) a.
Functor f =>
FsPath
-> (FsTreeError -> f (Maybe (FsTree a)))
-> f (Maybe (Folder a))
-> (Folder a -> f (Maybe (Folder a)))
-> FsTree a
-> f (FsTree a)
alterDirMaybe FsPath
fp FsTreeError -> Either FsTreeError (Maybe (FsTree a))
forall a b. a -> Either a b
Left Either FsTreeError (Maybe (Folder a))
forall {b}. Either FsTreeError b
errNotExist (Either FsTreeError (Maybe (Folder a))
-> Folder a -> Either FsTreeError (Maybe (Folder a))
forall a b. a -> b -> a
const (Maybe (Folder a) -> Either FsTreeError (Maybe (Folder a))
forall a b. b -> Either a b
Right Maybe (Folder a)
forall a. Maybe a
Nothing))
  where
    errNotExist :: Either FsTreeError b
errNotExist = FsTreeError -> Either FsTreeError b
forall a b. a -> Either a b
Left (FsPath -> NonEmpty Text -> FsTreeError
FsMissing FsPath
fp (HasCallStack => FsPath -> Text
FsPath -> Text
pathLast FsPath
fp Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:| []))

-- | Remove a file (which must exist)
removeFile :: FsPath -> FsTree a -> Either FsTreeError (FsTree a)
removeFile :: forall a. FsPath -> FsTree a -> Either FsTreeError (FsTree a)
removeFile FsPath
fp =
    FsPath
-> (FsTreeError -> Either FsTreeError (Maybe (FsTree a)))
-> Either FsTreeError (Maybe a)
-> (a -> Either FsTreeError (Maybe a))
-> FsTree a
-> Either FsTreeError (FsTree a)
forall (f :: * -> *) a.
Functor f =>
FsPath
-> (FsTreeError -> f (Maybe (FsTree a)))
-> f (Maybe a)
-> (a -> f (Maybe a))
-> FsTree a
-> f (FsTree a)
alterFileMaybe FsPath
fp FsTreeError -> Either FsTreeError (Maybe (FsTree a))
forall a b. a -> Either a b
Left Either FsTreeError (Maybe a)
forall {b}. Either FsTreeError b
errNotExist (Either FsTreeError (Maybe a) -> a -> Either FsTreeError (Maybe a)
forall a b. a -> b -> a
const (Maybe a -> Either FsTreeError (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing))
  where
    errNotExist :: Either FsTreeError b
errNotExist = FsTreeError -> Either FsTreeError b
forall a b. a -> Either a b
Left (FsPath -> NonEmpty Text -> FsTreeError
FsMissing FsPath
fp (HasCallStack => FsPath -> Text
FsPath -> Text
pathLast FsPath
fp Text -> [Text] -> NonEmpty Text
forall a. a -> [a] -> NonEmpty a
:| []))

-- | Rename the file (which must exist) from the first path to the second
-- path. If there is already a file at the latter path, it is replaced by the
-- new one.
renameFile :: FsPath -> FsPath -> FsTree a -> Either FsTreeError (FsTree a)
renameFile :: forall a.
FsPath -> FsPath -> FsTree a -> Either FsTreeError (FsTree a)
renameFile FsPath
fpOld FsPath
fpNew FsTree a
tree = do
    a
oldF  <- FsPath -> FsTree a -> Either FsTreeError a
forall a. FsPath -> FsTree a -> Either FsTreeError a
getFile FsPath
fpOld FsTree a
tree
    -- Remove the old file
    FsTree a
tree' <- FsPath -> FsTree a -> Either FsTreeError (FsTree a)
forall a. FsPath -> FsTree a -> Either FsTreeError (FsTree a)
removeFile FsPath
fpOld FsTree a
tree
    -- Overwrite the new file with the old one
    FsPath
-> (FsTreeError -> Either FsTreeError (FsTree a))
-> Either FsTreeError a
-> (a -> Either FsTreeError a)
-> FsTree a
-> Either FsTreeError (FsTree a)
forall (f :: * -> *) a.
Functor f =>
FsPath
-> (FsTreeError -> f (FsTree a))
-> f a
-> (a -> f a)
-> FsTree a
-> f (FsTree a)
alterFile FsPath
fpNew FsTreeError -> Either FsTreeError (FsTree a)
forall a b. a -> Either a b
Left (a -> Either FsTreeError a
forall a b. b -> Either a b
Right a
oldF) (Either FsTreeError a -> a -> Either FsTreeError a
forall a b. a -> b -> a
const (a -> Either FsTreeError a
forall a b. b -> Either a b
Right a
oldF)) FsTree a
tree'

{-------------------------------------------------------------------------------
  Path-listing
-------------------------------------------------------------------------------}

-- Find all the file paths reachable from fp. Similar to Unix's @find@.
--
-- The initial path will be prepended to the each item in the resulting list of
-- paths.
--
-- For instance, given the following file system, say @fs@:
--
-- > usr
-- >  |-- local
-- >        |-- bin
--
-- find ["usr"] fs will return:
--
-- > [usr, usr/local, usr/local/bin]
--
-- find ["usr", "local"] fs will return:
--
-- > [usr/local, usr/local/bin]
--
-- See the unit tests in @Test.Ouroboros.Storage.FsTree@ for additional
-- examples.
--
-- If the given file system path does not exist, a (Left FsMissing{}) is
-- returned.
find :: forall a . FsPath -> FsTree a -> Either FsTreeError [FsPath]
find :: forall a. FsPath -> FsTree a -> Either FsTreeError [FsPath]
find FsPath
fp FsTree a
fs = (Folder a -> [FsPath])
-> Either FsTreeError (Folder a) -> Either FsTreeError [FsPath]
forall a b.
(a -> b) -> Either FsTreeError a -> Either FsTreeError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([[Text]] -> [FsPath]
appendStartingDir ([[Text]] -> [FsPath])
-> (Folder a -> [[Text]]) -> Folder a -> [FsPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Folder a -> [[Text]]
findTree) (Either FsTreeError (Folder a) -> Either FsTreeError [FsPath])
-> Either FsTreeError (Folder a) -> Either FsTreeError [FsPath]
forall a b. (a -> b) -> a -> b
$ FsPath -> FsTree a -> Either FsTreeError (Folder a)
forall a. FsPath -> FsTree a -> Either FsTreeError (Folder a)
getDir FsPath
fp FsTree a
fs
  where
    appendStartingDir :: [[Text]] -> [FsPath]
    appendStartingDir :: [[Text]] -> [FsPath]
appendStartingDir [[Text]]
fps = ([Text] -> FsPath) -> [[Text]] -> [FsPath]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> FsPath
fsPathFromList
                          ([[Text]] -> [FsPath]) -> [[Text]] -> [FsPath]
forall a b. (a -> b) -> a -> b
$ ([Text] -> [Text]) -> [[Text]] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FsPath -> [Text]
fsPathToList FsPath
fp [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<>)
                          ([[Text]] -> [[Text]]) -> [[Text]] -> [[Text]]
forall a b. (a -> b) -> a -> b
$ [][Text] -> [[Text]] -> [[Text]]
forall a. a -> [a] -> [a]
: [[Text]]
fps

    findTree :: Folder a -> [[Text]]
    findTree :: Folder a -> [[Text]]
findTree Folder a
folder = [[[Text]]] -> [[Text]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                    ([[[Text]]] -> [[Text]]) -> [[[Text]]] -> [[Text]]
forall a b. (a -> b) -> a -> b
$ ((Text, FsTree a) -> [[Text]]) -> [(Text, FsTree a)] -> [[[Text]]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, FsTree a) -> [[Text]]
appendFileNameAndFind
                    ([(Text, FsTree a)] -> [[[Text]]])
-> [(Text, FsTree a)] -> [[[Text]]]
forall a b. (a -> b) -> a -> b
$ Folder a -> [(Text, FsTree a)]
forall k a. Map k a -> [(k, a)]
M.toList Folder a
folder
      where
        appendFileNameAndFind :: (Text, FsTree a) -> [[Text]]
        appendFileNameAndFind :: (Text, FsTree a) -> [[Text]]
appendFileNameAndFind (Text
fileName, FsTree a
t) =
            [Text
fileName] [Text] -> [[Text]] -> [[Text]]
forall a. a -> [a] -> [a]
: (([Text] -> [Text]) -> [[Text]] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text
fileName] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<>) ([[Text]] -> [[Text]]) -> [[Text]] -> [[Text]]
forall a b. (a -> b) -> a -> b
$ FsTree a -> [[Text]]
findFsTree FsTree a
t)

        findFsTree :: FsTree a -> [[Text]]
        findFsTree :: FsTree a -> [[Text]]
findFsTree (File   a
_      ) = []
        findFsTree (Folder Folder a
folder') = Folder a -> [[Text]]
findTree Folder a
folder'

{-------------------------------------------------------------------------------
  Pretty-printing
-------------------------------------------------------------------------------}

pretty :: forall a. (a -> String) -> FsTree a -> String
pretty :: forall a. (a -> String) -> FsTree a -> String
pretty a -> String
f = Tree String -> String
drawTree (Tree String -> String)
-> (FsTree a -> Tree String) -> FsTree a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Maybe a) -> String) -> Tree (Text, Maybe a) -> Tree String
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Maybe a) -> String
renderNode (Tree (Text, Maybe a) -> Tree String)
-> (FsTree a -> Tree (Text, Maybe a)) -> FsTree a -> Tree String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsTree a -> Tree (Text, Maybe a)
forall a. FsTree a -> Tree (Text, Maybe a)
toTree
  where
    renderNode :: (Text, Maybe a) -> String
    renderNode :: (Text, Maybe a) -> String
renderNode (Text
fp, Maybe a
Nothing) = Text -> String
Text.unpack Text
fp
    renderNode (Text
fp, Just a
a)  = Text -> String
Text.unpack Text
fp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
f a
a

-- | Translate to a tree
toTree :: FsTree a -> Tree (Text, Maybe a)
toTree :: forall a. FsTree a -> Tree (Text, Maybe a)
toTree = \case
    File   a
_ -> String -> Tree (Text, Maybe a)
forall a. HasCallStack => String -> a
error String
"toTree: root must be directory"
    Folder Folder a
m -> (Text, Maybe a) -> [Tree (Text, Maybe a)] -> Tree (Text, Maybe a)
forall a. a -> [Tree a] -> Tree a
Node (Text
"/", Maybe a
forall a. Maybe a
Nothing) ([Tree (Text, Maybe a)] -> Tree (Text, Maybe a))
-> [Tree (Text, Maybe a)] -> Tree (Text, Maybe a)
forall a b. (a -> b) -> a -> b
$ ((Text, FsTree a) -> Tree (Text, Maybe a))
-> [(Text, FsTree a)] -> [Tree (Text, Maybe a)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, FsTree a) -> Tree (Text, Maybe a)
forall a. (Text, FsTree a) -> Tree (Text, Maybe a)
go (Folder a -> [(Text, FsTree a)]
forall k a. Map k a -> [(k, a)]
M.toList Folder a
m)
  where
    go :: (Text, FsTree a) -> Tree (Text, Maybe a)
    go :: forall a. (Text, FsTree a) -> Tree (Text, Maybe a)
go (Text
parent, File   a
a) = (Text, Maybe a) -> [Tree (Text, Maybe a)] -> Tree (Text, Maybe a)
forall a. a -> [Tree a] -> Tree a
Node (Text
parent, a -> Maybe a
forall a. a -> Maybe a
Just a
a) []
    go (Text
parent, Folder Folder a
m) = (Text, Maybe a) -> [Tree (Text, Maybe a)] -> Tree (Text, Maybe a)
forall a. a -> [Tree a] -> Tree a
Node (Text
parent, Maybe a
forall a. Maybe a
Nothing) ([Tree (Text, Maybe a)] -> Tree (Text, Maybe a))
-> [Tree (Text, Maybe a)] -> Tree (Text, Maybe a)
forall a b. (a -> b) -> a -> b
$ ((Text, FsTree a) -> Tree (Text, Maybe a))
-> [(Text, FsTree a)] -> [Tree (Text, Maybe a)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, FsTree a) -> Tree (Text, Maybe a)
forall a. (Text, FsTree a) -> Tree (Text, Maybe a)
go (Folder a -> [(Text, FsTree a)]
forall k a. Map k a -> [(k, a)]
M.toList Folder a
m)