hsfm/src/HSFM/GUI/Gtk/Dialogs.hs

287 lines
9.1 KiB
Haskell
Raw Normal View History

2015-12-24 17:25:05 +00:00
{--
HSFM, a filemanager written in Haskell.
2016-03-30 22:28:23 +00:00
Copyright (C) 2016 Julian Ospald
2015-12-24 17:25:05 +00:00
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 #-}
2016-03-30 18:16:34 +00:00
module HSFM.GUI.Gtk.Dialogs where
import Control.Exception
(
catch
, displayException
, throw
, IOException
, catches
, Handler(..)
)
import Control.Monad
(
forM
, when
, void
)
2016-04-19 19:05:29 +00:00
import qualified Data.ByteString as BS
import Data.Version
(
showVersion
)
import Distribution.Package
(
PackageIdentifier(..)
, PackageName(..)
)
import Distribution.PackageDescription
(
GenericPackageDescription(..)
, PackageDescription(..)
)
import Distribution.PackageDescription.Parse
(
readPackageDescription
)
import Distribution.Verbosity
(
silent
)
import Graphics.UI.Gtk
import qualified HPath as P
2016-03-30 18:16:34 +00:00
import HSFM.FileSystem.Errors
import HSFM.FileSystem.FileOperations
2016-04-19 19:05:29 +00:00
import HSFM.FileSystem.FileType
import HSFM.GUI.Glib.GlibString()
import HSFM.GUI.Gtk.Data
2016-03-31 14:19:31 +00:00
import HSFM.GUI.Gtk.Errors
import Paths_hsfm
(
getDataFileName
)
---------------------
--[ Dialog popups ]--
---------------------
-- |Pops up an error Dialog with the given String.
showErrorDialog :: String -> IO ()
showErrorDialog str = do
errorDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageError
ButtonsClose
str
_ <- dialogRun errorDialog
widgetDestroy errorDialog
-- |Asks the user for confirmation and returns True/False.
showConfirmationDialog :: String -> IO Bool
showConfirmationDialog str = do
confirmDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageQuestion
ButtonsYesNo
str
rID <- dialogRun confirmDialog
widgetDestroy confirmDialog
case rID of
ResponseYes -> return True
ResponseNo -> return False
_ -> return False
-- |Asks the user which directory copy mode he wants via dialog popup
-- and returns 'DirCopyMode'. Default is always Strict, so this allows
-- switching to Merge/Replace/Rename.
showCopyModeDialog :: IO (Maybe CopyMode)
showCopyModeDialog = do
chooserDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageQuestion
ButtonsNone
"Target exists, how to proceed?"
2016-03-31 14:19:31 +00:00
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0)
_ <- dialogAddButton chooserDialog "Merge" (ResponseUser 1)
_ <- dialogAddButton chooserDialog "Replace" (ResponseUser 2)
_ <- dialogAddButton chooserDialog "Rename" (ResponseUser 3)
rID <- dialogRun chooserDialog
widgetDestroy chooserDialog
case rID of
ResponseUser 0 -> return Nothing
ResponseUser 1 -> return (Just Merge)
ResponseUser 2 -> return (Just Replace)
ResponseUser 3 -> do
mfn <- textInputDialog "Enter new name"
forM mfn $ \fn -> do
pfn <- P.parseFn (P.userStringToFP fn)
return $ Rename pfn
2016-03-31 14:19:31 +00:00
_ -> throw UnknownDialogButton
-- |Stipped version of `showCopyModeDialog` that only allows cancelling
-- or Renaming.
showRenameDialog :: IO (Maybe CopyMode)
showRenameDialog = do
chooserDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageQuestion
ButtonsNone
"Target exists, how to proceed?"
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0)
_ <- dialogAddButton chooserDialog "Rename" (ResponseUser 1)
rID <- dialogRun chooserDialog
widgetDestroy chooserDialog
case rID of
ResponseUser 0 -> return Nothing
ResponseUser 1 -> do
mfn <- textInputDialog "Enter new name"
forM mfn $ \fn -> do
pfn <- P.parseFn (P.userStringToFP fn)
return $ Rename pfn
_ -> throw UnknownDialogButton
-- |Attempts to run the given function with the `Strict` copy mode.
-- If that raises a `FileDoesExist` or `DirDoesExist`, then it prompts
-- the user for action via `showCopyModeDialog` and then carries out
-- the given function again.
withCopyModeDialog :: (CopyMode -> IO ()) -> IO ()
withCopyModeDialog fa =
catch (fa Strict) $ \e ->
case e of
FileDoesExist _ -> doIt showCopyModeDialog
DirDoesExist _ -> doIt showCopyModeDialog
SameFile _ _ -> doIt showRenameDialog
2016-03-31 14:19:31 +00:00
e' -> throw e'
where
doIt getCm = do
mcm <- getCm
case mcm of
(Just Strict) -> return () -- don't try again
(Just cm) -> fa cm
Nothing -> return ()
2015-12-24 16:44:55 +00:00
-- |Shows the about dialog from the help menu.
showAboutDialog :: IO ()
showAboutDialog = do
ad <- aboutDialogNew
2016-04-19 19:05:29 +00:00
lstr <- Prelude.readFile =<< getDataFileName "LICENSE"
hsfmicon <- pixbufNewFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png"
pdesc <- fmap packageDescription
(readPackageDescription silent
=<< getDataFileName "hsfm.cabal")
2015-12-24 16:44:55 +00:00
set ad
[ aboutDialogProgramName := (unPackageName . pkgName . package) pdesc
, aboutDialogName := (unPackageName . pkgName . package) pdesc
, aboutDialogVersion := (showVersion . pkgVersion . package) pdesc
, aboutDialogCopyright := copyright pdesc
, aboutDialogComments := description pdesc
, aboutDialogLicense := Just lstr
, aboutDialogWebsite := homepage pdesc
, aboutDialogAuthors := [author pdesc]
2015-12-24 16:44:55 +00:00
, aboutDialogLogo := Just hsfmicon
, aboutDialogWrapLicense := True
]
_ <- dialogRun ad
widgetDestroy ad
-- |Carry out an IO action with a confirmation dialog.
-- If the user presses "No", then do nothing.
withConfirmationDialog :: String -> IO () -> IO ()
withConfirmationDialog str io = do
run <- showConfirmationDialog str
when run io
-- |Execute the given IO action. If the action throws exceptions,
-- visualize them via 'showErrorDialog'.
withErrorDialog :: IO a -> IO ()
withErrorDialog io =
catches (void io)
[ Handler (\e -> showErrorDialog
$ displayException (e :: IOException))
, Handler (\e -> showErrorDialog
$ displayException (e :: FmIOException))
]
-- |Asks the user which directory copy mode he wants via dialog popup
-- and returns 'DirCopyMode'.
textInputDialog :: String -> IO (Maybe String)
textInputDialog title = do
chooserDialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageQuestion
ButtonsNone
title
entry <- entryNew
cbox <- dialogGetActionArea chooserDialog
2016-03-31 14:19:31 +00:00
_ <- dialogAddButton chooserDialog "Ok" (ResponseUser 0)
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 1)
boxPackStart (castToBox cbox) entry PackNatural 5
widgetShowAll chooserDialog
rID <- dialogRun chooserDialog
ret <- case rID of
-- TODO: make this more safe
ResponseUser 0 -> Just <$> entryGetText entry
ResponseUser 1 -> return Nothing
2016-03-31 14:19:31 +00:00
_ -> throw UnknownDialogButton
widgetDestroy chooserDialog
return ret
2016-04-19 19:05:29 +00:00
showFilePropertyDialog :: [Item] -> MyGUI -> MyView -> IO ()
showFilePropertyDialog [item] mygui _ = do
dialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageInfo
ButtonsNone
"File Properties"
let fprop' = fprop mygui
grid = fpropGrid fprop'
entrySetText (fpropFnEntry fprop') (maybe BS.empty P.fromRel
$ P.basename . path $ item)
entrySetText (fpropLocEntry fprop') (P.fromAbs . P.dirname . path $ item)
entrySetText (fpropTsEntry fprop') (fromFreeVar (show . fileSize) item)
entrySetText (fpropModEntry fprop') (packModTime item)
entrySetText (fpropAcEntry fprop') (packAccessTime item)
cbox <- dialogGetActionArea dialog
_ <- dialogAddButton dialog "Ok" (ResponseUser 0)
_ <- dialogAddButton dialog "Cancel" (ResponseUser 1)
boxPackStart (castToBox cbox) grid PackNatural 5
widgetShowAll dialog
_ <- dialogRun dialog
-- make sure our grid does not get destroyed
containerRemove (castToBox cbox) grid
widgetDestroy dialog
return ()
showFilePropertyDialog _ _ _ = return ()