diff --git a/src/HSFM/GUI/Gtk/Callbacks.hs b/src/HSFM/GUI/Gtk/Callbacks.hs index 8fd394c..d39024b 100644 --- a/src/HSFM/GUI/Gtk/Callbacks.hs +++ b/src/HSFM/GUI/Gtk/Callbacks.hs @@ -17,6 +17,7 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. --} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_HADDOCK ignore-exports #-} module HSFM.GUI.Gtk.Callbacks where @@ -76,6 +77,7 @@ import HSFM.GUI.Gtk.Callbacks.Utils import HSFM.GUI.Gtk.Data import HSFM.GUI.Gtk.Dialogs import HSFM.GUI.Gtk.MyView +import HSFM.GUI.Gtk.Plugins import HSFM.GUI.Gtk.Settings import HSFM.GUI.Gtk.Utils import HSFM.History @@ -97,7 +99,10 @@ import Control.Concurrent.MVar , readMVar , takeMVar ) - +import Paths_hsfm + ( + getDataFileName + ) @@ -284,8 +289,7 @@ setViewCallbacks mygui myview = do t <- eventTime case eb of RightButton -> do - _ <- liftIO $ menuPopup (rcMenu . rcmenu $ myview) - $ Just (RightButton, t) + _ <- liftIO $ showPopup mygui myview t -- this is just to not screw with current selection -- on right-click -- TODO: this misbehaves under IconView @@ -325,37 +329,7 @@ setViewCallbacks mygui myview = do -- not right-click, so pass on the signal _ -> return False - -- right click menu - _ <- (rcFileOpen . rcmenu) myview `on` menuItemActivated $ - liftIO $ withItems mygui myview open - _ <- (rcFileExecute . rcmenu) myview `on` menuItemActivated $ - liftIO $ withItems mygui myview execute - _ <- (rcFileNewRegFile . rcmenu) myview `on` menuItemActivated $ - liftIO $ newFile mygui myview - _ <- (rcFileNewDir . rcmenu) myview `on` menuItemActivated $ - liftIO $ newDir mygui myview - _ <- (rcFileNewTab . rcmenu) myview `on` menuItemActivated $ - liftIO $ newTab' mygui myview - _ <- (rcFileNewTerm . rcmenu) myview `on` menuItemActivated $ - liftIO $ void $ openTerminalHere myview - _ <- (rcFileCopy . rcmenu) myview `on` menuItemActivated $ - liftIO $ withItems mygui myview copyInit - _ <- (rcFileRename . rcmenu) myview `on` menuItemActivated $ - liftIO $ withItems mygui myview renameF - _ <- (rcFilePaste . rcmenu) myview `on` menuItemActivated $ - liftIO $ operationFinal mygui myview Nothing - _ <- (rcFileDelete . rcmenu) myview `on` menuItemActivated $ - liftIO $ withItems mygui myview del - _ <- (rcFileProperty . rcmenu) myview `on` menuItemActivated $ - liftIO $ withItems mygui myview showFilePropertyDialog - _ <- (rcFileCut . rcmenu) myview `on` menuItemActivated $ - liftIO $ withItems mygui myview moveInit - _ <- (rcFileIconView . rcmenu) myview `on` menuItemActivated $ - liftIO $ switchView mygui myview createIconView - _ <- (rcFileTreeView . rcmenu) myview `on` menuItemActivated $ - liftIO $ switchView mygui myview createTreeView return () - getPathAtPos fmv (x, y) = case fmv of FMTreeView treeView -> do @@ -627,3 +601,105 @@ mkHistoryMenuF mygui myview hs = do widgetShowAll menu return menu + + + +---- RIGHTCLICK CALLBACKS ---- + + +-- |TODO: hopefully this does not leak +showPopup :: MyGUI -> MyView -> TimeStamp -> IO () +showPopup mygui myview t + | null myplugins = return () + | otherwise = do + + rcmenu <- doRcMenu + + -- add common callbacks + _ <- (\_ -> rcFileOpen rcmenu) myview `on` menuItemActivated $ + liftIO $ withItems mygui myview open + _ <- (rcFileExecute rcmenu) `on` menuItemActivated $ + liftIO $ withItems mygui myview execute + _ <- (rcFileNewRegFile rcmenu) `on` menuItemActivated $ + liftIO $ newFile mygui myview + _ <- (rcFileNewDir rcmenu) `on` menuItemActivated $ + liftIO $ newDir mygui myview + _ <- (rcFileNewTab rcmenu) `on` menuItemActivated $ + liftIO $ newTab' mygui myview + _ <- (rcFileNewTerm rcmenu) `on` menuItemActivated $ + liftIO $ void $ openTerminalHere myview + _ <- (rcFileCopy rcmenu) `on` menuItemActivated $ + liftIO $ withItems mygui myview copyInit + _ <- (rcFileRename rcmenu) `on` menuItemActivated $ + liftIO $ withItems mygui myview renameF + _ <- (rcFilePaste rcmenu) `on` menuItemActivated $ + liftIO $ operationFinal mygui myview Nothing + _ <- (rcFileDelete rcmenu) `on` menuItemActivated $ + liftIO $ withItems mygui myview del + _ <- (rcFileProperty rcmenu) `on` menuItemActivated $ + liftIO $ withItems mygui myview showFilePropertyDialog + _ <- (rcFileCut rcmenu) `on` menuItemActivated $ + liftIO $ withItems mygui myview moveInit + _ <- (rcFileIconView rcmenu) `on` menuItemActivated $ + liftIO $ switchView mygui myview createIconView + _ <- (rcFileTreeView rcmenu) `on` menuItemActivated $ + liftIO $ switchView mygui myview createTreeView + + + -- add another plugin separator after the existing one + -- where we want to place our plugins + sep2 <- separatorMenuItemNew + widgetShow sep2 + + menuShellInsert (rcMenu rcmenu) sep2 insertPos + + plugins <- forM myplugins $ \(ma, mb, mc) -> fmap (, mb, mc) ma + -- need to reverse plugins list so the order is right + forM_ (reverse plugins) $ \(plugin, filter', cb) -> do + showItem <- withItems mygui myview filter' + + menuShellInsert (rcMenu rcmenu) plugin insertPos + when showItem $ widgetShow plugin + -- init callback + plugin `on` menuItemActivated $ withItems mygui myview cb + + menuPopup (rcMenu rcmenu) $ Just (RightButton, t) + where + doRcMenu = do + builder <- builderNew + builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml" + + -- create static right-click menu + rcMenu <- builderGetObject builder castToMenu + (fromString "rcMenu") + rcFileOpen <- builderGetObject builder castToImageMenuItem + (fromString "rcFileOpen") + rcFileExecute <- builderGetObject builder castToImageMenuItem + (fromString "rcFileExecute") + rcFileNewRegFile <- builderGetObject builder castToImageMenuItem + (fromString "rcFileNewRegFile") + rcFileNewDir <- builderGetObject builder castToImageMenuItem + (fromString "rcFileNewDir") + rcFileNewTab <- builderGetObject builder castToImageMenuItem + (fromString "rcFileNewTab") + rcFileNewTerm <- builderGetObject builder castToImageMenuItem + (fromString "rcFileNewTerm") + rcFileCut <- builderGetObject builder castToImageMenuItem + (fromString "rcFileCut") + rcFileCopy <- builderGetObject builder castToImageMenuItem + (fromString "rcFileCopy") + rcFileRename <- builderGetObject builder castToImageMenuItem + (fromString "rcFileRename") + rcFilePaste <- builderGetObject builder castToImageMenuItem + (fromString "rcFilePaste") + rcFileDelete <- builderGetObject builder castToImageMenuItem + (fromString "rcFileDelete") + rcFileProperty <- builderGetObject builder castToImageMenuItem + (fromString "rcFileProperty") + rcFileIconView <- builderGetObject builder castToImageMenuItem + (fromString "rcFileIconView") + rcFileTreeView <- builderGetObject builder castToImageMenuItem + (fromString "rcFileTreeView") + + return $ MkRightClickMenu {..} + diff --git a/src/HSFM/GUI/Gtk/Data.hs b/src/HSFM/GUI/Gtk/Data.hs index e0bb27f..1b5167b 100644 --- a/src/HSFM/GUI/Gtk/Data.hs +++ b/src/HSFM/GUI/Gtk/Data.hs @@ -84,7 +84,6 @@ data MyView = MkMyView { -- sub-widgets , scroll :: !ScrolledWindow , viewBox :: !Box - , rcmenu :: !RightClickMenu , backViewB :: !Button , upViewB :: !Button , forwardViewB :: !Button diff --git a/src/HSFM/GUI/Gtk/MyView.hs b/src/HSFM/GUI/Gtk/MyView.hs index 257d86d..2e1b139 100644 --- a/src/HSFM/GUI/Gtk/MyView.hs +++ b/src/HSFM/GUI/Gtk/MyView.hs @@ -208,8 +208,6 @@ createMyView mygui iofmv = do let rcmenu = MkRightClickMenu {..} let myview = MkMyView {..} - addPlugins mygui myview - -- set the bindings setViewCallbacks mygui myview diff --git a/src/HSFM/GUI/Gtk/Plugins.hs b/src/HSFM/GUI/Gtk/Plugins.hs index 5f78031..2d62dad 100644 --- a/src/HSFM/GUI/Gtk/Plugins.hs +++ b/src/HSFM/GUI/Gtk/Plugins.hs @@ -17,7 +17,6 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. --} -{-# LANGUAGE TupleSections #-} {-# OPTIONS_HADDOCK ignore-exports #-} @@ -51,42 +50,13 @@ import qualified Data.ByteString as BS + --------------- --[ Plugins ]-- --------------- ----- Init functions ---- - - --- |Usually, you don't want to overwrite this method. It --- adds plugins from `myplugins` and initializes the callbacks --- automatically. -addPlugins :: MyGUI -> MyView -> IO () -addPlugins mygui myview - | null myplugins = return () - | otherwise = do - -- add another plugin separator after the existing one - -- where we want to place our plugins - sep2 <- separatorMenuItemNew - widgetShow sep2 - - menuShellInsert (rcMenu . rcmenu $ myview) sep2 insertPos - - plugins <- forM myplugins $ \(ma,mb) -> fmap (,mb) ma - -- need to reverse plugins list so the order is right - forM_ (reverse plugins) $ \(plugin, cb) -> do - menuShellInsert (rcMenu . rcmenu $ myview) plugin insertPos - widgetShow plugin - -- init callback - plugin `on` menuItemActivated $ withItems mygui myview cb - - return () - - - - ---- Global settings ---- @@ -98,11 +68,19 @@ insertPos = 4 -- |A list of plugins to add to the right-click menu at position --- `insertPos`. The left part of the tuple is the menuitem, the right --- part the callback. +-- `insertPos`. +-- +-- The left part of the triple is the menuitem. +-- The middle part of the triple is a filter function that +-- decides whether the item is shown. +-- The right part of the triple is the callback, which is invoked +-- when the menu item is clicked. +-- -- Plugins are added in order of this list. -myplugins :: [(IO MenuItem, [Item] -> MyGUI -> MyView -> IO ())] -myplugins = [(diffItem, diffCallback) +myplugins :: [(IO MenuItem + ,[Item] -> MyGUI -> MyView -> IO Bool + ,[Item] -> MyGUI -> MyView -> IO ())] +myplugins = [(diffItem, diffFilter, diffCallback) ] @@ -116,6 +94,11 @@ myplugins = [(diffItem, diffCallback) diffItem :: IO MenuItem diffItem = menuItemNewWithLabel "diff" +diffFilter :: [Item] -> MyGUI -> MyView -> IO Bool +diffFilter items _ _ + | length items > 1 = return $ and $ fmap isFileC items + | otherwise = return False + diffCallback :: [Item] -> MyGUI -> MyView -> IO () diffCallback items _ _ = void $ forkProcess $ diff --git a/src/HSFM/GUI/Gtk/Utils.hs b/src/HSFM/GUI/Gtk/Utils.hs index 7cee258..7d64d47 100644 --- a/src/HSFM/GUI/Gtk/Utils.hs +++ b/src/HSFM/GUI/Gtk/Utils.hs @@ -78,8 +78,8 @@ withItems :: MyGUI -> ( [Item] -> MyGUI -> MyView - -> IO ()) -- ^ action to carry out - -> IO () + -> IO a) -- ^ action to carry out + -> IO a withItems mygui myview io = do items <- getSelectedItems mygui myview io items mygui myview