hsfm/src/GUI/Gtk/Callbacks.hs

289 lines
8.5 KiB
Haskell
Raw Normal View History

2015-12-24 17:25:05 +00:00
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 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.
--}
2015-12-17 03:42:22 +00:00
{-# OPTIONS_HADDOCK ignore-exports #-}
module GUI.Gtk.Callbacks where
import Control.Applicative
(
(<$>)
, (<*>)
)
import Control.Concurrent.STM
(
TVar
, newTVarIO
, readTVarIO
)
import Control.Monad
(
void
)
import Control.Monad.IO.Class
(
liftIO
)
import Data.DirTree
import Data.Foldable
(
for_
)
import Graphics.UI.Gtk
import GUI.Gtk.Data
import GUI.Gtk.Dialogs
import GUI.Gtk.Utils
import IO.File
import IO.Utils
import System.Directory
(
doesFileExist
, doesDirectoryExist
)
import System.FilePath
(
isAbsolute
, (</>)
)
import System.Glib.UTFString
(
glibToString
)
-----------------
--[ Callbacks ]--
-----------------
-- |Set callbacks, on hotkeys, events and stuff.
--
-- Interaction with mutable references:
--
-- * 'settings mygui' modifies
setCallbacks :: MyGUI -> MyView -> IO ()
setCallbacks mygui myview = do
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"q" <- fmap glibToString eventKeyName
liftIO mainQuit
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"h" <- fmap glibToString eventKeyName
cdir <- liftIO $ getCurrentDir myview
liftIO $ modifyTVarIO (settings mygui)
(\x -> x { showHidden = not . showHidden $ x})
2015-12-25 22:26:47 +00:00
>> refreshTreeView' mygui myview cdir
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Alt] <- eventModifier
"Up" <- fmap glibToString eventKeyName
liftIO $ upDir mygui myview
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
"Delete" <- fmap glibToString eventKeyName
liftIO $ withRow mygui myview del
_ <- treeView mygui `on` rowActivated $ (\_ _ -> withRow mygui myview open)
_ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"c" <- fmap glibToString eventKeyName
liftIO $ withRow mygui myview copyInit
2015-12-23 15:09:37 +00:00
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"x" <- fmap glibToString eventKeyName
liftIO $ withRow mygui myview moveInit
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"v" <- fmap glibToString eventKeyName
2015-12-23 15:09:37 +00:00
liftIO $ operationFinal mygui myview
2015-12-24 13:41:06 +00:00
2015-12-25 22:24:43 +00:00
_ <- refreshView mygui `on` buttonActivated $ do
cdir <- liftIO $ getCurrentDir myview
refreshTreeView' mygui myview cdir
2015-12-24 13:41:06 +00:00
-- menubar-file
_ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
_ <- menubarFileOpen mygui `on` menuItemActivated $
liftIO $ withRow mygui myview open
_ <- menubarFileExecute mygui `on` menuItemActivated $
liftIO $ withRow mygui myview execute
_ <- menubarFileNew mygui `on` menuItemActivated $
liftIO $ newFile mygui myview
2015-12-24 13:41:06 +00:00
-- menubar-edit
_ <- menubarEditCut mygui `on` menuItemActivated $
liftIO $ withRow mygui myview moveInit
2015-12-24 13:41:06 +00:00
_ <- menubarEditCopy mygui `on` menuItemActivated $
liftIO $ withRow mygui myview copyInit
_ <- menubarEditRename mygui `on` menuItemActivated $
liftIO $ withRow mygui myview renameF
2015-12-24 13:41:06 +00:00
_ <- menubarEditPaste mygui `on` menuItemActivated $
liftIO $ operationFinal mygui myview
_ <- menubarEditDelete mygui `on` menuItemActivated $
liftIO $ withRow mygui myview del
2015-12-24 16:44:55 +00:00
-- menubar-help
_ <- menubarHelpAbout mygui `on` menuItemActivated $
liftIO showAboutDialog
2015-12-24 14:36:21 +00:00
-- righ-click
_ <- treeView mygui `on` buttonPressEvent $ do
eb <- eventButton
t <- eventTime
case eb of
RightButton -> liftIO $ menuPopup (rcMenu mygui) $ Just (RightButton, t)
_ -> return ()
return False
_ <- rcFileOpen mygui `on` menuItemActivated $
liftIO $ withRow mygui myview open
_ <- rcFileExecute mygui `on` menuItemActivated $
liftIO $ withRow mygui myview execute
_ <- rcFileNew mygui `on` menuItemActivated $
liftIO $ newFile mygui myview
2015-12-24 14:36:21 +00:00
_ <- rcFileCopy mygui `on` menuItemActivated $
liftIO $ withRow mygui myview copyInit
_ <- rcFileRename mygui `on` menuItemActivated $
liftIO $ withRow mygui myview renameF
2015-12-24 14:36:21 +00:00
_ <- rcFilePaste mygui `on` menuItemActivated $
liftIO $ operationFinal mygui myview
_ <- rcFileDelete mygui `on` menuItemActivated $
liftIO $ withRow mygui myview del
_ <- rcFileCut mygui `on` menuItemActivated $
liftIO $ withRow mygui myview moveInit
return ()
-- |Go to the url given at the 'urlBar' and visualize it in the given
-- treeView.
urlGoTo :: MyGUI -> MyView -> IO ()
2015-12-24 04:52:46 +00:00
urlGoTo mygui myview = withErrorDialog $ do
fp <- entryGetText (urlBar mygui)
let abs = isAbsolute fp
exists <- (||) <$> doesDirectoryExist fp <*> doesFileExist fp
-- TODO: more explicit error handling?
refreshTreeView mygui myview (Just fp)
-- |Supposed to be used with 'withRow'. Opens a file or directory.
open :: Row -> MyGUI -> MyView -> IO ()
2015-12-22 16:56:37 +00:00
open row mygui myview = withErrorDialog $
case row of
ADirOrSym r -> do
nv <- Data.DirTree.readFile $ fullPath r
refreshTreeView' mygui myview nv
r ->
2015-12-22 16:56:37 +00:00
void $ openFile r
2015-12-24 13:41:06 +00:00
-- |Execute a given file.
execute :: Row -> MyGUI -> MyView -> IO ()
execute row mygui myview = withErrorDialog $
void $ executeFile row []
-- |Supposed to be used with 'withRow'. Deletes a file or directory.
del :: Row -> MyGUI -> MyView -> IO ()
2015-12-22 16:56:37 +00:00
del row mygui myview = withErrorDialog $ do
let cmsg = "Really delete \"" ++ fullPath row ++ "\"?"
2015-12-22 16:56:37 +00:00
withConfirmationDialog cmsg
$ easyDelete row
2015-12-23 15:09:37 +00:00
-- |Initializes a file move operation.
--
-- Interaction with mutable references:
--
-- * 'operationBuffer' writes
moveInit :: Row -> MyGUI -> MyView -> IO ()
moveInit row mygui myview =
writeTVarIO (operationBuffer myview) (FMove . MP1 $ row)
-- |Supposed to be used with 'withRow'. Initializes a file copy operation.
--
-- Interaction with mutable references:
--
-- * 'operationBuffer' writes
copyInit :: Row -> MyGUI -> MyView -> IO ()
copyInit row mygui myview =
writeTVarIO (operationBuffer myview) (FCopy . CP1 $ row)
2015-12-23 15:09:37 +00:00
-- |Finalizes a file operation, such as copy or move.
--
-- Interaction with mutable references:
--
-- * 'operationBuffer' reads
2015-12-23 15:09:37 +00:00
operationFinal :: MyGUI -> MyView -> IO ()
operationFinal mygui myview = withErrorDialog $ do
op <- readTVarIO (operationBuffer myview)
cdir <- getCurrentDir myview
case op of
2015-12-23 15:09:37 +00:00
FMove (MP1 s) -> do
let cmsg = "Really move \"" ++ fullPath s
++ "\"" ++ " to \"" ++ fullPath cdir ++ "\"?"
withConfirmationDialog cmsg
$ void $ runFileOp (FMove . MC s $ cdir)
2015-12-23 15:09:37 +00:00
return ()
FCopy (CP1 s) -> do
let cmsg = "Really copy \"" ++ fullPath s
2015-12-23 15:09:37 +00:00
++ "\"" ++ " to \"" ++ fullPath cdir ++ "\"?"
2015-12-22 18:50:07 +00:00
cm <- showCopyModeChooserDialog
2015-12-22 16:56:37 +00:00
withConfirmationDialog cmsg
$ void $ runFileOp (FCopy . CC s cdir $ cm)
return ()
_ -> return ()
-- |Go up one directory and visualize it in the treeView.
--
-- Interaction with mutable references:
--
-- * 'rawModel' reads
-- * 'sortedModel' reads
upDir :: MyGUI -> MyView -> IO ()
2015-12-22 16:56:37 +00:00
upDir mygui myview = withErrorDialog $ do
cdir <- getCurrentDir myview
rawModel' <- readTVarIO $ rawModel myview
sortedModel' <- readTVarIO $ sortedModel myview
2015-12-23 15:09:51 +00:00
nv <- goUp cdir
refreshTreeView' mygui myview nv
-- |Go up one directory and visualize it in the treeView.
newFile :: MyGUI -> MyView -> IO ()
newFile mygui myview = withErrorDialog $ do
mfn <- textInputDialog "Enter file name"
for_ mfn $ \fn -> do
cdir <- getCurrentDir myview
createFile cdir fn
renameF :: Row -> MyGUI -> MyView -> IO ()
renameF row mygui myview = withErrorDialog $ do
mfn <- textInputDialog "Enter new file name"
for_ mfn $ \fn -> do
let cmsg = "Really rename \"" ++ fullPath row
++ "\"" ++ " to \"" ++ anchor row </> fn ++ "\"?"
withConfirmationDialog cmsg $ IO.File.renameFile row fn