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

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

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
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
12 changed files with 1005 additions and 1056 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
hsfm.cabal
View File

@ -1,7 +1,7 @@
name: hsfm name: hsfm
version: 0.0.0.1 version: 0.0.0.1
synopsis: Haskell FileManager synopsis: Haskell FileManager
description: Lazy FileManager written in haskell description: FileManager written in haskell
license: GPL-2 license: GPL-2
license-file: LICENSE license-file: LICENSE
author: Julian Ospald author: Julian Ospald
@ -13,7 +13,6 @@ cabal-version: >=1.10
library library
exposed-modules: Data.DirTree exposed-modules: Data.DirTree
Data.DirTree.Zipper
IO.Utils IO.Utils
IO.File IO.File
IO.Error IO.Error
@ -21,12 +20,14 @@ library
build-depends: base >= 4.7, build-depends: base >= 4.7,
data-default, data-default,
bifunctors >= 5, bifunctors >= 5,
containers,
directory >= 1.1.0.0 && < 1.2.3.0, directory >= 1.1.0.0 && < 1.2.3.0,
easy-file >= 0.2.0, easy-file >= 0.2.0,
filepath >= 1.3.0.0, filepath >= 1.3.0.0,
mtl >= 2.2, mtl >= 2.2,
old-locale >= 1, old-locale >= 1,
process, process,
safe,
stm, stm,
text, text,
time >= 1.4.2, time >= 1.4.2,
@ -40,10 +41,14 @@ library
executable hsfm-gtk executable hsfm-gtk
main-is: GUI/Gtk.hs main-is: GUI/Gtk.hs
other-modules: GUI.Gtk.Callbacks other-modules: GUI.Gtk.Callbacks
GUI.Gtk.Icons GUI.Gtk.Data
GUI.Gtk.Dialogs
GUI.Gtk.Gui GUI.Gtk.Gui
GUI.Gtk.Icons
GUI.Gtk.Utils
build-depends: hsfm, build-depends: hsfm,
base >= 4.7, base >= 4.7,
containers,
data-default, data-default,
gtk3 >= 0.14.1, gtk3 >= 0.14.1,
glib >= 0.13, glib >= 0.13,
@ -54,10 +59,11 @@ executable hsfm-gtk
mtl >= 2.2, mtl >= 2.2,
old-locale >= 1, old-locale >= 1,
process, process,
safe,
stm, stm,
text, text,
time >= 1.4.2, time >= 1.4.2,
transformers >= 0.4, transformers,
unix unix
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010

559
src/Data/DirTree.hs
View File

