hsfm/src/GUI/Gtk/Callbacks.hs

198 lines
5.6 KiB
Haskell
Raw Normal View History

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.IO.Class
(
liftIO
)
import Data.DirTree
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
)
import qualified Data.IntMap.Lazy as IM
-----------------
--[ Callbacks ]--
-----------------
-- |Set callbacks, on hotkeys, events and stuff.
--
-- Interaction with mutable references:
--
-- * 'settings mygui' modifies
-- * 'fsState' reads
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
liftIO $ modifyTVarIO (settings mygui)
(\x -> x { showHidden = not . showHidden $ x})
>> (refreshTreeView' mygui myview =<< readTVarIO (fsState myview))
_ <- 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)
_ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
_ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"c" <- fmap glibToString eventKeyName
liftIO $ withRow mygui myview copyInit
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"v" <- fmap glibToString eventKeyName
liftIO $ copyFinal mygui myview
return ()
-- |Go to the url given at the 'urlBar' and visualize it in the given
-- treeView.
urlGoTo :: MyGUI -> MyView -> IO ()
urlGoTo mygui myview = 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.
--
-- Interaction with mutable references:
--
-- * 'fsState' reads
open :: Row -> MyGUI -> MyView -> IO ()
open row mygui myview = do
fS <- readTVarIO $ fsState myview
case IM.lookup row (dirTree fS) of
Just dt@(Dir n _) -> do
newP <- readPath (anchor fS </> n)
refreshTreeView' mygui myview newP
Just dt@(File n _) ->
withErrorDialog $ openFile (anchor fS </> n)
_ -> return ()
-- |Supposed to be used with 'withRow'. Deletes a file or directory.
--
-- Interaction with mutable references:
--
-- * 'fsState' reads
del :: Row -> MyGUI -> MyView -> IO ()
del row mygui myview = do
fS <- readTVarIO $ fsState myview
case dirLookup fS row of
dt@(Dir n _) -> do
let fp = anchor fS </> n
subADT <- readPath fp
let cmsg = "Really delete directory \"" ++ fp ++ "\"?"
cmsg2 = "Directory \"" ++ fp ++
"\" is not empty! Delete all contents?"
withConfirmationDialog cmsg $
if IM.null (dirTree subADT)
then withErrorDialog (deleteDir fp
>> refreshTreeView mygui myview Nothing)
else withConfirmationDialog cmsg2 $ withErrorDialog
(deleteDirRecursive fp
>> refreshTreeView mygui myview Nothing)
dt@(File _ _) -> do
let fp = subDirName fS row
cmsg = "Really delete file \"" ++ fp ++ "\"?"
withConfirmationDialog cmsg
$ withErrorDialog (deleteFile fp
>> refreshTreeView mygui myview Nothing)
-- |Supposed to be used with 'withRow'. Initializes a file copy operation.
--
-- Interaction with mutable references:
--
-- * 'operationBuffer' writes
-- * 'fsState' reads
copyInit :: Row -> MyGUI -> MyView -> IO ()
copyInit row mygui myview = do
fsState <- readTVarIO $ fsState myview
writeTVarIO (operationBuffer myview) (FCopy . CP1 $ subDirName fsState row)
-- |Finalizes a file copy operation.
--
-- Interaction with mutable references:
--
-- * 'operationBuffer' reads
-- * 'fsState' reads
copyFinal :: MyGUI -> MyView -> IO ()
copyFinal mygui myview = do
op <- readTVarIO (operationBuffer myview)
case op of
FCopy (CP1 sourceDir) -> do
curDir <- anchor <$> readTVarIO (fsState myview)
let cmsg = "Really copy file \"" ++ sourceDir
++ "\"" ++ " to \"" ++ curDir ++ "\"?"
withConfirmationDialog cmsg $ do
copyMode <- showCopyModeChooserDialog
withErrorDialog ((runFileOp . FCopy . CC sourceDir curDir $ copyMode)
>> refreshTreeView mygui myview Nothing)
_ -> return ()
-- |Go up one directory and visualize it in the treeView.
--
-- Interaction with mutable references:
--
-- * 'rawModel' reads
-- * 'sortedModel' reads
-- * 'fsState' reads
upDir :: MyGUI -> MyView -> IO ()
upDir mygui myview = do
rawModel' <- readTVarIO $ rawModel myview
sortedModel' <- readTVarIO $ sortedModel myview
fS <- readTVarIO $ fsState myview
newP <- readPath (baseDir . anchor $ fS)
refreshTreeView' mygui myview newP