{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module System.DirTree
(
DirTreeNode (..)
, RelativeFile (..)
, FileType
, fileTypeOfNode
, AsDirTreeNode (..)
, AsRelativeFile (..)
, getFileType
, readPath
, FileMap (..)
, emptyFileMap
, singletonFileMap
, toFileList
, fromFileList
, (.*), (./), (.*>), (.*.)
, lookupFileMap
, DirTree (..)
, RelativeDirTree
, asRelativeDirTree
, file
, realfile
, symlink
, directory
, directory'
, emptyDirectory
, createDeepFile
, createDeepTree
, FileKey
, fileKeyFromPath
, fileKeyToPath
, diffFileKey
, diffPath
, alterFile
, iflattenDirTree
, flattenDirTree
, depthfirst
, findNode
, listNodes
, readDirTree
, writeDirTree
, Link (..)
, toLink
, readRelativeDirTree
, followLinks
, writeRelativeDirTree
, DirForest (..)
, RelativeDirForest
, ForestFileKey
, fromForestFileKey
, toForestFileKey
, asRelativeDirForest
, emptyForest
, singletonForest
, createDeepForest
, alterForest
) where
import qualified Data.Map as Map
import Control.DeepSeq
import System.Directory hiding (findFile)
import System.FilePath
import Control.Lens.Combinators
import Control.Lens
import Data.Functor
import Data.Foldable
import Data.Bifunctor
import Data.Maybe
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.Semigroup (sconcat)
import Data.Monoid
import Data.Bitraversable
import Data.Bifoldable
import Control.Monad
import Text.Show
import GHC.Generics
data DirTreeNode r a
= Directory r
| File a
deriving (Show, Eq, Ord, Functor, Foldable, Traversable, NFData, Generic)
instance Bifunctor DirTreeNode where
bimap fr fa = \case
Directory r -> Directory (fr r)
File a -> File (fa a)
instance Bifoldable DirTreeNode where
bifoldMap fr fa = \case
Directory r -> fr r
File a -> fa a
instance Bitraversable DirTreeNode where
bitraverse fr fa = \case
Directory r -> Directory <$> fr r
File a -> File <$> fa a
makeClassyPrisms ''DirTreeNode
data RelativeFile s a
= Symlink s
| Real a
deriving (Show, Eq, Ord, Functor, Foldable, Traversable, NFData, Generic)
instance Bifunctor RelativeFile where
bimap fr fa = \case
Symlink r -> Symlink (fr r)
Real a -> Real (fa a)
instance Bifoldable RelativeFile where
bifoldMap fr fa = \case
Symlink r -> fr r
Real a -> fa a
instance Bitraversable RelativeFile where
bitraverse fr fa = \case
Symlink r -> Symlink <$> fr r
Real a -> Real <$> fa a
makeClassyPrisms ''RelativeFile
instance AsRelativeFile (DirTreeNode a (RelativeFile b c)) b c where
_RelativeFile = _File
type FileType = DirTreeNode () (RelativeFile () ())
fileTypeOfNode :: DirTreeNode a (RelativeFile b c) -> FileType
fileTypeOfNode = bimap (const ()) (bimap (const ()) (const ()))
getFileType :: FilePath -> IO FileType
getFileType fp =
pathIsSymbolicLink fp >>= \case
True ->
return $ File (Symlink ())
False ->
doesDirectoryExist fp >>= \case
True ->
return $ Directory ()
False ->
return $ File (Real ())
readPath ::
FilePath
-> IO (DirTreeNode [String] (RelativeFile FilePath ()))
readPath fp = bitraverse
(const $ listDirectory fp)
(bitraverse
(const $ getSymbolicLinkTarget fp)
return
) =<< getFileType fp
newtype FileMap a =
FileMap { fileMapAsMap :: Map.Map String a }
deriving (Eq, Ord, NFData, Generic, Functor, Foldable, Traversable)
singletonFileMap :: String -> a -> FileMap a
singletonFileMap s a = FileMap (Map.singleton s a)
emptyFileMap :: FileMap a
emptyFileMap = FileMap Map.empty
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 #-}
instance Show a => Show (DirForest a) where
showsPrec d m = showParen (d > 9) $ showString "DirForest . fromFileList " . showFileList m
where
showFileList =
showListWith (\(s, x) -> f s $ dirTreeNode x) . toFileList . getInternalFileMap
f s (Directory x) =
showsPrec (dir_prec+1) s .
showString " ./ " .
showFileList x
f s (File x) =
showsPrec (dir_prec+1) s .
showString " .* " .
showsPrec (dir_prec+1) x
dir_prec = 5
toFileList :: FileMap a -> [(String, a)]
toFileList (FileMap a) = Map.toList a
fromFileList :: [(String, a)] -> FileMap a
fromFileList = FileMap . Map.fromList
toFileNames :: FileMap a -> [String]
toFileNames = map fst . toFileList
lookupFileMap :: String -> FileMap a -> Maybe a
lookupFileMap s (FileMap a) = Map.lookup s a
alterFileMap ::
Functor f
=> (Maybe a -> f (Maybe a))
-> String
-> FileMap a
-> f (FileMap a)
alterFileMap fn key (FileMap fm) =
FileMap <$> Map.alterF fn key fm
type instance Index (FileMap a) = String
type instance IxValue (FileMap a) = a
instance Ixed (FileMap a) where
ix k f m = FileMap <$> ix k f (fileMapAsMap m)
{-# INLINE ix #-}
instance At (FileMap a) where
at = flip alterFileMap
{-# INLINE at #-}
type FileKey = [String]
type DirTreeN a = DirTreeNode (DirForest a) a
itraverseDirTreeN ::
Applicative f
=> (FileKey -> a -> f b)
-> DirTreeN a
-> f (DirTreeN b)
itraverseDirTreeN fia = \case
Directory m ->
Directory <$> itraverse (fia . fromForestFileKey) m
File a ->
File <$> fia [] a
newtype DirTree a = DirTree
{ dirTreeNode :: DirTreeNode (DirForest a) a
}
deriving (Eq, Ord, NFData, Generic)
instance Functor DirTree where
fmap f (DirTree a) = DirTree $ bimap (fmap f) f a
instance Foldable DirTree where
foldMap f (DirTree e) = bifoldMap (foldMap f) f e
instance Traversable DirTree where
traverse f (DirTree e) = DirTree <$> bitraverse (traverse f) f e
instance FunctorWithIndex FileKey DirTree
instance FoldableWithIndex FileKey DirTree
instance TraversableWithIndex FileKey DirTree where
itraverse f (DirTree fs) = DirTree <$> itraverseDirTreeN f fs
{-# INLINE itraverse #-}
type RelativeDirTree s a = DirTree (RelativeFile s a)
asRelativeDirTree :: DirTree a -> RelativeDirTree s a
asRelativeDirTree = fmap Real
instance (Show a) => Show (DirTree a) where
showsPrec d c = showParen (d >9) (f $ dirTreeNode c)
where
f = \case
Directory a ->
showString "directory " . showsPrec 11 a
File a ->
showString "file " . showsPrec 11 a
instance Semigroup (DirTree a) where
DirTree (Directory as) <> DirTree (Directory bs) =
DirTree (Directory (as <> bs))
_ <> a = a
file :: a -> DirTree a
file = DirTree . File
{-# INLINE file #-}
realfile :: a -> RelativeDirTree s a
realfile = file . Real
{-# INLINE realfile #-}
symlink :: s -> RelativeDirTree s a
symlink = file . Symlink
{-# INLINE symlink #-}
directory :: DirForest a -> DirTree a
directory = DirTree . Directory
{-# INLINE directory #-}
directory' :: [(String, DirTree a)] -> DirTree a
directory' = DirTree . Directory . DirForest . fromFileList
{-# INLINE directory' #-}
emptyDirectory :: DirTree a
emptyDirectory = directory' []
{-# INLINE emptyDirectory #-}
(.*) :: String -> a -> (String, DirTree a)
(.*) s a = (s, file a)
(.*>) :: String -> s -> (String, RelativeDirTree s a)
(.*>) s a = (s, symlink a)
(.*.) :: String -> a -> (String, RelativeDirTree s a)
(.*.) s a = (s, realfile a)
(./) :: String -> [(String, DirTree a)] -> (String, DirTree a)
(./) s a = (s, directory' a)
fileKeyFromPath :: FilePath -> FileKey
fileKeyFromPath =
splitDirectories
fileKeyToPath :: FileKey -> FilePath
fileKeyToPath =
joinPath
diffFileKey :: FileKey -> FileKey -> FilePath
diffFileKey f to' =
let (n, bs) = prefix f to'
in fileKeyToPath (replicate n ".." ++ bs)
where
prefix al@(a:as) bl@(b:bs)
| a == b = prefix as bs
| otherwise =
(length al, bl)
prefix (_:as) [] =
(1 + length as, [])
prefix [] bs =
(0, bs)
diffPath :: FileKey -> FilePath -> Maybe FileKey
diffPath f path
| isAbsolute path = Nothing
| otherwise = go (fileKeyFromPath path) (reverse f)
where
go = \case
"..":rest -> \case
_:as -> go rest as
[] -> Nothing
rest -> \m -> Just (reverse m ++ rest)
alterFile ::
forall f a. Functor f
=> (Maybe (DirTree a) -> f (Maybe (DirTree a)))
-> FileKey
-> Maybe (DirTree a)
-> f (Maybe (DirTree a))
alterFile fn key = maybe (newFile key) (go key) where
go key' tree@(DirTree node) =
case key' of
[] -> fn (Just tree)
k : rest ->
case node of
Directory a -> Just . directory <$> alterForest fn (k :| rest) a
File _ -> newFile rest
newFile :: FileKey -> f (Maybe (DirTree a))
newFile key' = fmap (createDeepTree key') <$> fn Nothing
{-# INLINE alterFile #-}
createDeepFile :: FileKey -> a -> DirTree a
createDeepFile key a =
createDeepTree key (file a)
{-# INLINE createDeepFile #-}
createDeepTree :: FileKey -> DirTree a -> DirTree a
createDeepTree key a =
foldr (\s f -> directory (singletonForest s f)) a key
{-# INLINE createDeepTree #-}
type instance Index (DirTree a) = FileKey
type instance IxValue (DirTree a) = DirTree a
instance Ixed (DirTree a) where
ix key fn = go key where
go key' tree@(DirTree node) =
case nonEmpty key' of
Nothing -> fn tree
Just fk ->
case node of
Directory a -> directory <$> ix fk fn a
File _ -> pure tree
{-# INLINE ix #-}
instance At (DirTree a) where
at k f m = fromMaybe m <$> alterFile f k (Just m)
{-# INLINE at #-}
iflattenDirTree ::
(FileKey -> DirTreeNode (FileMap m) a -> m)
-> DirTree a
-> m
iflattenDirTree f = go id where
go fk =
f (fk []) . first (imap (\k -> go (fk . (k:))) . getInternalFileMap) . dirTreeNode
{-# inline iflattenDirTree #-}
flattenDirTree ::
(DirTreeNode (FileMap m) a -> m)
-> DirTree a
-> m
flattenDirTree f = go where
go = f . first (fmap go . getInternalFileMap) . dirTreeNode
{-# inline flattenDirTree #-}
depthfirst ::
(Semigroup m)
=> (FileKey -> DirTreeNode [String] a -> m)
-> DirTree a
-> m
depthfirst f = iflattenDirTree $ \k -> \case
Directory fm -> sconcat $
f k (Directory . toFileNames $ fm) :| Data.Foldable.toList fm
File a -> f k (File a)
{-# inline depthfirst #-}
findNode ::
(FileKey -> DirTreeNode [String] a -> Bool)
-> DirTree a
-> Maybe (FileKey, DirTreeNode [String] a)
findNode f =
getFirst . depthfirst (\k a -> First $ guard (f k a) $> (k, a))
{-# inline findNode #-}
listNodes :: DirTree a -> [(FileKey, DirTreeNode [String] a)]
listNodes =
(`appEndo` []) . depthfirst (\k a -> Endo ((k, a):))
{-# inline listNodes #-}
data Link
= Internal !FileKey
| External !FilePath
deriving (Show, Eq, Generic, NFData)
toLink :: FileKey -> FilePath -> Link
toLink key f =
maybe (External f) Internal (diffPath (Prelude.init key) f)
readRelativeDirTree ::
(FilePath -> IO a)
-> FilePath
-> IO (RelativeDirTree Link a)
readRelativeDirTree reader' fp = do
from' <- canonicalizePath fp
go from' fp
where
go from' fp' = do
node <- readPath fp'
DirTree <$> bimapM
( fmap (DirForest . fromFileList) . mapM (\k -> (k,) <$> go from' (fp' </> k)) )
( bimapM absolute (const $ reader' fp') )
node
where
absolute a
| isAbsolute a =
return $ External a
| otherwise = do
a' <- canonicalizePath (takeDirectory fp' </> a)
let a'' = makeRelative from' a'
return $ if a'' /= a'
then Internal (fileKeyFromPath a'')
else External a'
readDirTree ::
(FilePath -> IO a)
-> FilePath
-> IO (DirTree a)
readDirTree fn fp =
readRelativeDirTree fn fp >>= followLinks fn
followLinks :: forall a. (FilePath -> IO a) -> RelativeDirTree Link a -> IO (DirTree a)
followLinks fn tree = go tree where
go = flattenDirTree $ \case
File (Symlink a) -> case a of
Internal s ->
case tree ^? ix s of
Just a' ->
go a'
Nothing ->
error $ "Could not find " ++ show s
++ " in the dirtree " ++ show (void tree)
External s ->
readDirTree fn s
File (Real a) ->
return $ file a
Directory a ->
directory . DirForest <$> sequence a
writeRelativeDirTree ::
(FilePath -> a -> IO ())
-> FilePath
-> RelativeDirTree Link a
-> IO ()
writeRelativeDirTree writer fp = depthfirst go where
go key = \case
Directory _ ->
createDirectory fp'
File a ->
case a of
Symlink (External target) ->
createFileLink target fp'
Symlink (Internal key') ->
createFileLink
(case (key, key') of
(_:fk', _) -> diffFileKey fk' key'
([], []) -> "."
([], _) -> error "Fail"
) fp'
Real a' ->
writer fp' a'
where fp' = fp </> fileKeyToPath key
{-# INLINE writeRelativeDirTree #-}
writeDirTree ::
(FilePath -> a -> IO ())
-> FilePath
-> DirTree a
-> IO ()
writeDirTree writer fp = writeRelativeDirTree writer fp . asRelativeDirTree
{-# INLINE writeDirTree #-}
newtype DirForest a = DirForest
{ getInternalFileMap :: FileMap (DirTree a)
} deriving (Eq, Ord, NFData, Generic)
instance Functor DirForest where
fmap f (DirForest a) = DirForest $ fmap (fmap f) a
instance Foldable DirForest where
foldMap f (DirForest e) = foldMap (foldMap f) e
instance Traversable DirForest where
traverse f (DirForest e) = DirForest <$> traverse (traverse f) e
instance FunctorWithIndex ForestFileKey DirForest
instance FoldableWithIndex ForestFileKey DirForest
instance TraversableWithIndex ForestFileKey DirForest where
itraverse f (DirForest fs) =
DirForest <$> itraverse (\k -> itraverse (f . (k:|))) fs
{-# INLINE itraverse #-}
instance Semigroup (DirForest a) where
(DirForest a) <> (DirForest b) = DirForest (a <> b)
instance Monoid (DirForest a) where
mempty = DirForest mempty
type ForestFileKey = NonEmpty String
fromForestFileKey :: ForestFileKey -> FileKey
fromForestFileKey = toList
toForestFileKey :: FileKey -> Maybe ForestFileKey
toForestFileKey = nonEmpty
emptyForest :: DirForest a
emptyForest = mempty
singletonForest :: String -> DirTree a -> DirForest a
singletonForest k f =
DirForest $ singletonFileMap k f
createDeepForest :: ForestFileKey -> DirTree a -> DirForest a
createDeepForest (k :| rest) f =
singletonForest k (createDeepTree rest f)
type RelativeDirForest s a = DirForest (RelativeFile s a)
asRelativeDirForest :: DirForest a -> RelativeDirForest s a
asRelativeDirForest = fmap Real
type instance Index (DirForest a) = ForestFileKey
type instance IxValue (DirForest a) = DirTree a
instance Ixed (DirForest a) where
ix (k :| key) fn a = DirForest <$> ix k (ix key fn) (getInternalFileMap a)
{-# INLINE ix #-}
alterForest ::
forall f a. Functor f
=> (Maybe (DirTree a) -> f (Maybe (DirTree a)))
-> ForestFileKey
-> DirForest a
-> f (DirForest a)
alterForest fn (k :| key) a =
DirForest <$> alterFileMap (alterFile fn key) k (getInternalFileMap a)
instance At (DirForest a) where
at k f = alterForest f k
{-# INLINE at #-}
makeWrapped ''DirTree
makeWrapped ''DirForest
instance AsDirTreeNode (DirTree a) (DirForest a) a where
_DirTreeNode = _Wrapped
{-# INLINE _DirTreeNode #-}