module System.File.Tree
(
FSTree(..), mkFSTree, FSForest
, Tree(..), Forest
, TreeLens(..)
, getDirectory, getDirectory'
, copyTo, copyTo_
, moveTo, moveTo_
, mergeInto, mergeInto_
, remove, tryRemove, tryRemoveWith
, pop, pop_, flatten, flattenPostOrder, levels
, map, mapM, mapM_
, find, findM
, filter, filterM
, isFile, isDir, isSymLink, isSymDir, isSymFile, isRealFile, isRealDir
, extract, extractM
, truncateAt
, zipWithDest, zipWithDestM, zipWithDestM_
) where
import System.IO.Unsafe (unsafeInterleaveIO)
import Unsafe.Coerce (unsafeCoerce)
import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist,
copyFile, renameFile, removeFile, createDirectory,
createDirectoryIfMissing, removeDirectory,
removeDirectoryRecursive)
import System.FilePath ((</>))
#if !mingw32_HOST_OS
import System.Posix.Files (getSymbolicLinkStatus, isSymbolicLink)
#endif
import Data.Tree (Tree(..), Forest)
import qualified Data.Tree as Tree (flatten, levels)
import Data.DList as DL (DList(..), cons, append, toList, empty, concat, snoc)
import Control.Exception (throwIO, catch, IOException)
import System.IO.Error (ioeGetErrorType, doesNotExistErrorType)
import Control.Monad (forM, liftM, liftM2, void)
import Control.Monad.Identity (runIdentity)
import Control.Applicative ((<$>), (<*>), (<*))
import Control.Arrow (second)
import Data.Foldable (foldrM)
import qualified Data.Traversable as T (mapM)
import Data.Maybe (mapMaybe, catMaybes)
import Data.Lens.Common (Lens, lens, getL, setL, modL)
import Control.DeepSeq (NFData(..), deepseq)
import Control.Conditional (ifM, (<&&>), (<||>), notM, condM, otherwiseM)
import Data.Word (Word)
import Data.Typeable (Typeable)
import Data.Data (Data)
import Prelude hiding (filter, catch, map, mapM, mapM_)
import qualified Prelude as P
newtype FSTree = FSTree { toTree :: Tree FilePath } deriving
(Typeable, Data, Eq, Read, Show)
instance NFData FSTree where
rnf t = getL label t `deepseq` rnf (getL children t)
type FSForest = [FSTree]
mkFSTree :: FilePath -> FSForest -> FSTree
mkFSTree a = FSTree . Node a . mapToTree
mapFSTree :: Forest FilePath -> FSForest
mapFSTree = unsafeCoerce
mapToTree :: FSForest -> Forest FilePath
mapToTree = unsafeCoerce
class TreeLens t a | t -> a where
label :: Lens t a
children :: Lens t [t]
instance TreeLens (Tree a) a where
label = lens rootLabel (\a t -> t {rootLabel = a})
children = lens subForest (\c t -> t {subForest = c})
instance TreeLens FSTree FilePath where
label = lens (rootLabel . toTree)
(\a fs -> FSTree $ (toTree fs) {rootLabel = a})
children = lens (mapFSTree . subForest . toTree)
(\c fs -> FSTree $ (toTree fs) {subForest = mapToTree c})
getDirectory :: FilePath -> IO FSTree
getDirectory = getDir_ unsafeInterleaveIO
getDirectory' :: FilePath -> IO FSTree
getDirectory' = getDir_ id
getDir_ :: (forall a. IO a -> IO a) -> FilePath -> IO FSTree
getDir_ f p = mkFSTree p <$> getChildren p
where getChildren path = do
cs <- P.filter (`notElem` [".",".."])
<$> f (getDirectoryContents path)
forM cs $ \c ->
let c' = path </> c
in ifM (isRealDir c')
( f . fmap (mkFSTree c) . getChildren $ c' )
( return $ mkFSTree c [] )
isFile :: FilePath -> IO Bool
isFile = doesFileExist
isDir :: FilePath -> IO Bool
isDir = doesDirectoryExist
isSymLink :: FilePath -> IO Bool
#if mingw32_HOST_OS
isSymLink p = return False
#else
isSymLink p = (isSymbolicLink <$> getSymbolicLinkStatus p)
`catch` handler
where handler :: IOError -> IO Bool
handler e
| ioeGetErrorType e == doesNotExistErrorType = return False
| otherwise = throwIO e
#endif
isSymDir :: FilePath -> IO Bool
isSymDir p = isDir p <&&> isSymLink p
isSymFile :: FilePath -> IO Bool
isSymFile p = isFile p <&&> isSymLink p
isRealDir :: FilePath -> IO Bool
isRealDir p = isDir p <&&> notM (isSymLink p)
isRealFile :: FilePath -> IO Bool
isRealFile p = isFile p <&&> notM (isSymLink p)
pop :: FSTree -> (FilePath, FSForest)
pop fs = (path, P.map prepend cs)
where path = getL label fs
cs = getL children fs
prepend = modL label (path </>)
pop_ :: FSTree -> FSForest
pop_ = snd . pop
flatten :: FSTree -> [FilePath]
flatten = Tree.flatten . prependPaths
flattenPostOrder :: FSTree -> [FilePath]
flattenPostOrder = toList . flatten' . prependPaths
where flatten' (Node p cs) = DL.concat (P.map flatten' cs) `snoc` p
levels :: FSTree -> [[FilePath]]
levels = Tree.levels . prependPaths
map :: (FilePath -> b) -> FSTree -> Tree b
map f = fmap f . toTree
mapM :: Monad m => (FilePath -> m b) -> FSTree -> m (Tree b)
mapM f = T.mapM f . toTree
mapM_ :: Monad m => (FilePath -> m b) -> FSTree -> m ()
mapM_ f t = mapM f t >> return ()
filter :: (FilePath -> Bool) -> FSForest -> FSForest
filter p = runIdentity . filterM (return . p)
find :: (FilePath -> Bool) -> FSForest -> FSForest
find p = snd . extract p
extract :: (FilePath -> Bool) -> FSForest -> (FSForest, FSForest)
extract p = runIdentity . extractM (return . p)
filterM :: Monad m =>
(FilePath -> m Bool) -> FSForest -> m FSForest
filterM p = foldrM (filter' "") [] . mapToTree
where
filter' d (Node file cs) ts = do
let path = d </> file
cs' <- foldrM (filter' path) [] cs
b <- p path
return $
if b
then mkFSTree file cs' : ts
else case cs' of
[] -> ts
_ -> mkFSTree file cs' : ts
findM :: Monad m =>
(FilePath -> m Bool) -> FSForest -> m FSForest
findM p = liftM snd . extractM p
extractM :: Monad m =>
(FilePath -> m Bool) -> FSForest -> m (FSForest, FSForest)
extractM p = liftM (second toList) . extractM_ p
extractM_ :: Monad m =>
(FilePath -> m Bool) -> FSForest -> m (FSForest, DList FSTree)
extractM_ p = foldrM extract' ([], DL.empty) . P.map prependPaths
where
extract' t@(Node path cs) (ts, es)
= ifM (p path)
(
return (ts, FSTree t `cons` es)
)
(do
(cs', es') <- foldrM extract' ([], DL.empty) cs
let t' = mkFSTree path cs'
return (t' : ts, es' `append` es)
)
truncateAt :: TreeLens t a => Word -> t -> t
truncateAt n = modL children (mapMaybe (truncate' 1))
where
truncate' i t
| i > n = Nothing
| otherwise = Just . modL children (mapMaybe (truncate' (i+1))) $ t
prependPaths :: FSTree -> Tree FilePath
prependPaths (FSTree root) = modL children (P.map (prepend' rootPath)) root
where
rootPath = rootLabel root
prepend' parentPath = prependChildren . modL label (parentPath </>)
prependChildren fs = modL children (P.map (prepend' (rootLabel fs))) fs
copyTo :: FilePath -> FSTree -> IO FSTree
copyTo = zipWithDestM_ $ \src dest ->ifM (isRealDir src)
(createDirectoryIfMissing False dest)
(copyFile src dest)
copyTo_ :: FilePath -> FSTree -> IO ()
copyTo_ = (void .) . copyTo
moveTo :: FilePath -> FSTree -> IO FSTree
moveTo dest fs = do
condM [(isSymLink dest <||> isFile dest, removeFile dest)
,(isDir dest, removeDirectoryRecursive dest)
,(otherwiseM, return ())
]
zipWithDestM_
(\s d -> ifM (isRealDir s)
(createDirectory d)
(renameFile s d)
)
dest fs
<* removeEmptyDirectories fs
moveTo_ :: FilePath -> FSTree -> IO ()
moveTo_ = (void .) . moveTo
mergeInto :: FilePath -> FSTree -> IO FSTree
mergeInto dest fs = zipWithDestM_
(\s d -> ifM (isRealDir s)
(createDirectoryIfMissing False d)
(renameFile s d)
)
dest fs
<* removeEmptyDirectories fs
mergeInto_ :: FilePath -> FSTree -> IO ()
mergeInto_ = (void .) . mergeInto
remove :: FSTree -> IO ()
remove = void . tryRemoveWith throwIO
tryRemove :: FSTree -> IO [IOException]
tryRemove = tryRemoveWith return
tryRemoveWith :: (IOException -> IO a) -> FSTree -> IO [a]
tryRemoveWith handler = fmap (catMaybes . DL.toList) . remove' . prependPaths
where remove' (Node p cs) =
DL.snoc <$> (fmap DL.concat . P.mapM remove' $ cs)
<*> ifM (doesDirectoryExist p)
(tryRemoveDirectory p >> return Nothing)
(removeFile p >> return Nothing)
`catch` (fmap Just . handler)
removeEmptyDirectories :: FSTree -> IO ()
removeEmptyDirectories = P.mapM_ tryRemoveDirectory . flattenPostOrder
tryRemoveDirectory :: FilePath -> IO ()
tryRemoveDirectory path = removeDirectory path `catch` handler
where handler :: IOException -> IO ()
handler = const (return ())
zipWithDest :: (FilePath -> FilePath -> a)
-> FilePath -> FSTree
-> [a]
zipWithDest f dest fs = runIdentity $ zipWithDestM ((return .) . f) dest fs
zipWithDestM :: Monad m => (FilePath -> FilePath -> m a)
-> FilePath -> FSTree
-> m [a]
zipWithDestM f dest fs = liftM fst $ zipWithDestM__ f dest fs
zipWithDestM_ :: Monad m =>
(FilePath -> FilePath -> m a)
-> FilePath -> FSTree
-> m FSTree
zipWithDestM_ f dest fs = liftM snd $ zipWithDestM__ f dest fs
zipWithDestM__ :: Monad m =>
(FilePath -> FilePath -> m a)
-> FilePath -> FSTree
-> m ([a], FSTree)
zipWithDestM__ f rootDest fs =
liftM2 (,) (sequence $ zipWith f (flatten fs) (flatten destFs))
(return destFs)
where
destFs = setL label rootDest fs