{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module System.DirTree
(
DirTree (..)
, file
, symlink
, directory
, directoryFromFiles
, fromFiles
, fromFiles'
, fromFile
, toFiles
, FileKey
, fileKeyToPath
, fileKeyFromPath
, lookupFile
, traverseDirTree
, traverseDirTree'
, itraverseDirTree
, itraverseDirTree'
, mapDirTree'
, imapDirTree'
, depthfirst
, foldDirTree
, foldDirTree'
, ifoldDirTree
, ifoldDirTree'
, flatten
, findNode
, listNodes
, readDirTree
, lazyReadDirTree
, writeDirTree
, followLinks
, lazyFollowLinks
, Link (..)
, DirTreeNode (..)
, FileType
, fileTypeOfNode
, mapDirTreeNode
, foldDirTreeNode
, traverseDirTreeNode
, getFileType
, readPath
, DirTreeN
, FileMap
, toFileList
, fromFileList
, (-.>), (-|>), (-/>)
, toDeepFileList
, fromDeepFileList
, toFileNames
, lookupFileMap
, emptyFileMap
) where
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import Control.DeepSeq
import System.Directory hiding (findFile)
import System.FilePath
import Control.Lens.Combinators
import Data.Foldable
import Data.Semigroup
import Data.Void
import Text.Show
import GHC.Generics
import System.IO.Unsafe
newtype DirTree s a = DirTree
{ dirTreeNode :: DirTreeN s a
}
deriving (Eq, Ord, NFData, Generic)
instance (Show v, Show c) => Show (DirTree v c) where
showsPrec d c = showParen (d >9) $ (f $ dirTreeNode c)
where
f = \case
Directory a ->
showString "directory " . showsPrec 11 a
Symlink a ->
showString "symlink " . showsPrec 11 a
File a ->
showString "file " . showsPrec 11 a
type DirTreeN s a = DirTreeNode (FileMap (DirTree s a)) s a
instance Semigroup (DirTree s a) where
DirTree (Directory as) <> DirTree (Directory bs) =
DirTree (Directory (as <> bs))
_ <> a = a
instance Functor (DirTree s) where
fmap = mapDirTree' id
instance Foldable (DirTree s) where
foldMap = foldDirTree' (const mempty)
instance Traversable (DirTree s) where
traverse = traverseDirTree' pure
instance FunctorWithIndex FileKey (DirTree v)
instance FoldableWithIndex FileKey (DirTree v)
instance TraversableWithIndex FileKey (DirTree v) where
itraverse = itraverseDirTree' (const pure)
{-# INLINE itraverse #-}
file :: a -> DirTree s a
file = DirTree . File
symlink :: s -> DirTree s a
symlink = DirTree . Symlink
directory :: FileMap (DirTree s a) -> DirTree s a
directory = DirTree . Directory
directoryFromFiles :: [(String, DirTree s a)] -> DirTree s a
directoryFromFiles = DirTree . Directory . fromFileList
type FileKey = [String]
fileKeyFromPath :: FilePath -> FileKey
fileKeyFromPath =
reverse . splitDirectories
fileKeyToPath :: FileKey -> FilePath
fileKeyToPath =
joinPath . reverse
diffFileKey :: FileKey -> FileKey -> FilePath
diffFileKey f to' =
let (n, bs) = (suffix f to')
in fileKeyToPath (bs ++ replicate n "..")
where
suffix (a:as) (b:bs)
| a /= b =
(1 + length as, b:bs)
| otherwise =
suffix as bs
suffix (_:as) [] =
(1 + length as, [])
suffix [] bs =
(0, bs)
lookupFile :: FileKey -> DirTree v a -> Maybe (DirTree v a)
lookupFile fk = go (reverse fk)
where
go [] tree = Just tree
go (a:rest) (DirTree (Directory x)) =
go rest =<< lookupFileMap a x
go _ _ = Nothing
{-# inline lookupFile #-}
toFiles :: DirTree v a -> [(FileKey, Either v a)]
toFiles =
flip appEndo []
. ifoldDirTree' (\i s -> Endo ((i, Left s):)) (\i s -> Endo ((i, Right s):))
{-# INLINE toFiles #-}
fromFiles :: [(FileKey, Either v a)] -> Maybe (DirTree v a)
fromFiles =
fmap fromFiles' . NonEmpty.nonEmpty
{-# INLINE fromFiles #-}
fromFiles' :: NonEmpty.NonEmpty (FileKey, Either v a) -> DirTree v a
fromFiles' =
sconcat . fmap (uncurry fromPath)
{-# INLINE fromFiles' #-}
fromPath :: FileKey -> Either s a -> DirTree s a
fromPath key a =
foldr (\s f -> directory (singleFile s f)) (either symlink file a) key
{-# INLINE fromPath #-}
fromFile :: FileKey -> a -> DirTree Void a
fromFile key a =
foldr (\s f -> directory (singleFile s f)) (file a) key
{-# INLINE fromFile #-}
itraverseDirTree ::
Applicative f
=> ( FileKey -> DirTreeNode (FileMap (f (DirTree s' a'))) s a -> f (DirTreeN s' a'))
-> DirTree s a
-> f (DirTree s' a')
itraverseDirTree f = go []
where
go x (DirTree fs) = fmap DirTree . f x $
case fs of
Directory fm ->
Directory $ imap (\s a -> go (s:x) a) fm
Symlink a -> Symlink a
File a -> File a
{-# inline itraverseDirTree #-}
itraverseDirTree' ::
Applicative f
=> (FileKey -> s -> f s') -> (FileKey -> a -> f a')
-> DirTree s a
-> f (DirTree s' a')
itraverseDirTree' fs fa =
itraverseDirTree
(\key -> \case
Directory fm ->
Directory <$> traverse id fm
Symlink a -> Symlink <$> fs key a
File a -> File <$> fa key a
)
{-# inline itraverseDirTree' #-}
imapDirTree' :: (FileKey -> s -> s') -> (FileKey -> a -> a') -> DirTree s a -> DirTree s' a'
imapDirTree' fs fa =
runIdentity . itraverseDirTree' (\i -> Identity . fs i) (\i -> Identity . fa i)
{-# inline imapDirTree' #-}
ifoldDirTree' :: Monoid m => (FileKey -> s -> m) -> (FileKey -> a -> m) -> DirTree s a -> m
ifoldDirTree' fs fa =
ifoldDirTree (\i -> foldDirTreeNode fold (fs i) (fa i))
{-# inline ifoldDirTree' #-}
ifoldDirTree :: (FileKey -> DirTreeNode (FileMap m) s a -> m) -> DirTree s a -> m
ifoldDirTree f = go []
where
go x (DirTree fs) = f x $
case fs of
Directory fm ->
Directory $ imap (\s a -> go (s:x) a) fm
Symlink a -> Symlink a
File a -> File a
{-# inline ifoldDirTree #-}
traverseDirTree ::
Applicative f
=> (DirTreeNode (FileMap (f (DirTree s' a'))) s a -> f (DirTreeN s' a'))
-> DirTree s a
-> f (DirTree s' a')
traverseDirTree fm =
itraverseDirTree (const fm)
{-# inline traverseDirTree #-}
traverseDirTree' ::
Applicative m
=> (s -> m s') -> (a -> m a')
-> DirTree s a -> m (DirTree s' a')
traverseDirTree' fs fa =
itraverseDirTree' (const fs) (const fa)
{-# inline traverseDirTree' #-}
foldDirTree :: (DirTreeNode (FileMap m) s a -> m) -> DirTree s a -> m
foldDirTree f =
ifoldDirTree (const f)
{-# inline foldDirTree #-}
foldDirTree' :: Monoid m => (s -> m) -> (a -> m) -> DirTree s a -> m
foldDirTree' fs fa =
ifoldDirTree' (const fs) (const fa)
{-# inline foldDirTree' #-}
mapDirTree' :: (s -> s') -> (a -> a') -> DirTree s a -> DirTree s' a'
mapDirTree' fs fa =
imapDirTree' (const fs) (const fa)
{-# inline mapDirTree' #-}
flatten ::
(s -> DirTree s' a')
-> (a -> DirTree s' a')
-> DirTree s a
-> DirTree s' a'
flatten s a =
foldDirTree (foldDirTreeNode directory s a)
{-# inline flatten #-}
depthfirst ::
Monoid m
=>(FileKey -> DirTreeNode [String] v a -> m)
-> DirTree v a
-> m
depthfirst fm =
ifoldDirTree $ \key file' ->
case file' of
Directory files -> do
fm key (Directory $ toFileNames files) <> fold files
File a ->
fm key (File a)
Symlink v ->
fm key (Symlink v)
{-# inline depthfirst #-}
findNode ::
(FileKey -> DirTreeNode [String] v a -> Bool)
-> DirTree v a
-> Maybe (FileKey, DirTreeNode [String] v a)
findNode f =
fmap getFirst . depthfirst
(curry $ \case
a | uncurry f a -> Just (First a)
| otherwise -> Nothing
)
{-# inline findNode #-}
listNodes :: DirTree v a -> [(FileKey, DirTreeNode [String] v a)]
listNodes =
flip appEndo [] . depthfirst (curry $ Endo . (:))
{-# inline listNodes #-}
data Link
= Internal !FileKey
| External !FilePath
deriving (Show, Eq, Generic, NFData)
readDirTree ::
NFData a =>
(FilePath -> IO a)
-> FilePath
-> IO (DirTree Link a)
readDirTree reader' fp = do
force <$> lazyReadDirTree reader' fp
lazyReadDirTree ::
(FilePath -> IO a)
-> FilePath
-> IO (DirTree Link a)
lazyReadDirTree reader' basepath = do
from' <- canonicalizePath basepath
go from' [] basepath
where
go from' key fp = unsafeInterleaveIO $ do
node <- readPath fp
foldDirTreeNode
(fmap directory . imapM (\s _ -> go from' (s:key) (fp </> s)) . fromFilenames)
(fmap symlink . absolute)
(const $ file <$> reader' fp)
node
where
absolute a
| isAbsolute a =
return $ External a
| otherwise = do
a' <- canonicalizePath (takeDirectory fp </> a)
let a'' = makeRelative from' a'
if a'' /= a'
then return $ Internal (fileKeyFromPath a'')
else return $ External a'
{-# INLINE lazyReadDirTree #-}
writeDirTree ::
(FilePath -> a -> IO ())
-> FilePath
-> DirTree Link a
-> IO ()
writeDirTree writer fp tree = do
ifoldDirTree
( \fk i ->
let fp' = fp </> fileKeyToPath fk in
case i of
Directory m -> do
createDirectory fp'
fold m
Symlink (External target) ->
createFileLink target fp'
Symlink (Internal key) ->
createFileLink
(case (fk, key) of
(_:fk', _) -> diffFileKey fk' key
([], []) -> "."
([], _) -> error "Fail"
) fp'
File a ->
writer fp' a
)
tree
{-# INLINE writeDirTree #-}
followLinks :: NFData a => (FilePath -> IO a) -> DirTree Link a -> IO (DirTree Void a)
followLinks fio dt =
force <$> lazyFollowLinks fio dt
{-# INLINE followLinks #-}
lazyFollowLinks :: (FilePath -> IO a) -> DirTree Link a -> IO (DirTree Void a)
lazyFollowLinks reader' tree =
go tree tree
where
go basetree =
unsafeInterleaveIO
. fmap (flatten id file)
. traverseDirTree' (readLink basetree) pure
readLink basetree = \case
Internal s -> do
case lookupFile s basetree of
Just a -> go basetree a
Nothing ->
error $ "Could not find " ++ show s ++ " in the dirtree " ++ show (fmap (const ()) tree)
External s -> do
t <- lazyReadDirTree reader' s
lazyFollowLinks reader' t
data DirTreeNode r s a
= Directory r
| Symlink s
| File a
deriving (Show, Eq, Ord, Functor, Foldable, Traversable, NFData, Generic)
type FileType = DirTreeNode () () ()
flattenDirTreeNode :: DirTreeNode m m m -> m
flattenDirTreeNode = \case
File m -> m
Symlink m -> m
Directory m -> m
mapDirTreeNode ::
(r -> r') -> (s -> s') -> (a -> a')
-> DirTreeNode r s a
-> DirTreeNode r' s' a'
mapDirTreeNode fr fs fa = \case
File a -> File $ fa a
Symlink s -> Symlink $ fs s
Directory r -> Directory $ fr r
foldDirTreeNode :: (r -> m) -> (s -> m) -> (a -> m) -> DirTreeNode r s a -> m
foldDirTreeNode fr fs fa =
flattenDirTreeNode . mapDirTreeNode fr fs fa
traverseDirTreeNode ::
Functor m
=>
(r -> m r') -> (s -> m s') -> (a -> m a')
-> DirTreeNode r s a -> m (DirTreeNode r' s' a')
traverseDirTreeNode fr fs fa =
flattenDirTreeNode . mapDirTreeNode
(fmap Directory . fr)
(fmap Symlink . fs)
(fmap File . fa)
fileTypeOfNode :: DirTreeNode a b c -> FileType
fileTypeOfNode = mapDirTreeNode (const ()) (const ()) (const ())
getFileType :: FilePath -> IO FileType
getFileType fp =
pathIsSymbolicLink fp >>= \case
True ->
return $ Symlink ()
False ->
doesDirectoryExist fp >>= \case
True ->
return $ Directory ()
False ->
return $ File ()
readPath ::
FilePath
-> IO (DirTreeNode [String] FilePath ())
readPath fp = do
node <- getFileType fp
foldDirTreeNode
(const $ Directory <$> listDirectory fp)
(const $ Symlink <$> getSymbolicLinkTarget fp)
(const . return $ File ())
node
newtype FileMap a =
FileMap (Map.Map String a)
deriving (Eq, Ord, NFData, Generic, Functor, Foldable, Traversable)
(-.>) :: String -> a -> (String, DirTree x a)
(-.>) s a = (s, file a)
(-|>) :: String -> a -> (String, DirTree a x)
(-|>) s a = (s, symlink a)
(-/>) :: String -> [(String, DirTree a b)] -> (String, DirTree a b)
(-/>) s a = (s, directoryFromFiles a)
toFileList :: FileMap a -> [(String, a)]
toFileList (FileMap a) = Map.toList a
fromFileList :: [(String, a)] -> FileMap a
fromFileList = FileMap . Map.fromList
fromFilenames :: [String] -> FileMap ()
fromFilenames = fromFileList . map (,())
singleFile :: String -> a -> FileMap a
singleFile s a = FileMap (Map.singleton s a)
emptyFileMap :: FileMap a
emptyFileMap = FileMap Map.empty
toFileNames :: FileMap a -> [String]
toFileNames = map fst . toFileList
lookupFileMap :: String -> FileMap a -> Maybe a
lookupFileMap s (FileMap a) = Map.lookup s a
toDeepFileList :: FileMap (DirTree s a) -> [(FileKey, Either s a)]
toDeepFileList fm =
toFiles $ directory fm
fromDeepFileList :: [(FileKey, Either s a)] -> FileMap (DirTree s a)
fromDeepFileList lst =
maybe emptyFileMap
((\case
Directory fm -> fm
_ -> emptyFileMap
) . dirTreeNode)
$ fromFiles lst
instance (Show a, Show b) => Show (FileMap (DirTree a b)) where
showsPrec d m = showParen (d > 9) $ showString "fromFileList " . showFileList m
where
showFileList =
showListWith (\(s, x) -> f s $ dirTreeNode x) . toFileList
f s (Directory x) =
showsPrec (dir_prec+1) s .
showString " -/> " .
showFileList x
f s (Symlink x) =
showsPrec (dir_prec+1) s .
showString " -|> " .
showsPrec (dir_prec+1) x
f s (File x) =
showsPrec (dir_prec+1) s .
showString " -.> " .
showsPrec (dir_prec+1) x
dir_prec = 5
instance Semigroup a => Semigroup (FileMap a) where
FileMap as <> FileMap bs =
FileMap (Map.unionWith (<>) as bs)
instance Semigroup a => Monoid (FileMap a) where
mempty = emptyFileMap
instance FunctorWithIndex String FileMap
instance FoldableWithIndex String FileMap
instance TraversableWithIndex String FileMap where
itraverse f (FileMap fs) = FileMap <$> itraverse f fs
{-# INLINE itraverse #-}
data Anchored a = (:/)
{ base :: FilePath
, dirTree :: a
} deriving (Show, Eq, Ord, Functor, Foldable, Traversable, NFData, Generic)