{-----------------------------------------------------------------------------
reactive-banana-wx
Example:
Small database with CRUD operations and filtering.
To keep things simple, the list box is rebuild every time
that the database is updated. This is perfectly fine for rapid prototyping.
A more sophisticated approach would use incremental updates.
------------------------------------------------------------------------------}
{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. NetworkDescription t"
{-# LANGUAGE RecursiveDo, NoMonomorphismRestriction #-}
import Prelude hiding (lookup)
import Data.List (isPrefixOf)
import Data.Maybe
import Data.Monoid
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Graphics.UI.WX as WX
import Graphics.UI.WX hiding (Event)
import Reactive.Banana
import Reactive.Banana.WX
{-----------------------------------------------------------------------------
Main
------------------------------------------------------------------------------}
main = start $ do
-- GUI layout
f <- frame [ text := "CRUD Example (Simple)" ]
listBox <- singleListBox f []
createBtn <- button f [ text := "Create" ]
deleteBtn <- button f [ text := "Delete" ]
filterEntry <- entry f [ processEnter := True ]
firstname <- entry f [ processEnter := True ]
lastname <- entry f [ processEnter := True ]
let dataItem = grid 10 10 [[label "First Name:", widget firstname]
,[label "Last Name:" , widget lastname]]
set f [layout := margin 10 $
grid 10 5
[[row 5 [label "Filter prefix:", widget filterEntry], glue]
,[minsize (sz 200 300) $ widget listBox, dataItem]
,[row 10 [widget createBtn, widget deleteBtn], glue]
]]
-- event network
let networkDescription :: forall t. NetworkDescription t ()
networkDescription = mdo
-- events from buttons
eCreate <- event0 createBtn command
eDelete <- event0 deleteBtn command
-- filter string
bFilterString <- behaviorText filterEntry ""
let bFilter :: Behavior t (String -> Bool)
bFilter = isPrefixOf <$> bFilterString
-- list box with selection
bSelection <- reactiveListDisplay listBox bListItems bShowDataItem
-- data item display
(_,eDataItemIn) <- reactiveDataItem (firstname,lastname) bDataItemOut
let -- database
bDatabase :: Behavior t (Database DataItem)
bDatabase = accumB emptydb $ mconcat
[ create ("Emil","Example") <$ eCreate
, filterJust $ update' <$> bSelection <@> eDataItemIn
, delete <$> filterJust (bSelection <@ eDelete)
]
where
update' mkey x = flip update x <$> mkey
bLookup :: Behavior t (DatabaseKey -> Maybe DataItem)
bLookup = flip lookup <$> bDatabase
bShowDataItem :: Behavior t (DatabaseKey -> String)
bShowDataItem = (maybe "" showDataItem .) <$> bLookup
bListItems :: Behavior t [DatabaseKey]
bListItems = (\p show -> filter (p. show) . keys)
<$> bFilter <*> bShowDataItem <*> bDatabase
bDataItemOut :: Behavior t (Maybe DataItem)
bDataItemOut = (=<<) <$> bLookup <*> bSelection
-- TODO: Delete event must change selection!
-- automatically enable / disable editing
let
bDisplayItem :: Behavior t Bool
bDisplayItem = maybe False (const True) <$> bSelection
sink deleteBtn [ enabled :== bDisplayItem ]
sink firstname [ enabled :== bDisplayItem ]
sink lastname [ enabled :== bDisplayItem ]
network <- compile networkDescription
actuate network
{-----------------------------------------------------------------------------
Database Model
------------------------------------------------------------------------------}
type DatabaseKey = Int
data Database a = Database { nextKey :: !Int, db :: Map.Map DatabaseKey a }
emptydb = Database 0 Map.empty
keys = Map.keys . db
create x (Database newkey db) = Database (newkey+1) $ Map.insert newkey x db
update key x (Database newkey db) = Database newkey $ Map.insert key x db
delete key (Database newkey db) = Database newkey $ Map.delete key db
lookup key (Database _ db) = Map.lookup key db
{-----------------------------------------------------------------------------
Data items that are stored in the data base
------------------------------------------------------------------------------}
type DataItem = (String, String)
showDataItem (firstname, lastname) = lastname ++ ", " ++ firstname
{- Note: On breaking feedback loops.
The right abstraction for this is a behavior + notifications .
The point is that the notifications do *not* represent every single change
in the behavior. Instead, they represent selected changes.
That's why the applicative instance for this data type is a bit different
than usual.
-}
-- text entry widgets in terms of discrete time-varying values
reactiveTextEntry
:: TextCtrl a
-> Behavior t String -- set text programmatically (view)
-> NetworkDescription t
(Behavior t String -- current text (both view & controller)
,Event t String) -- user changes (controller)
reactiveTextEntry entry input = do
sink entry [ text :== input ] -- display value
eUser <- changes =<< behaviorText entry "" -- user changes
eIn <- changes input -- input changes
x <- initial input
-- programmatic changes will affect the text box *after* user changes.
return (stepper x (eUser `union` eIn), eUser)
-- whole data item (consisting of two text entries)
reactiveDataItem
:: (TextCtrl a, TextCtrl b)
-> Behavior t (Maybe DataItem)
-> NetworkDescription t
(Behavior t DataItem, Event t DataItem)
reactiveDataItem (firstname,lastname) input = do
(b1,e1) <- reactiveTextEntry firstname (fst . maybe ("","") id <$> input)
(b2,e2) <- reactiveTextEntry lastname (snd . maybe ("","") id <$> input)
return ( (,) <$> b1 <*> b2 ,
((,) <$> b1 <@> e2) `union` (flip (,) <$> b2 <@> e1))
{-----------------------------------------------------------------------------
reactive list display
Display a list of (distinct) items in a list box.
The current selection contains one or no items.
Changing the set may unselect the current item,
but will not change it to another item.
------------------------------------------------------------------------------}
reactiveListDisplay :: forall t a b. Ord a
=> SingleListBox b -- ListBox widget to use
-> Behavior t [a] -- list of items
-> Behavior t (a -> String) -- display an item
-> NetworkDescription t
(Behavior t (Maybe a)) -- current selection as item (possibly empty)
reactiveListDisplay listBox elements display = do
-- retrieve selection index
bSelection <- behaviorListBoxSelection listBox
-- display items
sink listBox [ items :== map <$> display <*> elements ]
-- changing the display won't change the current selection
eDisplay <- changes display
sink listBox [ selection :== stepper (-1) $ bSelection <@ eDisplay ]
-- return current selection as element
let bIndexed :: Behavior t (Map.Map Int a)
bIndexed = Map.fromList . zip [0..] <$> elements
return $ Map.lookup <$> bSelection <*> bIndexed
{-----------------------------------------------------------------------------
wxHaskell convenience wrappers and bug fixes
------------------------------------------------------------------------------}
-- | Return *user* changes to the list box selection.
behaviorListBoxSelection :: SingleListBox b -> NetworkDescription t (Behavior t Int)
behaviorListBoxSelection listBox = do
liftIO $ fixSelectionEvent listBox
a <- liftIO $ event1ToAddHandler listBox (event0ToEvent1 select)
fromChanges (-1) $ mapIO (const $ get listBox selection) a
-- 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