{-----------------------------------------------------------------------------
reactive-banana-wx
Example: ListBox with CRUD operations
------------------------------------------------------------------------------}
{-# LANGUAGE RecursiveDo #-}
-- import Control.Monad
import qualified Data.List
import Data.Maybe
import qualified Data.Map as Map
import Graphics.UI.WX as WX hiding (Event)
import Reactive.Banana
import Reactive.Banana.WX
{-----------------------------------------------------------------------------
Main
------------------------------------------------------------------------------}
main = start $ do
-- GUI layout
f <- frame [ text := "CRUD Example" ]
listBox <- singleListBox f []
create <- button f [ text := "Create" ]
delete <- button f [ text := "Delete" ]
filter <- entry f [ processEnter := True ]
name <- entry f [ processEnter := True ]
surname <- entry f [ processEnter := True ]
let dataItem = grid 10 10 [[label "Name:", widget name]
,[label "Surname:", widget surname]]
set f [layout := margin 10 $
grid 10 5
[[row 5 [label "Filter prefix:", widget filter], glue]
,[minsize (sz 200 300) $ widget listBox, dataItem]
,[row 10 [widget create, widget delete], glue]
]]
-- event network
network <- compile $ mdo
-- events from buttons
eDelete <- event0 delete command
eCreate <- event0 create command
-- time-varying value corresponding to the filter string
(bFilter, eFilter) <- reactimateTextEntry filter (pure "")
let dFilter = stepperD "" $ bFilter <@ eFilter
-- list box with selection
dSelectedItem <- reactimateListBox listBox database dFilter
-- data corresponding to the selected item in the list box
(inDataItem, changeDataItem)
<- reactimateDataItem (name, surname) outDataItem
let
-- update the database whenever
-- a data item is created, updated or deleted
database :: DatabaseTime DataItem
database = accumDatabase $
(Create Nothing ("Emil","Example") <$ eCreate)
`union` (Update <$> dSelectedItem <@>
(inDataItem <@ changeDataItem))
`union` (Delete <$> dSelectedItem <@ eDelete )
-- display the data item whenever the selection changes
outDataItem = stepperD ("","") $
lookup <$> valueDB database <@> changes dSelectedItem
where
lookup database m = maybe ("","") id $
readDatabase database =<< m
-- automatically enable / disable editing
let dDisplayItem = maybe False (const True) <$> dSelectedItem
sink delete [ enabled :== dDisplayItem ]
sink name [ enabled :== dDisplayItem ]
sink surname [ enabled :== dDisplayItem ]
actuate network
{-----------------------------------------------------------------------------
Database Model
------------------------------------------------------------------------------}
-- Create/Update/Delete data type for efficient updates
data CUD key a
= Create { getKey :: key, getItem :: a }
| Update { getKey :: key, getItem :: a }
| Delete { getKey :: key }
instance Functor (CUD key) where
fmap f (Delete x) = Delete x
fmap f cud = cud { getItem = f $ getItem cud }
isDelete (Delete _) = True
isDelete _ = False
-- Database type
type DatabaseKey = Int
data Database a = Database { nextKey :: !Int, db :: Map.Map DatabaseKey a }
emptyDatabase = Database 0 Map.empty
-- Time-varying database,
-- similar to the Discrete type
data DatabaseTime a = DatabaseTime
{ valueDB :: Behavior (Database a)
, initialDB :: Database a
, changesDB :: Event (CUD DatabaseKey a)
}
-- accumulate a database from CUD operations
accumDatabase :: Event (CUD (Maybe DatabaseKey) a) -> DatabaseTime a
accumDatabase e = DatabaseTime valueDB initialDB changesDB
where
(changesDB, valueDB) = mapAccum initialDB $ acc <$> filterE valid e
initialDB = emptyDatabase
valid (Create Nothing _) = True
valid cud = maybe False (const True) $ getKey cud
-- accumulation function
acc (Create Nothing x) (Database newkey db)
= (Create newkey x, Database (newkey+1) $ Map.insert newkey x db)
acc (Update (Just key) x) (Database newkey db)
= (Update key x, Database newkey $ Map.insert key x db)
acc (Delete (Just key)) (Database newkey db)
= (Delete key , Database newkey $ Map.delete key db)
-- read a value from the database
readDatabase :: Database a -> DatabaseKey -> Maybe a
readDatabase (Database _ db) = flip Map.lookup db
{-----------------------------------------------------------------------------
Data items that are stored in the data base
------------------------------------------------------------------------------}
type DataItem = (String, String)
-- text entry widgets in terms of discrete time-varying values
reactimateTextEntry
:: TextCtrl a
-> Discrete String -- set text programmatically (view)
-> NetworkDescription
(Behavior String -- current text (both view & controller)
,Event ()) -- user changes (controller)
reactimateTextEntry entry input = do
sink entry [ text :== input ]
-- event: Enter key
eEnter <- event0 entry command
-- event: text entry loses focus
eLeave <- (() <$) . filterE not <$> event1 entry focus
b <- behavior entry text
return (b, eEnter `union` eLeave)
-- whole data item (consisting of two text entries)
reactimateDataItem
:: (TextCtrl a, TextCtrl b)
-> Discrete DataItem
-> NetworkDescription
(Behavior DataItem, Event ())
reactimateDataItem (name,surname) input = do
(d1,e1) <- reactimateTextEntry name (fst <$> input)
(d2,e2) <- reactimateTextEntry surname (snd <$> input)
return ( (,) <$> d1 <*> d2 , e1 `union` e2 )
-- custom show function
showDataItem (name, surname) = surname ++ ", " ++ name
{-----------------------------------------------------------------------------
List Box View
------------------------------------------------------------------------------}
-- Display the data base in a list box (view).
-- Also keep track of the currently selected item (controller).
reactimateListBox
:: SingleListBox b -- list box widget
-> DatabaseTime DataItem -- database
-> Discrete String -- filter string
-> NetworkDescription
(Discrete (Maybe DatabaseKey)) -- current selection as database key
reactimateListBox listBox database filter = do
-- The list box keeps track
-- of which data items are displayed, at which positions
let (eListBoxUpdates, bDisplayMap)
= mapAccum Map.empty
$ (cudUpdate . fmap showDataItem <$> changesDB database)
`union` (filterUpdate <$> valueDB database <@> changes filter)
-- "animate" changes to the list box
reactimate $ eListBoxUpdates
-- debug: reactimate $ fmap print $ bDisplayMap <@ eListBoxUpdates
-- event: item selection, maps to database key
fixSelectionEvent listBox
bSelection <- behavior listBox selection
eSelect <- event0 listBox select
let eDelete = filterE isDelete $ changesDB database
return $ stepperD Nothing $
-- event: item deleted
(Nothing <$ eDelete) `union`
-- event: filter string changed
(Nothing <$ changes filter) `union`
-- event: user changes selection
(lookupPositon <$> bSelection <*> bDisplayMap <@ eSelect)
where
-- turn CUD into a function that updates
-- ( the graphics of the list box
-- , the map from database keys to list positions )
cudUpdate
:: CUD DatabaseKey String -> DisplayMap -> (IO (), DisplayMap)
cudUpdate (Create key str) display
= (itemAppend listBox str, appendKey key display)
cudUpdate (Update key str) display
= case lookupKey key display of
Just position -> (set listBox [ item position := str ], display)
Nothing -> (return (), display)
cudUpdate (Delete key) display
= case lookupKey key display of
Just position -> (itemDelete listBox position
,deleteKey key position display)
Nothing -> (return (), display)
-- rebuild listBox when filter string changes
filterUpdate database s _ = (set listBox [ items := xs ], display)
where
dat = Map.filter (s `Data.List.isPrefixOf`)
. Map.map showDataItem . db $ database
xs = Map.elems dat
display = Map.fromList $ zip (Map.keys dat) [0..]
-- Map between database keys and their position in the list box
type DisplayMap = Map.Map DatabaseKey Int
lookupKey = Map.lookup
lookupPositon pos = fmap fst . Data.List.find ((pos ==) . snd) . Map.toList
appendKey key display = Map.insert key (Map.size display) display
deleteKey key position display
= Map.delete key
-- recalculate positions of the other elements
. Map.map (\pos -> if pos > position then pos - 1 else pos)
$ display
{-----------------------------------------------------------------------------
wxHaskell bug fixes
------------------------------------------------------------------------------}
-- Fix @select@ event not being fired when items are *un*selected
fixSelectionEvent listbox =
liftIO $ set listbox [ on unclick := handler ]
where
handler _ = do
propagateEvent
s <- get listbox selection
when (s == -1) $ (get listbox (on select)) >>= id