@ -1,5 +1,10 @@
{-# OPTIONS_HADDOCK ignore-exports #-} {-# 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 module Data.DirTree where
@ -27,10 +32,7 @@ import Control.Monad.State.Lazy
) )
import Data.Default import Data.Default
import Data.Ord import Data.IntMap.Lazy (IntMap)
(
comparing
)
import Data.List import Data.List
( (
delete delete
@ -38,10 +40,22 @@ import Data.List
, sortBy , sortBy
, (\\) , (\\)
) )
import Data.Time import Data.Maybe
( (
UTCTime fromMaybe
, formatTime )
import Data.Ord
(
comparing
)
import Data.Time.Clock.POSIX
(
POSIXTime
, posixSecondsToUTCTime
)
import Data.Traversable
(
for
) )
import Data.Word import Data.Word
( (
@ -49,23 +63,13 @@ import Data.Word
) )
import System.Directory import System.Directory
( (
Permissions(..) doesFileExist
, createDirectoryIfMissing , executable
, doesFileExist
, getDirectoryContents
, getModificationTime
, getPermissions , getPermissions
, writable , readable
, searchable , searchable
) , writable
import System.EasyFile , Permissions
(
getCreationTime
, getChangeTime
, getAccessTime
, getFileSize
, hasSubDirectories
, isSymlink
) )
import System.FilePath import System.FilePath
( (
@ -95,10 +99,26 @@ import System.Locale
defaultTimeLocale defaultTimeLocale
, rfc822DateFormat , rfc822DateFormat
) )
import System.Posix.Types
(
DeviceID
, EpochTime
, FileID
, FileMode
, FileOffset
, GroupID
, LinkCount
, UserID
)
import qualified Data.Bitraversable as BT import qualified Data.Bitraversable as BT
import qualified Data.Bifunctor as BF import qualified Data.Bifunctor as BF
import qualified Data.Bifoldable as BFL import qualified Data.Bifoldable as BFL
import qualified Data.Traversable as T 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 type FileName = String
-- |A simple wrapper to hold a base directory name, which can be either an -- |Represents a directory with it's contents (one level only), while
-- absolute or relative path. This lets us give the DirTree a context, while -- preserving the context via the anchor.
-- still letting us store only directory and file /names/ (not full paths) in data AnchoredDirFile a b =
-- the DirTree. (uses an infix constructor; don't be scared) (:/) { anchor :: FilePath, dirTree :: IntMap (DirFile a b) }
data AnchoredDirTree a b =
(:/) { anchor :: FilePath, dirTree :: DirTree a b }
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
@ -125,43 +143,46 @@ data AnchoredDirTree a b =
-- Handles, Strings representing a file's contents or anything else you can -- 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 -- think of. We catch any IO errors in the Failed constructor. an Exception
-- can be converted to a String with 'show'. -- can be converted to a String with 'show'.
data DirTree a b = data DirFile a b =
Failed { Failed {
name :: FileName name :: FileName
, err :: IOException , err :: IOException
} }
| Dir { | Dir {
name :: FileName name :: FileName
, contents :: [DirTree a b] , dir :: a
, dir :: a
} }
| File { | File {
name :: FileName name :: FileName
, file :: b , file :: b
} deriving Show } deriving (Show, Eq)
-- |All possible directory information we could ever need from a directory. -- |All possible file information we could ever need.
data DirTreeInfo = data FileInfo = FileInfo {
DirInfo { deviceID :: DeviceID
permissions :: Permissions , fileID :: FileID
, creationTime :: Maybe UTCTime , fileMode :: FileMode
, changeTime :: Maybe UTCTime , linkCount :: LinkCount
, modTime :: UTCTime , fileOwner :: UserID
, accessTime :: UTCTime , fileGroup :: GroupID
, sym :: Bool , specialDeviceID :: DeviceID
, hasSubDirs :: Maybe Bool , fileSize :: FileOffset
} , accessTime :: EpochTime
| FileInfo { , modificationTime :: EpochTime
permissions :: Permissions , statusChangeTime :: EpochTime
, creationTime :: Maybe UTCTime , accessTimeHiRes :: POSIXTime
, changeTime :: Maybe UTCTime , modificationTimeHiRes :: POSIXTime
, modTime :: UTCTime , statusChangeTimeHiRes :: POSIXTime
, accessTime :: UTCTime , isBlockDevice :: Bool
, sym :: Bool , isCharacterDevice :: Bool
, fileSize :: Word64 , isNamedPipe :: Bool
} , isRegularFile :: Bool
deriving (Show, Eq, Ord) , 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 bimap = BT.bimapDefault
instance BFL.Bifoldable DirTree where instance BFL.Bifoldable DirFile where
bifoldMap = BT.bifoldMapDefault bifoldMap = BT.bifoldMapDefault
instance BT.Bitraversable DirTree where instance BT.Bitraversable DirFile where
bitraverse f1 f2 (Dir n cs b) = bitraverse f1 f2 (Dir n b) =
Dir n Dir n <$> f1 b
<$> T.traverse (BT.bitraverse f1 f2) cs
<*> f1 b
bitraverse _ f2 (File n a) = bitraverse _ f2 (File n a) =
File n <$> f2 a File n <$> f2 a
bitraverse _ _ (Failed n e) = bitraverse _ _ (Failed n e) =
pure (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... -- | First compare constructors: Failed < Dir < File...
-- Then compare `name`... -- Then compare `name`...
-- Then compare free variable parameter of `File` constructors -- 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') = compare (File n a) (File n' a') =
case compare n n' of case compare n n' of
EQ -> compare a a' EQ -> compare a a'
el -> el el -> el
compare (Dir n cs b) (Dir n' cs' b') = compare (Dir n b) (Dir n' b') =
case compare n n' of case compare n n' of
EQ -> case compare b b' of EQ -> compare b b'
EQ -> comparing sort cs cs'
el -> el
el -> el el -> el
-- after comparing above we can hand off to shape ord function: -- after comparing above we can hand off to shape ord function:
compare d d' = comparingShape d d' 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 ]-- --[ 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. -- using readFile.
-- Uses `readDirectoryWith` internally and has the effect of traversing the -- Uses `readDirectoryWith` internally and has the effect of traversing the
-- entire directory structure. See `readDirectoryWithL` for lazy production -- entire directory structure. See `readDirectoryWithL` for lazy production
-- of a DirTree structure. -- of a DirFile structure.
readDirectory :: FilePath -> IO (AnchoredDirTree String String) readDirectory :: FilePath -> IO (AnchoredDirFile String String)
readDirectory = readDirectoryWith readFile return readDirectory = readDirectoryWith readFile return
@ -248,49 +249,10 @@ readDirectory = readDirectoryWith readFile return
readDirectoryWith :: (FilePath -> IO a) readDirectoryWith :: (FilePath -> IO a)
-> (FilePath -> IO b) -> (FilePath -> IO b)
-> FilePath -> FilePath
-> IO (AnchoredDirTree a b) -> IO (AnchoredDirFile a b)
readDirectoryWith fd ff p = buildWith' buildAtOnce' fd ff p 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 DirFile from the contents of the directory passed to it, saving
-- | builds a DirTree 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 base directory in the Anchored* wrapper. Errors are caught in the tree in
-- the Failed constructor. The 'file' fields initially are populated with full -- the Failed constructor. The 'file' fields initially are populated with full
-- paths to the files they are abstracting. -- 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 build = buildWith' buildAtOnce' return return -- we say 'return' here to get
-- back a tree of FilePaths -- 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: -- -- -- -- -- -- helpers: -- -- --
type UserIO a = FilePath -> IO a 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" -- remove non-existent file errors, which are artifacts of the "non-atomic"
-- nature of traversing a system firectory tree: -- nature of traversing a system firectory tree:
@ -332,43 +283,23 @@ buildWith' :: Builder a b
-> UserIO a -> UserIO a
-> UserIO b -> UserIO b
-> FilePath -> FilePath
-> IO (AnchoredDirTree a b) -> IO (AnchoredDirFile a b)
buildWith' bf' fd ff p = buildWith' bf' fd ff p =
do tree <- 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: -- IO function passed to our builder and finally executed here:
buildAtOnce' :: Builder a b buildAtOnce' :: Builder a b
buildAtOnce' fd ff p = handleDT n $ buildAtOnce' fd ff p = do
do isFile <- doesFileExist p contents <- getDirsFiles p
if isFile for contents $ \n -> handleDT n $ do
then File n <$> ff p let subf = p </> n
else do cs <- getDirsFiles p do isFile <- doesFileExist subf
Dir n if isFile
<$> T.mapM (buildAtOnce' fd ff . combine p) cs then File n <$> ff subf
<*> fd p else Dir n <$> fd subf
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
@ -383,84 +314,52 @@ buildLazilyUnsafe' fd ff p = handleDT n $
-- | True if any Failed constructors in the tree -- | True if any Failed constructors in the tree
anyFailed :: DirTree a b -> Bool anyFailed :: [DirFile a b] -> Bool
anyFailed = not . successful anyFailed = not . successful
-- | True if there are no Failed constructors in the tree -- | True if there are no Failed constructors in the tree
successful :: DirTree a b -> Bool successful :: [DirFile a b] -> Bool
successful = null . failures successful = null . failures
-- | returns true if argument is a `Failed` constructor: -- | returns true if argument is a `Failed` constructor:
failed :: DirTree a b -> Bool failed :: DirFile a b -> Bool
failed (Failed _ _) = True failed (Failed _ _) = True
failed _ = False failed _ = False
-- | returns a list of 'Failed' constructors only: -- | returns a list of 'Failed' constructors only:
failures :: DirTree a b -> [DirTree a b] failures :: [DirFile a b] -> [DirFile a b]
failures = filter failed . flattenDir 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 ---- ---- 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 -- | 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. -- 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 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: -- | a compare function that ignores the free "file" type variable:
comparingShape :: DirTree a b -> DirTree c d -> Ordering comparingShape :: DirFile a b -> DirFile c d -> Ordering
comparingShape (Dir n cs _) (Dir n' cs' _) = comparingShape (Dir n _) (Dir n' _) = compare n n'
case compare n n' of -- else simply compare the flat constructors, non-recursively:
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 t t' = comparingConstr t t' comparingShape t t' = comparingConstr t t'
-- HELPER: a non-recursive comparison -- HELPER: a non-recursive comparison
comparingConstr :: DirTree a b -> DirTree a1 b1 -> Ordering comparingConstr :: DirFile a b -> DirFile a1 b1 -> Ordering
comparingConstr (Failed _ _) (Dir _ _ _) = LT comparingConstr (Failed _ _) (Dir _ _) = LT
comparingConstr (Failed _ _) (File _ _) = LT comparingConstr (Failed _ _) (File _ _) = LT
comparingConstr (File _ _) (Failed _ _) = GT comparingConstr (File _ _) (Failed _ _) = GT
comparingConstr (File _ _) (Dir _ _ _) = GT comparingConstr (File _ _) (Dir _ _) = GT
comparingConstr (Dir _ _ _) (Failed _ _) = GT comparingConstr (Dir _ _) (Failed _ _) = GT
comparingConstr (Dir _ _ _) (File _ _) = LT comparingConstr (Dir _ _) (File _ _) = LT
-- else compare on the names of constructors that are the same, without -- else compare on the names of constructors that are the same, without
-- looking at the contents of Dir constructors: -- looking at the contents of Dir constructors:
comparingConstr t t' = compare (name t) (name t') comparingConstr t t' = compare (name t) (name t')
@ -470,82 +369,6 @@ comparingConstr t t' = compare (name t) (name t')
---- OTHER ---- ---- 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 ---- ---- CONSTRUCTOR IDENTIFIERS ----
isFileC :: DirTree a b -> Bool isFileC :: DirFile a b -> Bool
isFileC (File _ _) = True isFileC (File _ _) = True
isFileC _ = False isFileC _ = False
isDirC :: DirTree a b -> Bool isDirC :: DirFile a b -> Bool
isDirC (Dir _ _ _) = True isDirC (Dir _ _) = True
isDirC _ = False isDirC _ = False
---- PATH CONVERSIONS ---- ---- 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: -- extracting pathnames and base names:
topDir, baseDir :: FilePath -> FilePath topDir, baseDir :: FilePath -> FilePath
topDir = last . splitDirectories topDir = last . splitDirectories
@ -590,55 +400,72 @@ baseDir = joinPath . init . splitDirectories
---- IO HELPERS: ---- ---- 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 "." == "" ----- the let expression is an annoying hack, because dropFileName "." == ""
----- and getDirectoryContents fails epically on "" ----- and getDirectoryContents fails epically on ""
-- prepares the directory contents list. we sort so that we can be sure of -- prepares the directory contents list. we sort so that we can be sure of
-- a consistent fold/traversal order on the same directory: -- a consistent fold/traversal order on the same directory:
getDirsFiles :: String -> IO [FilePath] getDirsFiles :: FilePath -> IO (IntMap FilePath)
getDirsFiles cs = do let cs' = if null cs then "." else cs getDirsFiles fp = do
dfs <- getDirectoryContents cs' dirstream <- PFD.openDirStream fp
return $ dfs \\ [".",".."] 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 readPath :: FilePath
-> IO (AnchoredDirTree DirTreeInfo DirTreeInfo) -> IO (AnchoredDirFile FileInfo FileInfo)
readPath = readDirectoryWithL mkDirInfo mkFileInfo readPath = readDirectoryWith getFileInfo getFileInfo
mkFileInfo :: FilePath -> IO DirTreeInfo -- |Gets all file information.
mkFileInfo fp = getFileInfo :: FilePath -> IO FileInfo
FileInfo getFileInfo fp = do
<$> getPermissions fp fs <- PF.getSymbolicLinkStatus fp
<*> getCreationTime fp perms <- getPermissions fp
<*> getChangeTime fp return $ FileInfo
<*> getModificationTime fp (PF.deviceID fs)
<*> getAccessTime fp (PF.fileID fs)
<*> isSymlink fp (PF.fileMode fs)
<*> getFileSize fp (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 -- |Gets the free variable. Returns Nothing if the constructor is of `Failed`.
mkDirInfo fp = getFreeVar :: DirFile a a -> Maybe a
DirInfo
<$> getPermissions fp
<*> getCreationTime fp
<*> getChangeTime fp
<*> getModificationTime fp
<*> getAccessTime fp
<*> isSymlink fp
<*> hasSubDirectories fp
getFreeVar :: DirTree a a -> Maybe a
getFreeVar (File _ f) = Just f getFreeVar (File _ f) = Just f
getFreeVar (Dir _ _ d) = Just d getFreeVar (Dir _ d) = Just d
getFreeVar _ = Nothing getFreeVar _ = Nothing
@ -647,7 +474,7 @@ getFreeVar _ = Nothing
-- handles an IO exception by returning a Failed constructor filled with that -- handles an IO exception by returning a Failed constructor filled with that
-- exception: -- 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) 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 -- So we filter those errors out because the user should not see errors
-- raised by the internal implementation of this module: -- raised by the internal implementation of this module:
-- This leaves the error if it exists in the top (user-supplied) level: -- This leaves the error if it exists in the top (user-supplied) level:
removeNonexistent :: DirTree a b -> DirTree a b removeNonexistent :: IntMap (DirFile a b) -> IntMap (DirFile a b)
removeNonexistent = filterDir isOkConstructor removeNonexistent = IM.filter isOkConstructor
where isOkConstructor c = not (failed c) || isOkError c where isOkConstructor c = not (failed c) || isOkError c
isOkError = not . isDoesNotExistErrorType . ioeGetErrorType . err 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: ---- ---- OTHER: ----
anchoredToPath :: AnchoredDirTree a b -> FilePath -- TODO: use Maybe type?
anchoredToPath a = anchor a </> (name . dirTree $ a) 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 subDirName :: AnchoredDirFile a b -> Int -> FilePath
-> [(FileName, String)] subDirName df ix = anchor df </> name (dirLookup df ix)
ls dt = fmap (\x -> (name x, packModTime x)) (contents dt)
fromFreeVar :: (Default d) => (a -> d) -> DirTree a a -> d fromFreeVar :: (Default d) => (a -> d) -> DirFile a a -> d
fromFreeVar f dt = maybeD f $ getFreeVar dt fromFreeVar f df = maybeD f $ getFreeVar df
maybeD :: (Default b) => (a -> b) -> Maybe a -> b maybeD :: (Default b) => (a -> b) -> Maybe a -> b
@ -694,14 +517,12 @@ maybeD = maybe def
-- |Pack the modification time -- |Pack the modification time
packModTime :: DirTree DirTreeInfo DirTreeInfo packModTime :: DirFile FileInfo FileInfo
-> String -> String
packModTime = fromFreeVar packModTime = fromFreeVar
$ formatTime defaultTimeLocale rfc822DateFormat $ show . posixSecondsToUTCTime . realToFrac . modificationTime
. modTime
packPermissions :: DirFile FileInfo FileInfo
packPermissions :: DirTree DirTreeInfo DirTreeInfo
-> String -> String
packPermissions dt = fromFreeVar (pStr . permissions) dt packPermissions dt = fromFreeVar (pStr . permissions) dt
where 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

196
src/GUI/Gtk/Callbacks.hs
View File

@ -1,3 +1,197 @@
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
module GUI.Gtk.Callbacks (startGUI) where module GUI.Gtk.Callbacks where
import Control.Applicative
(
(<$>)
, (<*>)
)
import Control.Concurrent.STM
(
TVar
, newTVarIO
, readTVarIO
)
import Control.Monad.IO.Class
(
liftIO
)
import Data.DirTree
import Graphics.UI.Gtk
import GUI.Gtk.Data
import GUI.Gtk.Dialogs
import GUI.Gtk.Utils
import IO.File
import IO.Utils
import System.Directory
(
doesFileExist
, doesDirectoryExist
)
import System.FilePath
(
isAbsolute
, (</>)
)
import System.Glib.UTFString
(
glibToString
)
import qualified Data.IntMap.Lazy as IM
-----------------
--[ Callbacks ]--
-----------------
-- |Set callbacks, on hotkeys, events and stuff.
--
-- Interaction with mutable references:
--
-- * 'settings mygui' modifies
-- * 'fsState' reads
setCallbacks :: MyGUI -> MyView -> IO ()
setCallbacks mygui myview = do
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"q" <- fmap glibToString eventKeyName
liftIO mainQuit
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"h" <- fmap glibToString eventKeyName
liftIO $ modifyTVarIO (settings mygui)
(\x -> x { showHidden = not . showHidden $ x})
>> (refreshTreeView' mygui myview =<< readTVarIO (fsState myview))
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Alt] <- eventModifier
"Up" <- fmap glibToString eventKeyName
liftIO $ upDir mygui myview
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
"Delete" <- fmap glibToString eventKeyName
liftIO $ withRow mygui myview del
_ <- treeView mygui `on` rowActivated $ (\_ _ -> withRow mygui myview open)
_ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
_ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"c" <- fmap glibToString eventKeyName
liftIO $ withRow mygui myview copyInit
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"v" <- fmap glibToString eventKeyName
liftIO $ copyFinal mygui myview
return ()
-- |Go to the url given at the 'urlBar' and visualize it in the given
-- treeView.
urlGoTo :: MyGUI -> MyView -> IO ()
urlGoTo mygui myview = do
fp <- entryGetText (urlBar mygui)
let abs = isAbsolute fp
exists <- (||) <$> doesDirectoryExist fp <*> doesFileExist fp
-- TODO: more explicit error handling?
refreshTreeView mygui myview (Just fp)
-- |Supposed to be used with 'withRow'. Opens a file or directory.
--
-- Interaction with mutable references:
--
-- * 'fsState' reads
open :: Row -> MyGUI -> MyView -> IO ()
open row mygui myview = do
fS <- readTVarIO $ fsState myview
case IM.lookup row (dirTree fS) of
Just dt@(Dir n _) -> do
newP <- readPath (anchor fS </> n)
refreshTreeView' mygui myview newP
Just dt@(File n _) ->
withErrorDialog $ openFile (anchor fS </> n)
_ -> return ()
-- |Supposed to be used with 'withRow'. Deletes a file or directory.
--
-- Interaction with mutable references:
--
-- * 'fsState' reads
del :: Row -> MyGUI -> MyView -> IO ()
del row mygui myview = do
fS <- readTVarIO $ fsState myview
case dirLookup fS row of
dt@(Dir n _) -> do
let fp = anchor fS </> n
subADT <- readPath fp
let cmsg = "Really delete directory \"" ++ fp ++ "\"?"
cmsg2 = "Directory \"" ++ fp ++
"\" is not empty! Delete all contents?"
withConfirmationDialog cmsg $
if IM.null (dirTree subADT)
then withErrorDialog (deleteDir fp
>> refreshTreeView mygui myview Nothing)
else withConfirmationDialog cmsg2 $ withErrorDialog
(deleteDirRecursive fp
>> refreshTreeView mygui myview Nothing)
dt@(File _ _) -> do
let fp = subDirName fS row
cmsg = "Really delete file \"" ++ fp ++ "\"?"
withConfirmationDialog cmsg
$ withErrorDialog (deleteFile fp
>> refreshTreeView mygui myview Nothing)
-- |Supposed to be used with 'withRow'. Initializes a file copy operation.
--
-- Interaction with mutable references:
--
-- * 'operationBuffer' writes
-- * 'fsState' reads
copyInit :: Row -> MyGUI -> MyView -> IO ()
copyInit row mygui myview = do
fsState <- readTVarIO $ fsState myview
writeTVarIO (operationBuffer myview) (FCopy . CP1 $ subDirName fsState row)
-- |Finalizes a file copy operation.
--
-- Interaction with mutable references:
--
-- * 'operationBuffer' reads
-- * 'fsState' reads
copyFinal :: MyGUI -> MyView -> IO ()
copyFinal mygui myview = do
op <- readTVarIO (operationBuffer myview)
case op of
FCopy (CP1 sourceDir) -> do
curDir <- anchor <$> readTVarIO (fsState myview)
let cmsg = "Really copy file \"" ++ sourceDir
++ "\"" ++ " to \"" ++ curDir ++ "\"?"
withConfirmationDialog cmsg $ do
copyMode <- showCopyModeChooserDialog
withErrorDialog ((runFileOp . FCopy . CC sourceDir curDir $ copyMode)
>> refreshTreeView mygui myview Nothing)
_ -> return ()
-- |Go up one directory and visualize it in the treeView.
--
-- Interaction with mutable references:
--
-- * 'rawModel' reads
-- * 'sortedModel' reads
-- * 'fsState' reads
upDir :: MyGUI -> MyView -> IO ()
upDir mygui myview = do
rawModel' <- readTVarIO $ rawModel myview
sortedModel' <- readTVarIO $ sortedModel myview
fS <- readTVarIO $ fsState myview
newP <- readPath (baseDir . anchor $ fS)
refreshTreeView' mygui myview newP

71
src/GUI/Gtk/Data.hs Normal file
View File

@ -0,0 +1,71 @@
{-# OPTIONS_HADDOCK ignore-exports #-}
module GUI.Gtk.Data where
import Control.Concurrent.STM
(
TVar
)
import Data.DirTree
import Graphics.UI.Gtk
import IO.File
------------------
--[ Base Types ]--
------------------
-- |Monolithic object passed to various GUI functions in order
-- to keep the API stable and not alter the parameters too much.
-- This only holds GUI widgets that are needed to be read during
-- runtime.
data MyGUI = MkMyGUI {
-- |main Window
rootWin :: Window
, menubarFileQuit :: ImageMenuItem
, menubarFileOpen :: ImageMenuItem
, menubarFileCut :: ImageMenuItem
, menubarFileCopy :: ImageMenuItem
, menubarFilePaste :: ImageMenuItem
, menubarFileDelete :: ImageMenuItem
, menubarHelpAbout :: ImageMenuItem
, urlBar :: Entry
, statusBar :: Statusbar
, treeView :: TreeView
-- |first column
, cF :: TreeViewColumn
-- |second column
, cMD :: TreeViewColumn
, renderTxt :: CellRendererText
, renderPix :: CellRendererPixbuf
, settings :: TVar FMSettings
, folderPix :: Pixbuf
, filePix :: Pixbuf
, errorPix :: Pixbuf
}
-- |FM-wide settings.
data FMSettings = MkFMSettings {
showHidden :: Bool
, isLazy :: Bool
}
type Row = Int
-- |This describes the contents of the treeView and is separated from MyGUI,
-- because we might want to have multiple views.
data MyView = MkMyView {
rawModel :: TVar (ListStore Row)
, sortedModel :: TVar (TypedTreeModelSort Row)
, filteredModel :: TVar (TypedTreeModelFilter Row)
, fsState :: TVar (AnchoredDirFile FileInfo FileInfo)
, operationBuffer :: TVar FileOperation
}

94
src/GUI/Gtk/Dialogs.hs Normal file
View File

@ -0,0 +1,94 @@
{-# OPTIONS_HADDOCK ignore-exports #-}
module GUI.Gtk.Dialogs where
import Control.Exception
(
try
, SomeException
)
import Control.Monad
(
when
, void
)
import Graphics.UI.Gtk
import GUI.Gtk.Data
import IO.File
---------------------
--[ Dialog popups ]--
---------------------
-- |Pops up an error Dialog with the given String.
showErrorDialog :: String -> IO ()
showErrorDialog str = do
errorDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageError
ButtonsClose
str
_ <- dialogRun errorDialog
widgetDestroy errorDialog
-- |Asks the user for confirmation and returns True/False.
showConfirmationDialog :: String -> IO Bool
showConfirmationDialog str = do
confirmDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageQuestion
ButtonsYesNo
str
rID <- dialogRun confirmDialog
widgetDestroy confirmDialog
case rID of
ResponseYes -> return True
ResponseNo -> return False
_ -> return False
-- |Asks the user which directory copy mode he wants via dialog popup
-- and returns 'DirCopyMode'.
showCopyModeChooserDialog :: IO DirCopyMode
showCopyModeChooserDialog = do
chooserDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageQuestion
ButtonsNone
"Choose the copy mode"
dialogAddButton chooserDialog "Strict" (ResponseUser 0)
dialogAddButton chooserDialog "Merge" (ResponseUser 1)
dialogAddButton chooserDialog "Replace" (ResponseUser 2)
rID <- dialogRun chooserDialog
widgetDestroy chooserDialog
case rID of
ResponseUser 0 -> return Strict
ResponseUser 1 -> return Merge
ResponseUser 2 -> return Replace
-- |Carry out an IO action with a confirmation dialog.
-- If the user presses "No", then do nothing.
withConfirmationDialog :: String -> IO () -> IO ()
withConfirmationDialog str io = do
run <- showConfirmationDialog str
when run io
-- |Execute the given IO action. If the action throws exceptions,
-- visualize them via 'showErrorDialog'.
withErrorDialog :: IO a -> IO ()
withErrorDialog io = do
r <- try io
either (\e -> showErrorDialog $ show (e :: SomeException))
(\_ -> return ())
r

407
src/GUI/Gtk/Gui.hs
View File

@ -1,5 +1,6 @@
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
-- |The main Gtk Gui module for creating the main window.
module GUI.Gtk.Gui (startMainWindow) where module GUI.Gtk.Gui (startMainWindow) where
@ -34,7 +35,6 @@ import Control.Monad.IO.Class
liftIO liftIO
) )
import Data.DirTree import Data.DirTree
import Data.DirTree.Zipper
import Data.Foldable import Data.Foldable
( (
for_ for_
@ -55,7 +55,11 @@ import Data.Traversable
forM forM
) )
import Graphics.UI.Gtk import Graphics.UI.Gtk
import GUI.Gtk.Callbacks
import GUI.Gtk.Data
import GUI.Gtk.Dialogs
import GUI.Gtk.Icons import GUI.Gtk.Icons
import GUI.Gtk.Utils
import IO.Error import IO.Error
import IO.File import IO.File
import IO.Utils import IO.Utils
@ -72,6 +76,7 @@ import System.Environment
import System.FilePath import System.FilePath
( (
isAbsolute isAbsolute
, (</>)
) )
import System.Glib.UTFString import System.Glib.UTFString
( (
@ -87,396 +92,33 @@ import System.Process
) )
import Data.IntMap.Lazy (IntMap)
import qualified Data.IntMap.Lazy as IM
-- TODO: simplify where we modify the TVars -- TODO: simplify where we modify the TVars
-- TODO: double check garbage collection/gtk ref counting -- TODO: double check garbage collection/gtk ref counting
-- TODO: file watching, when and what to reread -- TODO: file watching, when and what to reread
-- |Monolithic object passed to various GUI functions in order
-- to keep the API stable and not alter the parameters too much.
-- This only holds GUI widgets that are needed to be read during
-- runtime.
data MyGUI = MkMyGUI {
-- |main Window
rootWin :: Window
, menubarFileQuit :: ImageMenuItem
, menubarFileOpen :: ImageMenuItem
, menubarFileCut :: ImageMenuItem
, menubarFileCopy :: ImageMenuItem
, menubarFilePaste :: ImageMenuItem
, menubarFileDelete :: ImageMenuItem
, menubarHelpAbout :: ImageMenuItem
, urlBar :: Entry
, statusBar :: Statusbar
-- |tree view
, treeView :: TreeView
-- |first column
, cF :: TreeViewColumn
-- |second column
, cMD :: TreeViewColumn
-- |renderer used for the treeView
, renderTxt :: CellRendererText
, renderPix :: CellRendererPixbuf
, settings :: TVar FMSettings
, folderPix :: Pixbuf
, filePix :: Pixbuf
, errorPix :: Pixbuf
}
-- |FM-wide settings.
data FMSettings = MkFMSettings {
showHidden :: Bool
, isLazy :: Bool
}
-------------------------
-- |This describes the contents of the treeView and is separated from MyGUI, --[ Main Window Setup ]--
-- because we might want to have multiple views. -------------------------
data MyView = MkMyView {
-- |raw model with unsorted data
rawModel :: TVar (ListStore DTInfoZipper)
-- |sorted proxy model
, sortedModel :: TVar (TypedTreeModelSort DTInfoZipper)
-- |filtered proxy model
, filteredModel :: TVar (TypedTreeModelFilter DTInfoZipper)
, fsState :: TVar DTInfoZipper
, operationBuffer :: TVar FileOperation
}
-- |Set callbacks, on hotkeys, events and stuff.
setCallbacks :: MyGUI -> MyView -> IO ()
setCallbacks mygui myview = do
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"q" <- fmap glibToString eventKeyName
liftIO mainQuit
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"h" <- fmap glibToString eventKeyName
liftIO $ modifyTVarIO (settings mygui)
(\x -> x { showHidden = not . showHidden $ x})
>> (refreshTreeView' mygui myview =<< readTVarIO (fsState myview))
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Alt] <- eventModifier
"Up" <- fmap glibToString eventKeyName
liftIO $ upDir mygui myview
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
"Delete" <- fmap glibToString eventKeyName
liftIO $ withRow mygui myview del
_ <- treeView mygui `on` rowActivated $ (\_ _ -> withRow mygui myview open)
_ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
_ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"c" <- fmap glibToString eventKeyName
liftIO $ withRow mygui myview copyInit
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"v" <- fmap glibToString eventKeyName
liftIO $ copyFinal mygui myview
return ()
-- |Go to the url given at the `urlBar` and visualize it in the given
-- treeView.
--
-- This might update the TVar `rawModel`.
urlGoTo :: MyGUI -> MyView -> IO ()
urlGoTo mygui myview = do
fp <- entryGetText (urlBar mygui)
let abs = isAbsolute fp
exists <- (||) <$> doesDirectoryExist fp <*> doesFileExist fp
-- TODO: more explicit error handling?
refreshTreeView mygui myview (Just fp)
-- |Gets the currently selected row of the treeView, if any.
getSelectedRow :: MyGUI
-> MyView
-> IO (Maybe DTInfoZipper)
getSelectedRow mygui myview = do
(tp, _) <- treeViewGetCursor $ treeView mygui
rawModel' <- readTVarIO $ rawModel myview
sortedModel' <- readTVarIO $ sortedModel myview
filteredModel' <- readTVarIO $ filteredModel myview
miter <- treeModelGetIter sortedModel' tp
forM miter $ \iter -> do
cIter' <- treeModelSortConvertIterToChildIter sortedModel' iter
cIter <- treeModelFilterConvertIterToChildIter filteredModel' cIter'
treeModelGetRow rawModel' cIter
-- |Carry out an action on the currently selected row.
--
-- If there is no row selected, does nothing.
withRow :: MyGUI
-> MyView
-> ( DTInfoZipper
-> MyGUI
-> MyView
-> IO ()) -- ^ action to carry out
-> IO ()
withRow mygui myview io = do
mrow <- getSelectedRow mygui myview
for_ mrow $ \row -> io row mygui myview
-- |Supposed to be used with `withRow`. Opens a file or directory.
open :: DTInfoZipper -> MyGUI -> MyView -> IO ()
open row mygui myview = case row of
(Dir {}, _) ->
refreshTreeView' mygui myview row
dz@(File {}, _) ->
withErrorDialog $ openFile dz
_ -> return ()
-- |Supposed to be used with `withRow`. Deletes a file or directory.
del :: DTInfoZipper -> MyGUI -> MyView -> IO ()
del row mygui myview = case row of
dz@(Dir _ cs _, _) -> do
let fp = getFullPath dz
cmsg = "Really delete directory \"" ++ fp ++ "\"?"
cmsg2 = "Directory \"" ++ fp ++ "\" is not empty! Delete all contents?"
withConfirmationDialog cmsg $
if null cs
then withErrorDialog (deleteDir dz
>> refreshTreeView mygui myview Nothing)
else withConfirmationDialog cmsg2 $ withErrorDialog
(deleteDirRecursive dz >> refreshTreeView mygui myview Nothing)
dz@(File {}, _) -> do
let fp = getFullPath dz
cmsg = "Really delete file \"" ++ fp ++ "\"?"
withConfirmationDialog cmsg
$ withErrorDialog (deleteFile dz
>> refreshTreeView mygui myview Nothing)
-- |Supposed to be used with `withRow`. Initializes a file copy operation.
copyInit :: DTInfoZipper -> MyGUI -> MyView -> IO ()
copyInit row mygui myview = case row of
dz -> writeTVarIO (operationBuffer myview) (FCopy . CP1 $ dz)
-- |Finalizes a file copy operation.
copyFinal :: MyGUI -> MyView -> IO ()
copyFinal mygui myview = do
op <- readTVarIO (operationBuffer myview)
case op of
FCopy (CP1 sourceDir) -> do
curDir <- readTVarIO (fsState myview)
let cmsg = "Really copy file \"" ++ getFullPath sourceDir
++ "\"" ++ " to \"" ++ getFullPath curDir ++ "\"?"
withConfirmationDialog cmsg $ do
copyMode <- showCopyModeChooserDialog
withErrorDialog ((runFileOp . FCopy . CC sourceDir curDir $ copyMode)
>> refreshTreeView mygui myview Nothing)
_ -> return ()
-- |Go up one directory and visualize it in the treeView.
upDir :: MyGUI -> MyView -> IO ()
upDir mygui myview = do
rawModel' <- readTVarIO $ rawModel myview
sortedModel' <- readTVarIO $ sortedModel myview
fS <- readTVarIO $ fsState myview
refreshTreeView' mygui myview (goUp fS)
-- |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.
--
-- This also updates the TVar `fsState` inside the given view.
fileListStore :: DTInfoZipper -- ^ current dir
-> MyView
-> IO (ListStore DTInfoZipper)
fileListStore dtz myview = do
writeTVarIO (fsState myview) dtz
listStoreNew (goAllDown dtz)
-- |Re-reads the current directory or the given one and updates the TreeView.
-- This means that the DTZipper is re-initialized.
-- If you can operate on the raw DTZipper directly, use `refreshTreeView'`
-- instead.
--
-- This also updates the TVar `rawModel`.
--
-- This throws exceptions via `dirSanityThrow` if the given/current
-- directory path does not exist.
refreshTreeView :: MyGUI
-> MyView
-> Maybe FilePath
-> IO ()
refreshTreeView mygui myview mfp = do
fsState <- readTVarIO $ fsState myview
let cfp = getFullPath fsState
fp = fromMaybe cfp mfp
-- TODO catch exceptions
dirSanityThrow fp
newFsState <- readPath' fp
newRawModel <- fileListStore newFsState myview
writeTVarIO (rawModel myview) newRawModel
constructTreeView mygui myview
-- |Refreshes the TreeView based on the given Zipper.
--
-- This also updates the TVar `rawModel`.
refreshTreeView' :: MyGUI
-> MyView
-> DTInfoZipper
-> IO ()
refreshTreeView' mygui myview dtz = do
newRawModel <- fileListStore dtz myview
writeTVarIO (rawModel myview) newRawModel
constructTreeView mygui myview
-- TODO: make this function more slim so only the most necessary parts are
-- called
-- |Constructs the visible TreeView with the current underlying mutable models,
-- which are retrieved from `MyGUI`.
--
-- This also updates the TVars `filteredModel` and `sortedModel` in the process.
constructTreeView :: MyGUI
-> MyView
-> IO ()
constructTreeView mygui myview = do
let treeView' = treeView mygui
cF' = cF mygui
cMD' = cMD mygui
render' = renderTxt mygui
-- update urlBar, this will break laziness slightly, probably
fsState <- readTVarIO $ fsState myview
let urlpath = getFullPath fsState
entrySetText (urlBar mygui) urlpath
rawModel' <- readTVarIO $ rawModel myview
-- filtering
filteredModel' <- treeModelFilterNew rawModel' []
writeTVarIO (filteredModel myview) filteredModel'
treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do
hidden <- showHidden <$> readTVarIO (settings mygui)
row <- treeModelGetRow rawModel' iter
if hidden
then return True
else return $ not ("." `isPrefixOf` (name . unZip $ row))
-- sorting
sortedModel' <- treeModelSortNewWithModel filteredModel'
writeTVarIO (sortedModel myview) sortedModel'
treeSortableSetSortFunc sortedModel' 1 $ \iter1 iter2 -> do
cIter1 <- treeModelFilterConvertIterToChildIter filteredModel' iter1
cIter2 <- treeModelFilterConvertIterToChildIter filteredModel' iter2
row1 <- treeModelGetRow rawModel' cIter1
row2 <- treeModelGetRow rawModel' cIter2
return $ compare (unZip row1) (unZip row2)
treeSortableSetSortColumnId sortedModel' 1 SortAscending
-- set values
treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
(dirtreePix . unZip)
treeModelSetColumn rawModel' (makeColumnIdString 1)
(name . unZip)
treeModelSetColumn rawModel' (makeColumnIdString 2)
(packModTime . unZip)
treeModelSetColumn rawModel' (makeColumnIdString 3)
(packPermissions . unZip)
-- update treeview model
treeViewSetModel treeView' sortedModel'
return ()
where
dirtreePix (Dir {}) = folderPix mygui
dirtreePix (File {}) = filePix mygui
dirtreePix (Failed {}) = errorPix mygui
-- |Push a message to the status bar.
pushStatusBar :: MyGUI -> String -> IO (ContextId, MessageId)
pushStatusBar mygui str = do
let sb = statusBar mygui
cid <- statusbarGetContextId sb "FM Status"
mid <- statusbarPush sb cid str
return (cid, mid)
-- |Pops up an error Dialog with the given String.
showErrorDialog :: String -> IO ()
showErrorDialog str = do
errorDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageError
ButtonsClose
str
_ <- dialogRun errorDialog
widgetDestroy errorDialog
-- |Asks the user for confirmation and returns True/False.
showConfirmationDialog :: String -> IO Bool
showConfirmationDialog str = do
confirmDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageQuestion
ButtonsYesNo
str
rID <- dialogRun confirmDialog
widgetDestroy confirmDialog
case rID of
ResponseYes -> return True
ResponseNo -> return False
_ -> return False
-- |Asks the user which directory copy mode he wants via dialog popup
-- and returns `DirCopyMode`.
showCopyModeChooserDialog :: IO DirCopyMode
showCopyModeChooserDialog = do
chooserDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageQuestion
ButtonsNone
"Choose the copy mode"
dialogAddButton chooserDialog "Strict" (ResponseUser 0)
dialogAddButton chooserDialog "Merge" (ResponseUser 1)
dialogAddButton chooserDialog "Replace" (ResponseUser 2)
rID <- dialogRun chooserDialog
widgetDestroy chooserDialog
case rID of
ResponseUser 0 -> return Strict
ResponseUser 1 -> return Merge
ResponseUser 2 -> return Replace
-- |Carry out an IO action with a confirmation dialog.
-- If the user presses "No", then do nothing.
withConfirmationDialog :: String -> IO () -> IO ()
withConfirmationDialog str io = do
run <- showConfirmationDialog str
when run io
-- |Execute the given IO action. If the action throws exceptions,
-- visualize them via `showErrorDialog`.
withErrorDialog :: IO a -> IO ()
withErrorDialog io = do
r <- try io
either (\e -> showErrorDialog $ show (e :: SomeException))
(\_ -> return ())
r
-- |Set up the GUI. -- |Set up the GUI.
--
-- Interaction with mutable references:
--
-- * 'settings' creates
-- * 'fsState' creates
-- * 'operationBuffer' creates
-- * 'rawModel' creates
-- * 'filteredModel' creates
-- * 'sortedModel' creates
startMainWindow :: FilePath -> IO () startMainWindow :: FilePath -> IO ()
startMainWindow startdir = do startMainWindow startdir = do
@ -488,7 +130,7 @@ startMainWindow startdir = do
filePix <- getIcon IFile 24 filePix <- getIcon IFile 24
errorPix <- getIcon IError 24 errorPix <- getIcon IError 24
fsState <- readPath' startdir >>= newTVarIO fsState <- readPath startdir >>= newTVarIO
operationBuffer <- newTVarIO None operationBuffer <- newTVarIO None
@ -520,7 +162,8 @@ startMainWindow startdir = do
"statusBar" "statusBar"
-- create initial list store model with unsorted data -- create initial list store model with unsorted data
rawModel <- newTVarIO =<< listStoreNew . goAllDown =<< readTVarIO fsState rawModel <- newTVarIO =<< listStoreNew . IM.keys . dirTree
=<< readTVarIO fsState
filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x []) filteredModel <- newTVarIO =<< (\x -> treeModelFilterNew x [])
=<< readTVarIO rawModel =<< readTVarIO rawModel

1
src/GUI/Gtk/Icons.hs
View File

@ -1,5 +1,6 @@
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
-- |Module for Gtk icon handling.
module GUI.Gtk.Icons where module GUI.Gtk.Icons where

221
src/GUI/Gtk/Utils.hs Normal file
View File

@ -0,0 +1,221 @@
{-# OPTIONS_HADDOCK ignore-exports #-}
module GUI.Gtk.Utils where
import Control.Applicative
(
(<$>)
)
import Control.Concurrent.STM
(
TVar
, newTVarIO
, readTVarIO
)
import Data.DirTree
import Data.Foldable
(
for_
)
import Data.List
(
isPrefixOf
)
import Data.Maybe
(
fromMaybe
)
import Data.Traversable
(
forM
)
import Graphics.UI.Gtk
import GUI.Gtk.Data
import IO.Error
import IO.Utils
import qualified Data.IntMap.Lazy as IM
-----------------
--[ Utilities ]--
-----------------
-- |Gets the currently selected row of the treeView, if any.
--
-- Interaction with mutable references:
--
-- * 'rawModel' reads
-- * 'sortedModel' reads
-- * 'filteredModel' reads
getSelectedRow :: MyGUI
-> MyView
-> IO (Maybe Row)
getSelectedRow mygui myview = do
(tp, _) <- treeViewGetCursor $ treeView mygui
rawModel' <- readTVarIO $ rawModel myview
sortedModel' <- readTVarIO $ sortedModel myview
filteredModel' <- readTVarIO $ filteredModel myview
miter <- treeModelGetIter sortedModel' tp
forM miter $ \iter -> do
cIter' <- treeModelSortConvertIterToChildIter sortedModel' iter
cIter <- treeModelFilterConvertIterToChildIter filteredModel' cIter'
treeModelGetRow rawModel' cIter
-- |Carry out an action on the currently selected row.
--
-- If there is no row selected, does nothing.
withRow :: MyGUI
-> MyView
-> ( Row
-> MyGUI
-> MyView
-> IO ()) -- ^ action to carry out
-> IO ()
withRow mygui myview io = do
mrow <- getSelectedRow mygui myview
for_ mrow $ \row -> io row mygui myview
-- |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.
--
-- Interaction with mutable references:
--
-- * 'fsState' writes
fileListStore :: AnchoredDirFile FileInfo FileInfo -- ^ current dir
-> MyView
-> IO (ListStore Row)
fileListStore dt myview = do
writeTVarIO (fsState myview) dt
listStoreNew (IM.keys . dirTree $ dt)
-- |Re-reads the current directory or the given one and updates the TreeView.
--
-- The operation may fail with:
--
-- * 'DirDoesNotExist' if the target directory does not exist
-- * 'PathNotAbsolute' if the target directory is not absolute
--
-- Interaction with mutable references:
--
-- * 'fsState' reads
-- * 'rawModel' writes
refreshTreeView :: MyGUI
-> MyView
-> Maybe FilePath
-> IO ()
refreshTreeView mygui myview mfp = do
fsState <- readTVarIO $ fsState myview
let cfp = anchor fsState
fp = fromMaybe cfp mfp
-- TODO catch exceptions
dirSanityThrow fp
newFsState <- readPath fp
newRawModel <- fileListStore newFsState myview
writeTVarIO (rawModel myview) newRawModel
constructTreeView mygui myview
-- |Refreshes the TreeView based on the given directory.
--
-- Interaction with mutable references:
--
-- * 'rawModel' writes
refreshTreeView' :: MyGUI
-> MyView
-> AnchoredDirFile FileInfo FileInfo
-> IO ()
refreshTreeView' mygui myview dt = do
newRawModel <- fileListStore dt myview
writeTVarIO (rawModel myview) newRawModel
constructTreeView mygui myview
-- TODO: make this function more slim so only the most necessary parts are
-- called
-- |Constructs the visible TreeView with the current underlying mutable models,
-- which are retrieved from 'MyGUI'.
--
-- Interaction with mutable references:
--
-- * 'fsState' reads
-- * 'rawModel' reads
-- * 'filteredModel' writes
-- * 'sortedModel' writes
-- * 'settings' reads
constructTreeView :: MyGUI
-> MyView
-> IO ()
constructTreeView mygui myview = do
let treeView' = treeView mygui
cF' = cF mygui
cMD' = cMD mygui
render' = renderTxt mygui
fsState <- readTVarIO $ fsState myview
let dirL = dirLookup fsState
-- update urlBar, this will break laziness slightly, probably
let urlpath = anchor fsState
entrySetText (urlBar mygui) urlpath
rawModel' <- readTVarIO $ rawModel myview
-- filtering
filteredModel' <- treeModelFilterNew rawModel' []
writeTVarIO (filteredModel myview) filteredModel'
treeModelFilterSetVisibleFunc filteredModel' $ \iter -> do
hidden <- showHidden <$> readTVarIO (settings mygui)
row <- (name . dirL) <$> treeModelGetRow rawModel' iter
if hidden
then return True
else return $ not ("." `isPrefixOf` row)
-- sorting
sortedModel' <- treeModelSortNewWithModel filteredModel'
writeTVarIO (sortedModel myview) sortedModel'
treeSortableSetSortFunc sortedModel' 1 $ \iter1 iter2 -> do
cIter1 <- treeModelFilterConvertIterToChildIter filteredModel' iter1
cIter2 <- treeModelFilterConvertIterToChildIter filteredModel' iter2
row1 <- dirL <$> treeModelGetRow rawModel' cIter1
row2 <- dirL <$> treeModelGetRow rawModel' cIter2
return $ compare row1 row2
treeSortableSetSortColumnId sortedModel' 1 SortAscending
-- set values
treeModelSetColumn rawModel' (makeColumnIdPixbuf 0)
(dirtreePix . dirL)
treeModelSetColumn rawModel' (makeColumnIdString 1)
(name . dirL)
treeModelSetColumn rawModel' (makeColumnIdString 2)
(packModTime . dirL)
treeModelSetColumn rawModel' (makeColumnIdString 3)
(packPermissions . dirL)
-- update treeview model
treeViewSetModel treeView' sortedModel'
return ()
where
dirtreePix (Dir {}) = folderPix mygui
dirtreePix (File {}) = filePix mygui
dirtreePix (Failed {}) = errorPix mygui
-- |Push a message to the status bar.
pushStatusBar :: MyGUI -> String -> IO (ContextId, MessageId)
pushStatusBar mygui str = do
let sb = statusBar mygui
cid <- statusbarGetContextId sb "FM Status"
mid <- statusbarPush sb cid str
return (cid, mid)

4
src/IO/Error.hs
View File

@ -1,6 +1,7 @@
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
-- |Provides error handling.
module IO.Error where module IO.Error where
@ -31,6 +32,7 @@ import System.FilePath
data FmIOException = FileDoesNotExist String data FmIOException = FileDoesNotExist String
| DirDoesNotExist String
| PathNotAbsolute String | PathNotAbsolute String
| FileNotExecutable String | FileNotExecutable String
| SameFile String String | SameFile String String
@ -67,7 +69,7 @@ throwDirDoesExist fp =
throwDirDoesNotExist :: FilePath -> IO () throwDirDoesNotExist :: FilePath -> IO ()
throwDirDoesNotExist fp = throwDirDoesNotExist fp =
unlessM (doesDirectoryExist fp) (throw $ FileDoesNotExist fp) unlessM (doesDirectoryExist fp) (throw $ DirDoesNotExist fp)
throwFileDoesNotExist :: FilePath -> IO () throwFileDoesNotExist :: FilePath -> IO ()

327
src/IO/File.hs
View File

@ -1,5 +1,13 @@
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
-- |This module provides all the atomic IO related file operations like
-- copy, delete, move and so on. It operates only on FilePaths and reads
-- all necessary file information manually in order to stay atomic and not
-- rely on the state of passed objects.
--
-- It would be nicer to pass states around, but the filesystem state changes
-- too quickly and cannot be relied upon. Lazy implementations of filesystem
-- trees have been tried as well, but they can introduce subtle bugs.
module IO.File where module IO.File where
@ -13,7 +21,6 @@ import Control.Monad
, void , void
) )
import Data.DirTree import Data.DirTree
import Data.DirTree.Zipper
import Data.Foldable import Data.Foldable
( (
for_ for_
@ -44,6 +51,8 @@ import System.Posix.Files
( (
createSymbolicLink createSymbolicLink
, readSymbolicLink , readSymbolicLink
, fileAccess
, getFileStatus
) )
import System.Process import System.Process
( (
@ -53,6 +62,8 @@ import System.Process
import qualified System.Directory as SD import qualified System.Directory as SD
import qualified System.Posix.Files as PF
-- TODO: modify the DTZipper directly after file operations!? -- TODO: modify the DTZipper directly after file operations!?
-- TODO: file operations should be threaded and not block the UI -- TODO: file operations should be threaded and not block the UI
@ -63,38 +74,41 @@ import qualified System.Directory as SD
-- or delay operations. -- or delay operations.
data FileOperation = FCopy Copy data FileOperation = FCopy Copy
| FMove Move | FMove Move
| FDelete DTInfoZipper | FDelete FilePath
| FOpen DTInfoZipper | FOpen FilePath
| FExecute DTInfoZipper [String] | FExecute FilePath [String]
| None | None
data Copy = CP1 DTInfoZipper -- |Data type describing partial or complete file copy operation.
| CP2 DTInfoZipper DTInfoZipper -- CC stands for a complete operation and can be used for `runFileOp`.
| CC DTInfoZipper DTInfoZipper DirCopyMode data Copy = CP1 FilePath
| CP2 FilePath FilePath
| CC FilePath FilePath DirCopyMode
data Move = MP1 DTInfoZipper -- |Data type describing partial or complete file move operation.
| MC DTInfoZipper DTInfoZipper -- MC stands for a complete operation and can be used for `runFileOp`.
data Move = MP1 FilePath
| MC FilePath FilePath
-- |Directory copy modes. -- |Directory copy modes.
-- Strict means we fail if the target directory already exists. data DirCopyMode = Strict -- ^ fail if the target directory already exists
-- Merge means we keep the old directories/files, but overwrite old files | Merge -- ^ overwrite files if necessary
-- on collision. | Replace -- ^ remove target directory before copying
-- Replace means the target directory will be removed recursively before
-- performing the copy operation.
data DirCopyMode = Strict
| Merge
| Replace
-- |Run a given FileOperation. If the FileOperation is partial, it will
-- be returned.
--
-- The operation may fail with:
--
-- * anything that `copyFileToDir`, `easyDelete`, `openFile`,
-- `executeFile` throws
runFileOp :: FileOperation -> IO (Maybe FileOperation) runFileOp :: FileOperation -> IO (Maybe FileOperation)
runFileOp (FCopy (CC from@(File {}, _) to cm)) = runFileOp (FCopy (CC from to cm)) = easyCopy cm from to >> return Nothing
copyFileToDir from to >> return Nothing runFileOp (FCopy fo) = return $ Just $ FCopy fo
runFileOp (FCopy (CC from@(Dir {}, _) to cm)) =
copyDir cm from to >> return Nothing
runFileOp fo@(FCopy _) = return $ Just fo
runFileOp (FDelete fp) = easyDelete fp >> return Nothing runFileOp (FDelete fp) = easyDelete fp >> return Nothing
runFileOp (FOpen fp) = openFile fp >> return Nothing runFileOp (FOpen fp) = openFile fp >> return Nothing
runFileOp (FExecute fp args) = executeFile fp args >> return Nothing runFileOp (FExecute fp args) = executeFile fp args >> return Nothing
@ -102,37 +116,51 @@ runFileOp _ = return Nothing
-- TODO: allow renaming --------------------
-- |Copies a directory to the given destination. --[ File Copying ]--
copyDir :: DirCopyMode --------------------
-> DTInfoZipper -- ^ source dir
-> DTInfoZipper -- ^ destination dir
-> IO ()
copyDir cm from@(Dir fn _ _, _) to@(tod@Dir {}, tobs) = do
let fromp = getFullPath from
top = getFullPath to
destdir = getFullPath to </> fn
dirSanityThrow fromp
dirSanityThrow top -- TODO: allow renaming
throwDestinationInSource fromp top -- |Copies a directory to the given destination with the specified
throwSameFile fromp destdir -- `DirCopyMode`.
--
-- The operation may fail with:
--
-- * `DirDoesNotExist` if the source or destination directory does not exist
-- * `DestinationInSource` if the destination directory is contained within
-- the source directory
-- * `SameFile` if the source and destination directory are the same
-- * `DirDoesExist` if the target directory already exists during the Strict
-- copy mode
-- * anything that `copyFileToDir`, `getFileStatus`, `createDirectory`,
-- `easyDelete`, `readSymbolicLink`, `createDirectoryIfMissing`,
-- `removeDirectoryRecursive`, `createSymbolicLink`, `copyDir`,
-- `copyFileToDir`, `getDirectoryContents` throws
copyDir :: DirCopyMode
-> FilePath -- ^ source dir
-> FilePath -- ^ destination dir
-> IO ()
copyDir cm from to = do
let fn = takeFileName from
destdir = to </> fn
dirSanityThrow from
dirSanityThrow to
throwDestinationInSource from to
throwSameFile from destdir
createDestdir destdir createDestdir destdir
ddinfo <- mkDirInfo destdir contents <- getDirsFiles from
let newDest = (Dir fn [] ddinfo, tod : tobs)
for_ (goAllDown from) $ \f -> for_ contents $ \f -> do
-- TODO: maybe do this strict? let ffn = from </> f
case f of fs <- PF.getSymbolicLinkStatus ffn
-- recreate symlink case (PF.isSymbolicLink fs, PF.isDirectory fs) of
sz@(Dir { name = n, dir = (DirInfo { sym = True }) }, _) -> (True, _) -> recreateSymlink destdir f ffn
recreateSymlink newDest n sz (_, True) -> copyDir cm ffn destdir
sz@(Dir {}, _) -> (_, _) -> copyFileToDir ffn destdir
copyDir cm sz newDest
sz@(File {}, _) ->
copyFileToDir sz newDest
where where
createDestdir destdir = createDestdir destdir =
case cm of case cm of
@ -144,144 +172,177 @@ copyDir cm from@(Dir fn _ _, _) to@(tod@Dir {}, tobs) = do
Replace -> do Replace -> do
whenM (doesDirectoryExist destdir) (removeDirectoryRecursive destdir) whenM (doesDirectoryExist destdir) (removeDirectoryRecursive destdir)
createDirectory destdir createDirectory destdir
recreateSymlink newDest n sz = do recreateSymlink destdir n f = do
let sympoint = getFullPath newDest </> n let sympoint = destdir </> n
case cm of case cm of
Merge -> -- delete old file/dir to be able to create symlink
-- delete old file/dir to be able to create symlink Merge -> easyDelete sympoint
for_ (goDown n newDest) $ \odtz ->
easyDelete odtz
_ -> return () _ -> return ()
symname <- readSymbolicLink (getFullPath sz) symname <- readSymbolicLink f
createSymbolicLink symname sympoint createSymbolicLink symname sympoint
copyDir _ from@(File _ _, _) _ = throw $ NotADir (getFullPath from)
copyDir _ _ to@(File _ _, _) = throw $ NotADir (getFullPath to)
-- |Copies the given file. -- |Copies the given file.
-- --
-- This will throw an exception if any of the filepaths are not absolute -- The operation may fail with:
-- and an exception if the source file does not exist.
-- --
-- If the destination file already exists, it will be replaced. -- * `PathNotAbsolute` either the source or destination file is not an
copyFile :: DTZipper a b -- ^ source file -- absolute path
-> FilePath -- ^ destination file -- * `FileDoesNotExist` the source file does not exist
-- * `DirDoesNotExist` the target directory does not exist
-- * `PathNotAbsolute` if either of the filepaths are not absolute
-- * `SameFile` if the source and destination files are the same
-- * anything that `canonicalizePath` or `System.Directory.copyFile` throws
copyFile :: FilePath -- ^ source file
-> FilePath -- ^ destination file
-> IO () -> IO ()
copyFile from@(File name _, _) to = do copyFile from to = do
let fp = getFullPath from fileSanityThrow from
fileSanityThrow fp
throwNotAbsolute to throwNotAbsolute to
throwDirDoesExist to throwDirDoesExist to
toC <- canonicalizePath (takeDirectory to) toC <- canonicalizePath (takeDirectory to)
let to' = toC </> takeFileName to let to' = toC </> takeFileName to
throwSameFile fp to' throwSameFile from to'
SD.copyFile fp to' SD.copyFile from to'
copyFile from _ = throw $ NotAFile (getFullPath from)
-- |Copies the given file to the given dir with the same filename. -- |Copies the given file to the given dir with the same filename.
-- --
-- This is just a convenience wrapper around `copyFile`. -- The operation may fail with:
copyFileToDir :: DTZipper a b -- ^ source file --
-> DTZipper a b -- ^ destination -- * `DirDoesNotExist` if the target directory does not exist
-> IO () -- * `PathNotAbsolute` if the target directory is not absolute
copyFileToDir from@(File name _, _) to@(Dir {}, _) = do -- * anything that `copyFile` throws
let dp = getFullPath to copyFileToDir :: FilePath -> FilePath -> IO ()
dirSanityThrow dp copyFileToDir from to = do
copyFile from (dp </> name) let name = takeFileName from
copyFileToDir from (Dir {}, _) = throw $ NotAFile (getFullPath from) dirSanityThrow to
copyFileToDir _ to = throw $ NotADir (getFullPath to) copyFile from (to </> name)
-- |Copies the given file, regardless of whether the destination is easyCopy :: DirCopyMode -> FilePath -> FilePath -> IO ()
-- a file or a directory. This is a wrapper around `copyFile` and easyCopy cm from to = doFileOrDir from (copyDir cm from to)
-- `copyFileToDir`. (copyFileToDir from to)
easyCopyFile :: DTZipper a b -> Either FilePath (DTZipper a b) -> IO ()
easyCopyFile from (Left to) = copyFile from to
easyCopyFile from (Right to) = copyFileToDir from to
---------------------
--[ File Deletion ]--
---------------------
-- TODO: misbehaves on symlinks
-- |Deletes the given file or symlink. -- |Deletes the given file or symlink.
-- --
-- This will throw an exception if the filepath is not absolute -- The operation may fail with:
-- or the file does not exist.
-- --
-- It also throws exceptions from `removeFile`. -- * `FileDoesNotExist` if the file does not exist
deleteFile :: DTInfoZipper -> IO () -- * `PathNotAbsolute` if the file is not absolute
deleteFile dtz@(File {}, _) = do -- * anything that `removeFile` throws
let fp = getFullPath dtz deleteFile :: FilePath -> IO ()
deleteFile fp = do
fileSanityThrow fp fileSanityThrow fp
removeFile fp removeFile fp
deleteFile dtz@(Dir { dir = (DirInfo { sym = True }) }, _) = do
let fp = getFullPath dtz
throwNotAbsolute fp
removeFile fp
deleteFile dtz = throw $ NotAFile (getFullPath dtz)
-- |Deletes the given directory. Does not work on symlinks. -- TODO: misbehaves on symlinks
-- |Deletes the given directory.
-- --
-- This will throw an exception if the filepath is not absolute -- The operation may fail with:
-- or the directory does not exist.
-- --
-- It also throws exceptions from `removeDirectory`. -- * `DirDoesNotExist` if the dir does not exist
deleteDir :: DTInfoZipper -> IO () -- * `PathNotAbsolute` if the dir is not absolute
deleteDir dtz@(Dir {}, _) = do -- * anything that `removeDirectory` throws
let fp = getFullPath dtz deleteDir :: FilePath -> IO ()
deleteDir fp = do
dirSanityThrow fp dirSanityThrow fp
removeDirectory fp removeDirectory fp
deleteDir dtz = throw $ NotADir (getFullPath dtz)
-- |Deletes the given directory recursively. Does not work on symlinks. -- |Deletes the given directory recursively.
-- --
-- This will throw an exception if the filepath is not absolute -- The operation may fail with:
-- or the directory does not exist.
-- --
-- It also throws exceptions from `removeDirectoryRecursive`. -- * `DirDoesNotExist` if the dir does not exist
deleteDirRecursive :: DTInfoZipper -> IO () -- * `PathNotAbsolute` if the dir is not absolute
deleteDirRecursive dtz@(Dir {}, _) = do -- * anything that `removeDirectoryRecursive` throws
let fp = getFullPath dtz deleteDirRecursive :: FilePath -> IO ()
deleteDirRecursive fp = do
dirSanityThrow fp dirSanityThrow fp
removeDirectoryRecursive fp removeDirectoryRecursive fp
deleteDirRecursive dtz = throw $ NotADir (getFullPath dtz)
-- |Deletes a file or directory, whatever it may be. -- |Deletes a file or directory, whatever it may be.
easyDelete :: DTInfoZipper -> IO () --
easyDelete dtz@(File {}, _) = deleteFile dtz -- The operation may fail with:
easyDelete dtz@(Dir { dir = (DirInfo { sym = True }) }, _) = deleteFile dtz --
easyDelete dtz@(Dir {}, _) = deleteDir dtz -- * `DirDoesNotExist`/`FileDoesNotExist` if the file/dir does not exist
-- * `PathNotAbsolute` if the file/dir is not absolute
-- * anything that `deleteDir`/`deleteFile` throws
easyDelete :: FilePath -> IO ()
easyDelete fp = doFileOrDir fp (deleteDir fp) (deleteFile fp)
--------------------
--[ File Opening ]--
--------------------
-- |Opens a file appropriately by invoking xdg-open. -- |Opens a file appropriately by invoking xdg-open.
-- --
-- This will throw an exception if the filepath is not absolute -- The operation may fail with:
-- or the file does not exist. --
openFile :: DTZipper a b -- * `FileDoesNotExist` if the file does not exist
-- * `PathNotAbsolute` if the file is not absolute
openFile :: FilePath
-> IO ProcessHandle -> IO ProcessHandle
openFile dtz@(File {}, _) = do openFile fp = do
let fp = getFullPath dtz
fileSanityThrow fp fileSanityThrow fp
spawnProcess "xdg-open" [fp] spawnProcess "xdg-open" [fp]
openFile dtz = throw $ NotAFile (getFullPath dtz)
-- |Executes a program with the given arguments. -- |Executes a program with the given arguments.
-- --
-- This will throw an exception if the filepath is not absolute -- The operation may fail with:
-- or the file does not exist. It will also throw an exception --
-- if the file is not executable. -- * `FileDoesNotExist` if the program does not exist
executeFile :: DTInfoZipper -- ^ program -- * `PathNotAbsolute` if the program is not absolute
-> [String] -- ^ arguments -- * `FileNotExecutable` if the program is not executable
executeFile :: FilePath -- ^ program
-> [String] -- ^ arguments
-> IO ProcessHandle -> IO ProcessHandle
executeFile dtz@(File { file = (FileInfo { permissions = p }) }, _) args = do executeFile prog args = do
let fp = getFullPath dtz fileSanityThrow prog
fileSanityThrow fp unlessM (fileAccess prog False False True) (throw $ FileNotExecutable prog)
unless (executable p) (throw $ FileNotExecutable fp) spawnProcess prog args
spawnProcess fp args
executeFile dtz _ = throw $ NotAFile (getFullPath dtz)
--------------------
--[ Utilities ]--
--------------------
-- |Executes either a directory or file related IO action, depending on
-- the input filepath.
--
-- The operation may fail with:
--
-- * `throwFileDoesNotExist` if the filepath is neither a file or directory
doFileOrDir :: FilePath -> IO () -> IO () -> IO ()
doFileOrDir fp iod iof = do
isD <- doesDirectoryExist fp
isF <- doesFileExist fp
case (isD, isF) of
(True, False) -> do
dirSanityThrow fp
iod
(False, True) -> do
fileSanityThrow fp
iof
_ -> throwFileDoesNotExist fp

1
src/IO/Utils.hs
View File

@ -1,5 +1,6 @@
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
-- |Random and general IO utilities.
module IO.Utils where module IO.Utils where