GTK: add inotify based file/dir watcher

This automatically updates the treeView if the folder/file changes.
This commit is contained in:
Julian Ospald 2015-12-26 20:27:29 +01:00
parent 0ec4aaac54
commit 464e65d574
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
5 changed files with 66 additions and 15 deletions

View File

@ -33,6 +33,7 @@ library
containers, containers,
directory >= 1.1.0.0 && < 1.2.3.0, directory >= 1.1.0.0 && < 1.2.3.0,
filepath >= 1.3.0.0, filepath >= 1.3.0.0,
hinotify,
mtl >= 2.2, mtl >= 2.2,
old-locale >= 1, old-locale >= 1,
process, process,
@ -70,6 +71,7 @@ executable hsfm-gtk
bifunctors >= 5, bifunctors >= 5,
directory >= 1.1.0.0 && < 1.2.3.0, directory >= 1.1.0.0 && < 1.2.3.0,
filepath >= 1.3.0.0, filepath >= 1.3.0.0,
hinotify,
mtl >= 2.2, mtl >= 2.2,
old-locale >= 1, old-locale >= 1,
process, process,

View File

@ -29,6 +29,10 @@ import Control.Concurrent
( (
forkIO forkIO
) )
import Control.Concurrent.MVar
(
newEmptyMVar
)
import Control.Concurrent.STM import Control.Concurrent.STM
( (
TVar TVar
@ -148,6 +152,8 @@ startMainWindow startdir = do
settings <- newTVarIO (MkFMSettings False True) settings <- newTVarIO (MkFMSettings False True)
inotify <- newEmptyMVar
-- get the icons -- get the icons
iT <- iconThemeGetDefault iT <- iconThemeGetDefault
folderPix <- getIcon IFolder 24 folderPix <- getIcon IFolder 24

View File

@ -206,7 +206,7 @@ del :: Row -> MyGUI -> MyView -> IO ()
del row mygui myview = withErrorDialog $ do del row mygui myview = withErrorDialog $ do
let cmsg = "Really delete \"" ++ fullPath row ++ "\"?" let cmsg = "Really delete \"" ++ fullPath row ++ "\"?"
withConfirmationDialog cmsg withConfirmationDialog cmsg
$ easyDelete row >> refreshTreeView mygui myview Nothing $ easyDelete row
-- |Initializes a file move operation. -- |Initializes a file move operation.
@ -243,16 +243,14 @@ operationFinal mygui myview = withErrorDialog $ do
let cmsg = "Really move \"" ++ fullPath s let cmsg = "Really move \"" ++ fullPath s
++ "\"" ++ " to \"" ++ fullPath cdir ++ "\"?" ++ "\"" ++ " to \"" ++ fullPath cdir ++ "\"?"
withConfirmationDialog cmsg withConfirmationDialog cmsg
(runFileOp (FMove . MC s $ cdir) $ void $ runFileOp (FMove . MC s $ cdir)
>> refreshTreeView mygui myview Nothing)
return () return ()
FCopy (CP1 s) -> do FCopy (CP1 s) -> do
let cmsg = "Really copy \"" ++ fullPath s let cmsg = "Really copy \"" ++ fullPath s
++ "\"" ++ " to \"" ++ fullPath cdir ++ "\"?" ++ "\"" ++ " to \"" ++ fullPath cdir ++ "\"?"
cm <- showCopyModeChooserDialog cm <- showCopyModeChooserDialog
withConfirmationDialog cmsg withConfirmationDialog cmsg
(runFileOp (FCopy . CC s cdir $ cm) $ void $ runFileOp (FCopy . CC s cdir $ cm)
>> refreshTreeView mygui myview Nothing)
return () return ()
_ -> return () _ -> return ()
@ -279,7 +277,6 @@ newFile mygui myview = withErrorDialog $ do
for_ mfn $ \fn -> do for_ mfn $ \fn -> do
cdir <- getCurrentDir myview cdir <- getCurrentDir myview
createFile cdir fn createFile cdir fn
refreshTreeView' mygui myview cdir
renameF :: Row -> MyGUI -> MyView -> IO () renameF :: Row -> MyGUI -> MyView -> IO ()
@ -289,5 +286,3 @@ renameF row mygui myview = withErrorDialog $ do
let cmsg = "Really rename \"" ++ fullPath row let cmsg = "Really rename \"" ++ fullPath row
++ "\"" ++ " to \"" ++ anchor row </> fn ++ "\"?" ++ "\"" ++ " to \"" ++ anchor row </> fn ++ "\"?"
withConfirmationDialog cmsg $ IO.File.renameFile row fn withConfirmationDialog cmsg $ IO.File.renameFile row fn
cdir <- getCurrentDir myview
refreshTreeView' mygui myview cdir

View File

@ -21,6 +21,10 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
module GUI.Gtk.Data where module GUI.Gtk.Data where
import Control.Concurrent.MVar
(
MVar
)
import Control.Concurrent.STM import Control.Concurrent.STM
( (
TVar TVar
@ -28,7 +32,10 @@ import Control.Concurrent.STM
import Data.DirTree import Data.DirTree
import Graphics.UI.Gtk import Graphics.UI.Gtk
import IO.File import IO.File
import System.INotify
(
INotify
)
@ -97,5 +104,6 @@ data MyView = MkMyView {
, sortedModel :: TVar (TypedTreeModelSort Row) , sortedModel :: TVar (TypedTreeModelSort Row)
, filteredModel :: TVar (TypedTreeModelFilter Row) , filteredModel :: TVar (TypedTreeModelFilter Row)
, operationBuffer :: TVar FileOperation , operationBuffer :: TVar FileOperation
, inotify :: MVar INotify
} }

View File

@ -25,6 +25,11 @@ import Control.Applicative
( (
(<$>) (<$>)
) )
import Control.Concurrent.MVar
(
putMVar
, tryTakeMVar
)
import Control.Concurrent.STM import Control.Concurrent.STM
( (
TVar TVar
@ -54,6 +59,14 @@ import GUI.Gtk.Data
import IO.Error import IO.Error
import IO.Utils import IO.Utils
import MyPrelude import MyPrelude
import System.INotify
(
addWatch
, initINotify
, killINotify
, EventVariety(..)
, Event(..)
)
@ -149,14 +162,22 @@ refreshTreeView mygui myview mfp = do
mcdir <- getFirstRow myview mcdir <- getFirstRow myview
let fp = fromMaybe (anchor mcdir) mfp let fp = fromMaybe (anchor mcdir) mfp
-- get selected rows
tvs <- treeViewGetSelection (treeView mygui)
srows <- treeSelectionGetSelectedRows tvs
-- TODO catch exceptions -- TODO catch exceptions
dirSanityThrow fp dirSanityThrow fp
newFsState <- Data.DirTree.readFile fp newFsState <- Data.DirTree.readFile fp
newRawModel <- fileListStore newFsState myview newRawModel <- fileListStore newFsState myview
writeTVarIO (rawModel myview) newRawModel writeTVarIO (rawModel myview) newRawModel
constructTreeView mygui myview constructTreeView mygui myview
-- reselect selected rows
mapM_ (treeSelectionSelectPath tvs) srows
-- |Refreshes the TreeView based on the given directory. -- |Refreshes the TreeView based on the given directory.
-- --
@ -170,8 +191,16 @@ refreshTreeView' :: MyGUI
refreshTreeView' mygui myview dt = do refreshTreeView' mygui myview dt = do
newRawModel <- fileListStore dt myview newRawModel <- fileListStore dt myview
writeTVarIO (rawModel myview) newRawModel writeTVarIO (rawModel myview) newRawModel
-- get selected rows
tvs <- treeViewGetSelection (treeView mygui)
srows <- treeSelectionGetSelectedRows tvs
constructTreeView mygui myview constructTreeView mygui myview
-- reselect selected rows
mapM_ (treeSelectionSelectPath tvs) srows
-- TODO: make this function more slim so only the most necessary parts are -- TODO: make this function more slim so only the most necessary parts are
-- called -- called
@ -189,14 +218,14 @@ constructTreeView :: MyGUI
-> IO () -> IO ()
constructTreeView mygui myview = do constructTreeView mygui myview = do
let treeView' = treeView mygui let treeView' = treeView mygui
cF' = cF mygui cF' = cF mygui
cMD' = cMD mygui cMD' = cMD mygui
render' = renderTxt mygui render' = renderTxt mygui
mcdir <- getFirstRow myview cdirp <- anchor <$> getFirstRow myview
-- update urlBar -- update urlBar
entrySetText (urlBar mygui) (anchor mcdir) entrySetText (urlBar mygui) cdirp
rawModel' <- readTVarIO $ rawModel myview rawModel' <- readTVarIO $ rawModel myview
@ -234,12 +263,23 @@ constructTreeView mygui myview = do
-- update treeview model -- update treeview model
treeViewSetModel treeView' sortedModel' treeViewSetModel treeView' sortedModel'
-- add watcher
mi <- tryTakeMVar (inotify myview)
for_ mi $ \i -> killINotify i
newi <- initINotify
w <- addWatch
newi
[Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
cdirp
(\_ -> postGUIAsync $ refreshTreeView mygui myview (Just cdirp))
putMVar (inotify myview) newi
return () return ()
where where
dirtreePix (Dir {}) = folderPix mygui dirtreePix (Dir {}) = folderPix mygui
dirtreePix (RegFile {}) = filePix mygui dirtreePix (RegFile {}) = filePix mygui
dirtreePix (Failed {}) = errorPix mygui dirtreePix (Failed {}) = errorPix mygui
dirtreePix _ = errorPix mygui dirtreePix _ = errorPix mygui
-- |Push a message to the status bar. -- |Push a message to the status bar.