LIB/GTK: refactor ViewPatterns/PatternSynonyms

This commit is contained in:
Julian Ospald 2015-12-26 22:00:08 +01:00
parent 83816ef1a6
commit 400a0242d6
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
4 changed files with 95 additions and 54 deletions

View File

@ -232,25 +232,29 @@ type Builder a = UserIO a -> FilePath -> IO [File a]
------------------------------------
saregfile :: AnchoredFile FileInfo
convertViewP :: (File FileInfo -> (Bool, File FileInfo))
-> AnchoredFile FileInfo
-> (Bool, AnchoredFile FileInfo)
saregfile f@(bp :/ constr) =
let (b, file) = sregfile constr
convertViewP f af@(bp :/ constr) =
let (b, file) = f constr
in (b, bp :/ file)
sregfile :: File FileInfo -> (Bool, File FileInfo)
sregfile f@(RegFile {}) = (True, f)
sregfile f@(SymLink {}) = (True, f)
sregfile f = (False, 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)
fileLike f@(CharDev {}) = (True, f)
fileLike f@(NamedPipe {}) = (True, f)
fileLike f@(Socket {}) = (True, f)
fileLike f = (False, f)
sadir :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
sadir f@(bp :/ constr) =
let (b, file) = sdir constr
in (b, bp :/ file)
sadir f = convertViewP sdir f
sdir :: File FileInfo -> (Bool, File FileInfo)
sdir f@(SymLink { sdest = (_ :/ s@(SymLink {}) )})
@ -265,27 +269,44 @@ sdir f@(Dir {}) = (True, f)
sdir f = (False, f)
safile :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
safile f@(bp :/ constr) =
let (b, file) = sfile constr
in (b, bp :/ file)
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
sfile :: File FileInfo -> (Bool, File FileInfo)
sfile f@(SymLink { sdest = (_ :/ s@(SymLink {}) )})
-- we have to follow a chain of symlinks here, but
-- return only the very first level
= case (sfile s) of
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)
sfile f@(SymLink { sdest = (_ :/ RegFile {} )})
= (True, f)
sfile f@(RegFile {}) = (True, f)
sfile f@(BlockDev {}) = (True, f)
sfile f@(CharDev {}) = (True, f)
sfile f@(NamedPipe {}) = (True, f)
sfile f@(Socket {}) = (True, f)
sfile 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)
invalidFileName :: FileName -> (Bool, FileName)
@ -295,31 +316,50 @@ invalidFileName ".." = (True, "..")
invalidFileName fn = (elem pathSeparator fn, fn)
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))
-- |Matches on symlinks (pointing to anything) or regular files.
pattern SARegFile <- (saregfile -> (True, _))
pattern SRegFile <- (sregfile -> (True, _))
-- |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 SADir f <- (sadir -> (True, f))
pattern SDir f <- (sdir -> (True, f))
pattern ADirOrSym f <- (sadir -> (True, f))
pattern DirOrSym f <- (sdir -> (True, f))
-- |Matches on symlinks pointing to directories only.
pattern ADirSym f <- (adirSym -> (True, f))
pattern DirSym f <- (dirSym -> (True, f))
-- |Matches on any non-directory kind of files or symlinks pointing to
-- such.
-- If the symlink is pointing to a symlink pointing to such a file, then
-- it will return True, but also return the first element in the symlink-
-- chain, not the last.
pattern SAFile f <- (safile -> (True, f))
pattern SFile f <- (sfile -> (True, f))
pattern AFileLikeOrSym f <- (safileLike -> (True, f))
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))
@ -466,12 +506,12 @@ failures = filter failed
-- HELPER: a non-recursive comparison
comparingConstr :: File FileInfo -> File FileInfo -> Ordering
comparingConstr (Failed _ _) (SDir _) = LT
comparingConstr (Failed _ _) (SFile _) = LT
comparingConstr (SFile _) (Failed _ _) = GT
comparingConstr (SFile _) (SDir _) = GT
comparingConstr (SDir _) (Failed _ _) = GT
comparingConstr (SDir _) (SFile _) = LT
comparingConstr (Failed _ _) (DirOrSym _) = LT
comparingConstr (Failed _ _) (FileLikeOrSym _) = LT
comparingConstr (FileLikeOrSym _) (Failed _ _) = GT
comparingConstr (FileLikeOrSym _) (DirOrSym _) = GT
comparingConstr (DirOrSym _) (Failed _ _) = GT
comparingConstr (DirOrSym _) (FileLikeOrSym _) = 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')
@ -590,7 +630,7 @@ goUp' fp = do
-- |Get the contents of a directory.
getContents :: AnchoredFile FileInfo
-> IO [AnchoredFile FileInfo]
getContents (SADir af) = readDirectory (fullPath af)
getContents (ADirOrSym af) = readDirectory (fullPath af)
getContents _ = return []

View File

@ -188,7 +188,7 @@ urlGoTo mygui myview = withErrorDialog $ do
open :: Row -> MyGUI -> MyView -> IO ()
open row mygui myview = withErrorDialog $
case row of
SADir r -> do
ADirOrSym r -> do
nv <- Data.DirTree.readFile $ fullPath r
refreshTreeView' mygui myview nv
r ->

View File

@ -277,10 +277,11 @@ constructTreeView mygui myview = do
return ()
where
dirtreePix (Dir {}) = folderPix mygui
dirtreePix (RegFile {}) = filePix mygui
dirtreePix (SDir _) = folderSymPix mygui
dirtreePix (SRegFile {}) = fileSymPix mygui
dirtreePix (FileLike {}) = filePix mygui
dirtreePix (DirSym _) = folderSymPix mygui
dirtreePix (FileLikeSym {}) = fileSymPix mygui
dirtreePix (Failed {}) = errorPix mygui
dirtreePix (BrokenSymlink _) = errorPix mygui
dirtreePix _ = errorPix mygui

View File

@ -362,7 +362,7 @@ executeFile _ _ = return Nothing
createFile :: AnchoredFile FileInfo -> FileName -> IO ()
createFile (SADir td) (ValFN fn) = do
createFile (ADirOrSym td) (ValFN fn) = do
let fullp = fullPath td </> fn
throwFileDoesExist fullp
fd <- System.Posix.IO.createFile fullp newFilePerms
@ -371,7 +371,7 @@ createFile _ _ = return ()
createDir :: AnchoredFile FileInfo -> FileName -> IO ()
createDir (SADir td) (ValFN fn) = do
createDir (ADirOrSym td) (ValFN fn) = do
let fullp = fullPath td </> fn
throwDirDoesExist fullp
createDirectory fullp newFilePerms