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
#if MIN_VERSION_gtk(0,10,5)
import Graphics.UI.Gtk hiding (eventKeyName, eventModifier)
#else
import Graphics.UI.Gtk
#endif
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
#if MIN_VERSION_gtk(0,10,5)
import Graphics.UI.Gtk.Gdk.Events (Event(..))
#else
import Graphics.UI.Gtk.Gdk.Events (Event(..))
#endif
import MyMissing (allOf)
instance ContainerClass Widget
instance BinClass Widget
instance ButtonClass Widget
noEditor :: alpha -> Editor alpha
noEditor proto parameters notifier =
mkEditor
(\ widget _ -> return ())
(return (Just proto))
parameters
notifier
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
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
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
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
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
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
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
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
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)
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
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
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
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
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
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
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
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"
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
entrySetText entry fn
return (e{gtkReturn=True})
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
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
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]