module HTk.Toolkit.SimpleListBox(
SimpleListBox,
newSimpleListBox,
SimpleListBoxItem,
addItemAtEnd,
deleteItem,
getItems,
bindSelection,
) where
import Data.Maybe
import Control.Concurrent.MVar
import Util.ExtendedPrelude
import Util.Object
import Util.Computation
import Events.Events
import HTk.Kernel.Core(GUIObject(..))
import HTk.Toplevel.HTk
data SimpleListBox val = SimpleListBox {
frame :: Frame,
listBox :: ListBox String,
mkString :: val -> String,
contentsMVar :: MVar [SimpleListBoxItem val]
}
data SimpleListBoxItem val = SimpleListBoxItem {
val :: val,
oID :: ObjectID
}
instance Object (SimpleListBox val) where
objectID simpleListBox = objectID (toGUIObject simpleListBox)
instance Destroyable (SimpleListBox val) where
destroy simpleListBox = destroy (frame simpleListBox)
instance Object (SimpleListBoxItem val) where
objectID simpleListBoxItem = oID simpleListBoxItem
instance Eq (SimpleListBoxItem val) where
(==) = mapEq oID
instance Ord (SimpleListBoxItem val) where
compare = mapOrd oID
instance GUIObject (SimpleListBox val) where
toGUIObject simpleListBox = toGUIObject (frame simpleListBox)
cname _ = "SimpleListBox"
instance Widget (SimpleListBox val)
instance HasSize (SimpleListBox val)
newSimpleListBox
:: Container par
=> par -> (val -> String) -> [Config (SimpleListBox val)]
-> IO (SimpleListBox val)
newSimpleListBox parent mkString configs =
do
frame <- newFrame parent []
listBox <- newListBox frame [value ([] :: [String]),bg "white"]
pack listBox [Side AtLeft,Fill Y]
scroll <- newScrollBar frame []
pack scroll [Side AtRight,Fill Y]
listBox # scrollbar Vertical scroll
listBox # selectMode Extended
contentsMVar <- newMVar []
let
simpleListBox = SimpleListBox {
frame = frame,
listBox = listBox,
mkString = mkString,
contentsMVar = contentsMVar
}
configure simpleListBox configs
return simpleListBox
addItemAtEnd :: SimpleListBox val -> val -> IO (SimpleListBoxItem val)
addItemAtEnd simpleListBox (val1 :: val) =
do
let
mVar = contentsMVar simpleListBox
mkS = mkString simpleListBox
oID <- newObject
let
simpleListBoxItem = SimpleListBoxItem {
val = val1,
oID = oID
}
contents0 <- takeMVar mVar
let
contents1 :: [SimpleListBoxItem val]
contents1 = contents0 ++ [simpleListBoxItem]
newValue :: [String]
newValue = map (mkS . val) contents1
(listBox simpleListBox) # value newValue
putMVar mVar contents1
return simpleListBoxItem
deleteItem :: SimpleListBox val -> SimpleListBoxItem val -> IO ()
deleteItem simpleListBox simpleListBoxItem =
do
let
mVar = contentsMVar simpleListBox
mkS = mkString simpleListBox
contents0 <- takeMVar mVar
let
contents1 = deleteFirst (== simpleListBoxItem) contents0
(newValue :: [String]) = map (mkS . val) contents1
(listBox simpleListBox) # value newValue
putMVar mVar contents1
done
getItems :: SimpleListBox value -> IO [value]
getItems simpleListBox =
do
contents <- readMVar (contentsMVar simpleListBox)
return (map val contents)
bindSelection :: SimpleListBox val
-> IO (Event [SimpleListBoxItem val],IO ())
bindSelection simpleListBox =
do
(press,terminator)
<- bindSimple (listBox simpleListBox) (ButtonPress (Just 1))
let
event =
press
>>>
do
indexOpt <- getSelection (listBox simpleListBox)
contents0 <- readMVar (contentsMVar simpleListBox)
return (case indexOpt of
Nothing -> []
Just items ->
let
max = length contents0
in
mapMaybe
(\ index -> if index >= max
then
Nothing
else
Just (contents0 !! index)
)
items
)
return (event,terminator)