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.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 HPath.IO.Utils
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
)
setGUICallbacks :: MyGUI -> IO ()
setGUICallbacks mygui = do
_ <- clearStatusBar mygui `on` buttonActivated $ do
popStatusbar mygui
writeTVarIO (operationBuffer mygui) None
_ <- (menubarFileQuit . menubar) mygui `on` menuItemActivated $
mainQuit
_ <- (menubarHelpAbout . menubar) mygui `on` menuItemActivated $
liftIO showAboutDialog
return ()
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
QuitModifier <- eventModifier
QuitKey <- fmap glibToString eventKeyName
liftIO mainQuit
return ()
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)
_ <- 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
_ <- 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
_ <- 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
_ <- view `on` buttonPressEvent $ do
eb <- eventButton
t <- eventTime
case eb of
RightButton -> do
_ <- liftIO $ showPopup mygui myview t
(x, y) <- eventCoordinates
mpath <- liftIO $ getPathAtPos fmv (x, y)
case mpath of
(Just tp) -> do
selectedTps <- liftIO $ getSelectedTreePaths mygui myview
return $ elem tp selectedTps
Nothing -> return False
MiddleButton -> do
(x, y) <- eventCoordinates
mitem <- liftIO $ (getPathAtPos fmv (x, y))
>>= \mpos -> fmap join
$ forM mpos (rawPathToItem myview)
case mitem of
(Just item) -> do
liftIO $ opeInNewTab mygui item
return True
Nothing -> return False
OtherButton 8 -> do
liftIO $ void $ goHistoryBack mygui myview
return False
OtherButton 9 -> do
liftIO $ void $ goHistoryForward mygui myview
return False
_ -> 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)
openTerminalHere :: MyView -> IO ProcessID
openTerminalHere myview = do
cwd <- (P.fromAbs . path) <$> getCurrentDir myview
SPP.forkProcess $ terminalCommand cwd
closeTab :: MyGUI -> MyView -> IO ()
closeTab mygui myview = do
n <- notebookGetNPages (notebook mygui)
when (n > 1) $ void $ destroyView mygui myview
newTab' :: MyGUI -> MyView -> IO ()
newTab' mygui myview = do
cwd <- getCurrentDir myview
void $ withErrorDialog $ newTab mygui createTreeView cwd (1)
opeInNewTab :: MyGUI -> Item -> IO ()
opeInNewTab mygui item@(DirOrSym _) =
void $ withErrorDialog $ newTab mygui createTreeView item (1)
opeInNewTab _ _ = return ()
del :: [Item] -> MyGUI -> MyView -> IO ()
del [item] _ _ = withErrorDialog $ do
let cmsg = "Really delete \"" ++ getFPasStr item ++ "\"?"
withConfirmationDialog cmsg
$ easyDelete . path $ item
del items@(_:_) _ _ = withErrorDialog $ do
let cmsg = "Really delete " ++ show (length items) ++ " files?"
withConfirmationDialog cmsg
$ forM_ items $ \item -> easyDelete . path $ item
del _ _ _ = withErrorDialog
. throwIO $ InvalidOperation
"Operation not supported on multiple files"
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
. throwIO $ InvalidOperation
"No file selected!"
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
. throwIO $ InvalidOperation
"No file selected!"
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"
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)
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
. throwIO $ InvalidOperation
"Operation not supported on multiple files"
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 =<< (readFile 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 =<< (readFile getFileInfo $ fp'))
execute :: [Item] -> MyGUI -> MyView -> IO ()
execute [item] _ _ = withErrorDialog $
void $ executeFile (path item) []
execute _ _ _ = withErrorDialog
. throwIO $ InvalidOperation
"Operation not supported on multiple files"
open :: [Item] -> MyGUI -> MyView -> IO ()
open [item] mygui myview = withErrorDialog $
case item of
DirOrSym r -> do
nv <- readFile getFileInfo $ path r
goDir True mygui myview nv
r ->
void $ openFile . path $ r
open items mygui _ = do
let dirs = filter (fst . sdir) items
files = filter (fst . sfileLike) items
forM_ dirs (withErrorDialog . opeInNewTab mygui)
forM_ files (withErrorDialog . openFile . path)
upDir :: MyGUI -> MyView -> IO ()
upDir mygui myview = withErrorDialog $ do
cdir <- getCurrentDir myview
nv <- goUp cdir
goDir True mygui myview nv
goHistoryBack :: MyGUI -> MyView -> IO (Path Abs)
goHistoryBack mygui myview = do
hs <- takeMVar (history myview)
let nhs = historyBack hs
putMVar (history myview) nhs
nv <- readFile getFileInfo $ currentDir nhs
goDir False mygui myview nv
return $ currentDir nhs
goHistoryForward :: MyGUI -> MyView -> IO (Path Abs)
goHistoryForward mygui myview = do
hs <- takeMVar (history myview)
let nhs = historyForward hs
putMVar (history myview) nhs
nv <- readFile getFileInfo $ currentDir nhs
goDir False mygui myview nv
return $ currentDir nhs
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
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
showPopup :: MyGUI -> MyView -> TimeStamp -> IO ()
showPopup mygui myview t
| null myplugins = return ()
| otherwise = do
rcmenu <- doRcMenu
_ <- (\_ -> 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
sep2 <- separatorMenuItemNew
widgetShow sep2
menuShellInsert (rcMenu rcmenu) sep2 insertPos
plugins <- forM myplugins $ \(ma, mb, mc) -> fmap (, mb, mc) ma
forM_ (reverse plugins) $ \(plugin, filter', cb) -> do
showItem <- withItems mygui myview filter'
menuShellInsert (rcMenu rcmenu) plugin insertPos
when showItem $ widgetShow plugin
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"
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 {..}