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

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

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

559
src/Data/DirTree.hs
View File

@ -1,5 +1,10 @@
{-# 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
@ -27,10 +32,7 @@ import Control.Monad.State.Lazy
)
import Data.Default
import Data.Ord
(
comparing
)
import Data.IntMap.Lazy (IntMap)
import Data.List
(
delete
@ -38,10 +40,22 @@ import Data.List
, sortBy
, (\\)
)
import Data.Time
import Data.Maybe
(
UTCTime
, formatTime
fromMaybe
)
import Data.Ord
(
comparing
)
import Data.Time.Clock.POSIX
(
POSIXTime
, posixSecondsToUTCTime
)
import Data.Traversable
(
for
)
import Data.Word
(
@ -49,23 +63,13 @@ import Data.Word
)
import System.Directory
(
Permissions(..)
, createDirectoryIfMissing
, doesFileExist
, getDirectoryContents
, getModificationTime
doesFileExist
, executable
, getPermissions
, writable
, readable
, searchable
)
import System.EasyFile
(
getCreationTime
, getChangeTime
, getAccessTime
, getFileSize
, hasSubDirectories
, isSymlink
, writable
, Permissions
)
import System.FilePath
(
@ -95,10 +99,26 @@ import System.Locale
defaultTimeLocale
, rfc822DateFormat
)
import System.Posix.Types
(
DeviceID
, EpochTime
, FileID
, FileMode
, FileOffset
, GroupID
, LinkCount
, UserID
)
import qualified Data.Bitraversable as BT
import qualified Data.Bifunctor as BF
import qualified Data.Bifoldable as BFL
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
-- |A simple wrapper to hold a base directory name, which can be either an
-- absolute or relative path. This lets us give the DirTree a context, while
-- still letting us store only directory and file /names/ (not full paths) in
-- the DirTree. (uses an infix constructor; don't be scared)
data AnchoredDirTree a b =
(:/) { anchor :: FilePath, dirTree :: DirTree a b }
-- |Represents a directory with it's contents (one level only), while
-- preserving the context via the anchor.
data AnchoredDirFile a b =
(:/) { anchor :: FilePath, dirTree :: IntMap (DirFile a b) }
deriving (Eq, Ord, Show)
@ -125,43 +143,46 @@ data AnchoredDirTree a b =
-- Handles, Strings representing a file's contents or anything else you can
-- think of. We catch any IO errors in the Failed constructor. an Exception
-- can be converted to a String with 'show'.
data DirTree a b =
data DirFile a b =
Failed {
name :: FileName
, err :: IOException
}
| Dir {
name :: FileName
, contents :: [DirTree a b]
, dir :: a
name :: FileName
, dir :: a
}
| File {
name :: FileName
, file :: b
} deriving Show
} deriving (Show, Eq)
-- |All possible directory information we could ever need from a directory.
data DirTreeInfo =
DirInfo {
permissions :: Permissions
, creationTime :: Maybe UTCTime
, changeTime :: Maybe UTCTime
, modTime :: UTCTime
, accessTime :: UTCTime
, sym :: Bool
, hasSubDirs :: Maybe Bool
}
| FileInfo {
permissions :: Permissions
, creationTime :: Maybe UTCTime
, changeTime :: Maybe UTCTime
, modTime :: UTCTime
, accessTime :: UTCTime
, sym :: Bool
, fileSize :: Word64
}
deriving (Show, Eq, Ord)
-- |All possible file information we could ever need.
data FileInfo = FileInfo {
deviceID :: DeviceID
, fileID :: FileID
, fileMode :: FileMode
, linkCount :: LinkCount
, fileOwner :: UserID
, fileGroup :: GroupID
, specialDeviceID :: DeviceID
, fileSize :: FileOffset
, accessTime :: EpochTime
, modificationTime :: EpochTime
, statusChangeTime :: EpochTime
, accessTimeHiRes :: POSIXTime
, modificationTimeHiRes :: POSIXTime
, statusChangeTimeHiRes :: POSIXTime
, isBlockDevice :: Bool
, isCharacterDevice :: Bool
, isNamedPipe :: Bool
, isRegularFile :: Bool
, isDirectory :: Bool
, isSymbolicLink :: Bool
, isSocket :: Bool
, permissions :: Permissions
} deriving (Show, Eq, Ord)
@ -171,75 +192,55 @@ data DirTreeInfo =
----------------------------
instance BF.Bifunctor DirTree where
instance BF.Bifunctor DirFile where
bimap = BT.bimapDefault
instance BFL.Bifoldable DirTree where
instance BFL.Bifoldable DirFile where
bifoldMap = BT.bifoldMapDefault
instance BT.Bitraversable DirTree where
bitraverse f1 f2 (Dir n cs b) =
Dir n
<$> T.traverse (BT.bitraverse f1 f2) cs
<*> f1 b
instance BT.Bitraversable DirFile where
bitraverse f1 f2 (Dir n b) =
Dir n <$> f1 b
bitraverse _ f2 (File n a) =
File n <$> f2 a
bitraverse _ _ (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...
-- Then compare `name`...
-- 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') =
case compare n n' of
EQ -> compare a a'
el -> el
compare (Dir n cs b) (Dir n' cs' b') =
compare (Dir n b) (Dir n' b') =
case compare n n' of
EQ -> case compare b b' of
EQ -> comparing sort cs cs'
el -> el
EQ -> compare b b'
el -> el
-- after comparing above we can hand off to shape ord function:
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 ]--
----------------------------
-- | 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.
-- Uses `readDirectoryWith` internally and has the effect of traversing the
-- entire directory structure. See `readDirectoryWithL` for lazy production
-- of a DirTree structure.
readDirectory :: FilePath -> IO (AnchoredDirTree String String)
-- of a DirFile structure.
readDirectory :: FilePath -> IO (AnchoredDirFile String String)
readDirectory = readDirectoryWith readFile return
@ -248,49 +249,10 @@ readDirectory = readDirectoryWith readFile return
readDirectoryWith :: (FilePath -> IO a)
-> (FilePath -> IO b)
-> FilePath
-> IO (AnchoredDirTree a b)
-> IO (AnchoredDirFile a b)
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 DirTree from the contents of the directory passed to it, saving
-- | builds a DirFile 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 Failed constructor. The 'file' fields initially are populated with full
-- 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
-- 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: -- -- --
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"
-- nature of traversing a system firectory tree:
@ -332,43 +283,23 @@ buildWith' :: Builder a b
-> UserIO a
-> UserIO b
-> FilePath
-> IO (AnchoredDirTree a b)
-> IO (AnchoredDirFile a b)
buildWith' 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:
buildAtOnce' :: Builder a b
buildAtOnce' fd ff p = handleDT n $
do isFile <- doesFileExist p
if isFile
then File n <$> ff p
else do cs <- getDirsFiles p
Dir n
<$> T.mapM (buildAtOnce' fd ff . combine p) cs
<*> fd p
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
buildAtOnce' fd ff p = do
contents <- getDirsFiles p
for contents $ \n -> handleDT n $ do
let subf = p </> n
do isFile <- doesFileExist subf
if isFile
then File n <$> ff subf
else Dir n <$> fd subf
@ -383,84 +314,52 @@ buildLazilyUnsafe' fd ff p = handleDT n $
-- | True if any Failed constructors in the tree
anyFailed :: DirTree a b -> Bool
anyFailed :: [DirFile a b] -> Bool
anyFailed = not . successful
-- | True if there are no Failed constructors in the tree
successful :: DirTree a b -> Bool
successful :: [DirFile a b] -> Bool
successful = null . failures
-- | returns true if argument is a `Failed` constructor:
failed :: DirTree a b -> Bool
failed :: DirFile a b -> Bool
failed (Failed _ _) = True
failed _ = False
-- | returns a list of 'Failed' constructors only:
failures :: DirTree a b -> [DirTree a b]
failures = filter failed . flattenDir
failures :: [DirFile a b] -> [DirFile a b]
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 ----
-- | 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
-- 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
-- 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:
comparingShape :: DirTree a b -> DirTree c d -> Ordering
comparingShape (Dir n cs _) (Dir n' cs' _) =
case compare n n' of
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 :: DirFile a b -> DirFile c d -> Ordering
comparingShape (Dir n _) (Dir n' _) = compare n n'
-- else simply compare the flat constructors, non-recursively:
comparingShape t t' = comparingConstr t t'
-- HELPER: a non-recursive comparison
comparingConstr :: DirTree a b -> DirTree a1 b1 -> Ordering
comparingConstr (Failed _ _) (Dir _ _ _) = LT
comparingConstr :: DirFile a b -> DirFile a1 b1 -> Ordering
comparingConstr (Failed _ _) (Dir _ _) = LT
comparingConstr (Failed _ _) (File _ _) = LT
comparingConstr (File _ _) (Failed _ _) = GT
comparingConstr (File _ _) (Dir _ _ _) = GT
comparingConstr (Dir _ _ _) (Failed _ _) = GT
comparingConstr (Dir _ _ _) (File _ _) = LT
comparingConstr (File _ _) (Dir _ _) = GT
comparingConstr (Dir _ _) (Failed _ _) = GT
comparingConstr (Dir _ _) (File _ _) = LT
-- else compare on the names of constructors that are the same, without
-- looking at the contents of Dir constructors:
comparingConstr t t' = compare (name t) (name t')
@ -470,82 +369,6 @@ comparingConstr t t' = compare (name t) (name t')
---- 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 ----
isFileC :: DirTree a b -> Bool
isFileC :: DirFile a b -> Bool
isFileC (File _ _) = True
isFileC _ = False
isDirC :: DirTree a b -> Bool
isDirC (Dir _ _ _) = True
isDirC _ = False
isDirC :: DirFile a b -> Bool
isDirC (Dir _ _) = True
isDirC _ = False
---- 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:
topDir, baseDir :: FilePath -> FilePath
topDir = last . splitDirectories
@ -590,55 +400,72 @@ baseDir = joinPath . init . splitDirectories
---- 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 "." == ""
----- and getDirectoryContents fails epically on ""
-- prepares the directory contents list. we sort so that we can be sure of
-- a consistent fold/traversal order on the same directory:
getDirsFiles :: String -> IO [FilePath]
getDirsFiles cs = do let cs' = if null cs then "." else cs
dfs <- getDirectoryContents cs'
return $ dfs \\ [".",".."]
getDirsFiles :: FilePath -> IO (IntMap FilePath)
getDirsFiles fp = do
dirstream <- PFD.openDirStream fp
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
-> IO (AnchoredDirTree DirTreeInfo DirTreeInfo)
readPath = readDirectoryWithL mkDirInfo mkFileInfo
-> IO (AnchoredDirFile FileInfo FileInfo)
readPath = readDirectoryWith getFileInfo getFileInfo
mkFileInfo :: FilePath -> IO DirTreeInfo
mkFileInfo fp =
FileInfo
<$> getPermissions fp
<*> getCreationTime fp
<*> getChangeTime fp
<*> getModificationTime fp
<*> getAccessTime fp
<*> isSymlink fp
<*> getFileSize fp
-- |Gets all file information.
getFileInfo :: FilePath -> IO FileInfo
getFileInfo fp = do
fs <- PF.getSymbolicLinkStatus fp
perms <- getPermissions fp
return $ FileInfo
(PF.deviceID fs)
(PF.fileID fs)
(PF.fileMode fs)
(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
mkDirInfo fp =
DirInfo
<$> getPermissions fp
<*> getCreationTime fp
<*> getChangeTime fp
<*> getModificationTime fp
<*> getAccessTime fp
<*> isSymlink fp
<*> hasSubDirectories fp
getFreeVar :: DirTree a a -> Maybe a
-- |Gets the free variable. Returns Nothing if the constructor is of `Failed`.
getFreeVar :: DirFile a a -> Maybe a
getFreeVar (File _ f) = Just f
getFreeVar (Dir _ _ d) = Just d
getFreeVar (Dir _ d) = Just d
getFreeVar _ = Nothing
@ -647,7 +474,7 @@ getFreeVar _ = Nothing
-- handles an IO exception by returning a Failed constructor filled with that
-- 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)
@ -657,36 +484,32 @@ handleDT n = handle (return . Failed n)
-- So we filter those errors out because the user should not see errors
-- raised by the internal implementation of this module:
-- This leaves the error if it exists in the top (user-supplied) level:
removeNonexistent :: DirTree a b -> DirTree a b
removeNonexistent = filterDir isOkConstructor
removeNonexistent :: IntMap (DirFile a b) -> IntMap (DirFile a b)
removeNonexistent = IM.filter isOkConstructor
where isOkConstructor c = not (failed c) || isOkError c
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: ----
anchoredToPath :: AnchoredDirTree a b -> FilePath
anchoredToPath a = anchor a </> (name . dirTree $ a)
-- TODO: use Maybe type?
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
-> [(FileName, String)]
ls dt = fmap (\x -> (name x, packModTime x)) (contents dt)
subDirName :: AnchoredDirFile a b -> Int -> FilePath
subDirName df ix = anchor df </> name (dirLookup df ix)
fromFreeVar :: (Default d) => (a -> d) -> DirTree a a -> d
fromFreeVar f dt = maybeD f $ getFreeVar dt
fromFreeVar :: (Default d) => (a -> d) -> DirFile a a -> d
fromFreeVar f df = maybeD f $ getFreeVar df
maybeD :: (Default b) => (a -> b) -> Maybe a -> b
@ -694,14 +517,12 @@ maybeD = maybe def
-- |Pack the modification time
packModTime :: DirTree DirTreeInfo DirTreeInfo
packModTime :: DirFile FileInfo FileInfo
-> String
packModTime = fromFreeVar
$ formatTime defaultTimeLocale rfc822DateFormat
. modTime
$ show . posixSecondsToUTCTime . realToFrac . modificationTime
packPermissions :: DirTree DirTreeInfo DirTreeInfo
packPermissions :: DirFile FileInfo FileInfo
-> String
packPermissions dt = fromFreeVar (pStr . permissions) dt
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 #-}
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 #-}
-- |The main Gtk Gui module for creating the main window.
module GUI.Gtk.Gui (startMainWindow) where
@ -34,7 +35,6 @@ import Control.Monad.IO.Class
liftIO
)
import Data.DirTree
import Data.DirTree.Zipper
import Data.Foldable
(
for_
@ -55,7 +55,11 @@ import Data.Traversable
forM
)
import Graphics.UI.Gtk
import GUI.Gtk.Callbacks
import GUI.Gtk.Data
import GUI.Gtk.Dialogs
import GUI.Gtk.Icons
import GUI.Gtk.Utils
import IO.Error
import IO.File
import IO.Utils
@ -72,6 +76,7 @@ import System.Environment
import System.FilePath
(
isAbsolute
, (</>)
)
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: double check garbage collection/gtk ref counting
-- 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,
-- 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
-------------------------
--[ Main Window Setup ]--
-------------------------
-- |Set up the GUI.
--
-- Interaction with mutable references:
--
-- * 'settings' creates
-- * 'fsState' creates
-- * 'operationBuffer' creates
-- * 'rawModel' creates
-- * 'filteredModel' creates
-- * 'sortedModel' creates
startMainWindow :: FilePath -> IO ()
startMainWindow startdir = do
@ -488,7 +130,7 @@ startMainWindow startdir = do
filePix <- getIcon IFile 24
errorPix <- getIcon IError 24
fsState <- readPath' startdir >>= newTVarIO
fsState <- readPath startdir >>= newTVarIO
operationBuffer <- newTVarIO None
@ -520,7 +162,8 @@ startMainWindow startdir = do
"statusBar"
-- 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 [])
=<< readTVarIO rawModel

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

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

