packages feed

ltk-0.8: src/Graphics/UI/Editor/Simple.hs

{-# OPTIONS_GHC -XScopedTypeVariables #-}
-----------------------------------------------------------------------------
--
-- 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
,   stringEditor
,   multilineStringEditor
,   intEditor
,   genericEditor
,   fontEditor
,   colorEditor
,   comboSelectionEditor
,   staticListEditor
,   staticListMultiEditor
,   multiselectionEditor
,   fileEditor
,   otherEditor
,   imageEditor

,   okCancelFields
) where

import Graphics.UI.Gtk
import qualified Graphics.UI.Gtk as Gtk
import Control.Monad
import Data.IORef
import Data.List
import Data.Maybe
import System.FilePath.Posix

import Graphics.UI.Editor.Parameters
import Graphics.UI.Editor.Basics
import Graphics.UI.Editor.MakeEditor
import Control.Event
import Graphics.UI.Gtk.Gdk.Events (Event(..))
import MyMissing (allOf)

-- ------------------------------------------------------------
-- * Simple Editors
-- ------------------------------------------------------------

instance ContainerClass Widget
instance BinClass Widget
instance ButtonClass Widget

--
-- | An invisible editor without any effect
--
noEditor :: alpha -> Editor alpha
noEditor proto parameters notifier =
    mkEditor
        (\ widget _ -> return ())
        (return (Just proto))
        parameters
        notifier

--
-- | 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)
                    widgetSetName button (getParameter paraName parameters)
                    containerAdd widget button
                    toggleButtonSetActive button bool
                    mapM_ (activateEvent (castToWidget button) notifier Nothing)
                        [Clicked,FocusOut,FocusIn]
                    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 "" $ parameters)
        notifier

--
-- | Editor for a boolean value in the form of two radio buttons
----
boolEditor2 :: String -> Editor Bool
boolEditor2 label2 parameters notifier = do
    coreRef <- newIORef Nothing
    mkEditor
        (\widget bool -> do
            core <- readIORef coreRef
            case core of
                Nothing  -> do
                    box <- vBoxNew True 2
                    radio1 <- radioButtonNewWithLabel (getParameter paraName parameters)
                    radio2 <- radioButtonNewWithLabelFromWidget radio1 label2
                    boxPackStart box radio1 PackGrow 2
                    boxPackStart box radio2 PackGrow 2
                    widgetSetName radio1 $ getParameter paraName parameters ++ ".1"
                    widgetSetName radio2 $ getParameter paraName parameters ++ ".2"
                    containerAdd widget box
                    if bool
                        then toggleButtonSetActive radio1 True
                        else toggleButtonSetActive radio2 True
                    mapM_ (activateEvent (castToWidget radio1) notifier Nothing)
                                [Clicked,FocusOut,FocusIn]
                    mapM_ (activateEvent (castToWidget radio2) notifier Nothing)
                                [Clicked,FocusOut,FocusIn]
                    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)  => [String] -> 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
                    box <- vBoxNew True 2
                    let label0 = if length labels > 0 then labels !! 0 else show (vals !! 0)
                    button0 <- radioButtonNewWithLabel label0
                    buttons <- mapM (\ v -> do
                        let n = fromEnum v
                        let label = if length labels > n then labels !! n else show v
                        radio <- if n == 0
                                    then return button0
                                    else radioButtonNewWithLabelFromWidget button0 label
                        boxPackStart box radio PackGrow 2
                        widgetSetName radio (label ++ show n)
                        return radio) vals
                    containerAdd widget box
                    mapM_
                        (\e ->
                            (mapM_
                                (\b -> activateEvent (castToWidget b) notifier Nothing e)
                             buttons))
                        [Clicked,FocusOut,FocusIn]
                    mapM_ (\(b,n) -> toggleButtonSetActive b (n == fromEnum enumValue))
                                (zip buttons [0..length buttons - 1])
                    writeIORef coreRef (Just buttons)
                Just buttons -> do
                    mapM_ (\(b,n) -> toggleButtonSetActive b (n == fromEnum enumValue))
                                (zip buttons [0..length buttons - 1]))
        (do core <- readIORef coreRef
            case core of
                Nothing -> return Nothing
                Just buttons -> do
                    boolArray <- mapM toggleButtonGetActive buttons
                    let mbInd =  findIndex (== 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 :: Editor ()
clickEditor parameters notifier = do
    coreRef <- newIORef Nothing
    mkEditor
        (\widget bool -> do
            core <- readIORef coreRef
            case core of
                Nothing  -> do
                    button <- case getParameter paraStockId parameters of
                        "" ->   buttonNewWithLabel (getParameter paraName parameters)
                        st ->   buttonNewFromStock st
                    widgetSetName button (getParameter paraName parameters)
                    containerAdd widget button
                    activateEvent (castToWidget button) notifier Nothing Clicked
                    writeIORef coreRef (Just button)
                Just button -> return ())
        (return (Just ()))
        (paraName <<<- ParaName "" $ parameters)
        notifier

-- | An Editor to display an image
--
imageEditor :: Editor StockId
imageEditor parameters notifier = do
    coreRef <- newIORef Nothing
    mkEditor
        (\widget stockId -> do
            core <- readIORef coreRef
            case core of
                Nothing  -> do
                    image <- imageNewFromStock stockId IconSizeLargeToolbar
                    widgetSetName image (getParameter paraName parameters)
                    containerAdd widget image
                    writeIORef coreRef (Just (image,stockId))
                Just (image,stockId2) -> imageSetFromStock image stockId IconSizeLargeToolbar)
        (do core <- readIORef coreRef
            case core of
                Nothing -> return Nothing
                Just (_,stockId3) -> return (Just stockId3))
        parameters
        notifier

--
-- | Editor for a string in the form of a text entry
--
stringEditor :: (String -> Bool) -> Editor String
stringEditor validation 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 (castToWidget entry) notifier Nothing)
                                [FocusOut,FocusIn,AfterKeyRelease]
                    containerAdd widget entry
                    entrySetText entry string
                    writeIORef coreRef (Just entry)
                Just entry -> entrySetText entry string)
        (do core <- readIORef coreRef
            case core of
                Nothing -> return Nothing
                Just entry -> do
                    r <- entryGetText entry
                    if validation r
                        then return (Just r)
                        else return Nothing)
        parameters
        notifier

