LIB/GTK: use new data structure with explicit SymLink constructor
This still needs a lot of work to function consistently, but it's better than the old approach.
This commit is contained in:
parent
06b96eecea
commit
5f183bef3f
@ -83,6 +83,7 @@ import System.FilePath
|
||||
combine
|
||||
, normalise
|
||||
, equalFilePath
|
||||
, isAbsolute
|
||||
, joinPath
|
||||
, splitDirectories
|
||||
, takeFileName
|
||||
@ -141,8 +142,8 @@ type FileName = String
|
||||
|
||||
-- |Represents a file. The `anchor` field is the path
|
||||
-- to that file without the filename.
|
||||
data AnchoredFile a b =
|
||||
(:/) { anchor :: FilePath, file :: File a b }
|
||||
data AnchoredFile a =
|
||||
(:/) { anchor :: FilePath, file :: File a }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
|
||||
@ -151,18 +152,40 @@ data AnchoredFile 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 File a b =
|
||||
data File a =
|
||||
Failed {
|
||||
name :: FileName
|
||||
, err :: IOException
|
||||
}
|
||||
| Dir {
|
||||
name :: FileName
|
||||
, dir :: a
|
||||
, fvar :: a
|
||||
}
|
||||
| RegFile {
|
||||
name :: FileName
|
||||
, regFile :: b
|
||||
, fvar :: a
|
||||
}
|
||||
| SymLink {
|
||||
name :: FileName
|
||||
, fvar :: a
|
||||
, sdest :: AnchoredFile a -- ^ symlink madness,
|
||||
-- we need to know where it points to
|
||||
}
|
||||
| BlockDev {
|
||||
name :: FileName
|
||||
, fvar :: a
|
||||
}
|
||||
| CharDev {
|
||||
name :: FileName
|
||||
, fvar :: a
|
||||
}
|
||||
| NamedPipe {
|
||||
name :: FileName
|
||||
, fvar :: a
|
||||
}
|
||||
| Socket {
|
||||
name :: FileName
|
||||
, fvar :: a
|
||||
} deriving (Show, Eq)
|
||||
|
||||
|
||||
@ -182,34 +205,31 @@ data FileInfo = FileInfo {
|
||||
, 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)
|
||||
|
||||
|
||||
isSymL :: AnchoredFile FileInfo FileInfo
|
||||
-> (Bool, AnchoredFile FileInfo FileInfo)
|
||||
isSymL f@(_ :/ Dir _ FileInfo { isSymbolicLink = True }) = (True, f)
|
||||
isSymL f@(_ :/ RegFile _ FileInfo { isSymbolicLink = True }) = (True, f)
|
||||
isSymL f = (False, f)
|
||||
type UserIO a = FilePath -> IO a
|
||||
|
||||
type Builder a = UserIO a -> FilePath -> IO [File a]
|
||||
|
||||
|
||||
symlOrRegFile :: AnchoredFile FileInfo FileInfo
|
||||
-> (Bool, AnchoredFile FileInfo FileInfo)
|
||||
symlOrRegFile :: AnchoredFile FileInfo
|
||||
-> (Bool, AnchoredFile FileInfo)
|
||||
symlOrRegFile f@(_ :/ RegFile {}) = (True, f)
|
||||
symlOrRegFile f@(_ :/ Dir _ FileInfo { isSymbolicLink = True }) = (True, f)
|
||||
symlOrRegFile f@(_ :/ SymLink {}) = (True, f)
|
||||
symlOrRegFile f = (False, f)
|
||||
|
||||
|
||||
pattern IsSymL b <- (isSymL -> (b, _))
|
||||
sdir :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
|
||||
sdir f@(_ :/ SymLink { sdest = (_ :/ Dir {} )}) = (True, f)
|
||||
sdir f@(_ :/ Dir {}) = (True, f)
|
||||
sdir f = (False, f)
|
||||
|
||||
|
||||
pattern SymlOrRegFile <- (symlOrRegFile -> (True, _))
|
||||
|
||||
pattern SDir f <- (sdir -> (True, f))
|
||||
|
||||
|
||||
|
||||
----------------------------
|
||||
@ -217,28 +237,10 @@ pattern SymlOrRegFile <- (symlOrRegFile -> (True, _))
|
||||
----------------------------
|
||||
|
||||
|
||||
instance BF.Bifunctor File where
|
||||
bimap = BT.bimapDefault
|
||||
|
||||
|
||||
instance BFL.Bifoldable File where
|
||||
bifoldMap = BT.bifoldMapDefault
|
||||
|
||||
|
||||
instance BT.Bitraversable File where
|
||||
bitraverse f1 f2 (Dir n b) =
|
||||
Dir n <$> f1 b
|
||||
bitraverse _ f2 (RegFile n a) =
|
||||
RegFile n <$> f2 a
|
||||
bitraverse _ _ (Failed n e) =
|
||||
pure (Failed n e)
|
||||
|
||||
|
||||
|
||||
-- | 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 (File a b) where
|
||||
instance (Ord a, Eq a) => Ord (File a) where
|
||||
compare (RegFile n a) (RegFile n' a') =
|
||||
case compare n n' of
|
||||
EQ -> compare a a'
|
||||
@ -261,96 +263,75 @@ instance (Ord a, Ord b, Eq a, Eq b) => Ord (File a b) where
|
||||
|
||||
|
||||
-- |Read a file into an `AnchoredFile`, filling the free variables via
|
||||
-- `getFileInfo`. This also works on directories, but doesn't look at
|
||||
-- their contents.
|
||||
-- the given function.
|
||||
readFileWith :: (FilePath -> IO a)
|
||||
-> (FilePath -> IO b)
|
||||
-> FilePath
|
||||
-> IO (AnchoredFile a b)
|
||||
readFileWith fd ff fp = do
|
||||
let fn = topDir fp
|
||||
bd = baseDir fp
|
||||
file <- handleDT (topDir fp) $ do
|
||||
isFile <- doesFileExist fp
|
||||
if isFile
|
||||
then RegFile fn <$> ff fp
|
||||
else Dir fn <$> fd fp
|
||||
return (bd :/ file)
|
||||
-> IO (AnchoredFile a)
|
||||
readFileWith ff p = do
|
||||
let fn = topDir p
|
||||
bd = baseDir p
|
||||
handleDT' bd fn $ do
|
||||
fs <- PF.getSymbolicLinkStatus p
|
||||
fv <- ff p
|
||||
file <- constructFile fs fv bd fn
|
||||
return (bd :/ file)
|
||||
where
|
||||
constructFile fs fv bd' n
|
||||
| PF.isSymbolicLink fs = do
|
||||
-- symlink madness, we need to make sure we save the correct
|
||||
-- AnchoredFile
|
||||
let fp = bd' </> n
|
||||
resolvedSyml <- handleDT' bd' n $ do
|
||||
sfp <- (\x -> if isAbsolute x then x else bd' </> x)
|
||||
<$> PF.readSymbolicLink fp
|
||||
_ <- PF.getFileStatus sfp -- important to break infinite symbolic
|
||||
-- link cycle
|
||||
readFileWith ff sfp
|
||||
return $ SymLink n fv resolvedSyml
|
||||
| PF.isDirectory fs = return $ Dir n fv
|
||||
| PF.isRegularFile fs = return $ RegFile n fv
|
||||
| PF.isBlockDevice fs = return $ BlockDev n fv
|
||||
| PF.isCharacterDevice fs = return $ CharDev n fv
|
||||
| PF.isNamedPipe fs = return $ NamedPipe n fv
|
||||
| PF.isSocket fs = return $ Socket n fv
|
||||
| otherwise = return $ Failed n (userError
|
||||
"Unknown filetype!")
|
||||
|
||||
|
||||
readFile :: FilePath -> IO (AnchoredFile FileInfo FileInfo)
|
||||
readFile fp = readFileWith getFileInfo getFileInfo =<< canonicalizePath' fp
|
||||
readFile :: FilePath -> IO (AnchoredFile FileInfo)
|
||||
readFile fp = readFileWith getFileInfo =<< canonicalizePath' fp
|
||||
|
||||
|
||||
-- |Build a list of AnchoredFile, given the path to a directory, filling
|
||||
-- the free variables via `getFileInfo`. This includes the "." and ".."
|
||||
-- directories.
|
||||
readDirectory :: FilePath -> IO [AnchoredFile FileInfo FileInfo]
|
||||
readDirectory fp = readDirectoryWith getAllDirsFiles getFileInfo getFileInfo
|
||||
readDirectory :: FilePath -> IO [AnchoredFile FileInfo]
|
||||
readDirectory fp = readDirectoryWith getAllDirsFiles getFileInfo
|
||||
=<< canonicalizePath' fp
|
||||
|
||||
|
||||
-- |Build a list of AnchoredFile, given the path to a directory, filling
|
||||
-- the free variables via `getFileInfo`. This excludes the "." and ".."
|
||||
-- directories.
|
||||
readDirectory' :: FilePath -> IO [AnchoredFile FileInfo FileInfo]
|
||||
readDirectory' fp = readDirectoryWith getDirsFiles getFileInfo getFileInfo
|
||||
=<< canonicalizePath' fp
|
||||
readDirectory' :: FilePath -> IO [AnchoredFile FileInfo]
|
||||
readDirectory' fp = readDirectoryWith getDirsFiles getFileInfo
|
||||
=<< canonicalizePath' fp
|
||||
|
||||
|
||||
-- | same as readDirectory but allows us to, for example, use
|
||||
-- ByteString.readFile to return a tree of ByteStrings.
|
||||
readDirectoryWith :: (FilePath -> IO [FilePath])
|
||||
-> (FilePath -> IO a)
|
||||
-> (FilePath -> IO b)
|
||||
-> FilePath
|
||||
-> IO [AnchoredFile a b]
|
||||
readDirectoryWith getfiles fd ff p = buildWith' (buildAtOnce' getfiles) fd ff
|
||||
=<< canonicalizePath' p
|
||||
-> IO [AnchoredFile a]
|
||||
readDirectoryWith getfiles ff p = do
|
||||
contents <- getfiles =<< canonicalizePath' p
|
||||
cs <- mapM (\x -> readFileWith ff $ p </> x) contents
|
||||
return $ removeNonexistent cs
|
||||
|
||||
|
||||
|
||||
|
||||
-----------------------------
|
||||
--[ LOWER LEVEL FUNCTIONS ]--
|
||||
-----------------------------
|
||||
|
||||
|
||||
|
||||
|
||||
-- -- -- helpers: -- -- --
|
||||
|
||||
|
||||
type UserIO a = FilePath -> IO a
|
||||
type Builder a b = UserIO a -> UserIO b -> FilePath -> IO [File a b]
|
||||
|
||||
-- remove non-existent file errors, which are artifacts of the "non-atomic"
|
||||
-- nature of traversing a system firectory tree:
|
||||
buildWith' :: Builder a b
|
||||
-> UserIO a
|
||||
-> UserIO b
|
||||
-> FilePath
|
||||
-> IO [AnchoredFile a b]
|
||||
buildWith' bf' fd ff p =
|
||||
do
|
||||
cfp <- canonicalizePath' p
|
||||
tree <- bf' fd ff cfp
|
||||
return $ fmap (cfp :/) (removeNonexistent tree)
|
||||
|
||||
|
||||
|
||||
-- IO function passed to our builder and finally executed here:
|
||||
buildAtOnce' :: (FilePath -> IO [FilePath]) -> Builder a b
|
||||
buildAtOnce' getfiles fd ff fp = do
|
||||
contents <- getfiles fp
|
||||
for contents $ \n -> handleDT n $ do
|
||||
let subf = fp </> n
|
||||
do isFile <- doesFileExist subf
|
||||
if isFile
|
||||
then RegFile n <$> ff subf
|
||||
else Dir n <$> fd subf
|
||||
|
||||
|
||||
|
||||
-----------------
|
||||
--[ UTILITIES ]--
|
||||
@ -362,22 +343,22 @@ buildAtOnce' getfiles fd ff fp = do
|
||||
|
||||
|
||||
-- | True if any Failed constructors in the tree
|
||||
anyFailed :: [File a b] -> Bool
|
||||
anyFailed :: [File a] -> Bool
|
||||
anyFailed = not . successful
|
||||
|
||||
-- | True if there are no Failed constructors in the tree
|
||||
successful :: [File a b] -> Bool
|
||||
successful :: [File a] -> Bool
|
||||
successful = null . failures
|
||||
|
||||
|
||||
-- | returns true if argument is a `Failed` constructor:
|
||||
failed :: File a b -> Bool
|
||||
failed :: File a -> Bool
|
||||
failed (Failed _ _) = True
|
||||
failed _ = False
|
||||
|
||||
|
||||
-- | returns a list of 'Failed' constructors only:
|
||||
failures :: [File a b] -> [File a b]
|
||||
failures :: [File a] -> [File a]
|
||||
failures = filter failed
|
||||
|
||||
|
||||
@ -387,21 +368,21 @@ failures = filter failed
|
||||
|
||||
-- | 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 :: File a b -> File c d -> Bool
|
||||
equalShape :: File a -> File 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 :: File a b -> File c d -> Ordering
|
||||
comparingShape :: File a -> File b -> 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 :: File a b -> File a1 b1 -> Ordering
|
||||
comparingConstr :: File a -> File b -> Ordering
|
||||
comparingConstr (Failed _ _) (Dir _ _) = LT
|
||||
comparingConstr (Failed _ _) (RegFile _ _) = LT
|
||||
comparingConstr (RegFile _ _) (Failed _ _) = GT
|
||||
@ -425,11 +406,11 @@ comparingConstr t t' = compare (name t) (name t')
|
||||
|
||||
|
||||
---- CONSTRUCTOR IDENTIFIERS ----
|
||||
isFileC :: File a b -> Bool
|
||||
isFileC :: File a -> Bool
|
||||
isFileC (RegFile _ _) = True
|
||||
isFileC _ = False
|
||||
|
||||
isDirC :: File a b -> Bool
|
||||
isDirC :: File a -> Bool
|
||||
isDirC (Dir _ _) = True
|
||||
isDirC _ = False
|
||||
|
||||
@ -481,20 +462,20 @@ canonicalizePath' fp = do
|
||||
|
||||
|
||||
-- |Go up one directory in the filesystem hierarchy.
|
||||
goUp :: AnchoredFile FileInfo FileInfo -> IO (AnchoredFile FileInfo FileInfo)
|
||||
goUp :: AnchoredFile FileInfo -> IO (AnchoredFile FileInfo)
|
||||
goUp af@("" :/ _) = return af
|
||||
goUp (bp :/ _) = Data.DirTree.readFile bp
|
||||
|
||||
|
||||
goUp' :: FilePath -> IO (AnchoredFile FileInfo FileInfo)
|
||||
goUp' :: FilePath -> IO (AnchoredFile FileInfo)
|
||||
goUp' fp = do
|
||||
cfp <- canonicalizePath' fp
|
||||
Data.DirTree.readFile $ baseDir cfp
|
||||
|
||||
|
||||
getContents :: AnchoredFile FileInfo FileInfo
|
||||
-> IO [AnchoredFile FileInfo FileInfo]
|
||||
getContents (bp :/ Dir n _) = readDirectory (bp </> n)
|
||||
getContents :: AnchoredFile FileInfo
|
||||
-> IO [AnchoredFile FileInfo]
|
||||
getContents (SDir af) = readDirectory (fullPath af)
|
||||
getContents _ = return []
|
||||
|
||||
|
||||
@ -539,7 +520,6 @@ getDirsFiles fp = do
|
||||
getFileInfo :: FilePath -> IO FileInfo
|
||||
getFileInfo fp = do
|
||||
fs <- PF.getSymbolicLinkStatus fp
|
||||
perms <- getPermissions fp
|
||||
return $ FileInfo
|
||||
(PF.deviceID fs)
|
||||
(PF.fileID fs)
|
||||
@ -555,18 +535,10 @@ getFileInfo fp = do
|
||||
(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
|
||||
|
||||
|
||||
-- |Gets the free variable. Returns Nothing if the constructor is of `Failed`.
|
||||
getFreeVar :: File a a -> Maybe a
|
||||
getFreeVar :: File a -> Maybe a
|
||||
getFreeVar (RegFile _ f) = Just f
|
||||
getFreeVar (Dir _ d) = Just d
|
||||
getFreeVar _ = Nothing
|
||||
@ -577,20 +549,27 @@ getFreeVar _ = Nothing
|
||||
|
||||
-- handles an IO exception by returning a Failed constructor filled with that
|
||||
-- exception:
|
||||
handleDT :: FileName -> IO (File a b) -> IO (File a b)
|
||||
handleDT :: FileName -> IO (File a) -> IO (File a)
|
||||
handleDT n = handle (return . Failed n)
|
||||
|
||||
|
||||
-- handles an IO exception by returning a Failed constructor filled with that
|
||||
-- exception:
|
||||
handleDT' :: FilePath -> FileName -> IO (AnchoredFile a) -> IO (AnchoredFile a)
|
||||
handleDT' bp n = handle (\e -> return $ bp :/ Failed n e)
|
||||
|
||||
|
||||
-- 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
|
||||
-- raised by the internal implementation of this module:
|
||||
-- This leaves the error if it exists in the top (user-supplied) level:
|
||||
removeNonexistent :: [File a b] -> [File a b]
|
||||
removeNonexistent :: [AnchoredFile a] -> [AnchoredFile a]
|
||||
removeNonexistent = filter isOkConstructor
|
||||
where isOkConstructor c = not (failed c) || isOkError c
|
||||
isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err
|
||||
where
|
||||
isOkConstructor (_ :/ c) = not (failed c) || isOkError c
|
||||
isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err
|
||||
|
||||
|
||||
|
||||
@ -598,11 +577,11 @@ removeNonexistent = filter isOkConstructor
|
||||
---- OTHER: ----
|
||||
|
||||
|
||||
fullPath :: AnchoredFile a b -> FilePath
|
||||
fullPath :: AnchoredFile a -> FilePath
|
||||
fullPath (bp :/ f) = bp </> name f
|
||||
|
||||
|
||||
fromFreeVar :: (Default d) => (a -> d) -> File a a -> d
|
||||
fromFreeVar :: (Default d) => (a -> d) -> File a -> d
|
||||
fromFreeVar f df = maybeD f $ getFreeVar df
|
||||
|
||||
|
||||
@ -610,20 +589,38 @@ maybeD :: (Default b) => (a -> b) -> Maybe a -> b
|
||||
maybeD = maybe def
|
||||
|
||||
|
||||
-- |Pack the modification time
|
||||
packModTime :: File FileInfo FileInfo
|
||||
-- |Pack the modification time into a string.
|
||||
packModTime :: File FileInfo
|
||||
-> String
|
||||
packModTime = fromFreeVar
|
||||
$ show . posixSecondsToUTCTime . realToFrac . modificationTime
|
||||
|
||||
packPermissions :: File FileInfo FileInfo
|
||||
|
||||
-- |Pack the permissions into a string, similar to what "ls -l" does.
|
||||
packPermissions :: File FileInfo
|
||||
-> String
|
||||
packPermissions dt = fromFreeVar (pStr . permissions) dt
|
||||
packPermissions dt = fromFreeVar (pStr . fileMode) dt
|
||||
where
|
||||
pStr perm = str perm readable "r"
|
||||
++ str perm writable "w"
|
||||
++ str perm (if isDirC dt then searchable else executable)
|
||||
"x"
|
||||
str perm f ch
|
||||
| f perm = ch
|
||||
| otherwise = "-"
|
||||
pStr ffm = typeModeStr ++ ownerModeStr ++ groupModeStr ++ otherModeStr
|
||||
where
|
||||
typeModeStr
|
||||
| hasFM PF.regularFileMode = "-"
|
||||
| hasFM PF.directoryMode = "d"
|
||||
| hasFM PF.symbolicLinkMode = "l"
|
||||
| hasFM PF.socketMode = "s"
|
||||
| hasFM PF.blockSpecialMode = "b"
|
||||
| hasFM PF.characterSpecialMode = "c"
|
||||
| hasFM PF.namedPipeMode = "p"
|
||||
ownerModeStr = hasFmStr PF.ownerReadMode "r"
|
||||
++ hasFmStr PF.ownerWriteMode "w"
|
||||
++ hasFmStr PF.ownerExecuteMode "x"
|
||||
groupModeStr = hasFmStr PF.groupReadMode "r"
|
||||
++ hasFmStr PF.groupWriteMode "w"
|
||||
++ hasFmStr PF.groupExecuteMode "x"
|
||||
otherModeStr = hasFmStr PF.otherReadMode "r"
|
||||
++ hasFmStr PF.otherWriteMode "w"
|
||||
++ hasFmStr PF.otherExecuteMode "x"
|
||||
hasFmStr fm str
|
||||
| hasFM fm = str
|
||||
| otherwise = "-"
|
||||
hasFM fm = ffm `PF.intersectFileModes` fm == fm
|
||||
|
||||
@ -111,7 +111,7 @@ urlGoTo mygui myview = do
|
||||
open :: Row -> MyGUI -> MyView -> IO ()
|
||||
open row mygui myview = withErrorDialog $
|
||||
case row of
|
||||
r@(_ :/ Dir _ _) -> do
|
||||
SDir r -> do
|
||||
nv <- Data.DirTree.readFile $ fullPath r
|
||||
refreshTreeView' mygui myview nv
|
||||
r ->
|
||||
|
||||
@ -56,7 +56,7 @@ data FMSettings = MkFMSettings {
|
||||
}
|
||||
|
||||
|
||||
type Row = AnchoredFile FileInfo FileInfo
|
||||
type Row = AnchoredFile FileInfo
|
||||
|
||||
|
||||
-- |This describes the contents of the treeView and is separated from MyGUI,
|
||||
|
||||
@ -85,7 +85,7 @@ withRow mygui myview io = do
|
||||
-- |Create the 'ListStore' of files/directories from the current directory.
|
||||
-- This is the function which maps the Data.DirTree data structures
|
||||
-- into the GTK+ data structures.
|
||||
fileListStore :: AnchoredFile FileInfo FileInfo -- ^ current dir
|
||||
fileListStore :: AnchoredFile FileInfo -- ^ current dir
|
||||
-> MyView
|
||||
-> IO (ListStore Row)
|
||||
fileListStore dt myview = do
|
||||
@ -100,7 +100,7 @@ fileListStore dt myview = do
|
||||
--
|
||||
-- * 'rawModel' reads
|
||||
getFirstRow :: MyView
|
||||
-> IO (AnchoredFile FileInfo FileInfo)
|
||||
-> IO (AnchoredFile FileInfo)
|
||||
getFirstRow myview = do
|
||||
rawModel' <- readTVarIO $ rawModel myview
|
||||
iter <- fromJust <$> treeModelGetIterFirst rawModel'
|
||||
@ -141,7 +141,7 @@ refreshTreeView mygui myview mfp = do
|
||||
-- * 'rawModel' writes
|
||||
refreshTreeView' :: MyGUI
|
||||
-> MyView
|
||||
-> AnchoredFile FileInfo FileInfo
|
||||
-> AnchoredFile FileInfo
|
||||
-> IO ()
|
||||
refreshTreeView' mygui myview dt = do
|
||||
newRawModel <- fileListStore dt myview
|
||||
@ -215,6 +215,7 @@ constructTreeView mygui myview = do
|
||||
dirtreePix (Dir {}) = folderPix mygui
|
||||
dirtreePix (RegFile {}) = filePix mygui
|
||||
dirtreePix (Failed {}) = errorPix mygui
|
||||
dirtreePix _ = errorPix mygui
|
||||
|
||||
|
||||
-- |Push a message to the status bar.
|
||||
|
||||
100
src/IO/File.hs
100
src/IO/File.hs
@ -77,27 +77,27 @@ import qualified System.Posix.Files as PF
|
||||
-- or delay operations.
|
||||
data FileOperation = FCopy Copy
|
||||
| FMove Move
|
||||
| FDelete (AnchoredFile FileInfo FileInfo)
|
||||
| FOpen (AnchoredFile FileInfo FileInfo)
|
||||
| FExecute (AnchoredFile FileInfo FileInfo) [String]
|
||||
| FDelete (AnchoredFile FileInfo)
|
||||
| FOpen (AnchoredFile FileInfo)
|
||||
| FExecute (AnchoredFile FileInfo) [String]
|
||||
| None
|
||||
|
||||
|
||||
-- |Data type describing partial or complete file copy operation.
|
||||
-- CC stands for a complete operation and can be used for `runFileOp`.
|
||||
data Copy = CP1 (AnchoredFile FileInfo FileInfo)
|
||||
| CP2 (AnchoredFile FileInfo FileInfo)
|
||||
(AnchoredFile FileInfo FileInfo)
|
||||
| CC (AnchoredFile FileInfo FileInfo)
|
||||
(AnchoredFile FileInfo FileInfo)
|
||||
data Copy = CP1 (AnchoredFile FileInfo)
|
||||
| CP2 (AnchoredFile FileInfo)
|
||||
(AnchoredFile FileInfo)
|
||||
| CC (AnchoredFile FileInfo)
|
||||
(AnchoredFile FileInfo)
|
||||
DirCopyMode
|
||||
|
||||
|
||||
-- |Data type describing partial or complete file move operation.
|
||||
-- MC stands for a complete operation and can be used for `runFileOp`.
|
||||
data Move = MP1 (AnchoredFile FileInfo FileInfo)
|
||||
| MC (AnchoredFile FileInfo FileInfo)
|
||||
(AnchoredFile FileInfo FileInfo)
|
||||
data Move = MP1 (AnchoredFile FileInfo)
|
||||
| MC (AnchoredFile FileInfo)
|
||||
(AnchoredFile FileInfo)
|
||||
|
||||
|
||||
-- |Directory copy modes.
|
||||
@ -129,11 +129,10 @@ runFileOp _ = return Nothing
|
||||
-- |Copies a directory to the given destination with the specified
|
||||
-- `DirCopyMode`. Excludes symlinks.
|
||||
copyDir :: DirCopyMode
|
||||
-> AnchoredFile FileInfo FileInfo -- ^ source dir
|
||||
-> AnchoredFile FileInfo FileInfo -- ^ destination dir
|
||||
-> AnchoredFile FileInfo -- ^ source dir
|
||||
-> AnchoredFile FileInfo -- ^ destination dir
|
||||
-> IO ()
|
||||
copyDir cm (IsSymL True) _
|
||||
= return ()
|
||||
copyDir cm (_ :/ SymLink {}) _ = return ()
|
||||
copyDir cm from@(_ :/ Dir fromn _)
|
||||
to@(_ :/ Dir {})
|
||||
= do
|
||||
@ -150,7 +149,7 @@ copyDir cm from@(_ :/ Dir fromn _)
|
||||
|
||||
for_ contents $ \f ->
|
||||
case f of
|
||||
(IsSymL True) -> recreateSymlink f destdir
|
||||
(_ :/ SymLink {}) -> recreateSymlink f destdir
|
||||
(_ :/ Dir {}) -> copyDir cm f destdir
|
||||
(_ :/ RegFile {}) -> copyFileToDir f destdir
|
||||
_ -> return ()
|
||||
@ -179,11 +178,11 @@ copyDir _ _ _ = return ()
|
||||
|
||||
|
||||
-- |Recreate a symlink.
|
||||
recreateSymlink :: AnchoredFile FileInfo FileInfo -- ^ the old symlink file
|
||||
-> AnchoredFile FileInfo FileInfo -- ^ destination dir of the
|
||||
recreateSymlink :: AnchoredFile FileInfo -- ^ the old symlink file
|
||||
-> AnchoredFile FileInfo -- ^ destination dir of the
|
||||
-- new symlink file
|
||||
-> IO ()
|
||||
recreateSymlink symf@(IsSymL True)
|
||||
recreateSymlink symf@(_ :/ SymLink {})
|
||||
symdest@(_ :/ Dir {})
|
||||
= do
|
||||
symname <- readSymbolicLink (fullPath symf)
|
||||
@ -193,10 +192,10 @@ recreateSymlink _ _ = return ()
|
||||
|
||||
-- |Copies the given file to the given file destination.
|
||||
-- Excludes symlinks.
|
||||
copyFile :: AnchoredFile FileInfo FileInfo -- ^ source file
|
||||
-> AnchoredFile FileInfo FileInfo -- ^ destination file
|
||||
copyFile :: AnchoredFile FileInfo -- ^ source file
|
||||
-> AnchoredFile FileInfo -- ^ destination file
|
||||
-> IO ()
|
||||
copyFile (IsSymL True) _ = return ()
|
||||
copyFile (_ :/ SymLink {}) _ = return ()
|
||||
copyFile from@(_ :/ RegFile {}) to@(_ :/ RegFile {}) = do
|
||||
let from' = fullPath from
|
||||
to' = fullPath to
|
||||
@ -207,10 +206,10 @@ copyFile _ _ = return ()
|
||||
|
||||
-- |Copies the given file to the given dir with the same filename.
|
||||
-- Excludes symlinks.
|
||||
copyFileToDir :: AnchoredFile FileInfo FileInfo
|
||||
-> AnchoredFile FileInfo FileInfo
|
||||
copyFileToDir :: AnchoredFile FileInfo
|
||||
-> AnchoredFile FileInfo
|
||||
-> IO ()
|
||||
copyFileToDir (IsSymL True) _ = return ()
|
||||
copyFileToDir (_ :/ SymLink {}) _ = return ()
|
||||
copyFileToDir from@(_ :/ RegFile fn _)
|
||||
to@(_ :/ Dir {}) =
|
||||
do
|
||||
@ -223,10 +222,10 @@ copyFileToDir _ _ = return ()
|
||||
-- |Copies a file, directory or symlink. In case of a symlink, it is just
|
||||
-- recreated, even if it points to a directory.
|
||||
easyCopy :: DirCopyMode
|
||||
-> AnchoredFile FileInfo FileInfo
|
||||
-> AnchoredFile FileInfo FileInfo
|
||||
-> AnchoredFile FileInfo
|
||||
-> AnchoredFile FileInfo
|
||||
-> IO ()
|
||||
easyCopy _ from@(IsSymL True) to@(_ :/ Dir {}) = recreateSymlink from to
|
||||
easyCopy _ from@(_ :/ SymLink {}) to@(_ :/ Dir {}) = recreateSymlink from to
|
||||
easyCopy _ from@(_ :/ RegFile fn _)
|
||||
to@(_ :/ Dir {})
|
||||
= copyFileToDir from to
|
||||
@ -249,8 +248,8 @@ easyCopy _ _ _ = return ()
|
||||
-- |Move a given file to the given target directory.
|
||||
-- Includes symlinks, which are treated as files and the symlink is not
|
||||
-- followed.
|
||||
moveFile :: AnchoredFile FileInfo FileInfo -- ^ file to move
|
||||
-> AnchoredFile FileInfo FileInfo -- ^ base target directory
|
||||
moveFile :: AnchoredFile FileInfo -- ^ file to move
|
||||
-> AnchoredFile FileInfo -- ^ base target directory
|
||||
-> IO ()
|
||||
moveFile from@SymlOrRegFile to@(_ :/ Dir {}) = do
|
||||
let from' = fullPath from
|
||||
@ -262,10 +261,10 @@ moveFile _ _ = return ()
|
||||
|
||||
-- |Move a given directory to the given target directory.
|
||||
-- Excludes symlinks.
|
||||
moveDir :: AnchoredFile FileInfo FileInfo -- ^ dir to move
|
||||
-> AnchoredFile FileInfo FileInfo -- ^ base target directory
|
||||
moveDir :: AnchoredFile FileInfo -- ^ dir to move
|
||||
-> AnchoredFile FileInfo -- ^ base target directory
|
||||
-> IO ()
|
||||
moveDir (IsSymL True) _ = return ()
|
||||
moveDir (_ :/ SymLink {}) _ = return ()
|
||||
moveDir from@(_ :/ Dir n _) to@(_ :/ Dir {}) = do
|
||||
let from' = fullPath from
|
||||
to' = fullPath to </> n
|
||||
@ -276,10 +275,10 @@ moveDir _ _ = return ()
|
||||
|
||||
-- |Moves a file, directory or symlink. In case of a symlink, it is
|
||||
-- treated as a file and the symlink is not being followed.
|
||||
easyMove :: AnchoredFile FileInfo FileInfo -- ^ source
|
||||
-> AnchoredFile FileInfo FileInfo -- ^ base target directory
|
||||
easyMove :: AnchoredFile FileInfo -- ^ source
|
||||
-> AnchoredFile FileInfo -- ^ base target directory
|
||||
-> IO ()
|
||||
easyMove from@(IsSymL True) to@(_ :/ Dir {}) = moveFile from to
|
||||
easyMove from@(_ :/ SymLink {}) to@(_ :/ Dir {}) = moveFile from to
|
||||
easyMove from@(_ :/ RegFile _ _) to@(_ :/ Dir {}) = moveFile from to
|
||||
easyMove from@(_ :/ Dir _ _) to@(_ :/ Dir {}) = moveDir from to
|
||||
easyMove _ _ = return ()
|
||||
@ -292,16 +291,16 @@ easyMove _ _ = return ()
|
||||
|
||||
|
||||
-- |Deletes a symlink, which can either point to a file or directory.
|
||||
deleteSymlink :: AnchoredFile FileInfo FileInfo -> IO ()
|
||||
deleteSymlink f@(IsSymL True)
|
||||
deleteSymlink :: AnchoredFile FileInfo -> IO ()
|
||||
deleteSymlink f@(_ :/ SymLink {})
|
||||
= removeFile (fullPath f)
|
||||
deleteSymlink _
|
||||
= return ()
|
||||
|
||||
|
||||
-- |Deletes the given file, never symlinks.
|
||||
deleteFile :: AnchoredFile FileInfo FileInfo -> IO ()
|
||||
deleteFile (IsSymL True) = return ()
|
||||
deleteFile :: AnchoredFile FileInfo -> IO ()
|
||||
deleteFile (_ :/ SymLink {}) = return ()
|
||||
deleteFile f@(_ :/ RegFile {})
|
||||
= removeFile (fullPath f)
|
||||
deleteFile _
|
||||
@ -309,16 +308,16 @@ deleteFile _
|
||||
|
||||
|
||||
-- |Deletes the given directory, never symlinks.
|
||||
deleteDir :: AnchoredFile FileInfo FileInfo -> IO ()
|
||||
deleteDir (IsSymL True) = return ()
|
||||
deleteDir :: AnchoredFile FileInfo -> IO ()
|
||||
deleteDir (_ :/ SymLink {}) = return ()
|
||||
deleteDir f@(_ :/ Dir {})
|
||||
= removeDirectory (fullPath f)
|
||||
deleteDir _ = return ()
|
||||
|
||||
|
||||
-- |Deletes the given directory recursively, never symlinks.
|
||||
deleteDirRecursive :: AnchoredFile FileInfo FileInfo -> IO ()
|
||||
deleteDirRecursive (IsSymL True) = return ()
|
||||
deleteDirRecursive :: AnchoredFile FileInfo -> IO ()
|
||||
deleteDirRecursive (_ :/ SymLink {}) = return ()
|
||||
deleteDirRecursive f@(_ :/ Dir {})
|
||||
= removeDirectoryRecursive (fullPath f)
|
||||
deleteDirRecursive _ = return ()
|
||||
@ -327,8 +326,8 @@ deleteDirRecursive _ = return ()
|
||||
-- |Deletes a file, directory or symlink, whatever it may be.
|
||||
-- In case of directory, performs recursive deletion. In case of
|
||||
-- a symlink, the symlink file is deleted.
|
||||
easyDelete :: AnchoredFile FileInfo FileInfo -> IO ()
|
||||
easyDelete f@(IsSymL True) = deleteSymlink f
|
||||
easyDelete :: AnchoredFile FileInfo -> IO ()
|
||||
easyDelete f@(_ :/ SymLink {}) = deleteSymlink f
|
||||
easyDelete f@(_ :/ RegFile {})
|
||||
= deleteFile f
|
||||
easyDelete f@(_ :/ Dir {})
|
||||
@ -345,16 +344,15 @@ easyDelete _
|
||||
|
||||
|
||||
-- |Opens a file appropriately by invoking xdg-open.
|
||||
openFile :: AnchoredFile a b
|
||||
openFile :: AnchoredFile a
|
||||
-> IO ProcessHandle
|
||||
openFile f = spawnProcess "xdg-open" [fullPath f]
|
||||
|
||||
|
||||
-- |Executes a program with the given arguments.
|
||||
executeFile :: AnchoredFile FileInfo FileInfo -- ^ program
|
||||
executeFile :: AnchoredFile FileInfo -- ^ program
|
||||
-> [String] -- ^ arguments
|
||||
-> IO (Maybe ProcessHandle)
|
||||
executeFile prog@(_ :/ RegFile _ FileInfo { permissions = perms }) args
|
||||
| executable perms = Just <$> spawnProcess (fullPath prog) args
|
||||
| otherwise = return Nothing
|
||||
executeFile prog@(_ :/ RegFile {}) args
|
||||
= Just <$> spawnProcess (fullPath prog) args
|
||||
executeFile _ _ = return Nothing
|
||||
|
||||
Loading…
Reference in New Issue
Block a user