LIB/GTK: use our hpath lib for path type
This commit is contained in:
parent
09d8910eae
commit
f301e2e519
3
.gitmodules
vendored
Normal file
3
.gitmodules
vendored
Normal file
@ -0,0 +1,3 @@
|
||||
[submodule "3rdparty/hpath"]
|
||||
path = 3rdparty/hpath
|
||||
url = https://github.com/hasufell/hpath.git
|
||||
1
3rdparty/hpath
vendored
Submodule
1
3rdparty/hpath
vendored
Submodule
@ -0,0 +1 @@
|
||||
Subproject commit 3c3a2d276646f6530970f675ef32c6089c1e56d4
|
||||
@ -36,6 +36,7 @@ library
|
||||
hinotify,
|
||||
mtl >= 2.2,
|
||||
old-locale >= 1,
|
||||
hpath,
|
||||
process,
|
||||
safe,
|
||||
stm,
|
||||
@ -75,6 +76,7 @@ executable hsfm-gtk
|
||||
hinotify,
|
||||
mtl >= 2.2,
|
||||
old-locale >= 1,
|
||||
hpath,
|
||||
process,
|
||||
safe,
|
||||
stm,
|
||||
|
||||
@ -62,7 +62,8 @@ import Data.List
|
||||
)
|
||||
import Data.Maybe
|
||||
(
|
||||
fromMaybe
|
||||
catMaybes
|
||||
, fromMaybe
|
||||
)
|
||||
import Data.Ord
|
||||
(
|
||||
@ -85,6 +86,15 @@ import Data.Word
|
||||
(
|
||||
Word64
|
||||
)
|
||||
import HPath
|
||||
(
|
||||
Abs
|
||||
, Path
|
||||
, Fn
|
||||
, Rel
|
||||
, pattern Path
|
||||
)
|
||||
import qualified HPath as P
|
||||
import Safe
|
||||
(
|
||||
atDef
|
||||
@ -144,14 +154,10 @@ import qualified System.Posix.Directory as PFD
|
||||
----------------------------
|
||||
|
||||
|
||||
-- |Weak type to distinguish between FilePath and FileName.
|
||||
type FileName = String
|
||||
|
||||
|
||||
-- |Represents a file. The `anchor` field is the path
|
||||
-- to that file without the filename.
|
||||
data AnchoredFile a =
|
||||
(:/) { anchor :: FilePath, file :: File a }
|
||||
(:/) { anchor :: Path Abs, file :: File a }
|
||||
deriving (Eq, Show)
|
||||
|
||||
|
||||
@ -162,37 +168,39 @@ data AnchoredFile a =
|
||||
-- can be converted to a String with 'show'.
|
||||
data File a =
|
||||
Failed {
|
||||
name :: FileName
|
||||
name :: Path Fn
|
||||
, err :: IOException
|
||||
}
|
||||
| Dir {
|
||||
name :: FileName
|
||||
name :: Path Fn
|
||||
, fvar :: a
|
||||
}
|
||||
| RegFile {
|
||||
name :: FileName
|
||||
name :: Path Fn
|
||||
, fvar :: a
|
||||
}
|
||||
-- TODO: add raw symlink dest (not normalized) to SymLink?
|
||||
| SymLink {
|
||||
name :: FileName
|
||||
name :: Path Fn
|
||||
, fvar :: a
|
||||
, sdest :: AnchoredFile a -- ^ symlink madness,
|
||||
-- we need to know where it points to
|
||||
, rawdest :: FilePath
|
||||
}
|
||||
| BlockDev {
|
||||
name :: FileName
|
||||
name :: Path Fn
|
||||
, fvar :: a
|
||||
}
|
||||
| CharDev {
|
||||
name :: FileName
|
||||
name :: Path Fn
|
||||
, fvar :: a
|
||||
}
|
||||
| NamedPipe {
|
||||
name :: FileName
|
||||
name :: Path Fn
|
||||
, fvar :: a
|
||||
}
|
||||
| Socket {
|
||||
name :: FileName
|
||||
name :: Path Fn
|
||||
, fvar :: a
|
||||
} deriving (Show, Eq)
|
||||
|
||||
@ -216,9 +224,9 @@ data FileInfo = FileInfo {
|
||||
} deriving (Show, Eq, Ord)
|
||||
|
||||
|
||||
type UserIO a = FilePath -> IO a
|
||||
type UserIO a t = Path Abs -> IO a
|
||||
|
||||
type Builder a = UserIO a -> FilePath -> IO [File a]
|
||||
type Builder a t = UserIO a t -> Path Abs -> IO [File a]
|
||||
|
||||
|
||||
|
||||
@ -240,11 +248,11 @@ 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@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)
|
||||
|
||||
|
||||
@ -268,11 +276,11 @@ 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@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
|
||||
|
||||
|
||||
@ -304,11 +312,11 @@ dirSym f@(SymLink { sdest = (_ :/ Dir {} )}) = (True, f)
|
||||
dirSym f = (False, f)
|
||||
|
||||
|
||||
invalidFileName :: FileName -> (Bool, FileName)
|
||||
invalidFileName "" = (True, "")
|
||||
invalidFileName "." = (True, ".")
|
||||
invalidFileName ".." = (True, "..")
|
||||
invalidFileName fn = (elem pathSeparator fn, fn)
|
||||
invalidFileName :: Path Fn -> (Bool, Path Fn)
|
||||
invalidFileName p@(Path "") = (True, p)
|
||||
invalidFileName p@(Path ".") = (True, p)
|
||||
invalidFileName p@(Path "..") = (True, p)
|
||||
invalidFileName p@(Path fn) = (elem pathSeparator fn, p)
|
||||
|
||||
|
||||
abrokenSymlink :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo)
|
||||
@ -408,72 +416,80 @@ instance Ord (AnchoredFile FileInfo) where
|
||||
----------------------------
|
||||
|
||||
|
||||
-- |Read a file into an `AnchoredFile`, filling the free variables via
|
||||
-- the given function.
|
||||
readFileWith :: (FilePath -> IO a)
|
||||
-> FilePath
|
||||
-- |Reads a file or directory Path into an `AnchoredFile`, filling the free
|
||||
-- variables via the given function.
|
||||
readWith :: (Path Abs -> IO a) -- ^ function that fills the free
|
||||
-- a variable
|
||||
-> Path Abs -- ^ Path to read
|
||||
-> IO (AnchoredFile a)
|
||||
readFileWith ff p = do
|
||||
let fn = topDir p
|
||||
bd = baseDir p
|
||||
handleDT' bd fn $ do
|
||||
fs <- PF.getSymbolicLinkStatus p
|
||||
readWith ff p = do
|
||||
let fn = P.basename p
|
||||
bd = P.dirname p
|
||||
p' = P.toFilePath p
|
||||
bd' <- P.canonicalizePath bd -- TODO: this will cause a dialog to pop up on error
|
||||
handleDT' bd' fn $ do
|
||||
fs <- PF.getSymbolicLinkStatus p'
|
||||
fv <- ff p
|
||||
file <- constructFile fs fv bd fn
|
||||
return (bd :/ file)
|
||||
file <- constructFile fs fv bd' fn
|
||||
return (bd' :/ file)
|
||||
where
|
||||
constructFile fs fv bd' n
|
||||
constructFile fs fv bd' fn'
|
||||
| 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
|
||||
let fp = bd' P.</> fn'
|
||||
x <- PF.readSymbolicLink (P.fromAbs fp)
|
||||
resolvedSyml <- handleDT' bd' fn' $ do
|
||||
-- watch out, we call </> from 'filepath' here, but it is safe
|
||||
-- TODO: could it happen that too many '..' lead
|
||||
-- to something like '/' after normalization?
|
||||
let sfp = if isAbsolute x then x else (P.fromAbs bd') </> x
|
||||
sf <- 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
|
||||
rsfp <- P.realPath sfp
|
||||
readWith ff =<< P.parseAbs rsfp
|
||||
return $ SymLink fn' fv resolvedSyml x
|
||||
| PF.isDirectory fs = return $ Dir fn' fv
|
||||
| PF.isRegularFile fs = return $ RegFile fn' fv
|
||||
| PF.isBlockDevice fs = return $ BlockDev fn' fv
|
||||
| PF.isCharacterDevice fs = return $ CharDev fn' fv
|
||||
| PF.isNamedPipe fs = return $ NamedPipe fn' fv
|
||||
| PF.isSocket fs = return $ Socket fn' fv
|
||||
| otherwise = return $ Failed fn' (userError
|
||||
"Unknown filetype!")
|
||||
|
||||
|
||||
readFile :: FilePath -> IO (AnchoredFile FileInfo)
|
||||
readFile fp = readFileWith getFileInfo $ normalize fp
|
||||
-- |Reads a file Path into an AnchoredFile.
|
||||
readFile :: (Path Abs -> IO a) -> Path Abs -> IO (AnchoredFile a)
|
||||
readFile ff fp = readWith ff fp
|
||||
|
||||
readFileWithFileInfo :: Path Abs -> IO (AnchoredFile FileInfo)
|
||||
readFileWithFileInfo = Data.DirTree.readFile getFileInfo
|
||||
|
||||
-- |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]
|
||||
readDirectory fp = readDirectoryWith getAllDirsFiles getFileInfo
|
||||
$ normalize fp
|
||||
readDirectoryContents :: Path Abs -> IO [AnchoredFile FileInfo]
|
||||
readDirectoryContents fp = readDirectoryContentsWith getAllDirsFiles getFileInfo 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]
|
||||
readDirectory' fp = readDirectoryWith getDirsFiles getFileInfo
|
||||
$ normalize fp
|
||||
readDirectoryContents' :: Path Abs -> IO [AnchoredFile FileInfo]
|
||||
readDirectoryContents' fp = readDirectoryContentsWith getDirsFiles getFileInfo fp
|
||||
|
||||
|
||||
-- | same as readDirectory but allows us to, for example, use
|
||||
-- |Same as readDirectoryContents but allows us to, for example, use
|
||||
-- ByteString.readFile to return a tree of ByteStrings.
|
||||
readDirectoryWith :: (FilePath -> IO [FilePath])
|
||||
-> (FilePath -> IO a)
|
||||
-> FilePath
|
||||
readDirectoryContentsWith :: (Path Abs -> IO [Path Fn])
|
||||
-> (Path Abs -> IO a)
|
||||
-> Path Abs
|
||||
-> IO [AnchoredFile a]
|
||||
readDirectoryWith getfiles ff p = do
|
||||
contents <- getfiles $ normalize p
|
||||
cs <- mapM (\x -> readFileWith ff $ p </> x) contents
|
||||
return $ removeNonexistent cs
|
||||
readDirectoryContentsWith getfiles ff p = do
|
||||
files <- getfiles p
|
||||
fcs <- mapM (\x -> Data.DirTree.readFile ff $ p P.</> x) files
|
||||
return $ removeNonexistent fcs
|
||||
|
||||
|
||||
|
||||
@ -549,7 +565,7 @@ isDirC _ = False
|
||||
|
||||
|
||||
isSymC :: File a -> Bool
|
||||
isSymC (SymLink _ _ _) = True
|
||||
isSymC (SymLink _ _ _ _) = True
|
||||
isSymC _ = False
|
||||
|
||||
|
||||
@ -579,19 +595,11 @@ isSocketC _ = False
|
||||
|
||||
|
||||
|
||||
-- extracting pathnames and base names:
|
||||
topDir, baseDir :: FilePath -> FilePath
|
||||
topDir = last . splitDirectories
|
||||
baseDir = joinPath . init . splitDirectories
|
||||
|
||||
|
||||
-- |Check whether the given file is a hidden file.
|
||||
hiddenFile :: FilePath -> Bool
|
||||
hiddenFile "." = False
|
||||
hiddenFile ".." = False
|
||||
hiddenFile str
|
||||
| "." `isPrefixOf` str = True
|
||||
| otherwise = False
|
||||
hiddenFile :: Path Fn -> Bool
|
||||
hiddenFile (Path ".") = False
|
||||
hiddenFile (Path "..") = False
|
||||
hiddenFile (Path fn) = "." `isPrefixOf` fn
|
||||
|
||||
|
||||
-- |Like `normalise` from System.FilePath but removes occurences of '..'.
|
||||
@ -612,29 +620,27 @@ normalize fp =
|
||||
|
||||
-- |Go up one directory in the filesystem hierarchy.
|
||||
goUp :: AnchoredFile FileInfo -> IO (AnchoredFile FileInfo)
|
||||
goUp af@("" :/ _) = return af
|
||||
goUp (bp :/ _) = Data.DirTree.readFile bp
|
||||
goUp af@(Path "" :/ _) = return af
|
||||
goUp (bp :/ _) = Data.DirTree.readFile getFileInfo bp
|
||||
|
||||
|
||||
-- |Go up one directory in the filesystem hierarchy.
|
||||
goUp' :: FilePath -> IO (AnchoredFile FileInfo)
|
||||
goUp' fp = do
|
||||
let cfp = normalize fp
|
||||
Data.DirTree.readFile $ baseDir cfp
|
||||
goUp' :: Path Abs -> IO (AnchoredFile FileInfo)
|
||||
goUp' fp = Data.DirTree.readFile getFileInfo $ P.dirname fp
|
||||
|
||||
|
||||
-- |Get the contents of a directory.
|
||||
getContents :: AnchoredFile FileInfo
|
||||
-> IO [AnchoredFile FileInfo]
|
||||
getContents (ADirOrSym af) = readDirectory (fullPath af)
|
||||
getContents (ADirOrSym af) = readDirectoryContents (fullPath af)
|
||||
getContents _ = return []
|
||||
|
||||
|
||||
getDirsFiles' :: (FilePath -> [FilePath] -> [FilePath])
|
||||
-> FilePath
|
||||
-> IO [FilePath]
|
||||
-> Path Abs
|
||||
-> IO [Path Fn]
|
||||
getDirsFiles' filterf fp = do
|
||||
dirstream <- PFD.openDirStream fp
|
||||
dirstream <- PFD.openDirStream . P.toFilePath $ fp
|
||||
let mdirs :: [FilePath] -> IO [FilePath]
|
||||
mdirs dirs = do
|
||||
-- make sure we close the directory stream in case of errors
|
||||
@ -645,18 +651,18 @@ getDirsFiles' filterf fp = do
|
||||
else mdirs (dir `filterf` dirs)
|
||||
dirs <- mdirs []
|
||||
PFD.closeDirStream dirstream
|
||||
return dirs
|
||||
return $ catMaybes (fmap P.parseFn dirs)
|
||||
|
||||
|
||||
-- |Get all files of a given directory and return them as a List.
|
||||
-- This includes "." and "..".
|
||||
getAllDirsFiles :: FilePath -> IO [FilePath]
|
||||
getAllDirsFiles :: Path Abs -> IO [Path Fn]
|
||||
getAllDirsFiles = getDirsFiles' (:)
|
||||
|
||||
|
||||
-- |Get all files of a given directory and return them as a List.
|
||||
-- This excludes "." and "..".
|
||||
getDirsFiles :: FilePath -> IO [FilePath]
|
||||
getDirsFiles :: Path Abs -> IO [Path Fn]
|
||||
getDirsFiles = getDirsFiles' insert
|
||||
where
|
||||
insert dir dirs = case dir of
|
||||
@ -666,9 +672,9 @@ getDirsFiles = getDirsFiles' insert
|
||||
|
||||
|
||||
-- |Gets all file information.
|
||||
getFileInfo :: FilePath -> IO FileInfo
|
||||
getFileInfo :: Path Abs -> IO FileInfo
|
||||
getFileInfo fp = do
|
||||
fs <- PF.getSymbolicLinkStatus fp
|
||||
fs <- PF.getSymbolicLinkStatus (P.fromAbs fp)
|
||||
return $ FileInfo
|
||||
(PF.deviceID fs)
|
||||
(PF.fileID fs)
|
||||
@ -690,7 +696,7 @@ getFileInfo fp = do
|
||||
getFreeVar :: File a -> Maybe a
|
||||
getFreeVar (Dir _ d) = Just d
|
||||
getFreeVar (RegFile _ d) = Just d
|
||||
getFreeVar (SymLink _ d _) = Just d
|
||||
getFreeVar (SymLink _ d _ _) = Just d
|
||||
getFreeVar (BlockDev _ d) = Just d
|
||||
getFreeVar (CharDev _ d) = Just d
|
||||
getFreeVar (NamedPipe _ d) = Just d
|
||||
@ -703,14 +709,19 @@ getFreeVar _ = Nothing
|
||||
|
||||
-- handles an IO exception by returning a Failed constructor filled with that
|
||||
-- exception:
|
||||
handleDT :: FileName -> IO (File a) -> IO (File a)
|
||||
handleDT :: Path Fn -> 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)
|
||||
-- TODO: only handle IO exceptions
|
||||
handleDT' :: Path Abs
|
||||
-> Path Fn
|
||||
-> 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
|
||||
@ -729,25 +740,12 @@ removeNonexistent = filter isOkConstructor
|
||||
---- SYMLINK HELPERS: ----
|
||||
|
||||
|
||||
-- |Follows a chain of symlinks until it finds a non-symlink. Note that
|
||||
-- this can be caught in an infinite loop if the symlinks haven't been
|
||||
-- constructed properly. This module however ensures that this cannot
|
||||
-- happen.
|
||||
followSymlink :: File FileInfo -> File FileInfo
|
||||
followSymlink (SymLink _ _ (_ :/ b@(SymLink {}))) = followSymlink b
|
||||
followSymlink af = af
|
||||
|
||||
|
||||
-- |Checks if a symlink is broken by examining the constructor of the
|
||||
-- symlink destination. This also follows the symlink chain.
|
||||
--
|
||||
-- When called on a non-symlink, returns False.
|
||||
isBrokenSymlink :: File FileInfo -> Bool
|
||||
isBrokenSymlink af@(SymLink _ _ (_ :/ Failed {})) = True
|
||||
isBrokenSymlink af@(SymLink {})
|
||||
= case followSymlink af of
|
||||
(Failed {}) -> True
|
||||
_ -> False
|
||||
isBrokenSymlink af@(SymLink _ _ (_ :/ Failed {}) _) = True
|
||||
isBrokenSymlink _ = False
|
||||
|
||||
|
||||
@ -755,8 +753,8 @@ isBrokenSymlink _ = False
|
||||
|
||||
|
||||
|
||||
fullPath :: AnchoredFile a -> FilePath
|
||||
fullPath (bp :/ f) = bp </> name f
|
||||
fullPath :: AnchoredFile a -> Path Abs
|
||||
fullPath (bp :/ f) = bp P.</> name f
|
||||
|
||||
|
||||
-- |Apply a function on the free variable. If there is no free variable
|
||||
|
||||
@ -53,6 +53,7 @@ import GUI.Gtk.Data
|
||||
import GUI.Gtk.Dialogs
|
||||
import GUI.Gtk.MyView
|
||||
import GUI.Gtk.Utils
|
||||
import qualified HPath as P
|
||||
import IO.Error
|
||||
import IO.File
|
||||
import IO.Utils
|
||||
@ -216,7 +217,7 @@ open :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
open [item] mygui myview = withErrorDialog $
|
||||
case item of
|
||||
ADirOrSym r -> do
|
||||
nv <- Data.DirTree.readFile $ fullPath r
|
||||
nv <- Data.DirTree.readFileWithFileInfo $ fullPath r
|
||||
refreshView' mygui myview nv
|
||||
r ->
|
||||
void $ openFile r
|
||||
@ -240,7 +241,7 @@ execute _ _ _ = withErrorDialog
|
||||
-- |Supposed to be used with 'withRows'. Deletes a file or directory.
|
||||
del :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
del [item] mygui myview = withErrorDialog $ do
|
||||
let cmsg = "Really delete \"" ++ fullPath item ++ "\"?"
|
||||
let cmsg = "Really delete \"" ++ P.fromAbs (fullPath item) ++ "\"?"
|
||||
withConfirmationDialog cmsg
|
||||
$ easyDelete item
|
||||
-- this throws on the first error that occurs
|
||||
@ -257,7 +258,7 @@ del _ _ _ = withErrorDialog
|
||||
moveInit :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
moveInit [item] mygui myview = do
|
||||
writeTVarIO (operationBuffer myview) (FMove . MP1 $ item)
|
||||
let sbmsg = "Move buffer: " ++ fullPath item
|
||||
let sbmsg = "Move buffer: " ++ P.fromAbs (fullPath item)
|
||||
popStatusbar mygui
|
||||
void $ pushStatusBar mygui sbmsg
|
||||
moveInit _ _ _ = withErrorDialog
|
||||
@ -268,7 +269,7 @@ moveInit _ _ _ = withErrorDialog
|
||||
copyInit :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
copyInit [item] mygui myview = do
|
||||
writeTVarIO (operationBuffer myview) (FCopy . CP1 $ item)
|
||||
let sbmsg = "Copy buffer: " ++ fullPath item
|
||||
let sbmsg = "Copy buffer: " ++ P.fromAbs (fullPath item)
|
||||
popStatusbar mygui
|
||||
void $ pushStatusBar mygui sbmsg
|
||||
copyInit _ _ _ = withErrorDialog
|
||||
@ -283,14 +284,14 @@ operationFinal mygui myview = withErrorDialog $ do
|
||||
cdir <- getCurrentDir myview
|
||||
case op of
|
||||
FMove (MP1 s) -> do
|
||||
let cmsg = "Really move \"" ++ fullPath s
|
||||
++ "\"" ++ " to \"" ++ fullPath cdir ++ "\"?"
|
||||
let cmsg = "Really move \"" ++ P.fromAbs (fullPath s)
|
||||
++ "\"" ++ " to \"" ++ P.fromAbs (fullPath cdir) ++ "\"?"
|
||||
withConfirmationDialog cmsg . withCopyModeDialog
|
||||
$ \cm -> void $ runFileOp (FMove . MC s cdir $ cm)
|
||||
return ()
|
||||
FCopy (CP1 s) -> do
|
||||
let cmsg = "Really copy \"" ++ fullPath s
|
||||
++ "\"" ++ " to \"" ++ fullPath cdir ++ "\"?"
|
||||
let cmsg = "Really copy \"" ++ P.fromAbs (fullPath s)
|
||||
++ "\"" ++ " to \"" ++ P.fromAbs (fullPath cdir) ++ "\"?"
|
||||
withConfirmationDialog cmsg . withCopyModeDialog
|
||||
$ \cm -> void $ runFileOp (FCopy . CC s cdir $ cm)
|
||||
return ()
|
||||
@ -311,7 +312,8 @@ upDir mygui myview = withErrorDialog $ do
|
||||
newFile :: MyGUI -> MyView -> IO ()
|
||||
newFile mygui myview = withErrorDialog $ do
|
||||
mfn <- textInputDialog "Enter file name"
|
||||
for_ mfn $ \fn -> do
|
||||
let pmfn = P.parseFn =<< mfn
|
||||
for_ pmfn $ \fn -> do
|
||||
cdir <- getCurrentDir myview
|
||||
createFile cdir fn
|
||||
|
||||
@ -319,9 +321,10 @@ newFile mygui myview = withErrorDialog $ do
|
||||
renameF :: [Item] -> MyGUI -> MyView -> IO ()
|
||||
renameF [item] mygui myview = withErrorDialog $ do
|
||||
mfn <- textInputDialog "Enter new file name"
|
||||
for_ mfn $ \fn -> do
|
||||
let cmsg = "Really rename \"" ++ fullPath item
|
||||
++ "\"" ++ " to \"" ++ anchor item </> fn ++ "\"?"
|
||||
let pmfn = P.parseFn =<< mfn
|
||||
for_ pmfn $ \fn -> do
|
||||
let cmsg = "Really rename \"" ++ P.fromAbs (fullPath item)
|
||||
++ "\"" ++ " to \"" ++ P.fromAbs (anchor item P.</> fn) ++ "\"?"
|
||||
withConfirmationDialog cmsg $ IO.File.renameFile item fn
|
||||
renameF _ _ _ = withErrorDialog
|
||||
. throw $ InvalidOperation
|
||||
|
||||
@ -44,11 +44,15 @@ import Data.Foldable
|
||||
import Data.Maybe
|
||||
(
|
||||
catMaybes
|
||||
, fromJust
|
||||
, fromMaybe
|
||||
)
|
||||
import Graphics.UI.Gtk
|
||||
import {-# SOURCE #-} GUI.Gtk.Callbacks (setCallbacks)
|
||||
import GUI.Gtk.Data
|
||||
import GUI.Gtk.Icons
|
||||
import GUI.Gtk.Utils
|
||||
import qualified HPath as P
|
||||
import IO.File
|
||||
import IO.Utils
|
||||
import System.FilePath
|
||||
@ -127,6 +131,8 @@ createIconView = do
|
||||
iconViewSetColumns iconv (-1)
|
||||
iconViewSetSpacing iconv 2
|
||||
iconViewSetMargin iconv 0
|
||||
{- set iconv [ iconViewItemOrientation := OrientationHorizontal ] -}
|
||||
{- set iconv [ iconViewOrientation := OrientationHorizontal ] -}
|
||||
|
||||
return $ FMIconView iconv
|
||||
|
||||
@ -189,9 +195,8 @@ refreshView :: MyGUI
|
||||
refreshView mygui myview mfp =
|
||||
case mfp of
|
||||
Just fp -> do
|
||||
cdir <- (\x -> if (failed . file $ x) || (not . isAbsolute . anchor $ x)
|
||||
then Data.DirTree.readFile "/"
|
||||
else return x) =<< Data.DirTree.readFile fp
|
||||
let mdir = fromMaybe (fromJust $ P.parseAbs "/") (P.parseAbs fp)
|
||||
cdir <- Data.DirTree.readFileWithFileInfo mdir
|
||||
refreshView' mygui myview cdir
|
||||
Nothing -> refreshView' mygui myview =<< getCurrentDir myview
|
||||
|
||||
@ -233,12 +238,30 @@ constructView :: MyGUI
|
||||
-> MyView
|
||||
-> IO ()
|
||||
constructView mygui myview = do
|
||||
settings' <- readTVarIO $ settings mygui
|
||||
|
||||
-- pix stuff
|
||||
iT <- iconThemeGetDefault
|
||||
folderPix <- getIcon IFolder iT (iconSize settings')
|
||||
folderSymPix <- getSymlinkIcon IFolder iT (iconSize settings')
|
||||
filePix <- getIcon IFile iT (iconSize settings')
|
||||
fileSymPix <- getSymlinkIcon IFile iT (iconSize settings')
|
||||
errorPix <- getIcon IError iT (iconSize settings')
|
||||
let dirtreePix (Dir {}) = folderPix
|
||||
dirtreePix (FileLike {}) = filePix
|
||||
dirtreePix (DirSym _) = folderSymPix
|
||||
dirtreePix (FileLikeSym {}) = fileSymPix
|
||||
dirtreePix (Failed {}) = errorPix
|
||||
dirtreePix (BrokenSymlink _) = errorPix
|
||||
dirtreePix _ = errorPix
|
||||
|
||||
|
||||
view' <- readTVarIO $ view myview
|
||||
|
||||
cdirp <- anchor <$> getFirstItem myview
|
||||
|
||||
-- update urlBar
|
||||
entrySetText (urlBar mygui) cdirp
|
||||
entrySetText (urlBar mygui) (P.fromAbs cdirp)
|
||||
|
||||
rawModel' <- readTVarIO $ rawModel myview
|
||||
|
||||
@ -267,7 +290,7 @@ constructView mygui myview = do
|
||||
treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
|
||||
(dirtreePix . file)
|
||||
treeModelSetColumn rawModel' (makeColumnIdString 1)
|
||||
(name . file)
|
||||
(P.fromRel . name . file)
|
||||
treeModelSetColumn rawModel' (makeColumnIdString 2)
|
||||
(packModTime . file)
|
||||
treeModelSetColumn rawModel' (makeColumnIdString 3)
|
||||
@ -292,16 +315,8 @@ constructView mygui myview = do
|
||||
w <- addWatch
|
||||
newi
|
||||
[Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
|
||||
cdirp
|
||||
(\_ -> postGUIAsync $ refreshView mygui myview (Just cdirp))
|
||||
(P.fromAbs cdirp)
|
||||
(\_ -> postGUIAsync $ refreshView mygui myview (Just $ P.fromAbs cdirp))
|
||||
putMVar (inotify myview) newi
|
||||
|
||||
return ()
|
||||
where
|
||||
dirtreePix (Dir {}) = folderPix mygui
|
||||
dirtreePix (FileLike {}) = filePix mygui
|
||||
dirtreePix (DirSym _) = folderSymPix mygui
|
||||
dirtreePix (FileLikeSym {}) = fileSymPix mygui
|
||||
dirtreePix (Failed {}) = errorPix mygui
|
||||
dirtreePix (BrokenSymlink _) = errorPix mygui
|
||||
dirtreePix _ = errorPix mygui
|
||||
|
||||
@ -50,6 +50,12 @@ import Foreign.C.Error
|
||||
(
|
||||
eXDEV
|
||||
)
|
||||
import HPath
|
||||
(
|
||||
Path
|
||||
, Fn
|
||||
)
|
||||
import qualified HPath as P
|
||||
import IO.Error
|
||||
import IO.Utils
|
||||
import System.FilePath
|
||||
@ -172,15 +178,17 @@ copyDir cm from@(_ :/ Dir fromn (FileInfo { fileMode = fmode }))
|
||||
to@(_ :/ Dir {})
|
||||
= do
|
||||
let fromp = fullPath from
|
||||
fromp' = P.toFilePath fromp
|
||||
top = fullPath to
|
||||
destdirp = top </> fromn
|
||||
throwDestinationInSource fromp destdirp
|
||||
throwSameFile fromp destdirp
|
||||
destdirp = top P.</> fromn
|
||||
destdirp' = P.toFilePath destdirp
|
||||
throwDestinationInSource fromp' destdirp'
|
||||
throwSameFile fromp' destdirp'
|
||||
|
||||
createDestdir destdirp fmode
|
||||
destdir <- Data.DirTree.readFile destdirp
|
||||
destdir <- Data.DirTree.readFileWithFileInfo destdirp
|
||||
|
||||
contents <- readDirectory' (fullPath from)
|
||||
contents <- readDirectoryContents' (fullPath from)
|
||||
|
||||
for_ contents $ \f ->
|
||||
case f of
|
||||
@ -190,17 +198,19 @@ copyDir cm from@(_ :/ Dir fromn (FileInfo { fileMode = fmode }))
|
||||
_ -> return ()
|
||||
where
|
||||
createDestdir destdir fmode =
|
||||
case cm of
|
||||
let destdir' = P.toFilePath destdir
|
||||
in case cm of
|
||||
Merge ->
|
||||
unlessM (doesDirectoryExist destdir)
|
||||
(createDirectory destdir fmode)
|
||||
unlessM (doesDirectoryExist destdir')
|
||||
(createDirectory destdir' fmode)
|
||||
Strict -> do
|
||||
throwDirDoesExist destdir
|
||||
createDirectory destdir fmode
|
||||
throwDirDoesExist destdir'
|
||||
createDirectory destdir' fmode
|
||||
Replace -> do
|
||||
whenM (doesDirectoryExist destdir)
|
||||
(deleteDirRecursive =<< Data.DirTree.readFile destdir)
|
||||
createDirectory destdir fmode
|
||||
whenM (doesDirectoryExist destdir')
|
||||
(deleteDirRecursive =<< Data.DirTree.readFileWithFileInfo
|
||||
destdir)
|
||||
createDirectory destdir' fmode
|
||||
copyDir _ _ _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
@ -215,16 +225,16 @@ recreateSymlink _ _ AFileInvFN = throw InvalidFileName
|
||||
recreateSymlink cm symf@(_ :/ SymLink {})
|
||||
symdest@(_ :/ Dir {})
|
||||
= do
|
||||
sympoint <- readSymbolicLink (fullPath symf)
|
||||
let symname = fullPath symdest </> (name . file $ symf)
|
||||
sympoint <- readSymbolicLink (P.fromAbs . fullPath $ symf)
|
||||
let symname = fullPath symdest P.</> (name . file $ symf)
|
||||
case cm of
|
||||
Merge -> delOld symname
|
||||
Replace -> delOld symname
|
||||
_ -> return ()
|
||||
createSymbolicLink sympoint symname
|
||||
createSymbolicLink sympoint (P.fromAbs symname)
|
||||
where
|
||||
delOld symname = do
|
||||
f <- Data.DirTree.readFile symname
|
||||
f <- Data.DirTree.readFileWithFileInfo symname
|
||||
unless (failed . file $ f)
|
||||
(easyDelete f)
|
||||
recreateSymlink _ _ _ = throw $ InvalidOperation "wrong input type"
|
||||
@ -253,8 +263,8 @@ overwriteFile _ AFileInvFN = throw InvalidFileName
|
||||
overwriteFile from@(_ :/ RegFile {})
|
||||
to@(_ :/ RegFile {})
|
||||
= do
|
||||
let from' = fullPath from
|
||||
to' = fullPath to
|
||||
let from' = P.fromAbs . fullPath $ from
|
||||
to' = P.fromAbs . fullPath $ to
|
||||
throwSameFile from' to'
|
||||
copyFile' from' to'
|
||||
overwriteFile _ _ = throw $ InvalidOperation "wrong input type"
|
||||
@ -271,8 +281,8 @@ copyFileToDir _ _ AFileInvFN = throw InvalidFileName
|
||||
copyFileToDir cm from@(_ :/ RegFile fn _)
|
||||
to@(_ :/ Dir {})
|
||||
= do
|
||||
let from' = fullPath from
|
||||
to' = fullPath to </> fn
|
||||
let from' = P.fromAbs . fullPath $ from
|
||||
to' = P.fromAbs (fullPath to P.</> fn)
|
||||
case cm of
|
||||
Strict -> throwFileDoesExist to'
|
||||
_ -> return ()
|
||||
@ -310,7 +320,7 @@ easyCopy _ _ _ = throw $ InvalidOperation "wrong input type"
|
||||
deleteSymlink :: AnchoredFile FileInfo -> IO ()
|
||||
deleteSymlink AFileInvFN = throw InvalidFileName
|
||||
deleteSymlink f@(_ :/ SymLink {})
|
||||
= removeLink (fullPath f)
|
||||
= removeLink (P.toFilePath . fullPath $ f)
|
||||
deleteSymlink _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
@ -318,7 +328,7 @@ deleteSymlink _ = throw $ InvalidOperation "wrong input type"
|
||||
deleteFile :: AnchoredFile FileInfo -> IO ()
|
||||
deleteFile AFileInvFN = throw InvalidFileName
|
||||
deleteFile f@(_ :/ RegFile {})
|
||||
= removeLink (fullPath f)
|
||||
= removeLink (P.toFilePath . fullPath $ f)
|
||||
deleteFile _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
@ -326,23 +336,25 @@ deleteFile _ = throw $ InvalidOperation "wrong input type"
|
||||
deleteDir :: AnchoredFile FileInfo -> IO ()
|
||||
deleteDir AFileInvFN = throw InvalidFileName
|
||||
deleteDir f@(_ :/ Dir {})
|
||||
= removeDirectory (fullPath f)
|
||||
= removeDirectory (P.toFilePath . fullPath $ f)
|
||||
deleteDir _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
-- TODO: check if we have permissions at all to remove the directory,
|
||||
-- before we go recursively messing with it
|
||||
-- |Deletes the given directory recursively.
|
||||
deleteDirRecursive :: AnchoredFile FileInfo -> IO ()
|
||||
deleteDirRecursive AFileInvFN = throw InvalidFileName
|
||||
deleteDirRecursive f@(_ :/ Dir {}) = do
|
||||
let fp = fullPath f
|
||||
files <- readDirectory' fp
|
||||
files <- readDirectoryContents' fp
|
||||
for_ files $ \file ->
|
||||
case file of
|
||||
(_ :/ SymLink {}) -> deleteSymlink file
|
||||
(_ :/ Dir {}) -> deleteDirRecursive file
|
||||
(_ :/ RegFile {}) -> removeLink (fullPath file)
|
||||
_ -> throw $ FileDoesExist (fullPath file)
|
||||
removeDirectory fp
|
||||
(_ :/ RegFile {}) -> removeLink (P.toFilePath . fullPath $ file)
|
||||
_ -> throw $ FileDoesExist (P.toFilePath . fullPath $ file)
|
||||
removeDirectory . P.toFilePath $ fp
|
||||
deleteDirRecursive _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
@ -369,7 +381,7 @@ easyDelete _ = throw $ InvalidOperation "wrong input type"
|
||||
openFile :: AnchoredFile a
|
||||
-> IO ProcessHandle
|
||||
openFile AFileInvFN = throw InvalidFileName
|
||||
openFile f = spawnProcess "xdg-open" [fullPath f]
|
||||
openFile f = spawnProcess "xdg-open" [P.fromAbs . fullPath $ f]
|
||||
|
||||
|
||||
-- |Executes a program with the given arguments.
|
||||
@ -378,7 +390,7 @@ executeFile :: AnchoredFile FileInfo -- ^ program
|
||||
-> IO ProcessHandle
|
||||
executeFile AFileInvFN _ = throw InvalidFileName
|
||||
executeFile prog@(_ :/ RegFile {}) args
|
||||
= spawnProcess (fullPath prog) args
|
||||
= spawnProcess (P.fromAbs . fullPath $ prog) args
|
||||
executeFile _ _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
@ -389,22 +401,22 @@ executeFile _ _ = throw $ InvalidOperation "wrong input type"
|
||||
---------------------
|
||||
|
||||
|
||||
createFile :: AnchoredFile FileInfo -> FileName -> IO ()
|
||||
createFile :: AnchoredFile FileInfo -> Path Fn -> IO ()
|
||||
createFile AFileInvFN _ = throw InvalidFileName
|
||||
createFile _ InvFN = throw InvalidFileName
|
||||
createFile (ADirOrSym td) (ValFN fn) = do
|
||||
let fullp = fullPath td </> fn
|
||||
let fullp = P.fromAbs (fullPath td P.</> fn)
|
||||
throwFileDoesExist fullp
|
||||
fd <- System.Posix.IO.createFile fullp newFilePerms
|
||||
closeFd fd
|
||||
createFile _ _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
createDir :: AnchoredFile FileInfo -> FileName -> IO ()
|
||||
createDir :: AnchoredFile FileInfo -> Path Fn -> IO ()
|
||||
createDir AFileInvFN _ = throw InvalidFileName
|
||||
createDir _ InvFN = throw InvalidFileName
|
||||
createDir (ADirOrSym td) (ValFN fn) = do
|
||||
let fullp = fullPath td </> fn
|
||||
let fullp = P.fromAbs (fullPath td P.</> fn)
|
||||
throwDirDoesExist fullp
|
||||
createDirectory fullp newFilePerms
|
||||
createDir _ _ = throw $ InvalidOperation "wrong input type"
|
||||
@ -417,12 +429,12 @@ createDir _ _ = throw $ InvalidOperation "wrong input type"
|
||||
----------------------------
|
||||
|
||||
|
||||
renameFile :: AnchoredFile FileInfo -> FileName -> IO ()
|
||||
renameFile :: AnchoredFile FileInfo -> Path Fn -> IO ()
|
||||
renameFile AFileInvFN _ = throw InvalidFileName
|
||||
renameFile _ InvFN = throw InvalidFileName
|
||||
renameFile af (ValFN fn) = do
|
||||
let fromf = fullPath af
|
||||
tof = anchor af </> fn
|
||||
let fromf = P.fromAbs . fullPath $ af
|
||||
tof = P.fromAbs (anchor af P.</> fn)
|
||||
throwFileDoesExist tof
|
||||
throwSameFile fromf tof
|
||||
rename fromf tof
|
||||
@ -438,18 +450,20 @@ moveFile _ AFileInvFN _ = throw InvalidFileName
|
||||
moveFile _ _ AFileInvFN = throw InvalidFileName
|
||||
moveFile cm from to@(_ :/ Dir {}) = do
|
||||
let from' = fullPath from
|
||||
to' = fullPath to </> (name . file $ from)
|
||||
froms' = P.fromAbs . fullPath $ from
|
||||
to' = fullPath to P.</> (name . file $ from)
|
||||
tos' = P.fromAbs (fullPath to P.</> (name . file $ from))
|
||||
case cm of
|
||||
Strict -> throwFileDoesExist to'
|
||||
Strict -> throwFileDoesExist tos'
|
||||
Merge -> delOld to'
|
||||
Replace -> delOld to'
|
||||
throwSameFile from' to'
|
||||
catchErrno eXDEV (rename from' to') $ do
|
||||
throwSameFile froms' tos'
|
||||
catchErrno eXDEV (rename froms' tos') $ do
|
||||
easyCopy Strict from to
|
||||
easyDelete from
|
||||
where
|
||||
delOld to = do
|
||||
to' <- Data.DirTree.readFile to
|
||||
to' <- Data.DirTree.readFileWithFileInfo to
|
||||
unless (failed . file $ to') (easyDelete to')
|
||||
moveFile _ _ _ = throw $ InvalidOperation "wrong input type"
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user