730 lines
24 KiB
Haskell
730 lines
24 KiB
Haskell
{--
|
|
HSFM, a filemanager written in Haskell.
|
|
Copyright (C) 2016 Julian Ospald
|
|
|
|
This program is free software; you can redistribute it and/or
|
|
modify it under the terms of the GNU General Public License
|
|
version 2 as published by the Free Software Foundation.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
along with this program; if not, write to the Free Software
|
|
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
|
|
|
|
|
|
import Control.Concurrent.STM
|
|
(
|
|
readTVarIO
|
|
)
|
|
import Control.Exception
|
|
(
|
|
throwIO
|
|
)
|
|
import Control.Monad
|
|
(
|
|
forM
|
|
, forM_
|
|
, join
|
|
, void
|
|
, when
|
|
)
|
|
import Control.Monad.IfElse
|
|
import Control.Monad.IO.Class
|
|
(
|
|
liftIO
|
|
)
|
|
import Control.Monad.Loops
|
|
(
|
|
iterateUntil
|
|
)
|
|
import Data.ByteString
|
|
(
|
|
ByteString
|
|
)
|
|
import Data.ByteString.UTF8
|
|
(
|
|
fromString
|
|
, toString
|
|
)
|
|
import Data.Foldable
|
|
(
|
|
for_
|
|
)
|
|
import Graphics.UI.Gtk
|
|
import qualified HPath as P
|
|
import HPath
|
|
(
|
|
fromAbs
|
|
, Abs
|
|
, Path
|
|
)
|
|
import HPath.IO
|
|
import HPath.IO.Errors
|
|
import HSFM.FileSystem.FileType
|
|
import HSFM.FileSystem.UtilTypes
|
|
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
|
|
import HSFM.Settings
|
|
import HSFM.Utils.IO
|
|
import Prelude hiding(readFile)
|
|
import System.Glib.UTFString
|
|
(
|
|
glibToString
|
|
)
|
|
import qualified System.Posix.Process.ByteString as SPP
|
|
import System.Posix.Types
|
|
(
|
|
ProcessID
|
|
)
|
|
import Control.Concurrent.MVar
|
|
(
|
|
putMVar
|
|
, readMVar
|
|
, takeMVar
|
|
)
|
|
import Paths_hsfm
|
|
(
|
|
getDataFileName
|
|
)
|
|
|
|
|
|
|
|
|
|
-----------------
|
|
--[ Callbacks ]--
|
|
-----------------
|
|
|
|
|
|
|
|
|
|
---- MAIN CALLBACK ENTRYPOINT ----
|
|
|
|
|
|
-- |Set callbacks for the whole gui, on hotkeys, events and stuff.
|
|
setGUICallbacks :: MyGUI -> IO ()
|
|
setGUICallbacks mygui = do
|
|
|
|
-- notebook toggle buttons
|
|
_ <- leftNbBtn mygui `on` toggled $ do
|
|
isPressed <- toggleButtonGetActive $ leftNbBtn mygui
|
|
if isPressed then widgetShow $ notebook1 mygui
|
|
else widgetHide $ notebook1 mygui
|
|
|
|
_ <- rightNbBtn mygui `on` toggled $ do
|
|
isPressed <- toggleButtonGetActive $ rightNbBtn mygui
|
|
if isPressed then widgetShow $ notebook2 mygui
|
|
else widgetHide $ notebook2 mygui
|
|
|
|
-- statusbar
|
|
_ <- clearStatusBar mygui `on` buttonActivated $ do
|
|
popStatusbar mygui
|
|
writeTVarIO (operationBuffer mygui) None
|
|
|
|
-- menubar-file
|
|
_ <- (menubarFileQuit . menubar) mygui `on` menuItemActivated $
|
|
mainQuit
|
|
|
|
-- menubar-help
|
|
_ <- (menubarHelpAbout . menubar) mygui `on` menuItemActivated $
|
|
liftIO showAboutDialog
|
|
return ()
|
|
|
|
-- key events
|
|
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
|
|
QuitModifier <- eventModifier
|
|
QuitKey <- fmap glibToString eventKeyName
|
|
liftIO mainQuit
|
|
|
|
return ()
|
|
|
|
|
|
-- |Set callbacks specific to a given view, on hotkeys, events and stuff.
|
|
setViewCallbacks :: MyGUI -> MyView -> IO ()
|
|
setViewCallbacks mygui myview = do
|
|
view' <- readTVarIO $ view myview
|
|
case view' of
|
|
fmv@(FMTreeView treeView) -> do
|
|
_ <- treeView `on` rowActivated
|
|
$ (\_ _ -> withItems mygui myview open)
|
|
|
|
-- drag events
|
|
_ <- treeView `on` dragBegin $
|
|
\_ -> withItems mygui myview moveInit
|
|
_ <- treeView `on` dragDrop $
|
|
\dc p ts -> do
|
|
p' <- treeViewConvertWidgetToTreeCoords treeView p
|
|
mpath <- treeViewGetPathAtPos treeView p'
|
|
case mpath of
|
|
Nothing -> do
|
|
dragFinish dc False False ts
|
|
return False
|
|
Just _ -> do
|
|
atom <- atomNew ("HSFM" :: String)
|
|
dragGetData treeView dc atom ts
|
|
return True
|
|
_ <- treeView `on` dragDataReceived $
|
|
\dc p _ ts ->
|
|
liftIO $ do
|
|
signalStopEmission treeView "drag_data_received"
|
|
p' <- treeViewConvertWidgetToTreeCoords treeView p
|
|
mpath <- treeViewGetPathAtPos treeView p'
|
|
case mpath of
|
|
Nothing -> dragFinish dc False False ts
|
|
Just (tp, _, _) -> do
|
|
mitem <- rawPathToItem myview tp
|
|
forM_ mitem $ \item ->
|
|
operationFinal mygui myview (Just item)
|
|
dragFinish dc True False ts
|
|
|
|
commonGuiEvents fmv
|
|
return ()
|
|
fmv@(FMIconView iconView) -> do
|
|
_ <- iconView `on` itemActivated
|
|
$ (\_ -> withItems mygui myview open)
|
|
commonGuiEvents fmv
|
|
return ()
|
|
where
|
|
commonGuiEvents fmv = do
|
|
let view = fmViewToContainer fmv
|
|
|
|
-- focus events
|
|
_ <- notebook1 mygui `on` setFocusChild $ \w ->
|
|
case w of
|
|
Nothing -> widgetSetSensitive (leftNbIcon mygui) False
|
|
_ -> widgetSetSensitive (leftNbIcon mygui) True
|
|
_ <- notebook2 mygui `on` setFocusChild $ \w ->
|
|
case w of
|
|
Nothing -> widgetSetSensitive (rightNbIcon mygui) False
|
|
_ -> widgetSetSensitive (rightNbIcon mygui) True
|
|
|
|
-- GUI events
|
|
_ <- backViewB myview `on` buttonPressEvent $ do
|
|
eb <- eventButton
|
|
t <- eventTime
|
|
case eb of
|
|
LeftButton -> do
|
|
liftIO $ void $ goHistoryBack mygui myview
|
|
return True
|
|
RightButton -> do
|
|
his <- liftIO $ readMVar (history myview)
|
|
menu <- liftIO $ mkHistoryMenuB mygui myview
|
|
(backwardsHistory his)
|
|
_ <- liftIO $ menuPopup menu $ Just (RightButton, t)
|
|
return True
|
|
_ -> return False
|
|
_ <- forwardViewB myview `on` buttonPressEvent $ do
|
|
eb <- eventButton
|
|
t <- eventTime
|
|
case eb of
|
|
LeftButton -> do
|
|
liftIO $ void $ goHistoryForward mygui myview
|
|
return True
|
|
RightButton -> do
|
|
his <- liftIO $ readMVar (history myview)
|
|
menu <- liftIO $ mkHistoryMenuF mygui myview
|
|
(forwardHistory his)
|
|
_ <- liftIO $ menuPopup menu $ Just (RightButton, t)
|
|
return True
|
|
_ -> return False
|
|
_ <- urlBar myview `on` entryActivated $ urlGoTo mygui myview
|
|
_ <- upViewB myview `on` buttonActivated $
|
|
upDir mygui myview
|
|
_ <- homeViewB myview `on` buttonActivated $
|
|
goHome mygui myview
|
|
_ <- refreshViewB myview `on` buttonActivated $ do
|
|
cdir <- liftIO $ getCurrentDir myview
|
|
refreshView mygui myview cdir
|
|
|
|
-- key events
|
|
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
|
ShowHiddenModifier <- eventModifier
|
|
ShowHiddenKey <- fmap glibToString eventKeyName
|
|
cdir <- liftIO $ getCurrentDir myview
|
|
liftIO $ modifyTVarIO (settings mygui)
|
|
(\x -> x { showHidden = not . showHidden $ x})
|
|
>> refreshView mygui myview cdir
|
|
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
|
UpDirModifier <- eventModifier
|
|
UpDirKey <- fmap glibToString eventKeyName
|
|
liftIO $ upDir mygui myview
|
|
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
|
HistoryBackModifier <- eventModifier
|
|
HistoryBackKey <- fmap glibToString eventKeyName
|
|
liftIO $ void $ goHistoryBack mygui myview
|
|
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
|
HistoryForwardModifier <- eventModifier
|
|
HistoryForwardKey <- fmap glibToString eventKeyName
|
|
liftIO $ void $ goHistoryForward mygui myview
|
|
_ <- view `on` keyPressEvent $ tryEvent $ do
|
|
DeleteModifier <- eventModifier
|
|
DeleteKey <- fmap glibToString eventKeyName
|
|
liftIO $ withItems mygui myview del
|
|
_ <- view `on` keyPressEvent $ tryEvent $ do
|
|
OpenModifier <- eventModifier
|
|
OpenKey <- fmap glibToString eventKeyName
|
|
liftIO $ withItems mygui myview open
|
|
_ <- view `on` keyPressEvent $ tryEvent $ do
|
|
CopyModifier <- eventModifier
|
|
CopyKey <- fmap glibToString eventKeyName
|
|
liftIO $ withItems mygui myview copyInit
|
|
_ <- view `on` keyPressEvent $ tryEvent $ do
|
|
MoveModifier <- eventModifier
|
|
MoveKey <- fmap glibToString eventKeyName
|
|
liftIO $ withItems mygui myview moveInit
|
|
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
|
PasteModifier <- eventModifier
|
|
PasteKey <- fmap glibToString eventKeyName
|
|
liftIO $ operationFinal mygui myview Nothing
|
|
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
|
NewTabModifier <- eventModifier
|
|
NewTabKey <- fmap glibToString eventKeyName
|
|
liftIO $ void $ newTab' mygui myview
|
|
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
|
CloseTabModifier <- eventModifier
|
|
CloseTabKey <- fmap glibToString eventKeyName
|
|
liftIO $ void $ closeTab mygui myview
|
|
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
|
|
OpenTerminalModifier <- eventModifier
|
|
OpenTerminalKey <- fmap glibToString eventKeyName
|
|
liftIO $ void $ openTerminalHere myview
|
|
|
|
-- mouse button click
|
|
_ <- view `on` buttonPressEvent $ do
|
|
eb <- eventButton
|
|
t <- eventTime
|
|
case eb of
|
|
RightButton -> do
|
|
_ <- liftIO $ showPopup mygui myview t
|
|
-- this is just to not screw with current selection
|
|
-- on right-click
|
|
-- TODO: this misbehaves under IconView
|
|
(x, y) <- eventCoordinates
|
|
mpath <- liftIO $ getPathAtPos fmv (x, y)
|
|
case mpath of
|
|
-- item under the cursor, only pass on the signal
|
|
-- if the item under the cursor is not within the current
|
|
-- selection
|
|
(Just tp) -> do
|
|
selectedTps <- liftIO $ getSelectedTreePaths mygui myview
|
|
return $ elem tp selectedTps
|
|
-- no item under the cursor, pass on the signal
|
|
Nothing -> return False
|
|
MiddleButton -> do
|
|
(x, y) <- eventCoordinates
|
|
mitem <- liftIO $ (getPathAtPos fmv (x, y))
|
|
>>= \mpos -> fmap join
|
|
$ forM mpos (rawPathToItem myview)
|
|
|
|
case mitem of
|
|
-- item under the cursor, only pass on the signal
|
|
-- if the item under the cursor is not within the current
|
|
-- selection
|
|
(Just item) -> do
|
|
liftIO $ opeInNewTab mygui myview item
|
|
return True
|
|
-- no item under the cursor, pass on the signal
|
|
Nothing -> return False
|
|
|
|
OtherButton 8 -> do
|
|
liftIO $ void $ goHistoryBack mygui myview
|
|
return False
|
|
OtherButton 9 -> do
|
|
liftIO $ void $ goHistoryForward mygui myview
|
|
return False
|
|
-- not right-click, so pass on the signal
|
|
_ -> return False
|
|
|
|
return ()
|
|
getPathAtPos fmv (x, y) =
|
|
case fmv of
|
|
FMTreeView treeView -> do
|
|
mp <- treeViewGetPathAtPos treeView (round x, round y)
|
|
return $ fmap (\(p, _, _) -> p) mp
|
|
FMIconView iconView ->
|
|
fmap (\tp -> if null tp then Nothing else Just tp)
|
|
$ iconViewGetPathAtPos iconView (round x) (round y)
|
|
|
|
|
|
|
|
|
|
---- OTHER ----
|
|
|
|
|
|
openTerminalHere :: MyView -> IO ProcessID
|
|
openTerminalHere myview = do
|
|
cwd <- (P.fromAbs . path) <$> getCurrentDir myview
|
|
SPP.forkProcess $ terminalCommand cwd
|
|
|
|
|
|
|
|
|
|
---- TAB OPERATIONS ----
|
|
|
|
|
|
-- |Closes the current tab, but only if there is more than one tab.
|
|
closeTab :: MyGUI -> MyView -> IO ()
|
|
closeTab _ myview = do
|
|
n <- notebookGetNPages (notebook myview)
|
|
when (n > 1) $ void $ destroyView myview
|
|
|
|
|
|
newTab' :: MyGUI -> MyView -> IO ()
|
|
newTab' mygui myview = do
|
|
cwd <- getCurrentDir myview
|
|
void $ withErrorDialog
|
|
$ newTab mygui (notebook myview) createTreeView cwd (-1)
|
|
|
|
|
|
opeInNewTab :: MyGUI -> MyView -> Item -> IO ()
|
|
opeInNewTab mygui myview item@(DirOrSym _) =
|
|
void $ withErrorDialog
|
|
$ newTab mygui (notebook myview) createTreeView item (-1)
|
|
opeInNewTab _ _ _ = return ()
|
|
|
|
|
|
|
|
---- FILE OPERATION CALLBACKS (COPY, MOVE, ...) ----
|
|
|
|
|
|
-- |Supposed to be used with 'withRows'. Deletes a file or directory.
|
|
del :: [Item] -> MyGUI -> MyView -> IO ()
|
|
del [item] _ _ = withErrorDialog $ do
|
|
let cmsg = "Really delete \"" ++ getFPasStr item ++ "\"?"
|
|
withConfirmationDialog cmsg
|
|
$ easyDelete . path $ item
|
|
-- this throws on the first error that occurs
|
|
del items@(_:_) _ _ = withErrorDialog $ do
|
|
let cmsg = "Really delete " ++ show (length items) ++ " files?"
|
|
withConfirmationDialog cmsg
|
|
$ forM_ items $ \item -> easyDelete . path $ item
|
|
del _ _ _ = withErrorDialog
|
|
. ioError $ userError
|
|
"Operation not supported on multiple files"
|
|
|
|
|
|
-- |Initializes a file move operation.
|
|
moveInit :: [Item] -> MyGUI -> MyView -> IO ()
|
|
moveInit items@(_:_) mygui _ = do
|
|
writeTVarIO (operationBuffer mygui) (FMove . PartialMove . map path $ items)
|
|
let sbmsg = case items of
|
|
(item:[]) -> "Move buffer: " ++ getFPasStr item
|
|
_ -> "Move buffer: " ++ (show . length $ items)
|
|
++ " items"
|
|
popStatusbar mygui
|
|
void $ pushStatusBar mygui sbmsg
|
|
moveInit _ _ _ = withErrorDialog
|
|
. ioError $ userError
|
|
"No file selected!"
|
|
|
|
-- |Supposed to be used with 'withRows'. Initializes a file copy operation.
|
|
copyInit :: [Item] -> MyGUI -> MyView -> IO ()
|
|
copyInit items@(_:_) mygui _ = do
|
|
writeTVarIO (operationBuffer mygui) (FCopy . PartialCopy . map path $ items)
|
|
let sbmsg = case items of
|
|
(item:[]) -> "Copy buffer: " ++ getFPasStr item
|
|
_ -> "Copy buffer: " ++ (show . length $ items)
|
|
++ " items"
|
|
popStatusbar mygui
|
|
void $ pushStatusBar mygui sbmsg
|
|
copyInit _ _ _ = withErrorDialog
|
|
. ioError $ userError
|
|
"No file selected!"
|
|
|
|
|
|
-- |Finalizes a file operation, such as copy or move.
|
|
operationFinal :: MyGUI -> MyView -> Maybe Item -> IO ()
|
|
operationFinal mygui myview mitem = withErrorDialog $ do
|
|
op <- readTVarIO (operationBuffer mygui)
|
|
cdir <- case mitem of
|
|
Nothing -> path <$> getCurrentDir myview
|
|
Just x -> return $ path x
|
|
case op of
|
|
FMove (PartialMove s) -> do
|
|
let cmsg = "Really move " ++ imsg s
|
|
++ " to \"" ++ toString (P.fromAbs cdir)
|
|
++ "\"?"
|
|
withConfirmationDialog cmsg $ doFileOperation (FMove $ Move s cdir)
|
|
popStatusbar mygui
|
|
writeTVarIO (operationBuffer mygui) None
|
|
FCopy (PartialCopy s) -> do
|
|
let cmsg = "Really copy " ++ imsg s
|
|
++ " to \"" ++ toString (P.fromAbs cdir)
|
|
++ "\"?"
|
|
withConfirmationDialog cmsg $ doFileOperation (FCopy $ Copy s cdir)
|
|
_ -> return ()
|
|
where
|
|
imsg s = case s of
|
|
(item:[]) -> "\"" ++ toString (P.fromAbs item) ++ "\""
|
|
items -> (show . length $ items) ++ " items"
|
|
|
|
|
|
-- |Create a new file.
|
|
newFile :: MyGUI -> MyView -> IO ()
|
|
newFile _ myview = withErrorDialog $ do
|
|
mfn <- textInputDialog "Enter file name" ("" :: String)
|
|
let pmfn = P.parseFn =<< fromString <$> mfn
|
|
for_ pmfn $ \fn -> do
|
|
cdir <- getCurrentDir myview
|
|
createRegularFile newFilePerms (path cdir P.</> fn)
|
|
|
|
|
|
-- |Create a new directory.
|
|
newDir :: MyGUI -> MyView -> IO ()
|
|
newDir _ myview = withErrorDialog $ do
|
|
mfn <- textInputDialog "Enter directory name" ("" :: String)
|
|
let pmfn = P.parseFn =<< fromString <$> mfn
|
|
for_ pmfn $ \fn -> do
|
|
cdir <- getCurrentDir myview
|
|
createDir newDirPerms (path cdir P.</> fn)
|
|
|
|
|
|
renameF :: [Item] -> MyGUI -> MyView -> IO ()
|
|
renameF [item] _ _ = withErrorDialog $ do
|
|
iname <- P.fromRel <$> (P.basename $ path item)
|
|
mfn <- textInputDialog "Enter new file name" (iname :: ByteString)
|
|
let pmfn = P.parseFn =<< fromString <$> mfn
|
|
for_ pmfn $ \fn -> do
|
|
let cmsg = "Really rename \"" ++ getFPasStr item
|
|
++ "\"" ++ " to \""
|
|
++ toString (P.fromAbs $ (P.dirname . path $ item)
|
|
P.</> fn) ++ "\"?"
|
|
withConfirmationDialog cmsg $
|
|
HPath.IO.renameFile (path item)
|
|
((P.dirname $ path item) P.</> fn)
|
|
renameF _ _ _ = withErrorDialog
|
|
. ioError $ userError
|
|
"Operation not supported on multiple files"
|
|
|
|
|
|
|
|
|
|
---- DIRECTORY TRAVERSAL AND FILE OPENING CALLBACKS ----
|
|
|
|
|
|
-- |Go to the url given at the 'urlBar' and visualize it in the given
|
|
-- treeView.
|
|
--
|
|
-- If the url is invalid, does nothing.
|
|
urlGoTo :: MyGUI -> MyView -> IO ()
|
|
urlGoTo mygui myview = withErrorDialog $ do
|
|
fp <- entryGetText (urlBar myview)
|
|
forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' ->
|
|
whenM (canOpenDirectory fp')
|
|
(goDir True mygui myview =<< (pathToFile getFileInfo $ fp'))
|
|
|
|
|
|
goHome :: MyGUI -> MyView -> IO ()
|
|
goHome mygui myview = withErrorDialog $ do
|
|
homedir <- home
|
|
forM_ (P.parseAbs homedir :: Maybe (Path Abs)) $ \fp' ->
|
|
whenM (canOpenDirectory fp')
|
|
(goDir True mygui myview =<< (pathToFile getFileInfo $ fp'))
|
|
|
|
|
|
-- |Execute a given file.
|
|
execute :: [Item] -> MyGUI -> MyView -> IO ()
|
|
execute [item] _ _ = withErrorDialog $
|
|
void $ executeFile (path item) []
|
|
execute _ _ _ = withErrorDialog
|
|
. ioError $ userError
|
|
"Operation not supported on multiple files"
|
|
|
|
|
|
-- |Supposed to be used with 'withRows'. Opens a file or directory.
|
|
open :: [Item] -> MyGUI -> MyView -> IO ()
|
|
open [item] mygui myview = withErrorDialog $
|
|
case item of
|
|
DirOrSym r -> do
|
|
nv <- pathToFile getFileInfo $ path r
|
|
goDir True mygui myview nv
|
|
r ->
|
|
void $ openFile . path $ r
|
|
open items mygui myview = do
|
|
let dirs = filter (fst . sdir) items
|
|
files = filter (fst . sfileLike) items
|
|
forM_ dirs (withErrorDialog . opeInNewTab mygui myview)
|
|
forM_ files (withErrorDialog . openFile . path)
|
|
|
|
|
|
-- |Go up one directory and visualize it in the treeView.
|
|
upDir :: MyGUI -> MyView -> IO ()
|
|
upDir mygui myview = withErrorDialog $ do
|
|
cdir <- getCurrentDir myview
|
|
nv <- goUp cdir
|
|
goDir True mygui myview nv
|
|
|
|
|
|
|
|
|
|
---- HISTORY CALLBACKS ----
|
|
|
|
|
|
-- |Go "back" in the history.
|
|
goHistoryBack :: MyGUI -> MyView -> IO (Path Abs)
|
|
goHistoryBack mygui myview = do
|
|
hs <- takeMVar (history myview)
|
|
let nhs = historyBack hs
|
|
putMVar (history myview) nhs
|
|
nv <- pathToFile getFileInfo $ currentDir nhs
|
|
goDir False mygui myview nv
|
|
return $ currentDir nhs
|
|
|
|
|
|
-- |Go "forward" in the history.
|
|
goHistoryForward :: MyGUI -> MyView -> IO (Path Abs)
|
|
goHistoryForward mygui myview = do
|
|
hs <- takeMVar (history myview)
|
|
let nhs = historyForward hs
|
|
putMVar (history myview) nhs
|
|
nv <- pathToFile getFileInfo $ currentDir nhs
|
|
goDir False mygui myview nv
|
|
return $ currentDir nhs
|
|
|
|
|
|
-- |Show backwards history in a drop-down menu, depending on the input.
|
|
mkHistoryMenuB :: MyGUI -> MyView -> [Path Abs] -> IO Menu
|
|
mkHistoryMenuB mygui myview hs = do
|
|
menu <- menuNew
|
|
menuitems <- forM hs $ \p -> do
|
|
item <- menuItemNewWithLabel (fromAbs p)
|
|
_ <- item `on` menuItemActivated $
|
|
void $ iterateUntil (== p) (goHistoryBack mygui myview)
|
|
return item
|
|
forM_ menuitems $ \item -> menuShellAppend menu item
|
|
widgetShowAll menu
|
|
return menu
|
|
|
|
|
|
-- |Show forward history in a drop-down menu, depending on the input.
|
|
mkHistoryMenuF :: MyGUI -> MyView -> [Path Abs] -> IO Menu
|
|
mkHistoryMenuF mygui myview hs = do
|
|
menu <- menuNew
|
|
menuitems <- forM hs $ \p -> do
|
|
item <- menuItemNewWithLabel (fromAbs p)
|
|
_ <- item `on` menuItemActivated $
|
|
void $ iterateUntil (== p) (goHistoryForward mygui myview)
|
|
return item
|
|
forM_ menuitems $ \item -> menuShellAppend menu item
|
|
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 {..}
|
|
|