--
-- | Editor for a multiline string in the form of a multiline text entry
--
multilineStringEditor :: Editor String
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 Nothing Nothing
                    scrolledWindowSetPolicy aScrolledWindow PolicyAutomatic PolicyAutomatic
                    containerAdd aScrolledWindow aTextView
                    containerAdd widget aScrolledWindow
                    mapM_ (activateEvent (castToWidget aTextView) notifier Nothing)
                        [ButtonRelease,FocusOut,FocusIn]
                    buffer          <-  textViewGetBuffer aTextView
                    textBufferSetText buffer string
                    writeIORef coreRef (Just (aScrolledWindow,aTextView))
                Just (aScrolledWindow,aTextView) -> do
                    buffer          <-  textViewGetBuffer aTextView
                    textBufferSetText buffer string)
        (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)
                    mapM_ (activateEvent (castToWidget spin) notifier Nothing)
                                [FocusOut,FocusIn]
                    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) parameters notifier
    let ginj = inj . show
    let gext = do
        s <- ext
        case s of
            Nothing -> return Nothing
            Just s -> catch (liftM Just (readIO s))
                            (\e -> 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 (castToWidget button) notifier Nothing)
                                [Clicked,FocusIn]
                    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 -> String) -> 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
                    mapM_ (\o -> comboBoxAppendText combo (showF o)) list
                    widgetSetName combo (getParameter paraName parameters)
                    mapM_ (activateEvent (castToWidget combo) notifier Nothing)
                            [FocusOut,FocusIn]
                    comboBoxSetActive combo 1
                    containerAdd widget combo
                    let ind = elemIndex obj list
                    case ind of
                        Just i -> comboBoxSetActive combo i
                        Nothing -> return ()
                    writeIORef coreRef (Just combo)
                Just combo -> do
                    let ind = elemIndex obj list
                    case ind of
                        Just i -> comboBoxSetActive combo 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 !! ind)))
        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
                    listStore   <- listStoreNew ([]:: [alpha])
                    listView    <- treeViewNewWithModel listStore
                    widgetSetName listView (getParameter paraName parameters)
                    mapM_ (activateEvent (castToWidget listView) notifier Nothing)
                            [FocusOut,FocusIn]
                    sel         <- treeViewGetSelection listView
                    treeSelectionSetMode sel SelectionMultiple
                    renderer    <- cellRendererTextNew
                    col         <- treeViewColumnNew
                    treeViewAppendColumn listView col
                    cellLayoutPackStart col renderer True
                    cellLayoutSetAttributes col renderer listStore
                        $ \row -> [ cellText := show row ]
                    treeViewSetHeadersVisible listView False
                    listStoreClear listStore
                    mapM_ (listStoreAppend listStore) 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,listStore))
                Just (listView,listStore) -> do
                    listStoreClear listStore
                    mapM_ (listStoreAppend listStore) objs)
        (do core <- readIORef coreRef
            case core of
                Nothing -> return Nothing
                Just (listView,listStore) -> do
                    sel         <- treeViewGetSelection listView
                    treePath    <- treeSelectionGetSelectedRows sel
                    values      <- mapM (\[i] -> listStoreGetValue listStore i) treePath
                    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 -> String) -> Editor [beta]
