hasufell/hsfm
1
1
Fork 0
Code Issues 33 Pull Requests Releases Wiki Activity

LIB/GTK: rewrite to use more atomic operations/data structures

Browse Source 
This is a little bit less fancy, but avoids lazy IO. It depends a
little bit more on FilePath, but that also allows for a more general
interface.
This commit is contained in:
Julian Ospald
2015-12-19 16:13:48 +01:00
parent aa5d29c41d
commit 3ba647d172
12 changed files with 1005 additions and 1056 deletions
Download Patch File Download Diff File Expand all files Collapse all files

559
src/Data/DirTree.hs
View File

@@ -1,5 +1,10 @@
{-# OPTIONS_HADDOCK ignore-exports #-}
-- |This module provides data types for representing directories/files
-- and related operations on it, mostly internal stuff, not actual IO actions.
--
-- It doesn't allow to represent the whole filesystem, since that's only
-- possible through IO laziness, which introduces too much internal state.
module Data.DirTree where
@@ -27,10 +32,7 @@ import Control.Monad.State.Lazy
)
import Data.Default
import Data.Ord
(
comparing
)
import Data.IntMap.Lazy (IntMap)
import Data.List
(
delete
@@ -38,10 +40,22 @@ import Data.List
, sortBy
, (\\)
)
import Data.Time
import Data.Maybe
(
UTCTime
, formatTime
fromMaybe
)
import Data.Ord
(
comparing
)
import Data.Time.Clock.POSIX
(
POSIXTime
, posixSecondsToUTCTime
)
import Data.Traversable
(
for
)
import Data.Word
(
@@ -49,23 +63,13 @@ import Data.Word
)
import System.Directory
(
Permissions(..)
, createDirectoryIfMissing
, doesFileExist
, getDirectoryContents
, getModificationTime
doesFileExist
, executable
, getPermissions
, writable
, readable
, searchable
)
import System.EasyFile
(
getCreationTime
, getChangeTime
, getAccessTime
, getFileSize
, hasSubDirectories
, isSymlink
, writable
, Permissions
)
import System.FilePath
(
@@ -95,10 +99,26 @@ import System.Locale
defaultTimeLocale
, rfc822DateFormat
)
import System.Posix.Types
(
DeviceID
, EpochTime
, FileID
, FileMode
, FileOffset
, GroupID
, LinkCount
, UserID
)
import qualified Data.Bitraversable as BT
import qualified Data.Bifunctor as BF
import qualified Data.Bifoldable as BFL
import qualified Data.Traversable as T
import qualified System.Posix.Files as PF
import qualified System.Posix.Directory as PFD
import qualified Data.IntMap.Lazy as IM
@@ -111,12 +131,10 @@ import qualified Data.Traversable as T
type FileName = String
-- |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 b =
(:/) { anchor :: FilePath, dirTree :: DirTree a b }
-- |Represents a directory with it's contents (one level only), while
-- preserving the context via the anchor.
data AnchoredDirFile a b =
(:/) { anchor :: FilePath, dirTree :: IntMap (DirFile a b) }
deriving (Eq, Ord, Show)
@@ -125,43 +143,46 @@ data AnchoredDirTree a b =
-- 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 converted to a String with 'show'.
data DirTree a b =
data DirFile a b =
Failed {
name :: FileName
, err :: IOException
}
| Dir {
name :: FileName
, contents :: [DirTree a b]
, dir :: a
name :: FileName
, dir :: a
}
| File {
name :: FileName
, file :: b
} deriving Show
} deriving (Show, Eq)
-- |All possible directory information we could ever need from a directory.
data DirTreeInfo =
DirInfo {
permissions :: Permissions
, creationTime :: Maybe UTCTime
, changeTime :: Maybe UTCTime
, modTime :: UTCTime
, accessTime :: UTCTime
, sym :: Bool
, hasSubDirs :: Maybe Bool
}
| FileInfo {
permissions :: Permissions
, creationTime :: Maybe UTCTime
, changeTime :: Maybe UTCTime
, modTime :: UTCTime
, accessTime :: UTCTime
, sym :: Bool
, fileSize :: Word64
}
deriving (Show, Eq, Ord)
-- |All possible file information we could ever need.
data FileInfo = FileInfo {
deviceID :: DeviceID
, fileID :: FileID
, fileMode :: FileMode
, linkCount :: LinkCount
, fileOwner :: UserID
, fileGroup :: GroupID
, specialDeviceID :: DeviceID
, fileSize :: FileOffset
, accessTime :: EpochTime
, modificationTime :: EpochTime
, statusChangeTime :: EpochTime
, accessTimeHiRes :: POSIXTime
, modificationTimeHiRes :: POSIXTime
, statusChangeTimeHiRes :: POSIXTime
, isBlockDevice :: Bool
, isCharacterDevice :: Bool
, isNamedPipe :: Bool
, isRegularFile :: Bool
, isDirectory :: Bool
, isSymbolicLink :: Bool
, isSocket :: Bool
, permissions :: Permissions
} deriving (Show, Eq, Ord)
@@ -171,75 +192,55 @@ data DirTreeInfo =
----------------------------
instance BF.Bifunctor DirTree where
instance BF.Bifunctor DirFile where
bimap = BT.bimapDefault
instance BFL.Bifoldable DirTree where
instance BFL.Bifoldable DirFile where
bifoldMap = BT.bifoldMapDefault
instance BT.Bitraversable DirTree where
bitraverse f1 f2 (Dir n cs b) =
Dir n
<$> T.traverse (BT.bitraverse f1 f2) cs
<*> f1 b
instance BT.Bitraversable DirFile where
bitraverse f1 f2 (Dir n b) =
Dir n <$> f1 b
bitraverse _ f2 (File n a) =
File n <$> f2 a
bitraverse _ _ (Failed n e) =
pure (Failed n e)
-- | 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 b) => Eq (DirTree a b) 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 compare constructors: Failed < Dir < File...
-- Then compare `name`...
-- Then compare free variable parameter of `File` constructors
instance (Ord a, Ord b, Eq a, Eq b) => Ord (DirTree a b) where
instance (Ord a, Ord b, Eq a, Eq b) => Ord (DirFile a b) where
compare (File n a) (File n' a') =
case compare n n' of
EQ -> compare a a'
el -> el
compare (Dir n cs b) (Dir n' cs' b') =
compare (Dir n b) (Dir n' b') =
case compare n n' of
EQ -> case compare b b' of
EQ -> comparing sort cs cs'
el -> el
EQ -> compare b b'
el -> el
-- after comparing above we can hand off to shape ord function:
compare d d' = comparingShape d d'
-- for convenience:
instance BF.Bifunctor AnchoredDirTree where
bimap fd ff (b:/d) = b :/ BF.bimap fd ff d
-- 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
-- | build an AnchoredDirFile, given the path to a directory, opening the files
-- using readFile.
-- Uses `readDirectoryWith` 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 String)
-- of a DirFile structure.
readDirectory :: FilePath -> IO (AnchoredDirFile String String)
readDirectory = readDirectoryWith readFile return
@@ -248,49 +249,10 @@ readDirectory = readDirectoryWith readFile return
readDirectoryWith :: (FilePath -> IO a)
-> (FilePath -> IO b)
-> FilePath
-> IO (AnchoredDirTree a b)
-> IO (AnchoredDirFile a b)
readDirectoryWith fd ff p = buildWith' buildAtOnce' fd ff 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 unsafeInterleaveIO under the hood. I believe
-- our use here is safe, but this function is experimental in this release:
readDirectoryWithL :: (FilePath -> IO a)
-> (FilePath -> IO b)
-> FilePath
-> IO (AnchoredDirTree a b)
readDirectoryWithL fd ff p = buildWith' buildLazilyUnsafe' fd ff 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
-- different names. Returns a new AnchoredDirTree where failures were
-- lifted into a `Failed` constructor:
writeDirectory :: AnchoredDirTree String String -> IO (AnchoredDirTree () ())
writeDirectory = writeDirectoryWith writeFile
-- | 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 -> af -> IO bf)
-> AnchoredDirTree ad af
-> IO (AnchoredDirTree () bf)
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 $
do let bas = b'</>n
createDirectoryIfMissing True bas
Dir n <$> mapM (write' bas) cs <*> return ()
write' _ (Failed n e) = return $ Failed n e
-----------------------------
@@ -298,33 +260,22 @@ writeDirectoryWith f (b:/t) = (b:/) <$> write' b t
-----------------------------
-- | a simple application of readDirectoryWith openFile:
openDirectory :: FilePath -> IOMode -> IO (AnchoredDirTree () Handle)
openDirectory p m = readDirectoryWith (\_ -> return ()) (flip openFile m) p
-- | builds a DirTree from the contents of the directory passed to it, saving
-- | builds a DirFile 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
-- paths to the files they are abstracting.
build :: FilePath -> IO (AnchoredDirTree FilePath FilePath)
build :: FilePath -> IO (AnchoredDirFile FilePath FilePath)
build = buildWith' buildAtOnce' return 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 FilePath)
buildL = buildWith' buildLazilyUnsafe' return return
-- -- -- helpers: -- -- --
type UserIO a = FilePath -> IO a
type Builder a b = UserIO a -> UserIO b -> FilePath -> IO (DirTree a b)
type Builder a b = UserIO a -> UserIO b -> FilePath -> IO (IntMap (DirFile a b))
-- remove non-existent file errors, which are artifacts of the "non-atomic"
-- nature of traversing a system firectory tree:
@@ -332,43 +283,23 @@ buildWith' :: Builder a b
-> UserIO a
-> UserIO b
-> FilePath
-> IO (AnchoredDirTree a b)
-> IO (AnchoredDirFile a b)
buildWith' bf' fd ff p =
do tree <- bf' fd ff p
return (baseDir p :/ removeNonexistent tree)
return (p :/ removeNonexistent tree)
-- IO function passed to our builder and finally executed here:
buildAtOnce' :: Builder a b
buildAtOnce' fd ff p = handleDT n $
do isFile <- doesFileExist p
if isFile
then File n <$> ff p
else do cs <- getDirsFiles p
Dir n
<$> T.mapM (buildAtOnce' fd ff . combine p) cs
<*> fd p
where n = topDir p
-- using unsafeInterleaveIO to get "lazy" traversal:
buildLazilyUnsafe' :: Builder a b
buildLazilyUnsafe' fd ff p = handleDT n $
do isFile <- doesFileExist p
if isFile
then File n <$> ff p
-- HERE IS THE UNSAFE CODE:
else do
-- this is not behind unsafeInterleaveIO on purpose
-- otherwise we might get runtime exceptions
files <- getDirsFiles p
contents <- unsafeInterleaveIO $
mapM (rec . combine p) files
d <- fd p
return $ Dir n contents d
where rec = buildLazilyUnsafe' fd ff
n = topDir p
buildAtOnce' fd ff p = do
contents <- getDirsFiles p
for contents $ \n -> handleDT n $ do
let subf = p </> n
do isFile <- doesFileExist subf
if isFile
then File n <$> ff subf
else Dir n <$> fd subf
@@ -383,84 +314,52 @@ buildLazilyUnsafe' fd ff p = handleDT n $
-- | True if any Failed constructors in the tree
anyFailed :: DirTree a b -> Bool
anyFailed :: [DirFile a b] -> Bool
anyFailed = not . successful
-- | True if there are no Failed constructors in the tree
successful :: DirTree a b -> Bool
successful :: [DirFile a b] -> Bool
successful = null . failures
-- | returns true if argument is a `Failed` constructor:
failed :: DirTree a b -> Bool
failed :: DirFile a b -> Bool
failed (Failed _ _) = True
failed _ = False
-- | returns a list of 'Failed' constructors only:
failures :: DirTree a b -> [DirTree a b]
failures = filter failed . flattenDir
failures :: [DirFile a b] -> [DirFile a b]
failures = filter failed
-- | maps a function to convert Failed DirTrees to Files or Dirs
failedMap :: (FileName -> IOException -> DirTree a b) -> DirTree a b -> DirTree a b
failedMap f = transformDir unFail
where unFail (Failed n e) = f n e
unFail c = c
---- ORDERING AND EQUALITY ----
-- | Recursively sort a directory tree according to the Ord instance
sortDir :: (Ord a, Ord b) => DirTree a b -> DirTree a b
sortDir = sortDirBy compare
-- | Recursively sort a tree as in `sortDir` but ignore the file contents of a
-- File constructor
sortDirShape :: DirTree a b -> DirTree a b
sortDirShape = sortDirBy comparingShape where
-- HELPER:
sortDirBy :: (DirTree a b -> DirTree a b -> Ordering) -> DirTree a b -> DirTree a b
sortDirBy cf = transformDir sortD
where sortD (Dir n cs a) = Dir n (sortBy cf cs) a
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 b -> DirTree c d -> Bool
equalShape :: DirFile a b -> DirFile c d -> 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?
-- 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 b -> DirTree c d -> 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 :: DirFile a b -> DirFile c d -> Ordering
comparingShape (Dir n _) (Dir n' _) = compare n n'
-- else simply compare the flat constructors, non-recursively:
comparingShape t t' = comparingConstr t t'
-- HELPER: a non-recursive comparison
comparingConstr :: DirTree a b -> DirTree a1 b1 -> Ordering
comparingConstr (Failed _ _) (Dir _ _ _) = LT
comparingConstr :: DirFile a b -> DirFile a1 b1 -> 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
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')
@@ -470,82 +369,6 @@ comparingConstr t t' = compare (name t) (name t')
---- OTHER ----
-- | 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 b -> Maybe (AnchoredDirTree a b)
dropTo n' (p :/ Dir n ds' _) = search ds'
where search [] = Nothing
search (d:ds) | equalFilePath n' (name d) = Just ((p</>n) :/ d)
| otherwise = search ds
dropTo _ _ = Nothing
find :: FilePath
-> AnchoredDirTree a b
-> Either String (AnchoredDirTree a b)
find f d = findAbs f d <|> findRel f d
-- |Finds a file or directory inside an @AnchoredDirTree@. This only
-- looks at the subdirectories of the underlying @DirTree@. If you
-- want to compare the name of the topmost @DirTree@ as well, use @find'@.
findRel :: FilePath
-> AnchoredDirTree a b
-> Either String (AnchoredDirTree a b)
findRel f d =
go (splitDirectories f) d
where
go (f:fs) (p :/ Dir n ds _) = search ds f >>= go fs
where
search [] _ = Left "Directory or file not found!"
search (d:ds) n | equalFilePath n (name d) = Right ((p</>n) :/ d)
| otherwise = search ds n
go [] d = Right d
go _ (p :/ Failed _ err) = Left $ show err
go _ _ = Left "Directory or file not found!"
-- |Finds a file or directory inside an @AnchoredDirTree@. This also
-- looks at the topmost @DirTree@ and compares the first path component
-- with it. If you only want to look at subdirectories, use @find@.
findAbs :: FilePath
-> AnchoredDirTree a b
-> Either String (AnchoredDirTree a b)
findAbs f d =
go (splitDirectories f) d
where
go (f':fs) (_ :/ Dir n _ _)
| equalFilePath f' n = find (joinPath fs) d
| otherwise = Left "Directory or file not found!"
go _ (p :/ Failed _ err) = Left $ show err
go _ _ = Left "Directory or file not found!"
-- | applies the predicate to each constructor in the tree, removing it (and
-- its children, of course) when the predicate returns False. The topmost
-- constructor will always be preserved:
filterDir :: (DirTree a b -> Bool) -> DirTree a b -> DirTree a b
filterDir p = transformDir filterD
where filterD (Dir n cs a) = Dir n (filter p cs) a
filterD c = c
-- | Flattens a `DirTree` into a (never empty) list of tree constructors. `Dir`
-- constructors will have [] as their `contents`:
flattenDir :: DirTree a b -> [ DirTree a b ]
flattenDir (Dir n cs a) = Dir n [] a : concatMap flattenDir cs
flattenDir f = [f]
-- | 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 a1 -> DirTree b b1) -> f (AnchoredDirTree a a1) ->
f (AnchoredDirTree b b1)
(</$>) f = fmap (\(b :/ t) -> b :/ f t)
---------------
@@ -554,32 +377,19 @@ flattenDir f = [f]
---- CONSTRUCTOR IDENTIFIERS ----
isFileC :: DirTree a b -> Bool
isFileC :: DirFile a b -> Bool
isFileC (File _ _) = True
isFileC _ = False
isDirC :: DirTree a b -> Bool
isDirC (Dir _ _ _) = True
isDirC _ = False
isDirC :: DirFile a b -> Bool
isDirC (Dir _ _) = True
isDirC _ = False
---- PATH CONVERSIONS ----
-- | 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.
zipPaths :: AnchoredDirTree a b -> DirTree (FilePath, a) (FilePath, b)
zipPaths (b :/ t) = zipP b t
where zipP p (File n a) = File n (p</>n , a)
zipP p (Dir n cs a) = Dir n (map (zipP $ p</>n) cs) (p</>n , a)
zipP _ (Failed n e) = Failed n e
-- extracting pathnames and base names:
topDir, baseDir :: FilePath -> FilePath
topDir = last . splitDirectories
@@ -590,55 +400,72 @@ baseDir = joinPath . init . splitDirectories
---- IO HELPERS: ----
-- | 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 b -> IO (AnchoredDirTree () b)
writeJustDirs = writeDirectoryWith (const return)
----- 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
-- a consistent fold/traversal order on the same directory:
getDirsFiles :: String -> IO [FilePath]
getDirsFiles cs = do let cs' = if null cs then "." else cs
dfs <- getDirectoryContents cs'
return $ dfs \\ [".",".."]
getDirsFiles :: FilePath -> IO (IntMap FilePath)
getDirsFiles fp = do
dirstream <- PFD.openDirStream fp
let mdirs :: Int -> IntMap FilePath -> IO (IntMap FilePath)
mdirs ix dirs = do
dir <- PFD.readDirStream dirstream
if dir == ""
then return dirs
else mdirs (ix + 1) (instertF ix dir dirs)
dirs <- mdirs 0 IM.empty
PFD.closeDirStream dirstream
return dirs
where
instertF ix dir dirs = case dir of
"." -> dirs
".." -> dirs
_ -> IM.insert ix dir dirs
-- |Read a filepath and return transform it into our `AnchoredDirFile`
-- with the free variables of both the File and Dir constructors filled
-- with `FileInfo`.
readPath :: FilePath
-> IO (AnchoredDirTree DirTreeInfo DirTreeInfo)
readPath = readDirectoryWithL mkDirInfo mkFileInfo
-> IO (AnchoredDirFile FileInfo FileInfo)
readPath = readDirectoryWith getFileInfo getFileInfo
mkFileInfo :: FilePath -> IO DirTreeInfo
mkFileInfo fp =
FileInfo
<$> getPermissions fp
<*> getCreationTime fp
<*> getChangeTime fp
<*> getModificationTime fp
<*> getAccessTime fp
<*> isSymlink fp
<*> getFileSize fp
-- |Gets all file information.
getFileInfo :: FilePath -> IO FileInfo
getFileInfo fp = do
fs <- PF.getSymbolicLinkStatus fp
perms <- getPermissions fp
return $ FileInfo
(PF.deviceID fs)
(PF.fileID fs)
(PF.fileMode fs)
(PF.linkCount fs)
(PF.fileOwner fs)
(PF.fileGroup fs)
(PF.specialDeviceID fs)
(PF.fileSize fs)
(PF.accessTime fs)
(PF.modificationTime fs)
(PF.statusChangeTime fs)
(PF.accessTimeHiRes fs)
(PF.modificationTimeHiRes fs)
(PF.statusChangeTimeHiRes fs)
(PF.isBlockDevice fs)
(PF.isCharacterDevice fs)
(PF.isNamedPipe fs)
(PF.isRegularFile fs)
(PF.isDirectory fs)
(PF.isSymbolicLink fs)
(PF.isSocket fs)
perms
mkDirInfo :: FilePath -> IO DirTreeInfo
mkDirInfo fp =
DirInfo
<$> getPermissions fp
<*> getCreationTime fp
<*> getChangeTime fp
<*> getModificationTime fp
<*> getAccessTime fp
<*> isSymlink fp
<*> hasSubDirectories fp
getFreeVar :: DirTree a a -> Maybe a
-- |Gets the free variable. Returns Nothing if the constructor is of `Failed`.
getFreeVar :: DirFile a a -> Maybe a
getFreeVar (File _ f) = Just f
getFreeVar (Dir _ _ d) = Just d
getFreeVar (Dir _ d) = Just d
getFreeVar _ = Nothing
@@ -647,7 +474,7 @@ getFreeVar _ = Nothing
-- handles an IO exception by returning a Failed constructor filled with that
-- exception:
handleDT :: FileName -> IO (DirTree a b) -> IO (DirTree a b)
handleDT :: FileName -> IO (DirFile a b) -> IO (DirFile a b)
handleDT n = handle (return . Failed n)
@@ -657,36 +484,32 @@ handleDT n = handle (return . Failed n)
-- 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 b -> DirTree a b
removeNonexistent = filterDir isOkConstructor
removeNonexistent :: IntMap (DirFile a b) -> IntMap (DirFile a b)
removeNonexistent = IM.filter isOkConstructor
where isOkConstructor c = not (failed c) || isOkError c
isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err
-- | 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 b -> DirTree a b) -> DirTree a b -> DirTree a b
transformDir f t = case f t of
(Dir n cs a) -> Dir n (map (transformDir f) cs) a
t' -> t'
---- OTHER: ----
anchoredToPath :: AnchoredDirTree a b -> FilePath
anchoredToPath a = anchor a </> (name . dirTree $ a)
-- TODO: use Maybe type?
dirLookup :: AnchoredDirFile a b -> Int -> DirFile a b
dirLookup df ix =
fromMaybe errTree (IM.lookup ix . dirTree $ df)
where
errTree = Failed "Not found!!!"
(userError $ "Failed to lookup index " ++ show ix)
ls :: DirTree DirTreeInfo DirTreeInfo
-> [(FileName, String)]
ls dt = fmap (\x -> (name x, packModTime x)) (contents dt)
subDirName :: AnchoredDirFile a b -> Int -> FilePath
subDirName df ix = anchor df </> name (dirLookup df ix)
fromFreeVar :: (Default d) => (a -> d) -> DirTree a a -> d
fromFreeVar f dt = maybeD f $ getFreeVar dt
fromFreeVar :: (Default d) => (a -> d) -> DirFile a a -> d
fromFreeVar f df = maybeD f $ getFreeVar df
maybeD :: (Default b) => (a -> b) -> Maybe a -> b
@@ -694,14 +517,12 @@ maybeD = maybe def
-- |Pack the modification time
packModTime :: DirTree DirTreeInfo DirTreeInfo
packModTime :: DirFile FileInfo FileInfo
-> String
packModTime = fromFreeVar
$ formatTime defaultTimeLocale rfc822DateFormat
. modTime
$ show . posixSecondsToUTCTime . realToFrac . modificationTime
packPermissions :: DirTree DirTreeInfo DirTreeInfo
packPermissions :: DirFile FileInfo FileInfo
-> String
packPermissions dt = fromFreeVar (pStr . permissions) dt
where

