Julian Ospald
b6342068f2
This moves some of the parsing logic where it belong, into Gtk.hs and fixes the type to be proper 'Path Abs'.
326 lines
11 KiB
Haskell
326 lines
11 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.
|
|
--}
|
|
|
|
{-# 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"
|