{-- 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. --} {-# OPTIONS_HADDOCK ignore-exports #-} module HSFM.GUI.Gtk.Callbacks where import Control.Concurrent.STM ( readTVarIO ) import Control.Exception ( throw ) import Control.Monad ( void , forM_ ) import Control.Monad.IO.Class ( liftIO ) import Data.Foldable ( for_ ) import Graphics.UI.Gtk import qualified HPath as P import HPath ( Abs , Path ) import HSFM.FileSystem.Errors import HSFM.FileSystem.FileOperations import HSFM.FileSystem.FileType import HSFM.GUI.Gtk.Data import HSFM.GUI.Gtk.Dialogs import HSFM.GUI.Gtk.MyView import HSFM.GUI.Gtk.Utils import HSFM.Utils.IO import System.Glib.UTFString ( glibToString ) ----------------- --[ Callbacks ]-- ----------------- -- |Set callbacks, on hotkeys, events and stuff. setCallbacks :: MyGUI -> MyView -> IO () setCallbacks mygui myview = do view' <- readTVarIO $ view myview case view' of FMTreeView treeView -> do _ <- treeView `on` rowActivated $ (\_ _ -> withItems mygui myview open) commonGuiEvents treeView return () FMIconView iconView -> do _ <- iconView `on` itemActivated $ (\_ -> withItems mygui myview open) commonGuiEvents iconView return () menubarCallbacks where menubarCallbacks = do -- menubar-file _ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit _ <- menubarFileOpen mygui `on` menuItemActivated $ liftIO $ withItems mygui myview open _ <- menubarFileExecute mygui `on` menuItemActivated $ liftIO $ withItems mygui myview execute _ <- menubarFileNew mygui `on` menuItemActivated $ liftIO $ newFile mygui myview -- menubar-edit _ <- menubarEditCut mygui `on` menuItemActivated $ liftIO $ withItems mygui myview moveInit _ <- menubarEditCopy mygui `on` menuItemActivated $ liftIO $ withItems mygui myview copyInit _ <- menubarEditRename mygui `on` menuItemActivated $ liftIO $ withItems mygui myview renameF _ <- menubarEditPaste mygui `on` menuItemActivated $ liftIO $ operationFinal mygui myview _ <- menubarEditDelete mygui `on` menuItemActivated $ liftIO $ withItems mygui myview del -- mewnubar-view _ <- menubarViewIcon mygui `on` menuItemActivated $ liftIO $ switchView mygui myview createIconView _ <- menubarViewTree mygui `on` menuItemActivated $ liftIO $ switchView mygui myview createTreeView -- menubar-help _ <- menubarHelpAbout mygui `on` menuItemActivated $ liftIO showAboutDialog return () commonGuiEvents view = do -- GUI events _ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview _ <- refreshViewB mygui `on` buttonActivated $ do cdir <- liftIO $ getCurrentDir myview refreshView' mygui myview cdir _ <- clearStatusBar mygui `on` buttonActivated $ do popStatusbar mygui writeTVarIO (operationBuffer myview) None -- key events _ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do [Control] <- eventModifier "q" <- fmap glibToString eventKeyName liftIO mainQuit _ <- view `on` keyPressEvent $ tryEvent $ do [Control] <- eventModifier "h" <- fmap glibToString eventKeyName cdir <- liftIO $ getCurrentDir myview liftIO $ modifyTVarIO (settings mygui) (\x -> x { showHidden = not . showHidden $ x}) >> refreshView' mygui myview cdir _ <- view `on` keyPressEvent $ tryEvent $ do [Alt] <- eventModifier "Up" <- fmap glibToString eventKeyName liftIO $ upDir mygui myview _ <- view `on` keyPressEvent $ tryEvent $ do "Delete" <- fmap glibToString eventKeyName liftIO $ withItems mygui myview del _ <- view `on` keyPressEvent $ tryEvent $ do [] <- eventModifier "Return" <- fmap glibToString eventKeyName liftIO $ withItems mygui myview open _ <- view `on` keyPressEvent $ tryEvent $ do [Control] <- eventModifier "c" <- fmap glibToString eventKeyName liftIO $ withItems mygui myview copyInit _ <- view `on` keyPressEvent $ tryEvent $ do [Control] <- eventModifier "x" <- fmap glibToString eventKeyName liftIO $ withItems mygui myview moveInit _ <- view `on` keyPressEvent $ tryEvent $ do [Control] <- eventModifier "v" <- fmap glibToString eventKeyName liftIO $ operationFinal mygui myview -- righ-click _ <- view `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 $ withItems mygui myview open _ <- rcFileExecute mygui `on` menuItemActivated $ liftIO $ withItems mygui myview execute _ <- rcFileNew mygui `on` menuItemActivated $ liftIO $ newFile mygui myview _ <- rcFileCopy mygui `on` menuItemActivated $ liftIO $ withItems mygui myview copyInit _ <- rcFileRename mygui `on` menuItemActivated $ liftIO $ withItems mygui myview renameF _ <- rcFilePaste mygui `on` menuItemActivated $ liftIO $ operationFinal mygui myview _ <- rcFileDelete mygui `on` menuItemActivated $ liftIO $ withItems mygui myview del _ <- rcFileCut mygui `on` menuItemActivated $ liftIO $ withItems mygui myview moveInit return () -- |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 mygui) forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' -> refreshView mygui myview (Just fp') -- |Supposed to be used with 'withRows'. Opens a file or directory. open :: [Item] -> MyGUI -> MyView -> IO () open [item] mygui myview = withErrorDialog $ case item of ADirOrSym r -> do nv <- HSFM.FileSystem.FileType.readFileWithFileInfo $ fullPath r refreshView' mygui myview nv r -> void $ openFile r -- this throws on the first error that occurs open (FileLikeList fs) _ _ = withErrorDialog $ forM_ fs $ \f -> void $ openFile f open _ _ _ = withErrorDialog . throw $ InvalidOperation "Operation not supported on multiple files" -- |Execute a given file. execute :: [Item] -> MyGUI -> MyView -> IO () execute [item] _ _ = withErrorDialog $ void $ executeFile item [] execute _ _ _ = withErrorDialog . throw $ InvalidOperation "Operation not supported on multiple files" -- |Supposed to be used with 'withRows'. Deletes a file or directory. del :: [Item] -> MyGUI -> MyView -> IO () del [item] _ _ = withErrorDialog $ do let cmsg = "Really delete \"" ++ fullPathS item ++ "\"?" withConfirmationDialog cmsg $ easyDelete 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 item del _ _ _ = withErrorDialog . throw $ InvalidOperation "Operation not supported on multiple files" -- |Initializes a file move operation. moveInit :: [Item] -> MyGUI -> MyView -> IO () moveInit [item] mygui myview = do writeTVarIO (operationBuffer myview) (FMove . MP1 $ item) let sbmsg = "Move buffer: " ++ fullPathS item popStatusbar mygui void $ pushStatusBar mygui sbmsg moveInit _ _ _ = withErrorDialog . throw $ InvalidOperation "Operation not supported on multiple files" -- |Supposed to be used with 'withRows'. Initializes a file copy operation. copyInit :: [Item] -> MyGUI -> MyView -> IO () copyInit [item] mygui myview = do writeTVarIO (operationBuffer myview) (FCopy . CP1 $ item) let sbmsg = "Copy buffer: " ++ fullPathS item popStatusbar mygui void $ pushStatusBar mygui sbmsg copyInit _ _ _ = withErrorDialog . throw $ InvalidOperation "Operation not supported on multiple files" -- |Finalizes a file operation, such as copy or move. operationFinal :: MyGUI -> MyView -> IO () operationFinal _ myview = withErrorDialog $ do op <- readTVarIO (operationBuffer myview) cdir <- getCurrentDir myview case op of FMove (MP1 s) -> do let cmsg = "Really move \"" ++ fullPathS s ++ "\"" ++ " to \"" ++ fullPathS cdir ++ "\"?" withConfirmationDialog cmsg . withCopyModeDialog $ \cm -> void $ runFileOp (FMove . MC s cdir $ cm) return () FCopy (CP1 s) -> do let cmsg = "Really copy \"" ++ fullPathS s ++ "\"" ++ " to \"" ++ fullPathS cdir ++ "\"?" withConfirmationDialog cmsg . withCopyModeDialog $ \cm -> void $ runFileOp (FCopy . CC s cdir $ cm) return () _ -> return () -- |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 refreshView' mygui myview nv -- |Go up one directory and visualize it in the treeView. newFile :: MyGUI -> MyView -> IO () newFile _ myview = withErrorDialog $ do mfn <- textInputDialog "Enter file name" let pmfn = P.parseFn =<< mfn for_ pmfn $ \fn -> do cdir <- getCurrentDir myview createFile cdir fn renameF :: [Item] -> MyGUI -> MyView -> IO () renameF [item] _ _ = withErrorDialog $ do mfn <- textInputDialog "Enter new file name" let pmfn = P.parseFn =<< mfn for_ pmfn $ \fn -> do let cmsg = "Really rename \"" ++ fullPathS item ++ "\"" ++ " to \"" ++ P.fromAbs (anchor item P. fn) ++ "\"?" withConfirmationDialog cmsg $ HSFM.FileSystem.FileOperations.renameFile item fn renameF _ _ _ = withErrorDialog . throw $ InvalidOperation "Operation not supported on multiple files"