From e310879d616f8deb4105a776c61862ba9d7f8c89 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Fri, 3 Jun 2016 13:44:59 +0200 Subject: [PATCH] GTK: add newTab{,Here} buttons and allow closing tabs via middle-click This also fixes behavior of destroyView. --- data/Gtk/builder.xml | 34 +++++++++++++++++ src/HSFM/GUI/Gtk/Callbacks.hs | 57 ++++++++++++++++++++++++++++- src/HSFM/GUI/Gtk/Callbacks/Utils.hs | 12 +++++- src/HSFM/GUI/Gtk/Data.hs | 2 + src/HSFM/GUI/Gtk/MyView.hs | 41 ++++----------------- 5 files changed, 108 insertions(+), 38 deletions(-) diff --git a/data/Gtk/builder.xml b/data/Gtk/builder.xml index c7e5b85..a259a72 100644 --- a/data/Gtk/builder.xml +++ b/data/Gtk/builder.xml @@ -510,6 +510,30 @@ False + + + True + False + + + + + New Tab + True + False + image8 + False + + + + + New Tab here + True + False + image9 + False + + @@ -614,6 +638,16 @@ + + True + False + gtk-add + + + True + False + gtk-add + True False diff --git a/src/HSFM/GUI/Gtk/Callbacks.hs b/src/HSFM/GUI/Gtk/Callbacks.hs index d88ddbc..8e6fda7 100644 --- a/src/HSFM/GUI/Gtk/Callbacks.hs +++ b/src/HSFM/GUI/Gtk/Callbacks.hs @@ -32,9 +32,10 @@ import Control.Exception ) import Control.Monad ( - forM_ - , forM + forM + , forM_ , join + , unless , void , when ) @@ -55,6 +56,10 @@ import Data.Foldable ( for_ ) +import Data.Maybe + ( + fromJust + ) import Graphics.UI.Gtk import qualified HPath as P import HPath @@ -78,6 +83,11 @@ import System.Glib.UTFString ( glibToString ) +import System.IO.Error + ( + catchIOError + , isUserError + ) import System.Posix.Env.ByteString ( getEnv @@ -296,6 +306,13 @@ setViewCallbacks mygui myview = do liftIO $ newFile mygui myview _ <- (rcFileNewDir . rcmenu) myview `on` menuItemActivated $ liftIO $ newDir mygui myview + _ <- (rcFileNewTab . rcmenu) myview `on` menuItemActivated $ + liftIO $ do + cwd <- getCurrentDir myview + newTabHere mygui cwd + _ <- (rcFileNewTabHere . rcmenu) myview `on` menuItemActivated $ + liftIO $ withItems mygui myview $ \items mygui' _ -> + forM_ items $ newTabHere mygui' _ <- (rcFileCopy . rcmenu) myview `on` menuItemActivated $ liftIO $ withItems mygui myview copyInit _ <- (rcFileRename . rcmenu) myview `on` menuItemActivated $ @@ -354,6 +371,42 @@ newTabHere mygui item@(DirOrSym _) = newTabHere _ _ = return () +-- |Creates a new tab with its own view and refreshes the view. +newTab :: MyGUI -> IO FMView -> Item -> IO MyView +newTab mygui iofmv item = do + -- create eventbox with label + label <- labelNewWithMnemonic + (maybe (P.fromAbs $ path item) P.fromRel $ P.basename $ path item) + ebox <- eventBoxNew + eventBoxSetVisibleWindow ebox False + containerAdd ebox label + widgetShowAll label + + myview <- createMyView mygui iofmv + _ <- notebookAppendPageMenu (notebook mygui) (viewBox myview) + ebox ebox + + notebookSetTabReorderable (notebook mygui) (viewBox myview) True + + catchIOError (refreshView mygui myview item) $ \e -> do + unless (isUserError e) (ioError e) + file <- readFile getFileInfo . fromJust . P.parseAbs . fromString + $ "/" + refreshView mygui myview file + labelSetText label (fromString "/") + + -- close callback + _ <- ebox `on` buttonPressEvent $ do + eb <- eventButton + case eb of + MiddleButton -> do + _ <- liftIO $ closeTab mygui myview + return True + _ -> return False + + return myview + + ---- FILE OPERATION CALLBACKS (COPY, MOVE, ...) ---- diff --git a/src/HSFM/GUI/Gtk/Callbacks/Utils.hs b/src/HSFM/GUI/Gtk/Callbacks/Utils.hs index 7602d48..6c44c92 100644 --- a/src/HSFM/GUI/Gtk/Callbacks/Utils.hs +++ b/src/HSFM/GUI/Gtk/Callbacks/Utils.hs @@ -111,6 +111,14 @@ goDir bhis mygui myview item = do -- set notebook tab label page <- notebookGetCurrentPage (notebook mygui) child <- fromJust <$> notebookGetNthPage (notebook mygui) page - notebookSetTabLabelText (notebook mygui) child - (maybe (P.fromAbs $ path item) P.fromRel $ P.basename . path $ item) + + -- get the label + ebox <- (castToEventBox . fromJust) + <$> notebookGetTabLabel (notebook mygui) child + label <- (castToLabel . head) <$> containerGetChildren ebox + + -- set the label + labelSetText label + (maybe (P.fromAbs $ path item) + P.fromRel $ P.basename . path $ item) diff --git a/src/HSFM/GUI/Gtk/Data.hs b/src/HSFM/GUI/Gtk/Data.hs index 8607961..f95e241 100644 --- a/src/HSFM/GUI/Gtk/Data.hs +++ b/src/HSFM/GUI/Gtk/Data.hs @@ -107,6 +107,8 @@ data RightClickMenu = MkRightClickMenu { , rcFileExecute :: !ImageMenuItem , rcFileNewRegFile :: !ImageMenuItem , rcFileNewDir :: !ImageMenuItem + , rcFileNewTab :: !ImageMenuItem + , rcFileNewTabHere :: !ImageMenuItem , rcFileCut :: !ImageMenuItem , rcFileCopy :: !ImageMenuItem , rcFileRename :: !ImageMenuItem diff --git a/src/HSFM/GUI/Gtk/MyView.hs b/src/HSFM/GUI/Gtk/MyView.hs index 72fc514..d491fb4 100644 --- a/src/HSFM/GUI/Gtk/MyView.hs +++ b/src/HSFM/GUI/Gtk/MyView.hs @@ -32,11 +32,6 @@ import Control.Concurrent.STM newTVarIO , readTVarIO ) -import Control.Monad - ( - forM_ - , unless - ) import Data.Foldable ( for_ @@ -46,10 +41,6 @@ import Data.Maybe catMaybes , fromJust ) -import Data.String - ( - fromString - ) import Graphics.UI.Gtk import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setViewCallbacks) import qualified HPath as P @@ -73,9 +64,7 @@ import System.INotify ) import System.IO.Error ( - catchIOError - , ioError - , isUserError + ioError ) import System.Posix.FilePath ( @@ -84,26 +73,6 @@ import System.Posix.FilePath --- |Creates a new tab with its own view and refreshes the view. -newTab :: MyGUI -> IO FMView -> Item -> IO MyView -newTab mygui iofmv item = do - myview <- createMyView mygui iofmv - i <- notebookAppendPage (notebook mygui) (viewBox myview) - (maybe (P.fromAbs $ path item) P.fromRel $ P.basename $ path item) - mpage <- notebookGetNthPage (notebook mygui) i - forM_ mpage $ \page -> notebookSetTabReorderable (notebook mygui) - page - True - catchIOError (refreshView mygui myview item) $ \e -> do - forM_ mpage $ \page -> do - file <- readFile getFileInfo . fromJust . P.parseAbs . fromString $ "/" - refreshView mygui myview file - notebookSetTabLabelText (notebook mygui) page "/" - unless (isUserError e) (ioError e) - - return myview - - -- |Constructs the initial MyView object with a few dummy models. -- It also initializes the callbacks. createMyView :: MyGUI @@ -138,6 +107,10 @@ createMyView mygui iofmv = do "rcFileNewRegFile" rcFileNewDir <- builderGetObject builder castToImageMenuItem "rcFileNewDir" + rcFileNewTab <- builderGetObject builder castToImageMenuItem + "rcFileNewTab" + rcFileNewTabHere <- builderGetObject builder castToImageMenuItem + "rcFileNewTabHere" rcFileCut <- builderGetObject builder castToImageMenuItem "rcFileCut" rcFileCopy <- builderGetObject builder castToImageMenuItem @@ -198,7 +171,7 @@ switchView mygui myview iofmv = do refreshView mygui nview cwd --- |Destroys the current view by disconnecting the watcher +-- |Destroys the given view by disconnecting the watcher -- and destroying the active FMView container. -- -- Everything that needs to be done in order to forget about a @@ -211,7 +184,7 @@ destroyView mygui myview = do mi <- tryTakeMVar (inotify myview) for_ mi $ \i -> killINotify i - page <- notebookGetCurrentPage (notebook mygui) + page <- fromJust <$> notebookPageNum (notebook mygui) (viewBox myview) -- destroy old view and tab page view' <- readTVarIO $ view myview