diff --git a/System/Directory/Tree.hs b/System/Directory/Tree.hs --- a/System/Directory/Tree.hs +++ b/System/Directory/Tree.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE CPP #-} -------------------------------------------------------------------- -- | -- Module : System.Directory.Tree @@ -9,50 +9,56 @@ -- Stability : experimental -- Portability: portable -- --- Provides a simple data structure mirroring a directory tree on the +-- Provides a simple data structure mirroring a directory tree on the -- filesystem, as well as useful functions for reading and writing file --- and directory structures in the IO monad. --- +-- and directory structures in the IO monad. +-- -- Errors are caught in a special constructor in the DirTree type. --- +-- -- Defined instances of Functor, Traversable and Foldable allow for -- easily operating on a directory of files. For example, you could use -- Foldable.foldr to create a hash of the entire contents of a directory. -- --- The functions `readDirectoryWithL` and `buildL` allow for doing +-- The functions `readDirectoryWithL` and `buildL` allow for doing -- directory-traversing IO lazily as required by the execution of pure -- code. This allows you to treat large directories the same way as you -- would a lazy infinite list. --- --- The AnchoredDirTree type is a simple wrapper for DirTree to keep --- track of a base directory context for the DirTree. -- +-- The AnchoredDirTree type is a simple wrapper for DirTree to keep +-- track of a base directory context for the DirTree. +-- -- Please send me any requests, bugs, or other feedback on this module! -- -------------------------------------------------------------------- module System.Directory.Tree ( - + -- * Data types for representing directory trees DirTree (..) , AnchoredDirTree (..) , FileName - + + -- * High level IO functions , readDirectory , readDirectoryWith , readDirectoryWithL , writeDirectory - , writeDirectoryWith - + , writeDirectoryWith + -- * Lower level functions - , zipPaths , build , buildL , openDirectory - , writeJustDirs - + , writeJustDirs + -- ** Manipulating FilePaths + , zipPaths + , free + -- * Utility functions + -- ** Shape comparison and equality + , equalShape + , comparingShape -- ** Handling failure , successful , anyFailed @@ -62,13 +68,26 @@ -- ** Tree Manipulations , flattenDir , sortDir + , sortDirShape , filterDir - , free + -- *** Low-level + , transformDir + -- ** Navigation + , dropTo -- ** Operators - , () + , () + + -- * Lenses + {- | These are compatible with the "lens" library + -} + , _contents, _err, _file, _name + , _anchor, _dirTree ) where -{- + + + +{- TODO: NEXT: - performance improvements, we want lazy dir functions to run in constant @@ -77,7 +96,7 @@ NEXT MAYBE: - tree combining functions - - tree searching based on file names + - more tree searching based on file names - look into comonad abstraction THE FUTURE!: @@ -87,25 +106,40 @@ {- CHANGES: 0.3.0 - -remove does not exist errors from DirTrees returned by `read*` + -remove does not exist errors from DirTrees returned by `read*` functions -add lazy `readDirectoryWithL` function which uses unsafePerformIO internally (and safely, we hope) to do DirTree-producing IO as needed by consuming function -writeDirectory now returns a DirTree to reflect what was written successfully to Disk. This lets us inspect for write failures with - (passed_DirTree == returned_DirTree) and easily inspect failures in + (passed_DirTree == returned_DirTree) and easily inspect failures in the returned DirTree -added functor instance for the AnchoredDirTree type 0.9.0: - -removed `sort` from `getDirsFiles`, move it to the Eq instance + -removed `sort` from `getDirsFiles`, move it to the Eq instance -Eq instance now only compares name, for directories we sort contents (see info re. Ord below) and recursively compare -Ord instance now works like this: 1) compare constructor: Failed < Dir < File 2) compare `name` - -added sortDir function + -added sortDir function + + 0.10.0 + -Eq and Ord instances now compare on free "contents" type variable + -we provide `equalShape` function for comparison of shape and filenames + of arbitrary trees (ignoring free "contents" variable) + -provide a comparingShape used in sortDirShape + -provide a `sortDirShape` function that sorts a tree, taking into + account the free file "contents" data + + 0.11.0 + - added records for AnchoredDirTree: 'anchor', 'dirTree' + - 'free' deprecated in favor of 'dirTree' + - added a new function 'dropTo' + - implemented lenses compatible with "lens" package, maybe even allowing + zipper usage! -} import System.Directory @@ -115,65 +149,73 @@ import System.IO.Error(ioeGetErrorType,isDoesNotExistErrorType) import Data.Ord (comparing) -import Data.List (sort, (\\)) +import Data.List (sort, sortBy, (\\)) -import Control.Applicative import qualified Data.Traversable as T import qualified Data.Foldable as F -- exported functions affected: `buildL`, `readDirectoryWithL` -import System.IO.Unsafe(unsafePerformIO) - +import System.IO.Unsafe(unsafeInterleaveIO) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif -- | the String in the name field is always a file name, never a full path. -- The free type variable is used in the File constructor and can hold Handles, -- Strings representing a file's contents or anything else you can think of. --- We catch any IO errors in the Failed constructor. an Exception can be +-- We catch any IO errors in the Failed constructor. an Exception can be -- converted to a String with 'show'. -data DirTree a = Failed { name :: FileName, +data DirTree a = Failed { name :: FileName, err :: IOException } | Dir { name :: FileName, - contents :: [DirTree a] } + contents :: [DirTree a] } | File { name :: FileName, file :: a } deriving Show - + -- | Two DirTrees are equal if they have the same constructor, the same name -- (and in the case of `Dir`s) their sorted `contents` are equal: -instance Eq (DirTree a) where - (Failed n _) == (Failed n' _) = n == n' - (File n _) == (File n' _) = n == n' - (Dir n cs) == (Dir n' cs') = (n == n') && (sort cs == sort cs') - _ == _ = False +instance (Eq a)=> Eq (DirTree a) where + (File n a) == (File n' a') = n == n' && a == a' + (Dir n cs) == (Dir n' cs') = + n == n' && sortBy comparingConstr cs == sortBy comparingConstr cs' + -- after comparing above we can hand off to shape equality function: + d == d' = equalShape d d' --- | FIRST: Failed < Dir < File, THEN: compare `on` name -instance Ord (DirTree a) where - compare (Failed _ _) (Dir _ _) = LT - compare (Failed _ _) (File _ _) = LT - compare (Dir _ _) (Failed _ _) = GT - compare (Dir _ _) (File _ _) = LT - compare (File _ _) (Failed _ _) = GT - compare (File _ _) (Dir _ _) = GT - compare t t' = comparing name t t' +-- | First compare constructors: Failed < Dir < File... +-- Then compare `name`... +-- Then compare free variable parameter of `File` constructors +instance (Ord a,Eq a) => Ord (DirTree a) where + compare (File n a) (File n' a') = + case compare n n' of + EQ -> compare a a' + el -> el + compare (Dir n cs) (Dir n' cs') = + case compare n n' of + EQ -> comparing sort cs cs' + el -> el + -- after comparing above we can hand off to shape ord function: + compare d d' = comparingShape d d' --- | a simple wrapper to hold a base directory name, which can be either --- an absolute or relative path. This lets us give the DirTree a context, --- while still letting us store only directory and file NAMES (not full paths) --- in the DirTree. (uses an infix constructor; don't be scared) -data AnchoredDirTree a = FilePath :/ DirTree a +-- | a simple wrapper to hold a base directory name, which can be either an +-- absolute or relative path. This lets us give the DirTree a context, while +-- still letting us store only directory and file /names/ (not full paths) in +-- the DirTree. (uses an infix constructor; don't be scared) +data AnchoredDirTree a = (:/) { anchor :: FilePath, dirTree :: DirTree a } deriving (Show, Ord, Eq) + -- | an element in a FilePath: type FileName = String instance Functor DirTree where - fmap = T.fmapDefault + fmap = T.fmapDefault instance F.Foldable DirTree where foldMap = T.foldMapDefault @@ -193,61 +235,68 @@ -- given the same fixity as <$>, is that right? infixl 4 - + ---------------------------- --[ HIGH LEVEL FUNCTIONS ]-- ---------------------------- --- | build an AnchoredDirTree, given the path to a directory, opening the files --- using readFile. --- Uses `readDirectoryWith` internally and has the effect of traversing the +-- | Build an AnchoredDirTree, given the path to a directory, opening the files +-- using readFile. +-- Uses @readDirectoryWith readFile@ internally and has the effect of traversing the -- entire directory structure. See `readDirectoryWithL` for lazy production -- of a DirTree structure. readDirectory :: FilePath -> IO (AnchoredDirTree String) readDirectory = readDirectoryWith readFile --- | same as readDirectory but allows us to, for example, use --- ByteString.readFile to return a tree of ByteStrings. +-- | Build a 'DirTree' rooted at @p@ and using @f@ to fill the 'file' field of 'File' nodes. +-- +-- The 'FilePath' arguments to @f@ will be the full path to the current file, and +-- will include the root @p@ as a prefix. +-- For example, the following would return a tree of full 'FilePath's +-- like \"..\/tmp\/foo\" and \"..\/tmp\/bar\/baz\": +-- +-- > readDirectoryWith return "../tmp" +-- +-- Note though that the 'build' function below already does this. readDirectoryWith :: (FilePath -> IO a) -> FilePath -> IO (AnchoredDirTree a) -readDirectoryWith f p = do (b:/t) <- buildWith' buildAtOnce' f p - let t' = removeNonexistent t - return ( b:/t') +readDirectoryWith f p = buildWith' buildAtOnce' f p -- | A "lazy" version of `readDirectoryWith` that does IO operations as needed -- i.e. as the tree is traversed in pure code. --- /NOTE:/ This function uses unsafePerformIO under the hood. I believe our use --- here is safe, but this function is experimental in this release: +-- +-- /NOTE:/ This function uses `unsafeInterleaveIO` under the hood. This means +-- that: +-- +-- * side effects are tied to evaluation order and only run on demand +-- * you might receive exceptions in pure code readDirectoryWithL :: (FilePath -> IO a) -> FilePath -> IO (AnchoredDirTree a) -readDirectoryWithL f p = do (b:/t) <- buildWith' buildLazilyUnsafe' f p - let t' = removeNonexistent t - return ( b:/t') +readDirectoryWithL f p = buildWith' buildLazilyUnsafe' f p --- | write a DirTree of strings to disk. Clobbers files of the same name. --- Doesn't affect files in the directories (if any already exist) with +-- | write a DirTree of strings to disk. Clobbers files of the same name. +-- Doesn't affect files in the directories (if any already exist) with -- different names. Returns a new AnchoredDirTree where failures were -- lifted into a `Failed` constructor: writeDirectory :: AnchoredDirTree String -> IO (AnchoredDirTree ()) writeDirectory = writeDirectoryWith writeFile --- | writes the directory structure to disk and uses the provided function to +-- | writes the directory structure to disk and uses the provided function to -- write the contents of `Files` to disk. The return value of the function will -- become the new `contents` of the returned, where IO errors at each node are -- replaced with `Failed` constructors. The returned tree can be compared to -- the passed tree to see what operations, if any, failed: writeDirectoryWith :: (FilePath -> a -> IO b) -> AnchoredDirTree a -> IO (AnchoredDirTree b) writeDirectoryWith f (b:/t) = (b:/) <$> write' b t - where write' b' (File n a) = handleDT n $ - File n <$> f (b'n) a - write' b' (Dir n cs) = handleDT n $ + where write' b' (File n a) = handleDT n $ + File n <$> f (b'n) a + write' b' (Dir n cs) = handleDT n $ do let bas = b'n createDirectoryIfMissing True bas Dir n <$> mapM (write' bas) cs - -- INTERESTING: have to rebuild Failed constr. to get to typecheck: write' _ (Failed n e) = return $ Failed n e @@ -266,72 +315,86 @@ --- | builds a DirTree from the contents of the directory passed to it, saving +-- | builds a DirTree from the contents of the directory passed to it, saving -- the base directory in the Anchored* wrapper. Errors are caught in the tree in --- the Failed constructor. The 'file' fields initially are populated with full +-- the Failed constructor. The 'file' fields initially are populated with full -- paths to the files they are abstracting. build :: FilePath -> IO (AnchoredDirTree FilePath) -build = buildWith' buildAtOnce' return -- we say 'return' here to get - -- back a tree of FilePaths +build = buildWith' buildAtOnce' return -- we say 'return' here to get + -- back a tree of FilePaths -- | identical to `build` but does directory reading IO lazily as needed: buildL :: FilePath -> IO (AnchoredDirTree FilePath) -buildL = buildWith' buildLazilyUnsafe' return - +buildL = buildWith' buildLazilyUnsafe' return + -- -- -- helpers: -- -- -- type UserIO a = FilePath -> IO a type Builder a = UserIO a -> FilePath -> IO (DirTree a) --- remove non-existent file errors, which are artifacts of the "non-atomic" --- nature of traversing a system firectory tree: +-- remove non-existent file errors, which are artifacts of the "non-atomic" +-- nature of traversing a system directory tree: buildWith' :: Builder a -> UserIO a -> FilePath -> IO (AnchoredDirTree a) -buildWith' bf' f p = +buildWith' bf' f p = do tree <- bf' f p return (baseDir p :/ removeNonexistent tree) - + -- IO function passed to our builder and finally executed here: buildAtOnce' :: Builder a buildAtOnce' f p = handleDT n $ - do isFile <- doesFileExist p - if isFile + do isFile <- doesFileExist p + if isFile then File n <$> f p else do cs <- getDirsFiles p Dir n <$> T.mapM (buildAtOnce' f . combine p) cs where n = topDir p --- using unsafePerformIO to get "lazy" traversal: +unsafeMapM :: (a -> IO b) -> [a] -> IO [b] +unsafeMapM _ [] = return [] +unsafeMapM f (x:xs) = unsafeInterleaveIO io + where + io = do + y <- f x + ys <- unsafeMapM f xs + return (y:ys) + + +-- using unsafeInterleaveIO to get "lazy" traversal: buildLazilyUnsafe' :: Builder a -buildLazilyUnsafe' f p = handleDT n $ - do isFile <- doesFileExist p - if isFile +buildLazilyUnsafe' f p = handleDT n $ + do isFile <- doesFileExist p + if isFile then File n <$> f p - -- HERE IS THE UNSAFE CODE: - else Dir n . fmap (rec . combine p) <$> getDirsFiles p - - where rec = unsafePerformIO . buildLazilyUnsafe' f + else do + files <- getDirsFiles p + + -- HERE IS THE UNSAFE LINE: + dirTrees <- unsafeMapM (rec . combine p) files + + return (Dir n dirTrees) + where rec = buildLazilyUnsafe' f n = topDir p - + ----------------- --[ UTILITIES ]-- ----------------- - ---- HANDLING FAILURES ---- + -- | True if any Failed constructors in the tree anyFailed :: DirTree a -> Bool anyFailed = not . successful @@ -349,31 +412,98 @@ -- | returns a list of 'Failed' constructors only: failures :: DirTree a -> [DirTree a] -failures = filter failed . flattenDir +failures = filter failed . flattenDir -- | maps a function to convert Failed DirTrees to Files or Dirs failedMap :: (FileName -> IOException -> DirTree a) -> DirTree a -> DirTree a -failedMap f = transform unFail +failedMap f = transformDir unFail where unFail (Failed n e) = f n e unFail c = c - +---- ORDERING AND EQUALITY ---- ----- OTHER ---- +-- | Recursively sort a directory tree according to the Ord instance +sortDir :: (Ord a)=> DirTree a -> DirTree a +sortDir = sortDirBy compare --- | strips away base directory wrapper: +-- | Recursively sort a tree as in `sortDir` but ignore the file contents of a +-- File constructor +sortDirShape :: DirTree a -> DirTree a +sortDirShape = sortDirBy comparingShape where + + -- HELPER: +sortDirBy :: (DirTree a -> DirTree a -> Ordering) -> DirTree a -> DirTree a +sortDirBy cf = transformDir sortD + where sortD (Dir n cs) = Dir n (sortBy cf cs) + sortD c = c + + +-- | Tests equality of two trees, ignoring their free variable portion. Can be +-- used to check if any files have been added or deleted, for instance. +equalShape :: DirTree a -> DirTree b -> Bool +equalShape d d' = comparingShape d d' == EQ + +-- TODO: we should use equalFilePath here, but how to sort properly? with System.Directory.canonicalizePath, before compare? + +-- | a compare function that ignores the free "file" type variable: +comparingShape :: DirTree a -> DirTree b -> Ordering +comparingShape (Dir n cs) (Dir n' cs') = + case compare n n' of + EQ -> comp (sortCs cs) (sortCs cs') + el -> el + where sortCs = sortBy comparingConstr + -- stolen from [] Ord instance: + comp [] [] = EQ + comp [] (_:_) = LT + comp (_:_) [] = GT + comp (x:xs) (y:ys) = case comparingShape x y of + EQ -> comp xs ys + other -> other + -- else simply compare the flat constructors, non-recursively: +comparingShape t t' = comparingConstr t t' + + + -- HELPER: a non-recursive comparison +comparingConstr :: DirTree a -> DirTree a1 -> Ordering +comparingConstr (Failed _ _) (Dir _ _) = LT +comparingConstr (Failed _ _) (File _ _) = LT +comparingConstr (File _ _) (Failed _ _) = GT +comparingConstr (File _ _) (Dir _ _) = GT +comparingConstr (Dir _ _) (Failed _ _) = GT +comparingConstr (Dir _ _) (File _ _) = LT + -- else compare on the names of constructors that are the same, without + -- looking at the contents of Dir constructors: +comparingConstr t t' = compare (name t) (name t') + + + + +---- OTHER ---- + +{-# DEPRECATED free "Use record 'dirTree'" #-} +-- | DEPRECATED. Use record 'dirTree' instead. free :: AnchoredDirTree a -> DirTree a -free (_:/t) = t +free = dirTree +-- | If the argument is a 'Dir' containing a sub-DirTree matching 'FileName' +-- then return that subtree, appending the 'name' of the old root 'Dir' to the +-- 'anchor' of the AnchoredDirTree wrapper. Otherwise return @Nothing@. +dropTo :: FileName -> AnchoredDirTree a -> Maybe (AnchoredDirTree a) +dropTo n' (p :/ Dir n ds') = search ds' + where search [] = Nothing + search (d:ds) | equalFilePath n' (name d) = Just ((pn) :/ d) + | otherwise = search ds +dropTo _ _ = Nothing + -- | applies the predicate to each constructor in the tree, removing it (and --- its children, of course) when the predicate returns False. The topmost +-- its children, of course) when the predicate returns False. The topmost -- constructor will always be preserved: filterDir :: (DirTree a -> Bool) -> DirTree a -> DirTree a -filterDir p = transform filterD +filterDir p = transformDir filterD where filterD (Dir n cs) = Dir n $ filter p cs filterD c = c @@ -385,16 +515,12 @@ flattenDir f = [f] --- | Sort the `contents` of every `Dir` constructor, see Ord instance above: -sortDir :: DirTree a -> DirTree a -sortDir = transform sortD - where sortD (Dir n cs) = Dir n (sort cs) - sortD c = c + -- | Allows for a function on a bare DirTree to be applied to an AnchoredDirTree --- within a Functor. Very similar to and useful in combination with `<$>`: -() :: (Functor f) => (DirTree a -> DirTree b) -> f (AnchoredDirTree a) -> +-- within a Functor. Very similar to and useful in combination with `<$>`: +() :: (Functor f) => (DirTree a -> DirTree b) -> f (AnchoredDirTree a) -> f (AnchoredDirTree b) () f = fmap (\(b :/ t) -> b :/ f t) @@ -404,15 +530,28 @@ --------------- +---- CONSTRUCTOR IDENTIFIERS ---- +{- +isFileC :: DirTree a -> Bool +isFileC (File _ _) = True +isFileC _ = False + +isDirC :: DirTree a -> Bool +isDirC (Dir _ _) = True +isDirC _ = False +-} + + ---- PATH CONVERSIONS ---- --- | tuple up the complete filename with the File contents, by building up the --- path, trie-style, from the root. The filepath will be relative to the current +-- | tuple up the complete file path with the 'file' contents, by building up the +-- path, trie-style, from the root. The filepath will be relative to \"anchored\" -- directory. --- This allows us to, for example, mapM_ 'uncurry writeFile' over a DirTree of --- strings, although `writeDirectory` does a better job of this. +-- +-- This allows us to, for example, @mapM_ uncurry writeFile@ over a DirTree of +-- strings, although 'writeDirectory' does a better job of this. zipPaths :: AnchoredDirTree a -> DirTree (FilePath, a) zipPaths (b :/ t) = zipP b t where zipP p (File n a) = File n (pn , a) @@ -422,7 +561,7 @@ -- extracting pathnames and base names: topDir, baseDir :: FilePath -> FilePath -topDir = last . splitDirectories +topDir = last . splitDirectories baseDir = joinPath . init . splitDirectories @@ -430,7 +569,7 @@ ---- IO HELPERS: ---- --- | writes the directory structure (not files) of a DirTree to the anchored +-- | writes the directory structure (not files) of a DirTree to the anchored -- directory. Returns a structure identical to the supplied tree with errors -- replaced by `Failed` constructors: writeJustDirs :: AnchoredDirTree a -> IO (AnchoredDirTree a) @@ -439,10 +578,10 @@ ----- the let expression is an annoying hack, because dropFileName "." == "" ----- and getDirectoryContents fails epically on "" --- prepares the directory contents list. we sort so that we can be sure of +-- prepares the directory contents list. we sort so that we can be sure of -- a consistent fold/traversal order on the same directory: getDirsFiles :: String -> IO [FilePath] -getDirsFiles cs = do let cs' = if null cs then "." else cs +getDirsFiles cs = do let cs' = if null cs then "." else cs dfs <- getDirectoryContents cs' return $ dfs \\ [".",".."] @@ -451,16 +590,16 @@ ---- FAILURE HELPERS: ---- --- handles an IO exception by returning a Failed constructor filled with that +-- handles an IO exception by returning a Failed constructor filled with that -- exception: handleDT :: FileName -> IO (DirTree a) -> IO (DirTree a) handleDT n = handle (return . Failed n) -- DoesNotExist errors not present at the topmost level could happen if a --- named file or directory is deleted after being listed by --- getDirectoryContents but before we can get it into memory. --- So we filter those errors out because the user should not see errors +-- named file or directory is deleted after being listed by +-- getDirectoryContents but before we can get it into memory. +-- So we filter those errors out because the user should not see errors -- raised by the internal implementation of this module: -- This leaves the error if it exists in the top (user-supplied) level: removeNonexistent :: DirTree a -> DirTree a @@ -469,13 +608,79 @@ isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err ----- THIS COULD BE USEFUL TO EXPORT: - --- at Dir constructor, apply transformation function to all of directory's --- contents, then remove the Nothing's and recurse. --- ALWAYS PRESERVES TOPMOST CONSTRUCTOR: -transform :: (DirTree a -> DirTree a) -> DirTree a -> DirTree a -transform f t = case f t of - (Dir n cs) -> Dir n $ map (transform f) cs +-- | At 'Dir' constructor, apply transformation function to all of directory's +-- contents, then remove the Nothing's and recurse. This always preserves the +-- topomst constructor. +transformDir :: (DirTree a -> DirTree a) -> DirTree a -> DirTree a +transformDir f t = case f t of + (Dir n cs) -> Dir n $ map (transformDir f) cs t' -> t' +-- Lenses, generated with TH from "lens" ----------- +-- TODO deprecate these? Pain in the ass to generate, and maybe it's intended +-- for users to generate their own lenses. +_contents :: + Applicative f => + ([DirTree a] -> f [DirTree a]) -> DirTree a -> f (DirTree a) + +_err :: + Applicative f => + (IOException -> f IOException) -> DirTree a -> f (DirTree a) + +_file :: + Applicative f => + (a -> f a) -> DirTree a -> f (DirTree a) + +_name :: + Functor f => + (FileName -> f FileName) -> DirTree a -> f (DirTree a) + +_anchor :: + Functor f => + (FilePath -> f FilePath) + -> AnchoredDirTree a -> f (AnchoredDirTree a) + +_dirTree :: + Functor f => + (DirTree t -> f (DirTree a)) + -> AnchoredDirTree t -> f (AnchoredDirTree a) + +--makeLensesFor [("name","_name"),("err","_err"),("contents","_contents"),("file","_file")] ''DirTree +_contents _f_a6s2 (Failed _name_a6s3 _err_a6s4) + = pure (Failed _name_a6s3 _err_a6s4) +_contents _f_a6s5 (Dir _name_a6s6 _contents'_a6s7) + = ((\ _contents_a6s8 -> Dir _name_a6s6 _contents_a6s8) + <$> (_f_a6s5 _contents'_a6s7)) +_contents _f_a6s9 (File _name_a6sa _file_a6sb) + = pure (File _name_a6sa _file_a6sb) +_err _f_a6sd (Failed _name_a6se _err'_a6sf) + = ((\ _err_a6sg -> Failed _name_a6se _err_a6sg) + <$> (_f_a6sd _err'_a6sf)) +_err _f_a6sh (Dir _name_a6si _contents_a6sj) + = pure (Dir _name_a6si _contents_a6sj) +_err _f_a6sk (File _name_a6sl _file_a6sm) + = pure (File _name_a6sl _file_a6sm) +_file _f_a6so (Failed _name_a6sp _err_a6sq) + = pure (Failed _name_a6sp _err_a6sq) +_file _f_a6sr (Dir _name_a6ss _contents_a6st) + = pure (Dir _name_a6ss _contents_a6st) +_file _f_a6su (File _name_a6sv _file'_a6sw) + = ((\ _file_a6sx -> File _name_a6sv _file_a6sx) + <$> (_f_a6su _file'_a6sw)) +_name _f_a6sz (Failed _name'_a6sA _err_a6sC) + = ((\ _name_a6sB -> Failed _name_a6sB _err_a6sC) + <$> (_f_a6sz _name'_a6sA)) +_name _f_a6sD (Dir _name'_a6sE _contents_a6sG) + = ((\ _name_a6sF -> Dir _name_a6sF _contents_a6sG) + <$> (_f_a6sD _name'_a6sE)) +_name _f_a6sH (File _name'_a6sI _file_a6sK) + = ((\ _name_a6sJ -> File _name_a6sJ _file_a6sK) + <$> (_f_a6sH _name'_a6sI)) + +--makeLensesFor [("anchor","_anchor"),("dirTree","_dirTree")] ''AnchoredDirTree +_anchor _f_a7wT (_anchor'_a7wU :/ _dirTree_a7wW) + = ((\ _anchor_a7wV -> (:/) _anchor_a7wV _dirTree_a7wW) + <$> (_f_a7wT _anchor'_a7wU)) +_dirTree _f_a7wZ (_anchor_a7x0 :/ _dirTree'_a7x1) + = ((\ _dirTree_a7x2 -> (:/) _anchor_a7x0 _dirTree_a7x2) + <$> (_f_a7wZ _dirTree'_a7x1)) diff --git a/Test.hs b/Test.hs new file mode 100644 --- /dev/null +++ b/Test.hs @@ -0,0 +1,107 @@ +module Main + where + +-- do a quick test for Darcs: + +import System.Directory.Tree +import Control.Applicative +import qualified Data.Foldable as F +import System.Directory +import System.Process +import System.IO.Error(ioeGetErrorType,isPermissionErrorType) +import Control.Monad(void) + + + + +testDir :: FilePath +testDir = "/tmp/TESTDIR-LKJHBAE" + +main :: IO () +main = do + putStrLn "-- The following tests will either fail with an error " + putStrLn "-- message or with an 'undefined' error" + -- write our testing directory structure to disk. We include Failed + -- constructors which should be discarded: + _:/written <- writeDirectory testTree + putStrLn "OK" + + + if (fmap (const ()) (filterDir (not . failed) $dirTree testTree)) == + filterDir (not . failed) written + then return () + else error "writeDirectory returned a tree that didn't match" + putStrLn "OK" + + -- make file farthest to the right unreadable: + (Dir _ [_,_,Dir "C" [_,_,File "G" p_unreadable]]) <- sortDir . dirTree <$> build testDir + setPermissions p_unreadable emptyPermissions{readable = False, + writable = True, + executable = True, + searchable = True} + putStrLn "OK" + + + -- read with lazy and standard functions, compare for equality. Also test that our crazy + -- operator works correctly inline with <$>: + tL <- readDirectoryWithL readFile testDir + t@(_:/Dir _ [_,_,Dir "C" [unreadable_constr,_,_]]) <- sortDir id <$> readDirectory testDir + if t == tL then return () else error "lazy read /= standard read" + putStrLn "OK" + + -- make sure the unreadable file left the correct error type in a Failed: + if isPermissionErrorType $ ioeGetErrorType $ err unreadable_constr + then return () + else error "wrong error type for Failed file read" + putStrLn "OK" + + + -- run lazy fold, concating file contents. compare for equality: + tL_again <- sortDir readDirectoryWithL readFile testDir + let tL_concated = F.concat $ dirTree tL_again + if tL_concated == "abcdef" then return () else error "foldable broke" + putStrLn "OK" + + -- get a lazy DirTree at root directory with lazy Directory traversal: + putStrLn "-- If lazy IO is not working, we should be stalled right now " + putStrLn "-- as we try to read in the whole root directory tree." + putStrLn "-- Go ahead and press CTRL-C if you've read this far" + mapM_ putStr =<< (map name . contents . dirTree) <$> readDirectoryWithL readFile "/" + putStrLn "\nOK" + + + let undefinedOrdFailed = Failed undefined undefined :: DirTree Char + undefinedOrdDir = Dir undefined undefined :: DirTree Char + undefinedOrdFile = File undefined undefined :: DirTree Char + -- simple equality and sorting + if Dir "d" [File "b" "b",File "a" "a"] == Dir "d" [File "a" "a", File "b" "b"] && + -- recursive sort order, enforces non-recursive sorting of Dirs + Dir "d" [Dir "b" undefined,File "a" "a"] /= Dir "d" [File "a" "a", Dir "c" undefined] && + -- check ordering of constructors: + undefinedOrdFailed < undefinedOrdDir && + undefinedOrdDir < undefinedOrdFile && + -- check ordering by dir contents list length: + Dir "d" [File "b" "b",File "a" "a"] > Dir "d" [File "a" "a"] && + -- recursive ordering on contents: + Dir "d" [File "b" "b", Dir "c" [File "a" "b"]] > Dir "d" [File "b" "b", Dir "c" [File "a" "a"]] + then putStrLn "OK" + else error "Ord/Eq instance is messed up" + + if Dir "d" [File "b" "b",File "a" "a"] `equalShape` Dir "d" [File "a" undefined, File "b" undefined] + then putStrLn "OK" + else error "equalShape or comparinghape functions broken" + + -- clean up by removing the directory: + void $ system $ "rm -r " ++ testDir + putStrLn "SUCCESS" + + + +testTree :: AnchoredDirTree String +testTree = "" :/ Dir testDir [dA , dB , dC , Failed "FAAAIIILL" undefined] + where dA = Dir "A" [dA1 , dA2 , Failed "FAIL" undefined] + dA1 = Dir "A1" [File "A" "a", File "B" "b"] + dA2 = Dir "A2" [File "C" "c"] + dB = Dir "B" [File "D" "d"] + dC = Dir "C" [File "E" "e", File "F" "f", File "G" "g"] + diff --git a/directory-tree.cabal b/directory-tree.cabal --- a/directory-tree.cabal +++ b/directory-tree.cabal @@ -1,11 +1,11 @@ name: directory-tree -version: 0.9.1 -homepage: http://coder.bsimmons.name/blog/2009/05/directory-tree-module-released/ -synopsis: A simple directory-like tree datatype, with useful IO functions -description: A simple directory-like tree datatype, with useful IO functions and Foldable and Traversable instance +version: 0.12.1 +homepage: http://brandon.si/code/directory-tree-module-released/ +synopsis: A simple directory-like tree datatype, with useful IO functions +description: A simple directory-like tree datatype, with useful IO functions and Foldable and Traversable instance . - Provides a simple data structure mirroring a directory tree on the - filesystem, as well as useful functions for reading and writing + Provides a simple data structure mirroring a directory tree on the + filesystem, as well as useful functions for reading and writing file and directory structures in the IO monad. . Importing the library and optional (useful) Foldable and Traverable libraries: @@ -14,7 +14,7 @@ > import qualified Data.Foldable as F > import qualified Data.Traversable as T . - Write a hand-made directory tree of textfiles (strings) to the disk. + Write a hand-made directory tree of textfiles (strings) to the disk. Simulates creating a new user Tux's home directory on a unix machine: . > writeDirectory$ "/home" :/ Dir "Tux" [File "README" "Welcome!"] @@ -33,11 +33,11 @@ > let f = F.concat dt > return$ b :/ File "ALL_TEXT" f . - Open all the files in the current directory as lazy bytestrings, ignoring + Open all the files in the current directory as lazy bytestrings, ignoring the base path in Anchored wrapper: . > import qualified Data.ByteString.Lazy as B - > do (_ :/ dTree) <- readDirectoryWith B.readFile "./" + > do (_ :/ dTree) <- readDirectoryWith B.readFile "./" . This version also offers an experimental function `readDirectoryWithL` that does lazy directory IO, allowing you to treat the returned `DirTree` as if it were a @@ -48,23 +48,41 @@ . > do d <- readDirectoryWithL readFile "/" > mapM_ (putStrLn . name) $ contents $ free d - . + . Any ideas or suggestions for improvements are most welcome :-) . - + /CHANGES/: from 0.11 + . + - export 'System.Directory.Tree.transformDir' as requested + . + - add test suite to cabal file + . + - remove redundant @removeNonexistent@ (thanks to dmwit for patch) + . + category: Data, System license: BSD3 license-file: LICENSE -copyright: (c) 2010, Brandon Simmons +copyright: (c) 2011, Brandon Simmons author: Brandon Simmons maintainer: Brandon Simmons -cabal-version: >= 1.2.0 +cabal-version: >= 1.8.0.4 build-type: Simple -tested-with: GHC <=6.12.1 +tested-with: GHC <=7.8.2 extra-source-files: EXAMPLES/Examples.hs, EXAMPLES/LazyExamples.hs +source-repository head + type: git + location: https://github.com/jberryman/directory-tree.git library exposed-modules: System.Directory.Tree build-depends: base <5, filepath <2, directory <2 + ghc-options: -Wall + +test-suite test + main-is: Test.hs + type: exitcode-stdio-1.0 + build-depends: base <5, filepath <2, directory <2 + , process ghc-options: -Wall