GTK: refactor refreshView a bit
This commit is contained in:
parent
89b231a2c9
commit
244a58d8c2
@ -185,7 +185,7 @@ setViewCallbacks mygui myview = do
|
|||||||
goHome mygui myview
|
goHome mygui myview
|
||||||
_ <- refreshViewB myview `on` buttonActivated $ do
|
_ <- refreshViewB myview `on` buttonActivated $ do
|
||||||
cdir <- liftIO $ getCurrentDir myview
|
cdir <- liftIO $ getCurrentDir myview
|
||||||
refreshView' mygui myview cdir
|
refreshView mygui myview cdir
|
||||||
|
|
||||||
-- key events
|
-- key events
|
||||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||||
@ -194,7 +194,7 @@ setViewCallbacks mygui myview = do
|
|||||||
cdir <- liftIO $ getCurrentDir myview
|
cdir <- liftIO $ getCurrentDir myview
|
||||||
liftIO $ modifyTVarIO (settings mygui)
|
liftIO $ modifyTVarIO (settings mygui)
|
||||||
(\x -> x { showHidden = not . showHidden $ x})
|
(\x -> x { showHidden = not . showHidden $ x})
|
||||||
>> refreshView' mygui myview cdir
|
>> refreshView mygui myview cdir
|
||||||
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
||||||
[Alt] <- eventModifier
|
[Alt] <- eventModifier
|
||||||
"Up" <- fmap glibToString eventKeyName
|
"Up" <- fmap glibToString eventKeyName
|
||||||
|
@ -26,14 +26,9 @@ module HSFM.GUI.Gtk.Callbacks.Utils where
|
|||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
(
|
(
|
||||||
forM
|
forM_
|
||||||
, forM_
|
|
||||||
, when
|
, when
|
||||||
)
|
)
|
||||||
import Control.Monad.IO.Class
|
|
||||||
(
|
|
||||||
liftIO
|
|
||||||
)
|
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
(
|
(
|
||||||
fromJust
|
fromJust
|
||||||
@ -57,10 +52,6 @@ import HSFM.Utils.IO
|
|||||||
modifyTVarIO
|
modifyTVarIO
|
||||||
)
|
)
|
||||||
import Prelude hiding(readFile)
|
import Prelude hiding(readFile)
|
||||||
import Control.Concurrent.STM.TVar
|
|
||||||
(
|
|
||||||
readTVarIO
|
|
||||||
)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@ -115,7 +106,7 @@ goDir bhis mygui myview item = do
|
|||||||
cdir <- getCurrentDir myview
|
cdir <- getCurrentDir myview
|
||||||
when bhis $ modifyTVarIO (history myview)
|
when bhis $ modifyTVarIO (history myview)
|
||||||
(\(p, _) -> (path cdir `addHistory` p, []))
|
(\(p, _) -> (path cdir `addHistory` p, []))
|
||||||
refreshView' mygui myview item
|
refreshView mygui myview item
|
||||||
|
|
||||||
-- set notebook tab label
|
-- set notebook tab label
|
||||||
page <- notebookGetCurrentPage (notebook mygui)
|
page <- notebookGetCurrentPage (notebook mygui)
|
||||||
|
@ -32,16 +32,11 @@ import Control.Concurrent.STM
|
|||||||
newTVarIO
|
newTVarIO
|
||||||
, readTVarIO
|
, readTVarIO
|
||||||
)
|
)
|
||||||
import Control.Exception
|
|
||||||
(
|
|
||||||
try
|
|
||||||
, SomeException
|
|
||||||
)
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
(
|
(
|
||||||
forM_
|
forM_
|
||||||
|
, unless
|
||||||
)
|
)
|
||||||
import qualified Data.ByteString as BS
|
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
(
|
(
|
||||||
for_
|
for_
|
||||||
@ -55,17 +50,8 @@ import Data.String
|
|||||||
(
|
(
|
||||||
fromString
|
fromString
|
||||||
)
|
)
|
||||||
import HPath.IO.Errors
|
|
||||||
(
|
|
||||||
canOpenDirectory
|
|
||||||
)
|
|
||||||
import Graphics.UI.Gtk
|
import Graphics.UI.Gtk
|
||||||
import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setViewCallbacks)
|
import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setViewCallbacks)
|
||||||
import HPath
|
|
||||||
(
|
|
||||||
Path
|
|
||||||
, Abs
|
|
||||||
)
|
|
||||||
import qualified HPath as P
|
import qualified HPath as P
|
||||||
import HSFM.FileSystem.FileType
|
import HSFM.FileSystem.FileType
|
||||||
import HSFM.GUI.Glib.GlibString()
|
import HSFM.GUI.Glib.GlibString()
|
||||||
@ -89,11 +75,11 @@ import System.IO.Error
|
|||||||
(
|
(
|
||||||
catchIOError
|
catchIOError
|
||||||
, ioError
|
, ioError
|
||||||
|
, isUserError
|
||||||
)
|
)
|
||||||
import System.Posix.FilePath
|
import System.Posix.FilePath
|
||||||
(
|
(
|
||||||
pathSeparator
|
hiddenFile
|
||||||
, hiddenFile
|
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
||||||
@ -108,11 +94,12 @@ newTab mygui iofmv item = do
|
|||||||
forM_ mpage $ \page -> notebookSetTabReorderable (notebook mygui)
|
forM_ mpage $ \page -> notebookSetTabReorderable (notebook mygui)
|
||||||
page
|
page
|
||||||
True
|
True
|
||||||
catchIOError (refreshView' mygui myview item) $ \e -> do
|
catchIOError (refreshView mygui myview item) $ \e -> do
|
||||||
forM_ mpage $ \page -> do
|
forM_ mpage $ \page -> do
|
||||||
refreshView mygui myview (P.parseAbs $ fromString "/")
|
file <- readFile getFileInfo . fromJust . P.parseAbs . fromString $ "/"
|
||||||
|
refreshView mygui myview file
|
||||||
notebookSetTabLabelText (notebook mygui) page "/"
|
notebookSetTabLabelText (notebook mygui) page "/"
|
||||||
ioError e
|
unless (isUserError e) (ioError e)
|
||||||
|
|
||||||
return myview
|
return myview
|
||||||
|
|
||||||
@ -208,7 +195,7 @@ switchView mygui myview iofmv = do
|
|||||||
$ P.basename . path $ cwd) oldpage
|
$ P.basename . path $ cwd) oldpage
|
||||||
notebookSetCurrentPage (notebook mygui) newpage
|
notebookSetCurrentPage (notebook mygui) newpage
|
||||||
|
|
||||||
refreshView' mygui nview cwd
|
refreshView mygui nview cwd
|
||||||
|
|
||||||
|
|
||||||
-- |Destroys the current view by disconnecting the watcher
|
-- |Destroys the current view by disconnecting the watcher
|
||||||
@ -305,49 +292,18 @@ createTreeView = do
|
|||||||
return $ FMTreeView treeView
|
return $ FMTreeView treeView
|
||||||
|
|
||||||
|
|
||||||
-- |Re-reads the current directory or the given one and updates the View.
|
|
||||||
-- This is more or less a wrapper around `refreshView'`
|
|
||||||
--
|
|
||||||
-- If the third argument is Nothing, it tries to re-read the current directory.
|
|
||||||
-- If that fails, it reads "/" instead.
|
|
||||||
--
|
|
||||||
-- If the third argument is (Just path) it tries to read "path". If that
|
|
||||||
-- fails, it reads "/" instead.
|
|
||||||
refreshView :: MyGUI
|
|
||||||
-> MyView
|
|
||||||
-> Maybe (Path Abs)
|
|
||||||
-> IO ()
|
|
||||||
refreshView mygui myview mfp =
|
|
||||||
case mfp of
|
|
||||||
Just fp -> do
|
|
||||||
canopen <- canOpenDirectory fp
|
|
||||||
if canopen
|
|
||||||
then refreshView' mygui myview =<< readFile getFileInfo fp
|
|
||||||
else refreshView mygui myview =<< getAlternativeDir
|
|
||||||
Nothing -> refreshView mygui myview =<< getAlternativeDir
|
|
||||||
where
|
|
||||||
getAlternativeDir = do
|
|
||||||
ecd <- try (getCurrentDir myview) :: IO (Either SomeException
|
|
||||||
Item)
|
|
||||||
case ecd of
|
|
||||||
Right dir -> return (Just $ path dir)
|
|
||||||
Left _ -> return (P.parseAbs $ BS.singleton pathSeparator)
|
|
||||||
|
|
||||||
|
|
||||||
-- |Refreshes the View based on the given directory.
|
-- |Refreshes the View based on the given directory.
|
||||||
--
|
--
|
||||||
-- If the directory is not a Dir or a Symlink pointing to a Dir, then
|
-- Throws:
|
||||||
-- calls `refreshView` with the 3rd argument being Nothing.
|
|
||||||
--
|
--
|
||||||
-- Does not do fallbacks if the directory cannot be read, but
|
-- - `userError` on inappropriate type
|
||||||
-- throws an error.
|
refreshView :: MyGUI
|
||||||
refreshView' :: MyGUI
|
|
||||||
-> MyView
|
-> MyView
|
||||||
-> Item
|
-> Item
|
||||||
-> IO ()
|
-> IO ()
|
||||||
refreshView' mygui myview SymLink { sdest = d@Dir{} } =
|
refreshView mygui myview SymLink { sdest = d@Dir{} } =
|
||||||
refreshView' mygui myview d
|
refreshView mygui myview d
|
||||||
refreshView' mygui myview item@Dir{} = do
|
refreshView mygui myview item@Dir{} = do
|
||||||
newRawModel <- fileListStore item myview
|
newRawModel <- fileListStore item myview
|
||||||
writeTVarIO (rawModel myview) newRawModel
|
writeTVarIO (rawModel myview) newRawModel
|
||||||
|
|
||||||
@ -370,8 +326,7 @@ refreshView' mygui myview item@Dir{} = do
|
|||||||
ntps <- mapM treeRowReferenceGetPath trs
|
ntps <- mapM treeRowReferenceGetPath trs
|
||||||
mapM_ (treeSelectionSelectPath tvs) ntps
|
mapM_ (treeSelectionSelectPath tvs) ntps
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
refreshView' mygui myview Failed{} = refreshView mygui myview Nothing
|
refreshView _ _ _ = ioError $ userError "Inappropriate type!"
|
||||||
refreshView' _ _ _ = return ()
|
|
||||||
|
|
||||||
|
|
||||||
-- |Constructs the visible View with the current underlying mutable models,
|
-- |Constructs the visible View with the current underlying mutable models,
|
||||||
@ -403,7 +358,8 @@ constructView mygui myview = do
|
|||||||
|
|
||||||
view' <- readTVarIO $ view myview
|
view' <- readTVarIO $ view myview
|
||||||
|
|
||||||
cdirp <- path <$> getCurrentDir myview
|
cdir <- getCurrentDir myview
|
||||||
|
let cdirp = path cdir
|
||||||
|
|
||||||
-- update urlBar
|
-- update urlBar
|
||||||
entrySetText (urlBar myview) (P.fromAbs cdirp)
|
entrySetText (urlBar myview) (P.fromAbs cdirp)
|
||||||
@ -461,7 +417,7 @@ constructView mygui myview = do
|
|||||||
newi
|
newi
|
||||||
[Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
|
[Move, MoveIn, MoveOut, MoveSelf, Create, Delete, DeleteSelf]
|
||||||
(P.fromAbs cdirp)
|
(P.fromAbs cdirp)
|
||||||
(\_ -> postGUIAsync $ refreshView mygui myview (Just $ cdirp))
|
(\_ -> postGUIAsync $ refreshView mygui myview cdir)
|
||||||
putMVar (inotify myview) newi
|
putMVar (inotify myview) newi
|
||||||
|
|
||||||
return ()
|
return ()
|
||||||
|
Loading…
Reference in New Issue
Block a user