GTK: refactor refreshView a bit

This commit is contained in:
Julian Ospald 2016-06-01 23:58:34 +02:00
parent 89b231a2c9
commit 244a58d8c2
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
3 changed files with 22 additions and 75 deletions

View File

@ -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

View File

@ -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)

View File

@ -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 ()