166
src/Data/DirTree/Zipper.hs
View File

@@ -1,166 +0,0 @@
{-# OPTIONS_HADDOCK ignore-exports #-}
module Data.DirTree.Zipper where
import Control.Applicative
(
(<$>)
)
import Control.Arrow
(
first
)
import Data.DirTree
import System.Directory
(
canonicalizePath
)
import System.FilePath
(
equalFilePath
, splitPath
, takeDirectory
, (</>)
)
import System.IO.Unsafe
(
unsafeInterleaveIO
)
import qualified Data.List as DL
----------------------------
--[ ZIPPING ]--
----------------------------
-- |The zipper type, left is the (current) directory, right
-- are the breadcrumbs.
type DTZipper a b = (DirTree a b, [DirTree a b])
type DTInfoZipper = DTZipper DirTreeInfo DirTreeInfo
-- |The base zipper of a tree with empty crumbs element.
baseZipper :: DirTree a b -> DTZipper a b
baseZipper dt = (dt, [])
-- |Goes down the given subdir or file in a given directory. Returns `Nothing`
-- if the subdir or file does not exist.
--
-- Note that this function can be slow, so it's not supposed to be called
-- over a list of zippers. Use `goAllDown` instead.
goDown :: FileName -> DTZipper a b -> Maybe (DTZipper a b)
goDown fn (dtp@(Dir n cs d), xs) =
case mcdt of
Just cdt -> Just (cdt, Dir n (crumb' fn cs) d : xs)
Nothing -> Nothing
where
mcdt = DL.find (\x -> equalFilePath (name x) fn) cs
goDown _ _ = Nothing
-- |Goes down all subdirs of a given directory.
goAllDown :: DTZipper a b -> [DTZipper a b]
goAllDown (Dir n cs d, xs) = fmap (\x -> (x, Dir n (crumb x cs) d : xs)) cs
goAllDown _ = []
-- |Goes down the given subpath in a given directory. Returns `Nothing`
-- if the subpath does not exist.
goDown' :: FilePath -> DTZipper a b -> Maybe (DTZipper a b)
goDown' fp dz = go (splitPath fp) dz
where
go [] dz = Just dz
go (fn:fns) dz = goDown fn dz >>= go fns
-- TODO: error handling if the parent of a file is a file too (wat?)
-- |Goes up one directory. This cannot fail. If you call it on the
-- root node of the zipper, you get it back untouched.
goUp :: DTZipper a b -> DTZipper a b
goUp dz@(_, []) = dz
goUp (dt, Dir n cs d : xs) = (Dir n (dt:cs) d, xs)
-- |Goes up to the root directory/node of the zipper.
goRoot :: DTZipper a b -> DTZipper a b
goRoot dz@(_, []) = dz
goRoot dz = goRoot (goUp dz)
-- |Gets the full path of the current directory in the zipper context.
-- This might not be a real absolute filesystem path, because it depends
-- on the zipper context.
getFullPath :: DTZipper a b -> FilePath
getFullPath dz@(dt, _:_) = getFullPath (goUp dz) </> name dt
getFullPath (dt, []) = name dt
-- |Retrieve the (current) directory component from the zipper.
unZip :: DTZipper a b -> DirTree a b
unZip = fst
-- |Retrieve the (current) directory component from the zipper and
-- transform it to an `AnchoredDirTree`.
unZip' :: DTZipper a b -> AnchoredDirTree a b
unZip' dz@(dt, _) = (takeDirectory . getFullPath $ dz) :/ dt
-- |Map a function over the (current) directory component of the zipper.
zipMap :: (DirTree a b -> DirTree a b) -> DTZipper a b -> DTZipper a b
zipMap = first
-- |Creates a zipper at the given location with lazy breadcrumbs. That
-- means it doesn't traverse to the destination directory through the whole
-- tree.
--
-- This can throw an exception on `canonicalizePath`.
--
-- It uses `unsafeInterleaveIO` and `readDirectoryWithL` to achieve
-- lazy traversal.
zipLazy :: (FilePath -> IO a) -- ^ builder function for the free dir var
-> (FilePath -> IO b) -- ^ builder function for the free file var
-> FilePath -- ^ file path to drop to
-> IO (DTZipper a b)
zipLazy fd ff fp = do
dt <- dirTree <$> readDirectoryWithL fd ff fp
go dt fp
where
go dt fp' = do
-- TODO: I hope parentDir doesn't blow up
parentDir <- canonicalizePath (fp' ++ "/..")
if fp' == parentDir
then return $ baseZipper dt
else do
-- HERE IS THE UNSAFE CODE:
crumbs <- unsafeInterleaveIO $ crumbrec parentDir
return (dt, crumbs)
where
crumbrec pD = do
pdt@(Dir n cs d) <- dirTree <$> readDirectoryWithL fd ff pD
(_, pc) <- go pdt pD
return $ Dir n (crumb dt cs) d : pc
readPath' :: FilePath -> IO (DTZipper DirTreeInfo DirTreeInfo)
readPath' = zipLazy mkDirInfo mkFileInfo
---------------
--[ HELPERS ]--
---------------
crumb :: DirTree a b -> [DirTree a b] -> [DirTree a b]
crumb dt cs = crumb' (name dt) cs
crumb' :: FileName -> [DirTree a b] -> [DirTree a b]
crumb' fn cs =
foldr (\x y -> if equalFilePath fn (name x) then y else x : y)
[] cs