diff --git a/System/Directory/Tree.hs b/System/Directory/Tree.hs --- a/System/Directory/Tree.hs +++ b/System/Directory/Tree.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -------------------------------------------------------------------- -- | -- Module : System.Directory.Tree @@ -8,52 +9,52 @@ -- 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 , build , buildL , openDirectory - , writeJustDirs + , writeJustDirs -- ** Manipulating FilePaths , zipPaths - , free - + , free + -- * Utility functions -- ** Shape comparison and equality , equalShape @@ -74,10 +75,10 @@ -- ** Navigation , dropTo -- ** Operators - , () + , () -- * Lenses - {- | These are compatible with the "lens" library + {- | These are compatible with the "lens" library -} , _contents, _err, _file, _name , _anchor, _dirTree @@ -86,7 +87,7 @@ -{- +{- TODO: NEXT: - performance improvements, we want lazy dir functions to run in constant @@ -105,25 +106,25 @@ {- 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 @@ -131,13 +132,13 @@ 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 + account the free file "contents" data 0.11.0 - added records for AnchoredDirTree: 'anchor', 'dirTree' - - 'free' deprecated in favor of 'dirTree' + - 'free' deprecated in favor of 'dirTree' - added a new function 'dropTo' - - implemented lenses compatible with "lens" package, maybe even allowing + - implemented lenses compatible with "lens" package, maybe even allowing zipper usage! -} @@ -150,39 +151,41 @@ import Data.Ord (comparing) 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 a)=> Eq (DirTree a) where (File n a) == (File n' a') = n == n' && a == a' - (Dir n cs) == (Dir n' cs') = + (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 compare constructors: Failed < Dir < File... +-- | 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 @@ -190,7 +193,7 @@ case compare n n' of EQ -> compare a a' el -> el - compare (Dir n cs) (Dir n' cs') = + compare (Dir n cs) (Dir n' cs') = case compare n n' of EQ -> comparing sort cs cs' el -> el @@ -212,7 +215,7 @@ instance Functor DirTree where - fmap = T.fmapDefault + fmap = T.fmapDefault instance F.Foldable DirTree where foldMap = T.foldMapDefault @@ -232,53 +235,65 @@ -- 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 = 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 = 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 @@ -300,63 +315,77 @@ --- | 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 +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 - -- TODO: this should really be unsafeInterleaveIO - 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 ]-- ----------------- @@ -383,7 +412,7 @@ -- | 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 @@ -391,8 +420,8 @@ failedMap f = transformDir unFail where unFail (Failed n e) = f n e unFail c = c - + ---- ORDERING AND EQUALITY ---- @@ -421,7 +450,7 @@ -- | a compare function that ignores the free "file" type variable: comparingShape :: DirTree a -> DirTree b -> Ordering -comparingShape (Dir n cs) (Dir n' cs') = +comparingShape (Dir n cs) (Dir n' cs') = case compare n n' of EQ -> comp (sortCs cs) (sortCs cs') el -> el @@ -471,7 +500,7 @@ -- | 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 = transformDir filterD @@ -490,8 +519,8 @@ -- | 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) @@ -517,12 +546,12 @@ --- | tuple up the complete file path with the 'file' contents, by building up the +-- | 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) @@ -532,7 +561,7 @@ -- extracting pathnames and base names: topDir, baseDir :: FilePath -> FilePath -topDir = last . splitDirectories +topDir = last . splitDirectories baseDir = joinPath . init . splitDirectories @@ -540,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) @@ -549,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 \\ [".",".."] @@ -561,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 @@ -590,28 +619,28 @@ -- 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 :: +_contents :: Applicative f => ([DirTree a] -> f [DirTree a]) -> DirTree a -> f (DirTree a) -_err :: +_err :: Applicative f => (IOException -> f IOException) -> DirTree a -> f (DirTree a) -_file :: +_file :: Applicative f => (a -> f a) -> DirTree a -> f (DirTree a) -_name :: +_name :: Functor f => (FileName -> f FileName) -> DirTree a -> f (DirTree a) -_anchor :: +_anchor :: Functor f => (FilePath -> f FilePath) -> AnchoredDirTree a -> f (AnchoredDirTree a) -_dirTree :: +_dirTree :: Functor f => (DirTree t -> f (DirTree a)) -> AnchoredDirTree t -> f (AnchoredDirTree a) 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.12.0 +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 +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,7 +48,7 @@ . > do d <- readDirectoryWithL readFile "/" > mapM_ (putStrLn . name) $ contents $ free d - . + . Any ideas or suggestions for improvements are most welcome :-) . /CHANGES/: from 0.11 @@ -59,19 +59,19 @@ . - remove redundant @removeNonexistent@ (thanks to dmwit for patch) . - + category: Data, System license: BSD3 license-file: LICENSE copyright: (c) 2011, Brandon Simmons author: Brandon Simmons maintainer: Brandon Simmons -cabal-version: >= 1.8 +cabal-version: >= 1.8.0.4 build-type: Simple tested-with: GHC <=7.8.2 extra-source-files: EXAMPLES/Examples.hs, EXAMPLES/LazyExamples.hs -source-repository head +source-repository head type: git location: https://github.com/jberryman/directory-tree.git @@ -86,4 +86,3 @@ build-depends: base <5, filepath <2, directory <2 , process ghc-options: -Wall -