ltk-0.16.1.0: src/Graphics/UI/Editor/Simple.hs
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
-----------------------------------------------------------------------------
--
-- Module : Graphics.UI.Editor.Simple
-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
-- License : GNU-GPL
--
-- Maintainer : <maintainer at leksah.org>
-- Stability : provisional
-- Portability : portable
--
-- | Module for making simple editors
--
-----------------------------------------------------------------------------------
module Graphics.UI.Editor.Simple (
noEditor
, boolEditor
, boolEditor2
, enumEditor
, clickEditor
, textEditor
, stringEditor
, multilineStringEditor
, intEditor
, genericEditor
, fontEditor
, colorEditor
, comboSelectionEditor
, comboEntryEditor
, staticListEditor
, staticListMultiEditor
, multiselectionEditor
, fileEditor
, otherEditor
, imageEditor
, okCancelFields
) where
import Prelude ()
import Prelude.Compat
import Control.Monad (void, (>=>), when, liftM)
import Data.IORef
import Data.List (elemIndex)
import Data.Maybe
import Data.Int (Int32)
import System.FilePath.Posix
import Graphics.UI.Utils
import Graphics.UI.Editor.Parameters
--import Graphics.UI.Editor.Basics
import Graphics.UI.Editor.MakeEditor
import Control.Event
import MyMissing (allOf)
import Unsafe.Coerce (unsafeCoerce)
import Graphics.UI.Editor.Basics
(GUIEvent(..), GUIEventSelector(..), propagateAsChanged,
genericGUIEvents, activateEvent, Editor)
import Control.Exception as E (catch, IOException)
import Control.Monad.IO.Class (MonadIO(..))
import qualified Data.Text as T (strip, unpack, pack, empty)
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.GI.Base (new', GObject(..), unsafeCastTo, nullToNothing)
import GI.Gtk
(orientableSetOrientation, colorChooserGetRgba,
colorChooserSetRgba, widgetSetHalign, imageSetFromIconName,
imageNewFromIconName, noWidget,
gridNew, noAdjustment, setCellRendererToggleActive, RadioButton,
pattern STOCK_CANCEL, pattern STOCK_OK, colorButtonGetColor, colorButtonSetColor,
ColorButton(..), onColorButtonColorSet, colorButtonNew,
fontButtonGetFontName, fontButtonSetFontName, FontButton(..),
onFontButtonFontSet, fontButtonNew, widgetDestroy,
fileChooserGetFilename, dialogRun, widgetShow,
fileChooserSetAction, dialogAddButton, setWindowTitle,
FileChooserDialog(..), boxPackEnd, toBox, hBoxNew,
FileChooserAction, treeSelectionSelectPath, onWidgetKeyPressEvent,
onCellRendererToggleToggled, scrolledWindowSetMinContentHeight,
setCellRendererToggleActivatable, cellRendererToggleNew,
treeSelectionUnselectAll, constructDialogUseHeaderBar,
treeViewSetHeadersVisible, setCellRendererTextText,
cellLayoutPackStart, treeViewAppendColumn, treeViewColumnNew,
cellRendererTextNew, treeSelectionSetMode, treeViewGetSelection,
treeViewNewWithModel, Entry(..), binGetChild,
comboBoxTextNewWithEntry, comboBoxGetActive, comboBoxSetActive,
ComboBox(..), onComboBoxChanged, widgetSetSizeRequest,
spinButtonGetValue, spinButtonSetValue, SpinButton(..),
afterSpinButtonChangeValue, spinButtonNewWithRange,
textBufferGetText, textBufferGetEndIter, textBufferGetStartIter,
textBufferSetText, textViewGetBuffer, scrolledWindowSetPolicy,
scrolledWindowNew, textViewNew, entryGetText, entrySetText,
entryNew, imageSetFromStock, imageNewFromStock,
setWidgetCanDefault, widgetGrabDefault, buttonNewFromStock,
buttonNewWithLabel, widgetSetName, boxPackStart,
radioButtonNewWithLabelFromWidget, radioButtonNewWithLabel,
vBoxNew, toggleButtonGetActive, toWidget, toggleButtonSetActive,
setWidgetName, checkButtonNewWithLabel, containerAdd,
onWidgetScrollEvent, comboBoxTextAppendText)
import GI.Gtk.Enums
(Orientation(..), Align(..), PositionType(..), ResponseType(..),
SelectionMode(..), PolicyType(..), IconSize(..))
import Data.GI.Gtk.ComboBox
(comboBoxSetModelText, comboBoxAppendText, comboBoxNewText)
import Data.GI.Gtk.ModelView.CellLayout
(cellLayoutSetDataFunction)
import Data.GI.Gtk.ModelView.CustomStore
(CustomStore(..), customStoreGetRow)
import Data.GI.Gtk.ModelView.SeqStore
(SeqStore(..), seqStoreNew, seqStoreToList, seqStoreGetValue,
seqStoreAppend, seqStoreClear, seqStoreSetValue)
import Data.GI.Gtk.ModelView.Types
(treeSelectionGetSelectedRows', treePathGetIndices',
treePathNewFromIndices', stringToTreePath)
import GI.Gdk (keyvalName, getEventKeyKeyval, EventScroll)
import GI.GObject (objectNew, signalStopEmissionByName)
import Text.PrinterParser (Color(..), toGdkRGBA, fromGdkRGBA)
-- ------------------------------------------------------------
-- * Simple Editors
-- ------------------------------------------------------------
--
-- | An invisible editor without any effect
--
noEditor :: alpha -> Editor alpha
noEditor proto =
mkEditor
(\ widget _ -> return ())
(return (Just proto))
--
-- | Editor for a boolean value in the form of a check button
--
boolEditor :: Editor Bool
boolEditor parameters notifier = do
coreRef <- newIORef Nothing
mkEditor
(\widget bool -> do
core <- readIORef coreRef
case core of
Nothing -> do
button <- checkButtonNewWithLabel (getParameter paraName parameters)
setWidgetName button (getParameter paraName parameters)
containerAdd widget button
toggleButtonSetActive button bool
mapM_ (activateEvent button notifier Nothing)
(Clicked: genericGUIEvents)
propagateAsChanged notifier [Clicked]
writeIORef coreRef (Just button)
Just button -> toggleButtonSetActive button bool)
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just button -> do
r <- toggleButtonGetActive button
return (Just r))
(paraName <<<- ParaName T.empty $ parameters)
notifier
--
-- | Editor for a boolean value in the form of two radio buttons
----
boolEditor2 :: Text -> Editor Bool
boolEditor2 label2 parameters notifier = do
coreRef <- newIORef Nothing
mkEditor
(\widget bool -> do
core <- readIORef coreRef
case core of
Nothing -> do
grid <- gridNew
orientableSetOrientation grid OrientationVertical
radio1 <- radioButtonNewWithLabel ([]::[RadioButton]) (getParameter paraName parameters)
radio2 <- radioButtonNewWithLabelFromWidget (Just radio1) label2
containerAdd grid radio1
containerAdd grid radio2
widgetSetName radio1 $ getParameter paraName parameters <> ".1"
widgetSetName radio2 $ getParameter paraName parameters <> ".2"
containerAdd widget grid
if bool
then toggleButtonSetActive radio1 True
else toggleButtonSetActive radio2 True
mapM_ (activateEvent radio1 notifier Nothing) (Clicked:genericGUIEvents)
mapM_ (activateEvent radio2 notifier Nothing) (Clicked:genericGUIEvents)
propagateAsChanged notifier [Clicked]
writeIORef coreRef (Just (radio1,radio2))
Just (radio1,radio2) ->
if bool
then toggleButtonSetActive radio1 True
else toggleButtonSetActive radio2 True)
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just (radio1,radio2) -> do
r <- toggleButtonGetActive radio1
return (Just r))
(paraName <<<- ParaName "" $ parameters)
notifier
--
-- | Editor for an enum value in the form of n radio buttons
----
enumEditor :: forall alpha . (Show alpha, Enum alpha, Bounded alpha) => [Text] -> Editor alpha
enumEditor labels parameters notifier = do
coreRef <- newIORef Nothing
let vals :: [alpha] = allOf
mkEditor
(\widget enumValue -> do
core <- readIORef coreRef
case core of
Nothing -> do
grid <- gridNew
orientableSetOrientation grid OrientationVertical
let label0 = case labels ++ map (T.pack . show) vals of
(x:_) -> x
_ -> error "enumEditor"
button0 <- radioButtonNewWithLabel ([]::[RadioButton]) label0
buttons <- mapM (\ v -> do
let n = fromEnum v
let label = case drop n labels of
(l:_) -> l
_ -> T.pack (show v)
radio <- if n == 0
then return button0
else radioButtonNewWithLabelFromWidget (Just button0) label
containerAdd grid radio
widgetSetName radio (label <> T.pack (show n))
return radio) vals
containerAdd widget grid
mapM_
(\e ->
(mapM_
(\b -> activateEvent b notifier Nothing e)
buttons)) (Clicked:genericGUIEvents)
propagateAsChanged notifier [Clicked]
mapM_ (\(b,n) -> toggleButtonSetActive b (n == fromEnum enumValue))
(zip buttons [0..])
writeIORef coreRef (Just buttons)
Just buttons ->
mapM_ (\(b,n) -> toggleButtonSetActive b (n == fromEnum enumValue))
(zip buttons [0..]))
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just buttons -> do
boolArray <- mapM toggleButtonGetActive buttons
let mbInd = elemIndex True boolArray
let res = case mbInd of
Nothing -> Nothing
Just i -> Just (vals !! i)
return res)
(paraName <<<- ParaName "" $ parameters)
notifier
-- | An Editor for nothing (which may report a click) in the form of a button
--
clickEditor :: Bool -> Editor ()
clickEditor canDefault parameters notifier = do
coreRef <- newIORef Nothing
mkEditor
(\widget bool -> do
core <- readIORef coreRef
case core of
Nothing -> do
button <- buttonNewWithLabel (getParameter paraName parameters)
containerAdd widget button
activateEvent button notifier Nothing Clicked
writeIORef coreRef (Just button)
when canDefault $ do
setWidgetCanDefault button True
widgetGrabDefault button
Just button -> return ())
(return (Just ()))
(paraName <<<- ParaName "" $ parameters)
notifier
-- | An Editor to display an image
--
imageEditor :: Editor Text
imageEditor parameters notifier = do
coreRef <- newIORef Nothing
mkEditor
(\widget stockId -> do
core <- readIORef coreRef
case core of
Nothing -> do
image <- imageNewFromIconName (Just stockId) (fromIntegral $ fromEnum IconSizeLargeToolbar)
widgetSetName image (getParameter paraName parameters)
containerAdd widget image
writeIORef coreRef (Just (image,stockId))
Just (image,stockId2) -> imageSetFromIconName image (Just stockId) (fromIntegral $ fromEnum IconSizeLargeToolbar))
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just (_,stockId3) -> return (Just stockId3))
parameters
notifier
--
-- | Editor for a Text in the form of a text entry
--
textEditor :: (Text -> Bool) -> Bool -> Editor Text
textEditor validation trimBlanks parameters notifier = do
coreRef <- newIORef Nothing
mkEditor
(\widget string -> do
core <- readIORef coreRef
case core of
Nothing -> do
entry <- entryNew
widgetSetName entry (getParameter paraName parameters)
mapM_ (activateEvent entry notifier Nothing) genericGUIEvents
propagateAsChanged notifier [KeyPressed]
containerAdd widget entry
entrySetText entry (if trimBlanks then T.strip string else string)
writeIORef coreRef (Just entry)
Just entry -> entrySetText entry (if trimBlanks then T.strip string else string))
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just entry -> do
r <- entryGetText entry
if validation r
then return (Just (if trimBlanks then T.strip r else r))
else return Nothing)
parameters
notifier
--
-- | Editor for a String in the form of a text entry
--
stringEditor :: (String -> Bool) -> Bool -> Editor String
stringEditor validation trimBlanks parameters notifier = do
(wid,inj,ext) <- textEditor (validation . T.unpack) True parameters notifier
return (wid, inj . T.pack, (T.unpack <$>) <$> ext)
--
-- | Editor for a multiline string in the form of a multiline text entry
--
multilineStringEditor :: Editor Text
multilineStringEditor parameters notifier = do
coreRef <- newIORef Nothing
mkEditor
(\widget string -> do
core <- readIORef coreRef
case core of
Nothing -> do
aTextView <- textViewNew
widgetSetName aTextView (getParameter paraName parameters)
aScrolledWindow <- scrolledWindowNew noAdjustment noAdjustment
scrolledWindowSetPolicy aScrolledWindow PolicyTypeAutomatic PolicyTypeAutomatic
containerAdd aScrolledWindow aTextView
containerAdd widget aScrolledWindow
mapM_ (activateEvent aTextView notifier Nothing) genericGUIEvents
propagateAsChanged notifier [KeyPressed]
buffer <- textViewGetBuffer aTextView
textBufferSetText buffer string (-1)
writeIORef coreRef (Just (aScrolledWindow,aTextView))
Just (aScrolledWindow,aTextView) -> do
buffer <- textViewGetBuffer aTextView
textBufferSetText buffer string (-1))
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just (aScrolledWindow, aTextView) -> do
buffer <- textViewGetBuffer aTextView
start <- textBufferGetStartIter buffer
end <- textBufferGetEndIter buffer
r <- textBufferGetText buffer start end False
return (Just r))
parameters
notifier
--
-- | Editor for an integer in the form of a spin entry
--
intEditor :: (Double,Double,Double) -> Editor Int
intEditor (min, max, step) parameters notifier = do
coreRef <- newIORef Nothing
mkEditor
(\widget v -> do
core <- readIORef coreRef
case core of
Nothing -> do
spin <- spinButtonNewWithRange min max step
widgetSetName spin (getParameter paraName parameters)
-- ignore scroll event, propagate to parent widget
onWidgetScrollEvent spin (\_ -> signalStopEmissionByName spin "scroll-event" >> return False)
mapM_ (activateEvent spin notifier Nothing) genericGUIEvents
activateEvent spin notifier
(Just (\ w h ->
afterSpinButtonChangeValue w (\_ -> void h))) MayHaveChanged
containerAdd widget spin
spinButtonSetValue spin (fromIntegral v)
writeIORef coreRef (Just spin)
Just spin -> spinButtonSetValue spin (fromIntegral v))
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just spin -> do
newNum <- spinButtonGetValue spin
return (Just (truncate newNum)))
parameters
notifier
--
-- | Editor for for any value which is an instance of Read and Show in the form of a
-- | text entry
genericEditor :: (Show beta, Read beta) => Editor beta
genericEditor parameters notifier = do
(wid,inj,ext) <- stringEditor (const True) True parameters notifier
let ginj = inj . show
let gext = do
s <- ext
case s of
Nothing -> return Nothing
Just s -> E.catch (liftM Just (readIO s))
(\(e :: IOException) -> do
putStrLn ("Generic editor no parse for " ++ s ++ " " ++ show e)
return Nothing)
return (wid,ginj,gext)
--
-- | Editor for no value, it only emtis a clicked event and has the form of a check button
--
buttonEditor :: Editor ()
buttonEditor parameters notifier = do
coreRef <- newIORef Nothing
mkEditor
(\widget _ -> do
core <- readIORef coreRef
case core of
Nothing -> do
button <- buttonNewWithLabel (getParameter paraName parameters)
widgetSetName button (getParameter paraName parameters)
containerAdd widget button
mapM_ (activateEvent button notifier Nothing) (Clicked:genericGUIEvents)
writeIORef coreRef (Just button)
Just button -> return ())
(return (Just ()))
parameters
notifier
--
-- | Editor for the selection of some element from a static list of elements in the
-- | form of a combo box
comboSelectionEditor :: Eq beta => [beta] -> (beta -> Text) -> Editor beta
comboSelectionEditor list showF parameters notifier = do
coreRef <- newIORef Nothing
mkEditor
(\widget obj -> do
core <- readIORef coreRef
case core of
Nothing -> do
combo <- comboBoxNewText
widgetSetSizeRequest combo 200 (-1)
-- ignore scroll event, propagate to parent widget
onWidgetScrollEvent combo (\_ -> signalStopEmissionByName combo "scroll-event" >> return False)
mapM_ (comboBoxAppendText combo . showF) list
widgetSetName combo (getParameter paraName parameters)
mapM_ (activateEvent combo notifier Nothing) genericGUIEvents
activateEvent combo notifier
(Just (\ w h -> do
res <- onComboBoxChanged w (void h)
return (unsafeCoerce res))) MayHaveChanged
comboBoxSetActive combo 1
containerAdd widget combo
let ind = elemIndex obj list
case ind of
Just i -> comboBoxSetActive combo (fromIntegral i)
Nothing -> return ()
writeIORef coreRef (Just combo)
Just combo -> do
let ind = elemIndex obj list
case ind of
Just i -> comboBoxSetActive combo (fromIntegral i)
Nothing -> return ())
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just combo -> do
ind <- comboBoxGetActive combo
case ind of
(-1) -> return Nothing
otherwise -> return (Just (list !! fromIntegral ind)))
parameters
notifier
-- | Like comboSelectionEditor but allows entry of text not in the list
comboEntryEditor :: [Text] -> Editor Text
comboEntryEditor list parameters notifier = do
coreRef <- newIORef Nothing
mkEditor
(\widget obj -> do
core <- readIORef coreRef
case core of
Nothing -> do
combo <- comboBoxTextNewWithEntry
widgetSetSizeRequest combo 200 (-1)
mapM_ (comboBoxTextAppendText combo) list
widgetSetName combo (getParameter paraName parameters)
mapM_ (activateEvent combo notifier Nothing) genericGUIEvents
activateEvent combo notifier
(Just (\ w h -> do
res <- onComboBoxChanged w (void h)
return (unsafeCoerce res))) MayHaveChanged
containerAdd widget combo
let ind = elemIndex obj list
case ind of
Just i -> comboBoxSetActive combo (fromIntegral i)
Nothing -> do
entry <- (fromJust <$> nullToNothing (binGetChild combo)) >>= unsafeCastTo Entry
entrySetText entry obj
writeIORef coreRef (Just combo)
Just combo -> do
let ind = elemIndex obj list
case ind of
Just i -> comboBoxSetActive combo (fromIntegral i)
Nothing -> return ())
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just combo -> do
entry <- (fromJust <$> nullToNothing (binGetChild combo)) >>= unsafeCastTo Entry
Just <$> entryGetText entry)
parameters
notifier
--
-- | Editor for the selection of some elements from a list of elements in the
-- | form of a list box
multiselectionEditor :: (Show beta, Eq beta) => Editor [beta]
multiselectionEditor parameters notifier = do
coreRef <- newIORef Nothing
mkEditor
(\widget objs -> do
core <- readIORef coreRef
case core of
Nothing -> do
seqStore <- seqStoreNew []
listView <- treeViewNewWithModel seqStore
widgetSetName listView (getParameter paraName parameters)
mapM_ (activateEvent listView notifier Nothing) genericGUIEvents
propagateAsChanged notifier [KeyPressed,ButtonPressed]
sel <- treeViewGetSelection listView
treeSelectionSetMode sel SelectionModeMultiple
renderer <- cellRendererTextNew
col <- treeViewColumnNew
treeViewAppendColumn listView col
cellLayoutPackStart col renderer True
cellLayoutSetDataFunction col renderer seqStore
(setCellRendererTextText renderer . T.pack . show)
treeViewSetHeadersVisible listView False
seqStoreClear seqStore
mapM_ (seqStoreAppend seqStore) objs
containerAdd widget listView
treeSelectionUnselectAll sel
--let inds = catMaybes $map (\obj -> elemIndex obj list) objs
--mapM_ (\i -> treeSelectionSelectPath sel [i]) inds
writeIORef coreRef (Just (listView,seqStore))
Just (listView,seqStore) -> do
seqStoreClear seqStore
mapM_ (seqStoreAppend seqStore) objs)
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just (listView,seqStore) -> do
sel <- treeViewGetSelection listView
treePaths <- treeSelectionGetSelectedRows' sel >>= mapM treePathGetIndices'
values <- mapM (\[i] -> seqStoreGetValue seqStore (fromIntegral i)) treePaths
return (Just values))
parameters
notifier
--
-- | Editor for the selection of some elements from a static list of elements in the
-- | form of a list box with toggle elements
staticListMultiEditor :: (Eq beta) => [beta] -> (beta -> Text) -> Editor [beta]
staticListMultiEditor list showF parameters notifier = do
coreRef <- newIORef Nothing
mkEditor
(\widget objs -> do
core <- readIORef coreRef
case core of
Nothing -> do
seqStore <- seqStoreNew ([]:: [(Bool,beta)])
listView <- treeViewNewWithModel seqStore
widgetSetName listView (getParameter paraName parameters)
mapM_ (activateEvent listView notifier Nothing) genericGUIEvents
propagateAsChanged notifier [KeyPressed,ButtonPressed]
sel <- treeViewGetSelection listView
treeSelectionSetMode sel SelectionModeSingle
rendererToggle <- cellRendererToggleNew
setCellRendererToggleActivatable rendererToggle True
rendererText <- cellRendererTextNew
col1 <- treeViewColumnNew
treeViewAppendColumn listView col1
cellLayoutPackStart col1 rendererToggle True
cellLayoutSetDataFunction col1 rendererToggle seqStore
(setCellRendererToggleActive rendererToggle . fst)
col2 <- treeViewColumnNew
treeViewAppendColumn listView col2
cellLayoutPackStart col2 rendererText True
cellLayoutSetDataFunction col2 rendererText seqStore
(setCellRendererTextText rendererText . showF . snd)
treeViewSetHeadersVisible listView False
seqStoreClear seqStore
mapM_ (seqStoreAppend seqStore . (\ e -> (e `elem` objs, e))) list
let minSize = getParameter paraMinSize parameters
uncurry (widgetSetSizeRequest listView) minSize
sw <- scrolledWindowNew noAdjustment noAdjustment
containerAdd sw listView
scrolledWindowSetPolicy sw PolicyTypeAutomatic PolicyTypeAutomatic
containerAdd widget sw
scrolledWindowSetMinContentHeight sw (snd minSize)
-- update the model when the toggle buttons are activated
onCellRendererToggleToggled rendererToggle $ \pathStr -> do
let (i:_) = stringToTreePath pathStr
val <- seqStoreGetValue seqStore i
seqStoreSetValue seqStore i (not (fst val),snd val)
onWidgetKeyPressEvent listView $ \e -> do
name <- getEventKeyKeyval e >>= keyvalName
liftIO $
case name of
Just "Return" -> do
sel <- treeViewGetSelection listView
rows <- treeSelectionGetSelectedRows' sel >>= mapM treePathGetIndices'
mapM_ (\ (i:_) -> do
val <- seqStoreGetValue seqStore i
seqStoreSetValue seqStore i (not (fst val),snd val)) rows
return True
_ -> return False
writeIORef coreRef (Just (listView,seqStore))
Just (listView,seqStore) -> do
let model = map (\e -> (e `elem` objs,e)) list
seqStoreClear seqStore
mapM_ (seqStoreAppend seqStore . (\ e -> (e `elem` objs, e))) list)
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just (listView,seqStore) -> do
model <- seqStoreToList seqStore
return (Just (map snd $ filter fst model)))
parameters
notifier
--
-- | Editor for the selection of some elements from a static list of elements in the
-- | form of a list box
staticListEditor :: (Eq beta) => [beta] -> (beta -> Text) -> Editor beta
staticListEditor list showF parameters notifier = do
coreRef <- newIORef Nothing
mkEditor
(\widget obj -> do
core <- readIORef coreRef
case core of
Nothing -> do
seqStore <- seqStoreNew ([]:: [alpha])
listView <- treeViewNewWithModel seqStore
widgetSetName listView (getParameter paraName parameters)
mapM_ (activateEvent listView notifier Nothing) genericGUIEvents
propagateAsChanged notifier [KeyPressed,ButtonPressed]
sel <- treeViewGetSelection listView
treeSelectionSetMode sel
(if getParameter paraMultiSel parameters
then SelectionModeMultiple
else SelectionModeSingle)
renderer <- cellRendererTextNew
col <- treeViewColumnNew
treeViewAppendColumn listView col
cellLayoutPackStart col renderer True
cellLayoutSetDataFunction col renderer seqStore
(setCellRendererTextText renderer . showF)
treeViewSetHeadersVisible listView False
seqStoreClear seqStore
mapM_ (seqStoreAppend seqStore) list
let minSize = getParameter paraMinSize parameters
uncurry (widgetSetSizeRequest listView) minSize
sw <- scrolledWindowNew noAdjustment noAdjustment
containerAdd sw listView
scrolledWindowSetPolicy sw PolicyTypeAutomatic PolicyTypeAutomatic
containerAdd widget sw
scrolledWindowSetMinContentHeight sw (snd minSize)
treeSelectionUnselectAll sel
let mbInd = elemIndex obj list
case mbInd of
Nothing -> return ()
Just ind -> treeSelectionSelectPath sel =<< treePathNewFromIndices' [fromIntegral ind]
writeIORef coreRef (Just listView)
Just listView -> do
sel <- treeViewGetSelection listView
treeSelectionUnselectAll sel
let mbInd = elemIndex obj list
case mbInd of
Nothing -> return ()
Just ind -> treeSelectionSelectPath sel =<< treePathNewFromIndices' [fromIntegral ind])
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just listView -> do
sel <- treeViewGetSelection listView
treePaths <- treeSelectionGetSelectedRows' sel >>= mapM treePathGetIndices'
case treePaths of
[[i]] -> return (Just (list !! fromIntegral i))
_ -> return Nothing)
parameters
notifier
--
-- | Editor for the selection of a file path in the form of a text entry and a button,
-- | which opens a gtk file chooser
fileEditor :: Maybe FilePath -> FileChooserAction -> Text -> Editor FilePath
fileEditor mbFilePath action buttonName parameters notifier = do
coreRef <- newIORef Nothing
mkEditor
(\widget filePath -> do
core <- readIORef coreRef
case core of
Nothing -> do
button <- buttonNewWithLabel buttonName
widgetSetName button $ getParameter paraName parameters <> "-button"
mapM_ (activateEvent button notifier Nothing)
(Clicked:genericGUIEvents)
entry <- entryNew
widgetSetName entry $ getParameter paraName parameters <> "-entry"
-- set entry [ entryEditable := False ]
mapM_ (activateEvent entry notifier Nothing) genericGUIEvents
registerEvent notifier Clicked (buttonHandler entry)
propagateAsChanged notifier [KeyPressed,ButtonPressed]
grid <- gridNew
orientableSetOrientation grid (getParameter paraOrientation parameters)
widgetSetHalign button AlignEnd
containerAdd grid entry
containerAdd grid button
containerAdd widget grid
entrySetText entry (T.pack filePath)
writeIORef coreRef (Just entry)
Just entry -> entrySetText entry (T.pack filePath))
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just entry -> do
str <- entryGetText entry
return (Just (T.unpack str)))
parameters
notifier
where
buttonHandler entry e = do
mbFileName <- do
dialog <- new' FileChooserDialog [constructDialogUseHeaderBar 1]
setWindowTitle dialog "Select File"
dialogAddButton dialog "gtk-cancel" (fromIntegral $ fromEnum ResponseTypeCancel)
dialogAddButton dialog "gtk-open" (fromIntegral $ fromEnum ResponseTypeAccept)
fileChooserSetAction dialog action
widgetShow dialog
response <- dialogRun dialog
case toEnum $ fromIntegral response of
ResponseTypeAccept -> do
f <- fileChooserGetFilename dialog
widgetDestroy dialog
return f
ResponseTypeCancel -> do
widgetDestroy dialog
return Nothing
ResponseTypeDeleteEvent-> do
widgetDestroy dialog
return Nothing
_ -> return Nothing
case mbFileName of
Nothing -> return (e{gtkReturn=True})
Just fn -> do
-- let relative = case mbFilePath of
-- Nothing -> fn
-- Just rel -> makeRelative rel fn
entrySetText entry (T.pack fn)
triggerEvent notifier GUIEvent {
selector = MayHaveChanged,
eventText = "",
gtkReturn = True}
return (e{gtkReturn=True})
--
-- | Editor for a font selection
--
fontEditor :: Editor (Maybe Text)
fontEditor parameters notifier = do
coreRef <- newIORef Nothing
mkEditor
(\widget mbValue -> do
core <- readIORef coreRef
case core of
Nothing -> do
fs <- fontButtonNew
widgetSetName fs $ getParameter paraName parameters
mapM_ (activateEvent fs notifier Nothing) (Clicked: genericGUIEvents)
activateEvent fs notifier
(Just (\ w h -> do
res <- onFontButtonFontSet w (void h)
return (unsafeCoerce res))) MayHaveChanged
containerAdd widget fs
case mbValue of
Nothing -> return True
Just s -> fontButtonSetFontName fs s
writeIORef coreRef (Just fs)
Just fs -> case mbValue of
Nothing -> return ()
Just s -> do
fontButtonSetFontName fs s
return ())
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just fs -> do
f <- fontButtonGetFontName fs
return (Just (Just f)))
parameters
notifier
--
-- | Editor for color selection
--
colorEditor :: Editor Color
colorEditor parameters notifier = do
coreRef <- newIORef Nothing
mkEditor
(\widget c -> do
core <- readIORef coreRef
case core of
Nothing -> do
cs <- colorButtonNew
widgetSetName cs $ getParameter paraName parameters
mapM_ (activateEvent cs notifier Nothing) (Clicked: genericGUIEvents)
activateEvent cs notifier
(Just (\ w h -> do
res <- onColorButtonColorSet w (void h)
return (unsafeCoerce res))) MayHaveChanged
containerAdd widget cs
colorChooserSetRgba cs =<< toGdkRGBA c
writeIORef coreRef (Just cs)
Just cs -> colorChooserSetRgba cs =<< toGdkRGBA c)
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just cs -> do
c <- colorChooserGetRgba cs >>= fromGdkRGBA
return (Just c))
parameters
notifier
--
-- | An editor, which opens another editor
-- You have to inject a value before the button can be clicked.
--
otherEditor :: (alpha -> Text -> IO (Maybe alpha)) -> Editor alpha
otherEditor func parameters notifier = do
coreRef <- newIORef Nothing
mkEditor
(\widget val -> do
core <- readIORef coreRef
case core of
Nothing -> do
button <- buttonNewWithLabel (getParameter paraName parameters)
widgetSetName button $ getParameter paraName parameters
containerAdd widget button
mapM_ (activateEvent button notifier Nothing) (Clicked:genericGUIEvents)
registerEvent notifier Clicked (buttonHandler coreRef)
propagateAsChanged notifier [KeyPressed,ButtonPressed,Clicked]
writeIORef coreRef (Just (button,val))
Just (button, oldval) -> writeIORef coreRef (Just (button, val)))
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just (_,val) -> return (Just val))
(paraName <<<- ParaName "" $ parameters)
notifier
where
buttonHandler coreRef e = do
core <- readIORef coreRef
case core of
Nothing -> error "You have to inject a value before the button can be clicked"
Just (b,val) -> do
res <- func val (getParameter paraName parameters)
case res of
Nothing -> return (e{gtkReturn=True})
Just nval -> do
writeIORef coreRef (Just (b, nval))
return (e{gtkReturn=True})
okCancelFields :: FieldDescription ()
okCancelFields = HFD emptyParams [
mkField
(paraName <<<- ParaName "Cancel"
$ emptyParams)
(const ())
(\ _ b -> b)
(clickEditor False)
, mkField
(paraName <<<- ParaName "Ok"
$ emptyParams)
(const ())
(\ a b -> b)
(clickEditor True)]