staticListMultiEditor list showF parameters notifier = do
    coreRef <- newIORef Nothing
    mkEditor
        (\widget objs -> do
            core <- readIORef coreRef
            case core of
                Nothing  -> do
                    listStore <- listStoreNew ([]:: [(Bool,beta)])
                    listView <- treeViewNewWithModel listStore
                    widgetSetName listView (getParameter paraName parameters)
                    mapM_ (activateEvent (castToWidget listView) notifier Nothing)
                            [FocusOut,FocusIn]
                    sel <- treeViewGetSelection listView
                    treeSelectionSetMode sel SelectionSingle
                    rendererToggle <- cellRendererToggleNew
                    set rendererToggle [cellToggleActivatable := True]
                    rendererText <- cellRendererTextNew
                    col1 <- treeViewColumnNew
                    treeViewAppendColumn listView col1
                    cellLayoutPackStart col1 rendererToggle True
                    cellLayoutSetAttributes col1 rendererToggle listStore
                        $ \row -> [ cellToggleActive := fst row]
                    col2 <- treeViewColumnNew
                    treeViewAppendColumn listView col2
                    cellLayoutPackStart col2 rendererText True
                    cellLayoutSetAttributes col2 rendererText listStore
                        $ \row -> [ cellText := showF (snd row)]
                    treeViewSetHeadersVisible listView False
                    listStoreClear listStore
                    mapM_ (listStoreAppend listStore) $ map (\e -> (elem e objs,e)) list
                    let minSize =   getParameter paraMinSize parameters
                    uncurry (widgetSetSizeRequest listView) minSize
                    sw          <-  scrolledWindowNew Nothing Nothing
                    containerAdd sw listView
                    scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic
                    containerAdd widget sw
                      -- update the model when the toggle buttons are activated
                    on rendererToggle cellToggled $ \pathStr -> do
                        let (i:_) = stringToTreePath pathStr
                        val <- listStoreGetValue listStore i
                        listStoreSetValue listStore i (not (fst val),snd val)
                    listView `onKeyPress` (\event -> do
                        let Key { eventKeyName = name, eventModifier = modifier, eventKeyChar = char } = event
                        case (name, modifier, char) of
                            ("Return", _, _) -> do
                                sel <- treeViewGetSelection listView
                                rows <- treeSelectionGetSelectedRows sel
                                mapM_ (\ (i:_) -> do
                                    val <- listStoreGetValue listStore i
                                    listStoreSetValue listStore i (not (fst val),snd val)) rows
                                return True
                            _ -> return False)
                    writeIORef coreRef (Just (listView,listStore))
                Just (listView,listStore) -> do
                    let model = map (\e -> (elem e objs,e)) list
                    listStoreClear listStore
                    mapM_ (listStoreAppend listStore) $ map (\e -> (elem e objs,e)) list)
        (do core <- readIORef coreRef
            case core of
                Nothing -> return Nothing
                Just (listView,listStore) -> do
                    model <- listStoreToList listStore
                    return (Just (map snd $ filter (\e -> fst e) 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 -> String) -> Editor beta
staticListEditor list showF parameters notifier = do
    coreRef <- newIORef Nothing
    mkEditor
        (\widget obj -> do
            core <- readIORef coreRef
            case core of
                Nothing  -> do
                    listStore <- listStoreNew ([]:: [alpha])
                    listView <- treeViewNewWithModel listStore
                    widgetSetName listView (getParameter paraName parameters)
                    mapM_ (activateEvent (castToWidget listView) notifier Nothing)
                            [FocusOut,FocusIn]
                    sel <- treeViewGetSelection listView
                    treeSelectionSetMode sel
                        (case getParameter paraMultiSel parameters of
                            True  -> SelectionMultiple
                            False -> SelectionSingle)
                    renderer <- cellRendererTextNew
                    col <- treeViewColumnNew
                    treeViewAppendColumn listView col
                    cellLayoutPackStart col renderer True
                    cellLayoutSetAttributes col renderer listStore
                        $ \row -> [ cellText := showF row ]
                    treeViewSetHeadersVisible listView False
                    listStoreClear listStore
                    mapM_ (listStoreAppend listStore) list
                    let minSize =   getParameter paraMinSize parameters
                    uncurry (widgetSetSizeRequest listView) minSize
                    sw          <-  scrolledWindowNew Nothing Nothing
                    containerAdd sw listView
                    scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic
                    containerAdd widget sw
                    treeSelectionUnselectAll sel
                    let mbInd = elemIndex obj list
                    case mbInd of
                        Nothing -> return ()
                        Just ind -> treeSelectionSelectPath sel [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 [ind])
        (do core <- readIORef coreRef
            case core of
                Nothing -> return Nothing
                Just listView -> do
                    sel <- treeViewGetSelection listView
                    treePaths <- treeSelectionGetSelectedRows sel
                    case treePaths of
                        [[i]] -> return (Just (list !! 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 -> String -> 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 (castToWidget button) notifier Nothing)
                            [FocusOut,FocusIn,Clicked]
                    entry   <-  entryNew
                    widgetSetName entry $ getParameter paraName parameters ++ "-entry"
                    -- set entry [ entryEditable := False ]
                    mapM_ (activateEvent (castToWidget entry) notifier Nothing)
                            [FocusOut,FocusIn]
                    registerEvent notifier Clicked (Left (buttonHandler entry))
                    box <- case getParameter paraDirection parameters of
                                Horizontal  -> do
                                    r <- hBoxNew False 1
                                    return (castToBox r)
                                Vertical    -> do
                                    r <- vBoxNew False 1
                                    return (castToBox r)
                    boxPackStart box entry PackGrow 0
                    boxPackEnd box button PackNatural 0
                    containerAdd widget box
                    entrySetText entry filePath
                    writeIORef coreRef (Just entry)
                Just entry -> entrySetText entry filePath)
        (do core <- readIORef coreRef
            case core of
                Nothing -> return Nothing
                Just entry -> do
                    str <- entryGetText entry
                    return (Just str))
        parameters
        notifier
    where
    buttonHandler entry e =  do
        mbFileName <- do
            dialog <- fileChooserDialogNew
                            (Just "Select File")
                            Nothing
                        action
                        [("gtk-cancel"
                        ,ResponseCancel)
                        ,("gtk-open"
                        ,ResponseAccept)]
            widgetShow dialog
            response <- dialogRun dialog
            case response of
                ResponseAccept -> do
                    f <- fileChooserGetFilename dialog
                    widgetDestroy dialog
                    return f
                ResponseCancel -> do
                    widgetDestroy dialog
                    return Nothing
                ResponseDeleteEvent-> 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 relative
--                triggerEvent notifier SelectionChanged...
                return (e{gtkReturn=True})

--
-- | Editor for a font selection
--
fontEditor :: Editor (Maybe String)
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 (castToWidget fs) notifier Nothing)
                            [FocusOut,FocusIn,Clicked]
                    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 (castToWidget cs) notifier Nothing)
                            [FocusOut,FocusIn,Clicked]
                    containerAdd widget cs
                    colorButtonSetColor cs c
                    writeIORef coreRef (Just cs)
                Just cs -> colorButtonSetColor cs c)
        (do core <- readIORef coreRef
            case core of
                Nothing -> return Nothing
                Just cs -> do
                    c <- colorButtonGetColor cs
                    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  -> String -> 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 (castToWidget button) notifier Nothing)
                            [FocusOut,FocusIn,Clicked]
                    registerEvent notifier Clicked (Left (buttonHandler coreRef))
                    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
            (paraStockId <<<- ParaStockId stockOk
                $ paraName <<<- ParaName "Ok"
                    $ emptyParams)
            (const ())
            (\ a b -> b)
            clickEditor
    ,   mkField
            (paraStockId <<<- ParaStockId stockCancel
                $ paraName <<<- ParaName "Cancel"
                    $ emptyParams)
            (const ())
            (\ _ b -> b)
            clickEditor]