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

LIB: cleanup ViewPatterns/PatternSynonyms

Browse Source
This commit is contained in:
Julian Ospald 2016-03-30 19:38:06 +02:00
parent 4b68bf759b
commit efd2535ef9
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
1 changed files with 95 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

160
src/Data/DirTree.hs
View File

@ -232,6 +232,8 @@ data FileInfo = FileInfo {
------------------------------------
-- |Converts a viewpattern like function written for `File` to one
-- for `AnchoredFile`.
convertViewP :: (File FileInfo -> (Bool, File FileInfo))
-> AnchoredFile FileInfo
-> (Bool, AnchoredFile FileInfo)
@ -240,9 +242,27 @@ convertViewP f af@(bp :/ constr) =
in (b, bp :/ file)
---- Filetypes ----
safileLike :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
safileLike f = convertViewP sfileLike f
sfileLike :: File FileInfo -> (Bool, File FileInfo)
sfileLike f@RegFile{} = (True, f)
sfileLike f@BlockDev{} = (True, f)
sfileLike f@CharDev{} = (True, f)
sfileLike f@NamedPipe{} = (True, f)
sfileLike f@Socket{} = (True, f)
sfileLike f = fileLikeSym f
afileLike :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
afileLike f@(bp :/ constr) = convertViewP fileLike f
fileLike :: File FileInfo -> (Bool, File FileInfo)
fileLike f@RegFile {} = (True, f)
fileLike f@BlockDev{} = (True, f)
@ -255,58 +275,38 @@ fileLike f = (False, f)
sadir :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
sadir f = convertViewP sdir f
sdir :: File FileInfo -> (Bool, File FileInfo)
sdir f@(SymLink { sdest = (_ :/ s@(SymLink {}) )})
sdir f@SymLink{ sdest = (_ :/ s@SymLink{} )}
-- we have to follow a chain of symlinks here, but
-- return only the very first level
-- TODO: this is probably obsolete now
= case (sdir s) of
(True, _) -> (True, f)
_ -> (False, f)
sdir f@(SymLink { sdest = (_ :/ Dir {} )})
sdir f@SymLink{ sdest = (_ :/ Dir {} )}
= (True, f)
sdir f@(Dir {}) = (True, f)
sdir f@Dir{} = (True, f)
sdir f = (False, f)
safileLike :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
safileLike f = convertViewP sfileLike f
-- |Matches on any non-directory kind of files, excluding symlinks.
pattern AFileLike f <- (afileLike -> (True, f))
-- |Like `AFileLike`, except on File.
pattern FileLike f <- (fileLike -> (True, f))
sfileLike :: File FileInfo -> (Bool, File FileInfo)
sfileLike f@RegFile{} = (True, f)
sfileLike f@BlockDev{} = (True, f)
sfileLike f@CharDev{} = (True, f)
sfileLike f@NamedPipe{} = (True, f)
sfileLike f@Socket{} = (True, f)
sfileLike f = fileLikeSym f
-- |Matches a list of directories or symlinks pointing to directories.
pattern DirList fs <- (\fs -> (and . fmap (fst . sadir) $ fs, fs)
-> (True, fs))
-- |Matches a list of any non-directory kind of files or symlinks
-- pointing to such.
pattern FileLikeList fs <- (\fs -> (and
. fmap (fst . safileLike)
$ fs, fs) -> (True, fs))
afileLikeSym :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
afileLikeSym f = convertViewP fileLikeSym f
fileLikeSym :: File FileInfo -> (Bool, File FileInfo)
fileLikeSym f@(SymLink { sdest = (_ :/ s@(SymLink {}) )})
= case (fileLikeSym s) of
(True, _) -> (True, f)
_ -> (False, f)
fileLikeSym f@(SymLink { sdest = (_ :/ RegFile {} )}) = (True, f)
fileLikeSym f@(SymLink { sdest = (_ :/ BlockDev {} )}) = (True, f)
fileLikeSym f@(SymLink { sdest = (_ :/ CharDev {} )}) = (True, f)
fileLikeSym f@(SymLink { sdest = (_ :/ NamedPipe {} )}) = (True, f)
fileLikeSym f@(SymLink { sdest = (_ :/ Socket {} )}) = (True, f)
fileLikeSym f = (False, f)
adirSym :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
adirSym f = convertViewP dirSym f
dirSym :: File FileInfo -> (Bool, File FileInfo)
dirSym f@(SymLink { sdest = (_ :/ s@(SymLink {}) )})
= case (dirSym s) of
(True, _) -> (True, f)
_ -> (False, f)
dirSym f@(SymLink { sdest = (_ :/ Dir {} )}) = (True, f)
dirSym f = (False, f)
---- Filenames ----
invalidFileName :: Path Fn -> (Bool, Path Fn)
invalidFileName p@(Path "") = (True, p)
@ -315,32 +315,79 @@ invalidFileName p@(Path "..") = (True, p)
invalidFileName p@(Path fn) = (elem pathSeparator fn, p)
abrokenSymlink :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
abrokenSymlink f = convertViewP brokenSymlink f
brokenSymlink :: File FileInfo -> (Bool, File FileInfo)
brokenSymlink f = (isBrokenSymlink f, f)
-- |Matches on invalid filesnames, such as ".", ".." and anything
-- that contains a path separator.
pattern InvFN <- (invalidFileName -> (True,_))
-- |Opposite of `InvFN`.
pattern ValFN f <- (invalidFileName -> (False, f))
-- |Like `InvFN`, but for AnchoredFile.
pattern AFileInvFN <- (fst . invalidFileName . name . file -> True)
-- |Like `InvFN`, but for File.
pattern FileInvFN <- (fst . invalidFileName . name -> True)
---- Symlinks ----
abrokenSymlink :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
abrokenSymlink f = convertViewP brokenSymlink f
brokenSymlink :: File FileInfo -> (Bool, File FileInfo)
brokenSymlink f = (isBrokenSymlink f, f)
afileLikeSym :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
afileLikeSym f = convertViewP fileLikeSym f
fileLikeSym :: File FileInfo -> (Bool, File FileInfo)
fileLikeSym f@SymLink{ sdest = (_ :/ s@SymLink{} )}
= case (fileLikeSym s) of
(True, _) -> (True, f)
_ -> (False, f)
fileLikeSym f@SymLink{ sdest = (_ :/ RegFile {} )} = (True, f)
fileLikeSym f@SymLink{ sdest = (_ :/ BlockDev {} )} = (True, f)
fileLikeSym f@SymLink{ sdest = (_ :/ CharDev {} )} = (True, f)
fileLikeSym f@SymLink{ sdest = (_ :/ NamedPipe {} )} = (True, f)
fileLikeSym f@SymLink{ sdest = (_ :/ Socket {} )} = (True, f)
fileLikeSym f = (False, f)
adirSym :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
adirSym f = convertViewP dirSym f
dirSym :: File FileInfo -> (Bool, File FileInfo)
dirSym f@SymLink{ sdest = (_ :/ s@SymLink{} )}
= case (dirSym s) of
(True, _) -> (True, f)
_ -> (False, f)
dirSym f@SymLink{ sdest = (_ :/ Dir {} )} = (True, f)
dirSym f = (False, f)
-- |Matches on symlinks pointing to file-like files only.
pattern AFileLikeSym f <- (afileLikeSym -> (True, f))
-- |Like `AFileLikeSym`, except on File.
pattern FileLikeSym f <- (fileLikeSym -> (True, f))
-- |Matches on broken symbolic links.
pattern ABrokenSymlink f <- (abrokenSymlink -> (True, f))
-- |Like `ABrokenSymlink`, except on File.
pattern BrokenSymlink f <- (brokenSymlink -> (True, f))
-- |Matches on directories or symlinks pointing to directories.
-- If the symlink is pointing to a symlink pointing to a directory, then
-- it will return True, but also return the first element in the symlink-
-- chain, not the last.
pattern ADirOrSym f <- (sadir -> (True, f))
-- |Like `ADirOrSym`, except on File.
pattern DirOrSym f <- (sdir -> (True, f))
-- |Matches on symlinks pointing to directories only.
pattern ADirSym f <- (adirSym -> (True, f))
-- |Like `ADirSym`, except on File.
pattern DirSym f <- (dirSym -> (True, f))
-- |Matches on any non-directory kind of files or symlinks pointing to
@ -349,28 +396,9 @@ pattern DirSym f <- (dirSym -> (True, f))
-- it will return True, but also return the first element in the symlink-
-- chain, not the last.
pattern AFileLikeOrSym f <- (safileLike -> (True, f))
-- |Like `AFileLikeOrSym`, except on File.
pattern FileLikeOrSym f <- (sfileLike -> (True, f))
-- |Matches on any non-directory kind of files, excluding symlinks.
pattern AFileLike f <- (afileLike -> (True, f))
pattern FileLike f <- (fileLike -> (True, f))
-- |Matches on symlinks pointing to file-like files only.
pattern AFileLikeSym f <- (afileLikeSym -> (True, f))
pattern FileLikeSym f <- (fileLikeSym -> (True, f))
-- |Matches on broken symbolic links.
pattern ABrokenSymlink f <- (abrokenSymlink -> (True, f))
pattern BrokenSymlink f <- (brokenSymlink -> (True, f))
-- |Matches a list of directories or symlinks pointing to directories.
pattern DirList fs <- (\fs -> (foldr (&&) True . fmap (fst . sadir) $ fs, fs)
-> (True, fs))
-- |Matches a list of any non-directory kind of files or symlinks
-- pointing to such.
pattern FileLikeList fs <- (\fs -> (foldr (&&) True
. fmap (fst . safileLike)
$ fs, fs) -> (True, fs))