dirforest (empty) → 0.1.0.0
raw patch · 3 files changed
+835/−0 lines, 3 filesdep +aesondep +autodocodecdep +base
Dependencies added: aeson, autodocodec, base, containers, deepseq, filepath, path, path-io, validity, validity-containers, validity-path
Files
- CHANGELOG.md +7/−0
- dirforest.cabal +45/−0
- src/Data/DirForest.hs +783/−0
+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# Changelog++## [0.1.0.0] - 2023-02-25++### Added++- `HasCodec` instance
+ dirforest.cabal view
@@ -0,0 +1,45 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.7.+--+-- see: https://github.com/sol/hpack+--+-- hash: 07edc1e97f6ea7c920746bf65d638e8846b8bc05e28ec5984e55703ef5d57ea2++name: dirforest+version: 0.1.0.0+synopsis: Typed directory forest+homepage: https://github.com/NorfairKing/dirforest#readme+bug-reports: https://github.com/NorfairKing/dirforest/issues+author: Tom Sydney Kerckhove+maintainer: syd@cs-syd.eu+copyright: 2020-2023 Tom Sydney Kerckhove+license: MIT+build-type: Simple+extra-source-files:+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/NorfairKing/dirforest++library+ exposed-modules:+ Data.DirForest+ other-modules:+ Paths_dirforest+ hs-source-dirs:+ src+ build-depends:+ aeson+ , autodocodec+ , base >=4.7 && <5+ , containers+ , deepseq+ , filepath+ , path+ , path-io+ , validity+ , validity-containers+ , validity-path+ default-language: Haskell2010
+ src/Data/DirForest.hs view
@@ -0,0 +1,783 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | A directory forest of files associated with values+--+-- This module is meant to be imported like this:+--+-- > import Data.DirForest (DirForest)+-- > import qualified Data.DirForest as DF+module Data.DirForest+ ( -- * Dirforest types+ DirTree (..),+ DirForest (..),+ InsertionError (..),+ FOD (..),++ -- * Comparisons+ eq1DirTree,+ ord1DirTree,+ eq1DirForest,+ ord1DirForest,++ -- * Query+ null,+ nullFiles,+ lookup,++ -- * Construction+ empty,+ singletonFile,+ singletonDir,+ insertFile,+ insertDir,++ -- * Traversal+ mapWithPath,+ traverseWithPath,+ traverseWithPath_,++ -- * Pruning+ pruneEmptyDirs,+ anyEmptyDir,++ -- * Conversion++ -- ** Map+ fromFileMap,+ toFileMap,+ fromMap,+ toMap,++ -- ** List+ fromFileList,+ toFileList,++ -- * IO++ -- ** Read+ read,+ readNonHidden,+ readFiltered,+ readNonHiddenFiltered,+ readOneLevel,+ readOneLevelNonHidden,+ readOneLevelFiltered,+ readOneLevelNonHiddenFiltered,+ hiddenRel,++ -- ** Write+ write,++ -- * Combinations++ -- ** Union+ InsertValidation (..),+ unpackInsertValidation,+ union,+ unionWith,+ unionWithKey,+ unions,++ -- ** Intersection+ intersection,+ intersectionWith,+ intersectionWithKey,+ intersections,++ -- ** Difference+ difference,+ differenceWith,+ differenceWithKey,++ -- * Filter+ filter,+ filterWithKey,+ filterHidden,+ )+where++import Autodocodec+import Control.Arrow (left)+import Control.DeepSeq+import Control.Monad+import Control.Monad.IO.Class+import Data.Aeson (FromJSON, ToJSON)+import Data.Functor.Classes+import Data.Functor.Identity+import Data.List (foldl')+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Validity+import Data.Validity.Containers ()+import Data.Validity.Map+import Data.Validity.Path ()+import GHC.Generics (Generic)+import Path+import Path.IO+import Path.Internal+import qualified System.FilePath as FP+import Prelude hiding (filter, lookup, null, read)+import qualified Prelude++data DirTree a+ = NodeFile a+ | NodeDir (DirForest a)+ deriving stock (Show, Generic, Functor)+ deriving (FromJSON, ToJSON) via (Autodocodec (DirTree a))++instance (Validity a) => Validity (DirTree a)++instance Eq a => Eq (DirTree a) where+ (==) = eq1DirTree (==)++instance Ord a => Ord (DirTree a) where+ compare = ord1DirTree compare++instance Eq1 DirTree where+ liftEq = eq1DirTree++instance Ord1 DirTree where+ liftCompare = ord1DirTree++instance NFData a => NFData (DirTree a)++instance Foldable DirTree where+ foldMap func =+ \case+ NodeFile v -> func v+ NodeDir df -> foldMap func df++instance Traversable DirTree where+ traverse func =+ \case+ NodeFile v -> NodeFile <$> func v+ NodeDir df -> NodeDir <$> traverse func df++instance HasCodec a => HasCodec (DirTree a) where+ codec =+ named "DirTree" $+ dimapCodec f g $+ eitherCodec+ (codec :: JSONCodec a)+ (codec :: JSONCodec (DirForest a))+ where+ f = \case+ Left a -> NodeFile a+ Right b -> NodeDir b+ g = \case+ NodeFile a -> Left a+ NodeDir b -> Right b++eq1DirTree :: (a -> b -> Bool) -> DirTree a -> DirTree b -> Bool+eq1DirTree eq dt1 dt2 = case (dt1, dt2) of+ (NodeFile a1, NodeFile a2) -> eq a1 a2+ (NodeDir df1, NodeDir df2) -> eq1DirForest eq df1 df2+ _ -> False++ord1DirTree :: (a -> b -> Ordering) -> DirTree a -> DirTree b -> Ordering+ord1DirTree cmp dt1 dt2 = case (dt1, dt2) of+ (NodeFile a1, NodeFile a2) -> cmp a1 a2+ (NodeDir df1, NodeDir df2) -> ord1DirForest cmp df1 df2+ (NodeFile _, NodeDir _) -> LT+ (NodeDir _, NodeFile _) -> GT++newtype DirForest a = DirForest+ { unDirForest :: Map FilePath (DirTree a)+ }+ deriving stock (Show, Generic, Functor)+ deriving (FromJSON, ToJSON) via (Autodocodec (DirForest a))++instance (Validity a) => Validity (DirForest a) where+ validate df@(DirForest m) =+ mconcat+ [ genericValidate df,+ decorateMap m $ \p dt ->+ let isTopLevel p_ = parent p_ == [reldir|./|]+ in case dt of+ NodeFile _ ->+ let rf = Path p :: Path Rel File+ in mconcat+ [ declare "There are no separators on this level" $ isTopLevel rf,+ validate (Path p :: Path Rel File)+ ]+ NodeDir (DirForest _) ->+ let rd = Path (FP.addTrailingPathSeparator p) :: Path Rel Dir+ in mconcat+ [ declare "the path has no trailing path separator" $+ not $+ FP.hasTrailingPathSeparator p,+ declare "There are no separators on this level" $ isTopLevel rd, -- We need this for equality with the files.+ validate rd+ ]+ ]++instance Eq a => Eq (DirForest a) where+ (==) = eq1DirForest (==)++instance Ord a => Ord (DirForest a) where+ compare = ord1DirForest compare++instance Eq1 DirForest where+ liftEq = eq1DirForest++instance Ord1 DirForest where+ liftCompare = ord1DirForest++instance NFData a => NFData (DirForest a)++instance Foldable DirForest where+ foldMap func (DirForest dtm) = foldMap (foldMap func) dtm++instance Traversable DirForest where+ traverse func (DirForest dtm) = DirForest <$> traverse (traverse func) dtm++instance HasCodec a => HasCodec (DirForest a) where+ codec =+ named "DirForest" $+ dimapCodec+ DirForest+ unDirForest+ (codec :: JSONCodec (Map FilePath (DirTree a)))++eq1DirForest :: (a -> b -> Bool) -> DirForest a -> DirForest b -> Bool+eq1DirForest eq (DirForest m1) (DirForest m2) =+ let l1 = M.toAscList m1+ l2 = M.toAscList m2+ in length l1 == length l2 && liftEq (\(p1, a1) (p2, a2) -> p1 == p2 && eq1DirTree eq a1 a2) l1 l2++ord1DirForest :: (a -> b -> Ordering) -> DirForest a -> DirForest b -> Ordering+ord1DirForest cmp (DirForest m1) (DirForest m2) =+ let l1 = M.toAscList m1+ l2 = M.toAscList m2+ in liftCompare (\(p1, a1) (p2, a2) -> compare p1 p2 <> ord1DirTree cmp a1 a2) l1 l2++-- | File or Dir+data FOD a+ = F a+ | D+ deriving (Show, Eq, Ord, Generic, Functor)++instance Validity a => Validity (FOD a)++-- | The empty forest+empty :: DirForest a+empty = DirForest M.empty++-- | True iff the forest is entirely empty+null :: DirForest a -> Bool+null (DirForest dtm) = M.null dtm++-- | True iff there are only empty directories in the directory forest+nullFiles :: DirForest a -> Bool+nullFiles (DirForest df) = all goTree df+ where+ goTree = \case+ NodeFile _ -> False+ NodeDir df' -> nullFiles df'++singletonFile :: Path Rel File -> a -> DirForest a+singletonFile rp a =+ case insertFile rp a empty of+ Right df -> df+ _ -> error "There can't have been anything in the way in an empty dir forest."++singletonDir :: Path Rel Dir -> DirForest a+singletonDir rp =+ case insertDir rp empty of+ Right df -> df+ _ -> error "There can't have been anything in the way in an empty dir forest."++mapWithPath :: (Path Rel File -> a -> b) -> DirForest a -> DirForest b+mapWithPath func df = runIdentity $ traverseWithPath (\a b -> Identity $ func a b) df++traverseWithPath :: forall a b f. Applicative f => (Path Rel File -> a -> f b) -> DirForest a -> f (DirForest b)+traverseWithPath func = goF [reldir|./|]+ where+ goF :: Path Rel Dir -> DirForest a -> f (DirForest b)+ goF cur (DirForest ts) = DirForest <$> M.traverseWithKey (goT cur) ts+ goT :: Path Rel Dir -> FilePath -> DirTree a -> f (DirTree b)+ goT cur fp = \case+ NodeFile v ->+ let rf = cur </> fromJust (parseRelFile fp)+ in NodeFile <$> func rf v+ NodeDir df ->+ let rd = cur </> fromJust (parseRelDir fp)+ in NodeDir <$> goF rd df++traverseWithPath_ :: forall a b f. Applicative f => (Path Rel File -> a -> f b) -> DirForest a -> f ()+traverseWithPath_ func = goF [reldir|./|]+ where+ goF :: Path Rel Dir -> DirForest a -> f ()+ goF cur (DirForest ts) = void $ M.traverseWithKey (goT cur) ts+ goT :: Path Rel Dir -> FilePath -> DirTree a -> f ()+ goT cur fp = \case+ NodeFile v ->+ let rf = cur </> fromJust (parseRelFile fp)+ in void $ func rf v+ NodeDir df ->+ let rd = cur </> fromJust (parseRelDir fp)+ in goF rd df++-- | Remove all empty directories from a 'DirForest'+--+-- This will return 'Nothing' if the root was also empty.+pruneEmptyDirs :: DirForest a -> Maybe (DirForest a)+pruneEmptyDirs (DirForest m) =+ let m' = M.mapMaybe goTree m+ in if M.null m' then Nothing else Just (DirForest m')+ where+ goTree :: DirTree a -> Maybe (DirTree a)+ goTree dt = case dt of+ NodeFile _ -> Just dt+ NodeDir df -> NodeDir <$> pruneEmptyDirs df++anyEmptyDir :: DirForest a -> Bool+anyEmptyDir (DirForest m) = M.null m || any goTree m+ where+ goTree :: DirTree a -> Bool+ goTree = \case+ NodeFile _ -> False+ NodeDir df -> anyEmptyDir df++lookup ::+ forall a.+ Path Rel File ->+ DirForest a ->+ Maybe a+lookup rp df = go df (FP.splitDirectories $ fromRelFile rp)+ where+ go :: DirForest a -> [FilePath] -> Maybe a+ go (DirForest ts) =+ \case+ [] -> Nothing+ [f] -> do+ dt <- M.lookup f ts+ case dt of+ NodeFile contents -> Just contents+ _ -> Nothing+ (d : ds) -> do+ dt <- M.lookup d ts+ case dt of+ NodeDir dt_ -> go dt_ ds+ _ -> Nothing++insertFOD ::+ forall a.+ FilePath ->+ FOD a ->+ DirForest a ->+ Either (InsertionError a) (DirForest a)+insertFOD fp fod dirForest = go [reldir|./|] dirForest (FP.splitDirectories fp)+ where+ node = case fod of+ F a -> NodeFile a+ D -> NodeDir empty+ go ::+ Path Rel Dir ->+ DirForest a ->+ [FilePath] ->+ Either (InsertionError a) (DirForest a)+ go cur df@(DirForest ts) =+ \case+ [] -> Right df -- Should not happen, but just insert nothing if it does.+ [f] ->+ -- The last piece+ case M.lookup f ts of+ Nothing ->+ pure $ DirForest $ M.insert f node ts+ Just dt ->+ case dt of+ NodeFile contents -> do+ let rf = cur </> fromJust (parseRelFile f)+ Left (FileInTheWay rf contents)+ NodeDir df' -> case fod of+ F _ -> do+ let rd = cur </> fromJust (parseRelDir f)+ Left (DirInTheWay rd df')+ D -> pure df -- If it's already there, nothing changes++ -- Not the last piece, must be a dir+ (d : ds) ->+ -- Check if this piece is already in the forest+ case M.lookup d ts of+ -- If it isn't, then we need to make it and try again+ Nothing -> do+ let df' = DirForest $ M.insert d (NodeDir empty) ts+ go cur df' (d : ds)+ -- If it is, then we can recurse down there.+ Just dt ->+ case dt of+ NodeFile contents -> do+ let rf = cur </> fromJust (parseRelFile d)+ Left (FileInTheWay rf contents)+ NodeDir df' -> do+ let newCur = cur </> fromJust (parseRelDir d)+ df'' <- go newCur df' ds+ pure $ DirForest $ M.insert d (NodeDir df'') ts++insertFile ::+ forall a.+ Path Rel File ->+ a ->+ DirForest a ->+ Either (InsertionError a) (DirForest a)+insertFile rp a = insertFOD (fromRelFile rp) (F a)++insertDir ::+ forall a.+ Path Rel Dir ->+ DirForest a ->+ Either (InsertionError a) (DirForest a)+insertDir rp = insertFOD (FP.dropTrailingPathSeparator $ fromRelDir rp) D++fromFileList :: [(Path Rel File, a)] -> Either (InsertionError a) (DirForest a)+fromFileList = foldM (flip $ uncurry insertFile) empty++toFileList :: DirForest a -> [(Path Rel File, a)]+toFileList = M.toList . toFileMap++data InsertValidation e a = InsertionErrors (NonEmpty (InsertionError e)) | NoInsertionErrors a+ deriving (Show, Eq, Generic, Functor)++instance (Validity e, Validity a) => Validity (InsertValidation e a)++instance Applicative (InsertValidation e) where+ pure = NoInsertionErrors+ InsertionErrors es1 <*> InsertionErrors es2 = InsertionErrors $ es1 <> es2+ InsertionErrors es <*> NoInsertionErrors _ = InsertionErrors es+ NoInsertionErrors _ <*> InsertionErrors es = InsertionErrors es+ NoInsertionErrors f <*> NoInsertionErrors a = NoInsertionErrors $ f a++unpackInsertValidation :: InsertValidation e a -> Either (NonEmpty (InsertionError e)) a+unpackInsertValidation = \case+ InsertionErrors es -> Left es+ NoInsertionErrors r -> Right r++-- Left-biased+union :: DirForest a -> DirForest a -> InsertValidation a (DirForest a)+union = unionWith const++-- Left-biased+unionWith :: (a -> a -> a) -> DirForest a -> DirForest a -> InsertValidation a (DirForest a)+unionWith func = unionWithKey (\_ a b -> func a b)++-- Left-biased+unionWithKey :: forall a. (Path Rel File -> a -> a -> a) -> DirForest a -> DirForest a -> InsertValidation a (DirForest a)+unionWithKey func = goForest "" -- Because "" FP.</> "anything" = "anything"+ where+ goForest :: FilePath -> DirForest a -> DirForest a -> InsertValidation a (DirForest a)+ goForest base (DirForest dtm1) (DirForest dtm2) =+ DirForest+ <$> sequenceA+ ( M.unionWithKey+ ( \p e1 e2 -> case (e1, e2) of+ (NoInsertionErrors m1, NoInsertionErrors m2) -> goTree (base FP.</> p) m1 m2+ _ -> error "Should not happen because we just M.map-ed only NoInsertionErrors, but it did"+ )+ (M.map NoInsertionErrors dtm1)+ (M.map NoInsertionErrors dtm2)+ )+ goTree :: FilePath -> DirTree a -> DirTree a -> InsertValidation a (DirTree a)+ goTree base dt1 dt2 = case (dt1, dt2) of+ (NodeDir df1, NodeDir df2) -> NodeDir <$> goForest base df1 df2+ (NodeFile a1, NodeFile a2) -> NoInsertionErrors $ NodeFile $ func (fromJust $ parseRelFile base) a1 a2+ (NodeFile a, NodeDir _) -> InsertionErrors $ FileInTheWay (fromJust $ parseRelFile base) a :| []+ (NodeDir df, NodeFile _) -> InsertionErrors $ DirInTheWay (fromJust $ parseRelDir base) df :| []++unions :: [DirForest a] -> Either (InsertionError a) (DirForest a)+unions = foldM (\df1 df2 -> left NE.head $ unpackInsertValidation $ union df1 df2) empty++intersection :: DirForest a -> DirForest b -> DirForest a+intersection = intersectionWith const++intersectionWith :: (a -> b -> c) -> DirForest a -> DirForest b -> DirForest c+intersectionWith func = intersectionWithKey (\_ a b -> func a b)++intersectionWithKey :: forall a b c. (Path Rel File -> a -> b -> c) -> DirForest a -> DirForest b -> DirForest c+intersectionWithKey func = goForest "" -- Because "" FP.</> "anything" = "anything"+ where+ goForest :: FilePath -> DirForest a -> DirForest b -> DirForest c+ goForest base (DirForest dtm1) (DirForest dtm2) =+ DirForest $ M.mapMaybe id $ M.intersectionWithKey (\p m1 m2 -> goTree (base FP.</> p) m1 m2) dtm1 dtm2+ goTree :: FilePath -> DirTree a -> DirTree b -> Maybe (DirTree c)+ goTree base dt1 dt2 = case (dt1, dt2) of+ (NodeDir df1_, NodeDir df2_) -> Just $ NodeDir $ goForest base df1_ df2_+ (NodeFile f1, NodeFile f2) -> Just $ NodeFile $ func (fromJust $ parseRelFile base) f1 f2 -- TODO is this what we want?+ _ -> Nothing++intersections :: [DirForest a] -> DirForest a+intersections = foldl' intersection empty++filter :: (a -> Bool) -> DirForest a -> DirForest a+filter func = filterWithKey (const func)++filterWithKey :: forall a. (Path Rel File -> a -> Bool) -> DirForest a -> DirForest a+filterWithKey filePred = goForest "" -- Because "" FP.</> "anything" = "anything"+ where+ goForest :: FilePath -> DirForest a -> DirForest a+ goForest base (DirForest df) =+ DirForest $+ M.mapMaybeWithKey+ (\p dt -> goTree (base FP.</> p) dt)+ df+ goTree :: FilePath -> DirTree a -> Maybe (DirTree a) -- Nothing means it will be removed+ goTree base dt = case dt of+ NodeFile cts -> do+ rf <- parseRelFile base+ if filePred rf cts then Just dt else Nothing+ NodeDir df -> Just $ NodeDir $ goForest base df++filterHidden :: forall a. DirForest a -> DirForest a+filterHidden = goForest+ where+ goPair :: FilePath -> DirTree a -> Maybe (DirTree a)+ goPair fp dt = if hiddenHere fp then Nothing else Just $ goTree dt+ goForest :: DirForest a -> DirForest a+ goForest (DirForest m) =+ DirForest $ M.mapMaybeWithKey goPair m+ goTree :: DirTree a -> DirTree a+ goTree dt = case dt of+ NodeFile _ -> dt+ NodeDir df -> NodeDir $ goForest df++difference :: DirForest a -> DirForest b -> DirForest a+difference = differenceWith $ \_ _ -> Nothing++differenceWith :: (a -> b -> Maybe a) -> DirForest a -> DirForest b -> DirForest a+differenceWith func = differenceWithKey $ const func++differenceWithKey :: forall a b. (Path Rel File -> a -> b -> Maybe a) -> DirForest a -> DirForest b -> DirForest a+differenceWithKey func = goForest "" -- Because "" </> "anything" = "anything"+ where+ goForest :: FilePath -> DirForest a -> DirForest b -> DirForest a+ goForest base (DirForest df1_) (DirForest df2_) =+ DirForest $ M.differenceWithKey (\p dt1 dt2 -> goTree (base FP.</> p) dt1 dt2) df1_ df2_+ goTree :: FilePath -> DirTree a -> DirTree b -> Maybe (DirTree a)+ goTree base dt1 dt2 = case (dt1, dt2) of+ (NodeFile v1, NodeFile v2) -> NodeFile <$> func (fromJust $ parseRelFile base) v1 v2+ (NodeFile v, NodeDir _) -> Just $ NodeFile v -- TODO not sure what the semantics are here+ (NodeDir df, NodeFile _) -> Just $ NodeDir df -- TODO not sure what the semantics are here+ (NodeDir df1_, NodeDir df2_) -> Just $ NodeDir $ goForest base df1_ df2_++data InsertionError a+ = FileInTheWay (Path Rel File) a+ | DirInTheWay (Path Rel Dir) (DirForest a)+ deriving (Show, Eq, Ord, Generic)++instance (Validity a) => Validity (InsertionError a)++fromFileMap :: Map (Path Rel File) a -> Either (InsertionError a) (DirForest a)+fromFileMap = foldM (\df (rf, cts) -> insertFile rf cts df) empty . M.toList++toFileMap :: DirForest a -> Map (Path Rel File) a+toFileMap = M.foldlWithKey go M.empty . unDirForest+ where+ go :: Map (Path Rel File) a -> FilePath -> DirTree a -> Map (Path Rel File) a+ go m path =+ \case+ NodeFile contents ->+ let rf = fromJust (parseRelFile path) -- Cannot fail if the original dirforest is valid+ in M.insert rf contents m+ NodeDir df ->+ let rd = fromJust (parseRelDir path) -- Cannot fail if the original dirforest is valid+ in M.union m $ M.mapKeys (rd </>) (toFileMap df)++fromMap :: Map FilePath (FOD a) -> Either (InsertionError a) (DirForest a)+fromMap = foldM (\df (rf, fod) -> insertFOD rf fod df) empty . M.toList++toMap :: DirForest a -> Map FilePath (FOD a)+toMap = M.foldlWithKey go M.empty . unDirForest+ where+ go :: Map FilePath (FOD a) -> FilePath -> DirTree a -> Map FilePath (FOD a)+ go m path =+ \case+ NodeFile contents ->+ M.insert path (F contents) m+ NodeDir df ->+ M.insert path D $ M.union m $ M.mapKeys (path FP.</>) (toMap df)++read ::+ forall a b m.+ (MonadIO m) =>+ Path b Dir ->+ (Path b File -> m a) ->+ m (DirForest a)+read = readFiltered (const True) (const True)++readNonHidden ::+ forall a b m.+ (MonadIO m) =>+ Path b Dir ->+ (Path b File -> m a) ->+ m (DirForest a)+readNonHidden = readNonHiddenFiltered (const True) (const True)++readNonHiddenFiltered ::+ forall a b m.+ (MonadIO m) =>+ (Path b File -> Bool) ->+ (Path b Dir -> Bool) ->+ Path b Dir ->+ (Path b File -> m a) ->+ m (DirForest a)+readNonHiddenFiltered filePred dirPred root = readFiltered (\f -> go f && filePred f) (\d -> go d && dirPred d) root+ where+ go af = case stripProperPrefix root af of+ Nothing -> True -- Whatever+ Just rf -> not $ hiddenRel rf++readFiltered ::+ forall a b m.+ (MonadIO m) =>+ (Path b File -> Bool) ->+ (Path b Dir -> Bool) ->+ Path b Dir ->+ (Path b File -> m a) ->+ m (DirForest a)+readFiltered filePred dirPred root readFunc = do+ e <- doesDirExist root+ if e+ then do+ fs <- walkDirAccumRel (Just decendHandler) outputWriter root+ case unions fs of+ Left _ -> error "There can't have been any intra-dir collisions, but there were."+ Right r -> pure r+ else pure empty+ where+ decendHandler :: Path Rel Dir -> [Path Rel Dir] -> [Path Rel File] -> m (WalkAction Rel)+ decendHandler subdir dirs _ = do+ let toExclude = Prelude.filter (not . dirPred . ((root </> subdir) </>)) dirs+ pure $ WalkExclude toExclude+ outputWriter :: Path Rel Dir -> [Path Rel Dir] -> [Path Rel File] -> m [DirForest a]+ outputWriter subdir dirs files = do+ df1 <- foldM goDir empty dirs+ (: []) <$> foldM goFile df1 files+ where+ goDir :: DirForest a -> Path Rel Dir -> m (DirForest a)+ goDir df p =+ let path = root </> subdir </> p+ in if dirPred path+ then case insertDir (subdir </> p) df of+ Left _ ->+ error+ "There can't have been anything in the way while reading a dirforest, but there was."+ Right df' -> pure df'+ else pure df+ goFile :: DirForest a -> Path Rel File -> m (DirForest a)+ goFile df p =+ let path = root </> subdir </> p+ in if filePred path+ then do+ contents <- readFunc path+ case insertFile (subdir </> p) contents df of+ Left _ ->+ error+ "There can't have been anything in the way while reading a dirforest, but there was."+ Right df' -> pure df'+ else pure df++readOneLevel ::+ forall a b m.+ (MonadIO m) =>+ Path b Dir ->+ (Path b File -> m a) ->+ m (DirForest a)+readOneLevel = readOneLevelFiltered (const True) (const True)++readOneLevelNonHidden ::+ forall a b m.+ (MonadIO m) =>+ Path b Dir ->+ (Path b File -> m a) ->+ m (DirForest a)+readOneLevelNonHidden = readOneLevelNonHiddenFiltered (const True) (const True)++readOneLevelNonHiddenFiltered ::+ forall a b m.+ (MonadIO m) =>+ (Path b File -> Bool) ->+ (Path b Dir -> Bool) ->+ Path b Dir ->+ (Path b File -> m a) ->+ m (DirForest a)+readOneLevelNonHiddenFiltered filePred dirPred root = readOneLevelFiltered (\f -> go f && filePred f) (\d -> go d && dirPred d) root+ where+ go af = case stripProperPrefix root af of+ Nothing -> True -- Whatever+ Just rf -> not $ hiddenRel rf++readOneLevelFiltered ::+ forall a b m.+ (MonadIO m) =>+ (Path b File -> Bool) ->+ (Path b Dir -> Bool) ->+ Path b Dir ->+ (Path b File -> m a) ->+ m (DirForest a)+readOneLevelFiltered filePred dirPred root readFunc = do+ (dirs, files) <- fmap (fromMaybe ([], [])) $ liftIO $ forgivingAbsence $ listDirRel root+ df1 <- foldM goDir empty dirs+ foldM goFile df1 files+ where+ goDir :: DirForest a -> Path Rel Dir -> m (DirForest a)+ goDir df p =+ let path = root </> p+ in if dirPred path+ then case insertDir p df of+ Left _ ->+ error+ "There can't have been anything in the way while reading a dirforest, but there was."+ Right df' -> pure df'+ else pure df+ goFile :: DirForest a -> Path Rel File -> m (DirForest a)+ goFile df p =+ let path = root </> p+ in if filePred path+ then do+ contents <- readFunc path+ case insertFile p contents df of+ Left _ ->+ error+ "There can't have been anything in the way while reading a dirforest, but there was."+ Right df' -> pure df'+ else pure df++write ::+ forall a b.+ (Show a, Ord a) =>+ Path b Dir ->+ DirForest a ->+ (Path b File -> a -> IO ()) ->+ IO ()+write root dirForest writeFunc = do+ ensureDir root+ forM_ (M.toList $ unDirForest dirForest) $ \(path, dt) ->+ case dt of+ NodeFile contents -> do+ f <- parseRelFile path+ let af = root </> f+ writeFunc af contents+ NodeDir df' -> do+ d <- parseRelDir path+ let ad = root </> d+ write ad df' writeFunc++hiddenRel :: Path Rel t -> Bool+hiddenRel = any hiddenHere . FP.splitDirectories . toFilePath++hiddenHere :: FilePath -> Bool+hiddenHere [] = False -- Technically not possible, but fine+hiddenHere ('.' : _) = True+hiddenHere _ = False