{-# LANGUAGE CPP #-}
{- |
Module : ./GUI/GtkUtils.hs
Description : Access to the .glade files stored as strings inside the binary
Copyright : (c) Thiemo Wiedemeyer, Uni Bremen 2008
License : GPLv2 or higher, see LICENSE.txt
Maintainer : raider@informatik.uni-bremen.de
Stability : provisional
Portability : non-portable
This module provides the ability to store xml stings in a temporary file to load
it with gtk2hs. This is needed, because gtk2hs needs glade files for input, but
we want to distribute them within the binary.
-}
module GUI.GtkUtils
( getGladeXML
, startMainLoop
, stopMainLoop
, forkIO_
, forkIOWithPostProcessing
-- * Windows for use inside Gtk thread
, infoDialog
, errorDialog
, warningDialog
, questionDialog
, fileOpenDialog
, fileSaveDialog
, listChoiceAux
, listChoice
, progressBar
, pulseBar
, textView
, displayTheoryWithWarning
-- * Windows for use in Gtk windows
, infoDialogExt
, errorDialogExt
, warningDialogExt
, questionDialogExt
, fileOpenDialogExt
, fileSaveDialogExt
, listChoiceExt
, progressBarExt
, pulseBarExt
, textViewExt
, displayTheoryWithWarningExt
-- * Frequently used functions inside Gtk thread
, setListData
, updateListData
, setListSelectorSingle
, setListSelectorMultiple
, selectFirst
, getSelectedSingle
, getSelectedMultiple
, selectAllRows
, activate
, escapeGtkMarkup
, ComboBoxText
, toComboBoxText
) where
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Glade
import qualified GUI.Glade.Utils as Utils
import Static.GTheory
import Common.DocUtils (showDoc)
import Common.IO
import Common.Utils (getTempFile)
import Control.Concurrent (forkIO)
import Control.Monad (when)
import qualified Data.Text as Text
import System.Directory ( removeFile, doesFileExist
, canonicalizePath)
import System.FilePath (takeFileName, takeDirectory)
-- | Returns a GladeXML Object of a xmlstring.
getGladeXML :: (String, String) -> IO GladeXML
getGladeXML (name, xmlstr) = do
filename <- getTempFile xmlstr name
mxml <- xmlNew filename
removeFile filename
case mxml of
Just xml -> return xml
Nothing -> error "GtkUtils: Can't load xml string."
-- | Starts the gtk main event loop in a thread
startMainLoop :: IO ()
startMainLoop = forkIO_ $ do
unsafeInitGUIForThreadedRTS
mainGUI
stopMainLoop :: IO ()
stopMainLoop = postGUISync mainQuit
forkIO_ :: IO () -> IO ()
forkIO_ f = forkIO f >> return ()
forkIOWithPostProcessing :: IO a -> (a -> IO ()) -> IO ()
forkIOWithPostProcessing action post = forkIO_ $ action >>= postGUIAsync . post
escapeGtkMarkup :: String -> String
escapeGtkMarkup = concatMap $ \ c -> case c of
'<' -> "&lt;"
'>' -> "&gt;"
'&' -> "&amp;"
_ -> [c]
{- * Usefull windows and function.
!!! IMPORTANT for all following functions !!!
Functions for use outside of the Gtk thread have a "Ext" postfix.
All other functions must be called from inside the Gtk thread. -}
-- | Dialog for different typed messages
dialog :: MessageType -- ^ Dialogtype
-> String -- ^ Title
-> String -- ^ Message
-> IO Bool
dialog messageType title message = do
dlg <- case messageType of
MessageInfo ->
messageDialogNew Nothing [] messageType ButtonsOk message
MessageWarning ->
messageDialogNew Nothing [] messageType ButtonsYesNo message
MessageQuestion ->
messageDialogNew Nothing [] messageType ButtonsYesNo message
_ ->
messageDialogNew Nothing [] messageType ButtonsOk message
windowSetTitle dlg title
rspns <- dialogRun dlg
widgetDestroy dlg
case rspns of
ResponseOk -> return True
ResponseYes -> return True
_ -> return False
-- | create a window which displays a given text
infoDialog :: String -- ^ Title
-> String -- ^ Message
-> IO ()
infoDialog title message = do
dialog MessageInfo title message
return ()
-- | create a window which displays a given text
infoDialogExt :: String -- ^ Title
-> String -- ^ Message
-> IO ()
infoDialogExt title = postGUISync . infoDialog title
-- | create a window which displays a given error
errorDialog :: String -- ^ Title
-> String -- ^ Message
-> IO ()
errorDialog title message = do
dialog MessageError title message
return ()
-- | create a window which displays a given error
errorDialogExt :: String -- ^ Title
-> String -- ^ Message
-> IO ()
errorDialogExt title = postGUISync . errorDialog title
-- | create a window which displays a given warning and ask for continue
warningDialog :: String -- ^ Title
-> String -- ^ Message
-> IO Bool
warningDialog = dialog MessageWarning
-- | create a window which displays a given warning and ask for continue
warningDialogExt :: String -- ^ Title
-> String -- ^ Message
-> IO Bool
warningDialogExt title = postGUISync . warningDialog title
-- | create a window which displays a given question
questionDialog :: String -- ^ Title
-> String -- ^ Message
-> IO Bool
questionDialog = dialog MessageQuestion
-- | create a window which displays a given question
questionDialogExt :: String -- ^ Title
-> String -- ^ Message
-> IO Bool
questionDialogExt title = postGUISync . questionDialog title
-- | Filedialog for opening and saving
fileDialog :: FileChooserAction -- ^ Action
-> FilePath -- ^ Defaultname for file
-> [(String, [String])] -- ^ Filter (name, pattern list)
-> Maybe (FilePath -> IO ()) -- ^ Action on open
-> IO (Maybe FilePath)
fileDialog fAction fname' filters mAction = do
fname <- catchIOException fname' $ canonicalizePath fname'
dlg <- case fAction of
FileChooserActionOpen -> do
dlg' <- fileChooserDialogNew Nothing Nothing FileChooserActionOpen
[ (stockCancel, ResponseCancel)
, (stockOpen, ResponseAccept)]
fileChooserSetCurrentFolder dlg' $ takeDirectory fname
fileChooserSetFilename dlg' $ takeFileName fname
return dlg'
FileChooserActionSave -> do
dlg' <- fileChooserDialogNew Nothing Nothing FileChooserActionSave
[ (stockCancel, ResponseCancel)
, (stockSave, ResponseAccept)]
fileChooserSetCurrentFolder dlg' $ takeDirectory fname
fileChooserSetCurrentName dlg' $ takeFileName fname
return dlg'
_ -> error "FileDialog: Wrong Type"
mapM_ (\ (name, pattern) -> do
fileFilter <- fileFilterNew
mapM_ (fileFilterAddPattern fileFilter) pattern
fileFilterSetName fileFilter name
fileChooserAddFilter dlg fileFilter
) filters
rspns <- dialogRun dlg
ret <- case rspns of
ResponseCancel -> return Nothing
ResponseAccept -> do
mpath <- fileChooserGetFilename dlg
case mpath of
Just path -> do
exist <- doesFileExist path
answer <- if exist then questionDialog "File already exist"
"Are you sure to overwrite existing file?"
else return True
if answer then
case mAction of
Just action -> do
action path
return mpath
Nothing -> return mpath
else return Nothing
Nothing -> return Nothing
_ -> return Nothing
widgetDestroy dlg
return ret
fileOpenDialog :: FilePath -- ^ Defaultname for file
-> [(String, [String])] -- ^ Filter (name, pattern list)
-> Maybe (FilePath -> IO ()) -- ^ Action on open
-> IO (Maybe FilePath)
fileOpenDialog = fileDialog FileChooserActionOpen
fileOpenDialogExt :: FilePath -- ^ Defaultname for file
-> [(String, [String])] -- ^ Filter (name, pattern list)
-> Maybe (FilePath -> IO ()) -- ^ Action on open
-> IO (Maybe FilePath)
fileOpenDialogExt p f = postGUISync . fileOpenDialog p f
fileSaveDialog :: FilePath -- ^ Defaultname for file
-> [(String, [String])] -- ^ Filter (name, pattern list)
-> Maybe (FilePath -> IO ()) -- ^ Action on save
-> IO (Maybe FilePath)
fileSaveDialog = fileDialog FileChooserActionSave
fileSaveDialogExt :: FilePath -- ^ Defaultname for file
-> [(String, [String])] -- ^ Filter (name, pattern list)
-> Maybe (FilePath -> IO ()) -- ^ Action on save
-> IO (Maybe FilePath)
fileSaveDialogExt p f = postGUISync . fileSaveDialog p f
-- | create a window with title and list of options, return selected option
listChoiceAux :: String -- ^ Title
-> (a -> String) -- ^ Name of element
-> [a] -- ^ Rows to display
-> IO (Maybe (Int, a)) -- ^ Selected row
listChoiceAux title showF items = do
xml <- getGladeXML Utils.get
-- get objects
dlg <- xmlGetWidget xml castToDialog "ListView"
trvList <- xmlGetWidget xml castToTreeView "trvList"
windowSetTitle dlg title
store <- setListData trvList showF items
selector <- treeViewGetSelection trvList
setListSelectorSingle trvList (return ())
mIter <- treeModelGetIterFirst store
case mIter of
Just iter -> treeSelectionSelectIter selector iter
Nothing -> return ()
dialogAddButton dlg stockCancel ResponseCancel
dialogAddButton dlg stockOk ResponseOk
rspns <- dialogRun dlg
ret <- case rspns of
ResponseCancel -> return Nothing
ResponseOk -> getSelectedSingle trvList store
_ -> return Nothing
widgetDestroy dlg
return ret
-- | create a window with title and list of options, return selected option
listChoice :: String -- ^ Title
-> [String] -- ^ Rows to display
-> IO (Maybe Int) -- ^ Selected row
listChoice title items = do
ret <- listChoiceAux title id items
return $ maybe Nothing (\ (i, _) -> Just i) ret
-- | create a window with title and list of options, return selected option
listChoiceExt :: String -- ^ Title
-> [String] -- ^ Rows to display
-> IO (Maybe Int) -- ^ Selected row
listChoiceExt title = postGUISync . listChoice title
-- | Progress/Pulse bar window
progressBarAux :: Bool -- ^ Percent or pulse
-> String -- ^ Title
-> String -- ^ Description
-> IO (Double -> String -> IO (), IO ())
progressBarAux isProgress title description = do
xml <- getGladeXML Utils.get
-- get window
window <- xmlGetWidget xml castToWindow "ProgressBar"
-- get progress bar
bar <- xmlGetWidget xml castToProgressBar "pbProgress"
windowSetTitle window title
progressBarSetText bar description
progressBarSetPulseStep bar 0.05
windowSetPosition window WinPosCenter
windowSetTypeHint window WindowTypeHintUtility
exit <- if isProgress then return (widgetDestroy window) else do
h <- timeoutAdd (do
progressBarPulse bar
return True
) 75
return (timeoutRemove h >> widgetDestroy window)
widgetShow window
let update p d = do
progressBarSetText bar d
when isProgress $ progressBarSetFraction bar p
return (update, exit)
progressBar :: String -- ^ Title
-> String -- ^ Description
-> IO (Double -> String -> IO (), IO ())
progressBar = progressBarAux True
progressBarExt :: String -- ^ Title
-> String -- ^ Description
-> IO (Double -> String -> IO (), IO ())
progressBarExt title description = do
(update, exit) <- postGUISync $ progressBar title description
return (\ a -> postGUISync . update a, postGUISync exit)
pulseBar :: String -- ^ Title
-> String -- ^ Description
-> IO (String -> IO (), IO ())
pulseBar title description = do
(update, exit) <- progressBarAux False title description
let update' = update 0
return (update', exit)
pulseBarExt :: String -- ^ Title
-> String -- ^ Description
-> IO (String -> IO (), IO ())
pulseBarExt title description = do
(update, exit) <- postGUISync $ pulseBar title description
return (postGUISync . update, postGUISync exit)
-- | Display text in an uneditable, scrollable editor. Not blocking!
textView :: String -- ^ Title
-> String -- ^ Message
-> Maybe FilePath -- ^ Filename
-> IO ()
textView title message mfile = do
xml <- getGladeXML Utils.get
-- get objects
dlg <- xmlGetWidget xml castToDialog "TextView"
tvText <- xmlGetWidget xml castToTextView "tvText"
windowSetTitle dlg title
buffer <- textViewGetBuffer tvText
textBufferInsertAtCursor buffer message
tagTable <- textBufferGetTagTable buffer
font <- textTagNew Nothing
set font [ textTagFont := "FreeMono" ]
textTagTableAdd tagTable font
start <- textBufferGetStartIter buffer
end <- textBufferGetEndIter buffer
textBufferApplyTag buffer font start end
case mfile of
Just file -> do
btnSave <- dialogAddButton dlg stockSave ResponseNone
onClicked btnSave $ do
fileDialog FileChooserActionSave file
[("Nothing", ["*"]), ("Text", ["*.txt"])]
$ Just (`writeFile` message)
return ()
return ()
Nothing -> return ()
btnClose <- dialogAddButton dlg stockClose ResponseNone
onClicked btnClose $ widgetDestroy dlg
widgetShow dlg
return ()
-- | Display text in an uneditable, scrollable editor. Not blocking!
textViewExt :: String -- ^ Title
-> String -- ^ Message
-> Maybe FilePath -- ^ Filename
-> IO ()
textViewExt title message = postGUIAsync . textView title message
-- | displays a theory with warning in a window
displayTheoryWithWarning :: String -- ^ Kind of theory
-> String -- ^ Name of theory
-> String -- ^ Warning
-> G_theory -- ^ Theory
-> IO ()
displayTheoryWithWarning k n w t =
textView (k ++ " of " ++ n) (w ++ showDoc t "\n") $ Just $ n ++ ".het"
-- | displays a theory with warning in a window
displayTheoryWithWarningExt :: String -- ^ Kind of theory
-> String -- ^ Name of theory
-> String -- ^ Warning
-> G_theory -- ^ Theory
-> IO ()
displayTheoryWithWarningExt k n w =
postGUIAsync . displayTheoryWithWarning k n w
-- * Frequently used functions
-- | Setup list with single selection
setListSelectorSingle :: TreeView -> IO () -> IO (ConnectId TreeSelection)
setListSelectorSingle view action = do
selector <- treeViewGetSelection view
treeSelectionSetMode selector SelectionSingle
afterSelectionChanged selector action
-- | Setup list with multiple selection
setListSelectorMultiple :: TreeView -> Button -> Button -> Button -> IO ()
-> IO (ConnectId TreeSelection)
setListSelectorMultiple view btnAll btnNone btnInvert action = do
selector <- treeViewGetSelection view
treeSelectionSetMode selector SelectionMultiple
sh <- afterSelectionChanged selector action
-- setup buttons
onClicked btnAll $ selectAllRows view
onClicked btnNone $ selectNoRows view
onClicked btnInvert (selectInvert view sh >> action)
return sh
-- | Selects the first item if possible
selectFirst :: TreeView -> IO ()
selectFirst view = do
mModel <- treeViewGetModel view
case mModel of
Nothing -> return ()
Just model -> do
mIter <- treeModelGetIterFirst model
case mIter of
Nothing -> return ()
Just iter -> do
selector <- treeViewGetSelection view
treeSelectionSelectIter selector iter
-- | Select all rows
selectAllRows :: TreeView -> IO ()
selectAllRows view = treeViewGetSelection view >>= treeSelectionSelectAll
-- | Deselect all rows
selectNoRows :: TreeView -> IO ()
selectNoRows view = treeViewGetSelection view >>= treeSelectionUnselectAll
-- | Invert selection of list
selectInvert :: TreeView -> ConnectId TreeSelection -> IO ()
selectInvert view handle = do
signalBlock handle
sel <- treeViewGetSelection view
selected <- treeSelectionGetSelectedRows sel
treeSelectionSelectAll sel
rows <- treeSelectionGetSelectedRows sel
mapM_ (\ row -> (if elem row selected
then treeSelectionUnselectPath else treeSelectionSelectPath) sel row
) rows
signalUnblock handle
-- | Get selected item
getSelectedSingle :: TreeView -> ListStore a -> IO (Maybe (Int, a))
getSelectedSingle view list = do
mModel <- treeViewGetModel view
case mModel of
Nothing -> return Nothing
Just model -> do
selector <- treeViewGetSelection view
mIter <- treeSelectionGetSelected selector
case mIter of
Nothing -> return Nothing
Just iter -> do
path <- treeModelGetPath model iter
case path of
row : [] -> do
item <- listStoreGetValue list row
return $ Just (row, item)
_ -> error "List type not supported"
-- | Get selected items and row number
getSelectedMultiple :: TreeView -> ListStore a -> IO [(Int, a)]
getSelectedMultiple view list = do
selector <- treeViewGetSelection view
rows' <- treeSelectionGetSelectedRows selector
let rows = map head rows'
items <- mapM (listStoreGetValue list) rows
return $ zip rows items
-- | Sets data of list
setListData :: TreeView -> (a -> String) -> [a] -> IO (ListStore a)
setListData view getT listData = do
store <- listStoreNew listData
treeViewSetModel view store
treeViewSetHeadersVisible view False
ren <- cellRendererTextNew
col <- treeViewColumnNew
treeViewColumnPackStart col ren True
cellLayoutSetAttributes col ren store
$ \ i -> [ cellTextMarkup := Just $ getT i ]
treeViewAppendColumn view col
return store
-- | Updates data of list
updateListData :: ListStore a -> [a] -> IO ()
updateListData list listData = do
listStoreClear list
mapM_ (listStoreAppend list) listData
-- | Activates or deactivates a list of widgets
activate :: [Widget] -> Bool -> IO ()
activate widgets active = mapM_ (`widgetSetSensitive` active) widgets
toComboBoxText :: Show a => [a] -> [ComboBoxText]
#ifdef GTK12
toComboBoxText = map show
type ComboBoxText = String
#else
toComboBoxText = map (Text.pack . show)
#endif