327
src/IO/File.hs
View File

@ -1,5 +1,13 @@
{-# 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
@ -13,7 +21,6 @@ import Control.Monad
, void
)
import Data.DirTree
import Data.DirTree.Zipper
import Data.Foldable
(
for_
@ -44,6 +51,8 @@ import System.Posix.Files
(
createSymbolicLink
, readSymbolicLink
, fileAccess
, getFileStatus
)
import System.Process
(
@ -53,6 +62,8 @@ import System.Process
import qualified System.Directory as SD
import qualified System.Posix.Files as PF
-- TODO: modify the DTZipper directly after file operations!?
-- TODO: file operations should be threaded and not block the UI
@ -63,38 +74,41 @@ import qualified System.Directory as SD
-- or delay operations.
data FileOperation = FCopy Copy
| FMove Move
| FDelete DTInfoZipper
| FOpen DTInfoZipper
| FExecute DTInfoZipper [String]
| FDelete FilePath
| FOpen FilePath
| FExecute FilePath [String]
| None
data Copy = CP1 DTInfoZipper
| CP2 DTInfoZipper DTInfoZipper
| CC DTInfoZipper DTInfoZipper DirCopyMode
-- |Data type describing partial or complete file copy operation.
-- CC stands for a complete operation and can be used for `runFileOp`.
data Copy = CP1 FilePath
| CP2 FilePath FilePath
| CC FilePath FilePath DirCopyMode
data Move = MP1 DTInfoZipper
| MC DTInfoZipper DTInfoZipper
-- |Data type describing partial or complete file move operation.
-- MC stands for a complete operation and can be used for `runFileOp`.
data Move = MP1 FilePath
| MC FilePath FilePath
-- |Directory copy modes.
-- Strict means we fail if the target directory already exists.
-- Merge means we keep the old directories/files, but overwrite old files
-- on collision.
-- Replace means the target directory will be removed recursively before
-- performing the copy operation.
data DirCopyMode = Strict
| Merge
| Replace
data DirCopyMode = Strict -- ^ fail if the target directory already exists
| Merge -- ^ overwrite files if necessary
| Replace -- ^ remove target directory before copying
-- |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 (FCopy (CC from@(File {}, _) to cm)) =
copyFileToDir from to >> return Nothing
runFileOp (FCopy (CC from@(Dir {}, _) to cm)) =
copyDir cm from to >> return Nothing
runFileOp fo@(FCopy _) = return $ Just fo
runFileOp (FCopy (CC from to cm)) = easyCopy cm from to >> return Nothing
runFileOp (FCopy fo) = return $ Just $ FCopy fo
runFileOp (FDelete fp) = easyDelete fp >> return Nothing
runFileOp (FOpen fp) = openFile fp >> 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.
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
--------------------
--[ File Copying ]--
--------------------
dirSanityThrow fromp
dirSanityThrow top
throwDestinationInSource fromp top
throwSameFile fromp destdir
-- TODO: allow renaming
-- |Copies a directory to the given destination with the specified
-- `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
ddinfo <- mkDirInfo destdir
let newDest = (Dir fn [] ddinfo, tod : tobs)
contents <- getDirsFiles from
for_ (goAllDown from) $ \f ->
-- TODO: maybe do this strict?
case f of
-- recreate symlink
sz@(Dir { name = n, dir = (DirInfo { sym = True }) }, _) ->
recreateSymlink newDest n sz
sz@(Dir {}, _) ->
copyDir cm sz newDest
sz@(File {}, _) ->
copyFileToDir sz newDest
for_ contents $ \f -> do
let ffn = from </> f
fs <- PF.getSymbolicLinkStatus ffn
case (PF.isSymbolicLink fs, PF.isDirectory fs) of
(True, _) -> recreateSymlink destdir f ffn
(_, True) -> copyDir cm ffn destdir
(_, _) -> copyFileToDir ffn destdir
where
createDestdir destdir =
case cm of
@ -144,144 +172,177 @@ copyDir cm from@(Dir fn _ _, _) to@(tod@Dir {}, tobs) = do
Replace -> do
whenM (doesDirectoryExist destdir) (removeDirectoryRecursive destdir)
createDirectory destdir
recreateSymlink newDest n sz = do
let sympoint = getFullPath newDest </> n
recreateSymlink destdir n f = do
let sympoint = destdir </> n
case cm of
Merge ->
-- delete old file/dir to be able to create symlink
for_ (goDown n newDest) $ \odtz ->
easyDelete odtz
-- delete old file/dir to be able to create symlink
Merge -> easyDelete sympoint
_ -> return ()
symname <- readSymbolicLink (getFullPath sz)
symname <- readSymbolicLink f
createSymbolicLink symname sympoint
copyDir _ from@(File _ _, _) _ = throw $ NotADir (getFullPath from)
copyDir _ _ to@(File _ _, _) = throw $ NotADir (getFullPath to)
-- |Copies the given file.
--
-- This will throw an exception if any of the filepaths are not absolute
-- and an exception if the source file does not exist.
-- The operation may fail with:
--
-- If the destination file already exists, it will be replaced.
copyFile :: DTZipper a b -- ^ source file
-> FilePath -- ^ destination file
-- * `PathNotAbsolute` either the source or destination file is not an
-- absolute path
-- * `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 ()
copyFile from@(File name _, _) to = do
let fp = getFullPath from
fileSanityThrow fp
copyFile from to = do
fileSanityThrow from
throwNotAbsolute to
throwDirDoesExist to
toC <- canonicalizePath (takeDirectory to)
let to' = toC </> takeFileName to
throwSameFile fp to'
SD.copyFile fp to'
copyFile from _ = throw $ NotAFile (getFullPath from)
throwSameFile from to'
SD.copyFile from to'
-- |Copies the given file to the given dir with the same filename.
--
-- This is just a convenience wrapper around `copyFile`.
copyFileToDir :: DTZipper a b -- ^ source file
-> DTZipper a b -- ^ destination
-> IO ()
copyFileToDir from@(File name _, _) to@(Dir {}, _) = do
let dp = getFullPath to
dirSanityThrow dp
copyFile from (dp </> name)
copyFileToDir from (Dir {}, _) = throw $ NotAFile (getFullPath from)
copyFileToDir _ to = throw $ NotADir (getFullPath to)
-- The operation may fail with:
--
-- * `DirDoesNotExist` if the target directory does not exist
-- * `PathNotAbsolute` if the target directory is not absolute
-- * anything that `copyFile` throws
copyFileToDir :: FilePath -> FilePath -> IO ()
copyFileToDir from to = do
let name = takeFileName from
dirSanityThrow to
copyFile from (to </> name)
-- |Copies the given file, regardless of whether the destination is
-- a file or a directory. This is a wrapper around `copyFile` and
-- `copyFileToDir`.
easyCopyFile :: DTZipper a b -> Either FilePath (DTZipper a b) -> IO ()
easyCopyFile from (Left to) = copyFile from to
easyCopyFile from (Right to) = copyFileToDir from to
easyCopy :: DirCopyMode -> FilePath -> FilePath -> IO ()
easyCopy cm from to = doFileOrDir from (copyDir cm from to)
(copyFileToDir from to)
---------------------
--[ File Deletion ]--
---------------------
-- TODO: misbehaves on symlinks
-- |Deletes the given file or symlink.
--
-- This will throw an exception if the filepath is not absolute
-- or the file does not exist.
-- The operation may fail with:
--
-- It also throws exceptions from `removeFile`.
deleteFile :: DTInfoZipper -> IO ()
deleteFile dtz@(File {}, _) = do
let fp = getFullPath dtz
-- * `FileDoesNotExist` if the file does not exist
-- * `PathNotAbsolute` if the file is not absolute
-- * anything that `removeFile` throws
deleteFile :: FilePath -> IO ()
deleteFile fp = do
fileSanityThrow 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
-- or the directory does not exist.
-- The operation may fail with:
--
-- It also throws exceptions from `removeDirectory`.
deleteDir :: DTInfoZipper -> IO ()
deleteDir dtz@(Dir {}, _) = do
let fp = getFullPath dtz
-- * `DirDoesNotExist` if the dir does not exist
-- * `PathNotAbsolute` if the dir is not absolute
-- * anything that `removeDirectory` throws
deleteDir :: FilePath -> IO ()
deleteDir fp = do
dirSanityThrow 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
-- or the directory does not exist.
-- The operation may fail with:
--
-- It also throws exceptions from `removeDirectoryRecursive`.
deleteDirRecursive :: DTInfoZipper -> IO ()
deleteDirRecursive dtz@(Dir {}, _) = do
let fp = getFullPath dtz
-- * `DirDoesNotExist` if the dir does not exist
-- * `PathNotAbsolute` if the dir is not absolute
-- * anything that `removeDirectoryRecursive` throws
deleteDirRecursive :: FilePath -> IO ()
deleteDirRecursive fp = do
dirSanityThrow fp
removeDirectoryRecursive fp
deleteDirRecursive dtz = throw $ NotADir (getFullPath dtz)
-- |Deletes a file or directory, whatever it may be.
easyDelete :: DTInfoZipper -> IO ()
easyDelete dtz@(File {}, _) = deleteFile dtz
easyDelete dtz@(Dir { dir = (DirInfo { sym = True }) }, _) = deleteFile dtz
easyDelete dtz@(Dir {}, _) = deleteDir dtz
--
-- The operation may fail with:
--
-- * `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.
--
-- This will throw an exception if the filepath is not absolute
-- or the file does not exist.
openFile :: DTZipper a b
-- The operation may fail with:
--
-- * `FileDoesNotExist` if the file does not exist
-- * `PathNotAbsolute` if the file is not absolute
openFile :: FilePath
-> IO ProcessHandle
openFile dtz@(File {}, _) = do
let fp = getFullPath dtz
openFile fp = do
fileSanityThrow fp
spawnProcess "xdg-open" [fp]
openFile dtz = throw $ NotAFile (getFullPath dtz)
-- |Executes a program with the given arguments.
--
-- This will throw an exception if the filepath is not absolute
-- or the file does not exist. It will also throw an exception
-- if the file is not executable.
executeFile :: DTInfoZipper -- ^ program
-> [String] -- ^ arguments
-- The operation may fail with:
--
-- * `FileDoesNotExist` if the program does not exist
-- * `PathNotAbsolute` if the program is not absolute
-- * `FileNotExecutable` if the program is not executable
executeFile :: FilePath -- ^ program
-> [String] -- ^ arguments
-> IO ProcessHandle
executeFile dtz@(File { file = (FileInfo { permissions = p }) }, _) args = do
let fp = getFullPath dtz
fileSanityThrow fp
unless (executable p) (throw $ FileNotExecutable fp)
spawnProcess fp args
executeFile dtz _ = throw $ NotAFile (getFullPath dtz)
executeFile prog args = do
fileSanityThrow prog
unlessM (fileAccess prog False False True) (throw $ FileNotExecutable prog)
spawnProcess prog args
--------------------
--[ 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 #-}
-- |Random and general IO utilities.
module IO.Utils where