leksah-0.1: src/IDE/Framework/SimpleEditors.hs
-----------------------------------------------------------------------------
--
-- Module : IDE.Framework.SimpleEditors
-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)
-- License : GNU-GPL
--
-- Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>
-- Stability : experimental
-- Portability : portable
--
-- | Module for making simple editors
--
-----------------------------------------------------------------------------------
module IDE.Framework.SimpleEditors (
boolEditor
, boolEditor2
, stringEditor
, multilineStringEditor
, intEditor
, genericEditor
, fontEditor
, staticSelectionEditor
, staticMultiselectionEditor
, multiselectionEditor
, fileEditor
, otherEditor
) where
import Graphics.UI.Gtk
import Graphics.UI.Gtk.ModelView as New
import Control.Monad
import Data.IORef
import Data.List
import Data.Maybe
import System.FilePath.Posix
import IDE.Framework.Parameters
import IDE.Framework.EditorBasics
import IDE.Framework.MakeEditor
import IDE.Core.Exception
-- ------------------------------------------------------------
-- * Simple Editors
-- ------------------------------------------------------------
instance ContainerClass Widget
instance BinClass Widget
instance ButtonClass Widget
--
-- | Editor for a boolean value in the form of a check button
--
boolEditor :: Editor Bool
boolEditor parameters = do
coreRef <- newIORef Nothing
notifier <- emptyNotifier
declareEvent Clicked (\w h -> w `onClicked` do h (Event True); return ()) notifier
declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier
mkEditor
(\widget bool -> do
core <- readIORef coreRef
case core of
Nothing -> do
button <- checkButtonNewWithLabel (getParameter paraName parameters)
containerAdd widget button
toggleButtonSetActive button bool
activateEvent (castToWidget button) Clicked notifier
activateEvent (castToWidget button) FocusOut notifier
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))
(mkNotifier notifier)
(paraName <<<- (ParaName "") $ parameters)
--
-- | Editor for a boolean value in the form of two radio buttons
--
boolEditor2 :: String -> Editor Bool
boolEditor2 label2 parameters = do
coreRef <- newIORef Nothing
notifier <- emptyNotifier
declareEvent Clicked (\w h -> w `onClicked` do h (Event True); return ()) notifier
declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier
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
containerAdd widget box
if bool
then do
toggleButtonSetActive radio1 True
else do
toggleButtonSetActive radio2 True
activateEvent (castToWidget radio1) Clicked notifier
activateEvent (castToWidget radio1) FocusOut notifier
writeIORef coreRef (Just (radio1,radio2))
Just (radio1,radio2) ->
if bool
then do
toggleButtonSetActive radio1 True
else do
toggleButtonSetActive radio2 True)
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just (radio1,radio2) -> do
r <- toggleButtonGetActive radio1
return (Just r))
(mkNotifier notifier)
(paraName <<<- (ParaName "") $ parameters)
--
-- | Editor for a string in the form of a text entry
--
stringEditor :: Editor String
stringEditor parameters = do
coreRef <- newIORef Nothing
notifier <- emptyNotifier
declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier
mkEditor
(\widget string -> do
core <- readIORef coreRef
case core of
Nothing -> do
entry <- entryNew
activateEvent (castToWidget entry) FocusOut notifier
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
return (Just r))
(mkNotifier notifier)
parameters
--
-- | Editor for a multiline string in the form of a multiline text entry
--
multilineStringEditor :: Editor String
multilineStringEditor parameters = do
coreRef <- newIORef Nothing
notifier <- emptyNotifier
declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier
declareEvent ButtonRelease (\w h -> w `onButtonRelease` h) notifier
mkEditor
(\widget string -> do
core <- readIORef coreRef
case core of
Nothing -> do
aTextView <- textViewNew
aScrolledWindow <- scrolledWindowNew Nothing Nothing
scrolledWindowSetPolicy aScrolledWindow PolicyAutomatic PolicyAutomatic
containerAdd aScrolledWindow aTextView
containerAdd widget aScrolledWindow
activateEvent (castToWidget aTextView) FocusOut notifier
activateEvent (castToWidget aTextView) ButtonRelease notifier
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))
(mkNotifier notifier)
parameters
--
-- | Editor for an integer in the form of a spin entry
--
intEditor :: (Double,Double,Double) -> Editor Int
intEditor (min, max, step) parameters = do
coreRef <- newIORef Nothing
notifier <- emptyNotifier
declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier
mkEditor
(\widget v -> do
core <- readIORef coreRef
case core of
Nothing -> do
spin <- spinButtonNewWithRange min max step
activateEvent (castToWidget spin) FocusOut notifier
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)))
(mkNotifier notifier)
parameters
--
-- | 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 = do
(wid,inj,ext,notif) <- stringEditor parameters
let ginj v = inj (show v)
let gext = do
s <- ext
case s of
Nothing -> return Nothing
Just s ->
let l = read s in
if null l then
return Nothing
else return (Just (head l))
return (wid,ginj,gext,notif)
#ifdef False
--
-- | Editor for the selection of an element from a static list of elements in the
-- | form of a combo box
staticSelectionEditor :: (Show beta, Eq beta) => [beta] -> Editor beta
staticSelectionEditor list parameters = do
coreRef <- newIORef Nothing
notifier <- emptyNotifier
declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier
mkEditor
(\widget obj -> do
core <- readIORef coreRef
case core of
Nothing -> do
(combo,_) <- New.comboBoxNewText show list
activateEvent (castToWidget combo) FocusOut notifier
New.comboBoxSetActive combo 1
containerAdd widget combo
let ind = elemIndex obj list
case ind of
Just i -> New.comboBoxSetActive combo i
Nothing -> return ()
writeIORef coreRef (Just combo)
Just combo -> do
let ind = elemIndex obj list
case ind of
Just i -> New.comboBoxSetActive combo i
Nothing -> return ())
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just combo -> do
ind <- New.comboBoxGetActive combo
case ind of
i | i >= 0 -> return (Just (list !! i))
otherwise -> return Nothing)
(mkNotifier notifier)
parameters
#else
staticSelectionEditor :: (Show beta, Eq beta) => [beta] -> Editor beta
staticSelectionEditor list parameters = do
coreRef <- newIORef Nothing
notifier <- emptyNotifier
declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier
mkEditor
(\widget obj -> do
core <- readIORef coreRef
case core of
Nothing -> do
combo <- New.comboBoxNewText
activateEvent (castToWidget combo) FocusOut notifier
New.comboBoxSetActive combo 1
containerAdd widget combo
mapM_ (\t -> New.comboBoxAppendText combo (show t)) list
let ind = elemIndex obj list
case ind of
Just i -> New.comboBoxSetActive combo i
Nothing -> return ()
writeIORef coreRef (Just combo)
Just combo -> do
let ind = elemIndex obj list
case ind of
Just i -> New.comboBoxSetActive combo i
Nothing -> return ())
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just combo -> do
mbInd <- New.comboBoxGetActive combo
case mbInd of
Just i -> return (Just (list !! i))
otherwise -> return Nothing)
(mkNotifier notifier)
parameters
#endif
--
-- | Editor for the selection of some elements from a static list of elements in the
-- | form of a list box
multiselectionEditor :: (Show beta, Eq beta) => Editor [beta]
multiselectionEditor parameters = do
coreRef <- newIORef Nothing
notifier <- emptyNotifier
declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier
mkEditor
(\widget objs -> do
core <- readIORef coreRef
case core of
Nothing -> do
listStore <- New.listStoreNew ([]:: [alpha])
listView <- New.treeViewNewWithModel listStore
activateEvent (castToWidget listView) FocusOut notifier
sel <- New.treeViewGetSelection listView
New.treeSelectionSetMode sel SelectionMultiple
renderer <- New.cellRendererTextNew
col <- New.treeViewColumnNew
New.treeViewAppendColumn listView col
New.cellLayoutPackStart col renderer True
New.cellLayoutSetAttributes col renderer listStore $ \row -> [ New.cellText := show row ]
New.treeViewSetHeadersVisible listView False
New.listStoreClear listStore
mapM_ (New.listStoreAppend listStore) objs
containerAdd widget listView
New.treeSelectionUnselectAll sel
--let inds = catMaybes $map (\obj -> elemIndex obj list) objs
--mapM_ (\i -> New.treeSelectionSelectPath sel [i]) inds
writeIORef coreRef (Just (listView,listStore))
Just (listView,listStore) -> do
New.listStoreClear listStore
mapM_ (New.listStoreAppend listStore) objs)
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just (listView,listStore) -> do
sel <- New.treeViewGetSelection listView
treePath <- New.treeSelectionGetSelectedRows sel
values <- mapM (\[i] -> listStoreGetValue listStore i) treePath
return (Just values))
(mkNotifier notifier)
parameters
--
-- | Editor for the selection of some elements from a static list of elements in the
-- | form of a list box
staticMultiselectionEditor :: (Show beta, Eq beta) => [beta] -> Editor [beta]
staticMultiselectionEditor list parameters = do
coreRef <- newIORef Nothing
notifier <- emptyNotifier
declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier
mkEditor
(\widget objs -> do
core <- readIORef coreRef
case core of
Nothing -> do
listStore <- New.listStoreNew ([]:: [alpha])
listView <- New.treeViewNewWithModel listStore
activateEvent (castToWidget listView) FocusOut notifier
sel <- New.treeViewGetSelection listView
New.treeSelectionSetMode sel SelectionMultiple
renderer <- New.cellRendererTextNew
col <- New.treeViewColumnNew
New.treeViewAppendColumn listView col
New.cellLayoutPackStart col renderer True
New.cellLayoutSetAttributes col renderer listStore $ \row -> [ New.cellText := show row ]
New.treeViewSetHeadersVisible listView False
New.listStoreClear listStore
mapM_ (New.listStoreAppend listStore) list
containerAdd widget listView
New.treeSelectionUnselectAll sel
let inds = catMaybes $map (\obj -> elemIndex obj list) objs
mapM_ (\i -> New.treeSelectionSelectPath sel [i]) inds
writeIORef coreRef (Just listView)
Just listView -> do
sel <- New.treeViewGetSelection listView
New.treeSelectionUnselectAll sel
let inds = catMaybes $map (\obj -> elemIndex obj list) objs
mapM_ (\i -> New.treeSelectionSelectPath sel [i]) inds)
(do core <- readIORef coreRef
case core of
Nothing -> return Nothing
Just listView -> do
sel <- New.treeViewGetSelection listView
treePath <- New.treeSelectionGetSelectedRows sel
return (Just (map (\[i] -> list !! i) treePath)))
(mkNotifier notifier)
parameters
--
-- | 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 = do
coreRef <- newIORef Nothing
notifier <- emptyNotifier
declareEvent Clicked
(\widget handler -> do widget `onClicked` do
handler (Event True)
return ()) notifier
declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier
mkEditor
(\widget filePath -> do
core <- readIORef coreRef
case core of
Nothing -> do
button <- buttonNewWithLabel buttonName
entry <- entryNew
set entry [ entryEditable := False ]
activateEvent (castToWidget button) Clicked notifier
(mkNotifier 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)
activateEvent (castToWidget button) FocusOut notifier
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))
(mkNotifier notifier)
parameters
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 True
Just fn -> do
let relative = case mbFilePath of
Nothing -> fn
Just rel -> makeRelative rel fn
entrySetText entry relative
return True)
--
-- | Editor for a font selection
--
fontEditor :: Editor (Maybe String)
fontEditor parameters = do
coreRef <- newIORef Nothing
notifier <- emptyNotifier
declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier
mkEditor
(\widget mbValue -> do
core <- readIORef coreRef
case core of
Nothing -> do
fs <- fontButtonNew
activateEvent (castToWidget fs) FocusOut notifier
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)))
(mkNotifier notifier)
parameters
--
-- | 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 = do
coreRef <- newIORef Nothing
notifier <- emptyNotifier
declareEvent Clicked (\w h -> w `onClicked` do h (Event True); return ()) notifier
declareEvent FocusIn (\w h -> w `onFocusIn` do h) notifier
declareEvent FocusOut (\w h -> w `onFocusOut` do h) notifier
mkEditor
(\widget val -> do
core <- readIORef coreRef
case core of
Nothing -> do
button <- buttonNewWithLabel (getParameter paraName parameters)
containerAdd widget button
activateEvent (castToWidget button) Clicked notifier
activateEvent (castToWidget button) FocusIn notifier
activateEvent (castToWidget button) FocusOut notifier
(mkNotifier 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))
(mkNotifier notifier)
(paraName <<<- (ParaName "") $ parameters)
where
buttonHandler coreRef = (\ e -> do
core <- readIORef coreRef
case core of
Nothing -> throwIDE "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 True
Just nval -> do
writeIORef coreRef (Just (b, nval))
return True)