{-----------------------------------------------------------------------------
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. Moment 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 qualified Graphics.UI.WXCore as WXCore
import Reactive.Banana
import Reactive.Banana.WX
import Tidings
{-----------------------------------------------------------------------------
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 [ ]
firstname <- entry f [ ]
lastname <- entry f [ ]
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. Frameworks t => Moment t ()
networkDescription = mdo
-- events from buttons
eCreate <- event0 createBtn command
eDelete <- event0 deleteBtn command
-- filter string
tFilterString <- reactiveTextEntry filterEntry bFilterString
let bFilterString = stepper "" $ rumors tFilterString
tFilter = isPrefixOf <$> tFilterString
bFilter = facts tFilter
eFilter = rumors tFilter
-- list box with selection
eSelection <- rumors <$> reactiveListDisplay listBox
bListBoxItems bSelection bShowDataItem
-- data item display
eDataItemIn <- rumors <$> reactiveDataItem (firstname,lastname)
bSelectionDataItem
let -- database
bDatabase :: Behavior t (Database DataItem)
bDatabase = accumB emptydb $ unions
[ create ("Emil","Example") <$ eCreate
, filterJust $ update' <$> bSelection <@> eDataItemIn
, delete <$> filterJust (bSelection <@ eDelete)
]
where
update' mkey x = flip update x <$> mkey
-- selection
bSelection :: Behavior t (Maybe DatabaseKey)
bSelection = stepper Nothing $ unions
[ eSelection
, Nothing <$ eDelete
, Just . nextKey <$> bDatabase <@ eCreate
, (\b s p -> b >>= \a -> if p (s a) then Just a else Nothing)
<$> bSelection <*> bShowDataItem <@> eFilter
]
bLookup :: Behavior t (DatabaseKey -> Maybe DataItem)
bLookup = flip lookup <$> bDatabase
bShowDataItem :: Behavior t (DatabaseKey -> String)
bShowDataItem = (maybe "" showDataItem .) <$> bLookup
bListBoxItems :: Behavior t [DatabaseKey]
bListBoxItems = (\p show -> filter (p. show) . keys)
<$> bFilter <*> bShowDataItem <*> bDatabase
bSelectionDataItem :: Behavior t (Maybe DataItem)
bSelectionDataItem = (=<<) <$> bLookup <*> bSelection
-- 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
-- single text entry
reactiveTextEntry :: Frameworks t
=> TextCtrl a
-> Behavior t String -- text value
-> Moment t (Tidings t String) -- user changes
reactiveTextEntry w btext = do
eUser <- eventText w -- user changes
-- filter text setting that are simultaneous with user events
itext <- initial btext
etext <- changes btext
let etext2 = fst $ split $ unionWith (curry snd) (Left <$> etext) (Right <$> eUser)
btext2 = stepper itext etext2
sink w [ text :== btext2 ] -- display value
return $ tidings btext eUser
-- whole data item (consisting of two text entries)
reactiveDataItem :: Frameworks t
=> (TextCtrl a, TextCtrl b)
-> Behavior t (Maybe DataItem)
-> Moment t (Tidings t DataItem)
reactiveDataItem (firstname,lastname) binput = do
t1 <- reactiveTextEntry firstname (fst . maybe ("","") id <$> binput)
t2 <- reactiveTextEntry lastname (snd . maybe ("","") id <$> binput)
return $ (,) <$> t1 <*> t2
{-----------------------------------------------------------------------------
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, Frameworks t)
=> SingleListBox b -- ListBox widget to use
-> Behavior t [a] -- list of items
-> Behavior t (Maybe a) -- selected element
-> Behavior t (a -> String) -- display an item
-> Moment t
(Tidings t (Maybe a)) -- current selection as item (possibly empty)
reactiveListDisplay w bitems bsel bdisplay = do
-- animate output items
liftIO $ putStrLn "test"
sink w [ items :== map <$> bdisplay <*> bitems ]
-- animate output selection
let bindices :: Behavior t (Map.Map a Int)
bindices = (Map.fromList . flip zip [0..]) <$> bitems
bindex = (\m a -> maybe (-1) id $ flip Map.lookup m =<< a) <$>
bindices <*> bsel
sink w [ selection :== bindex ]
-- changing the display won't change the current selection
-- eDisplay <- changes display
-- sink listBox [ selection :== stepper (-1) $ bSelection <@ eDisplay ]
-- user selection
let bindices2 :: Behavior t (Map.Map Int a)
bindices2 = Map.fromList . zip [0..] <$> bitems
esel <- eventSelection w
return $ tidings bsel $ flip Map.lookup <$> bindices2 <@> esel
{-----------------------------------------------------------------------------
wxHaskell convenience wrappers and bug fixes
------------------------------------------------------------------------------}
{- Currently exported from Reactive.Banana.WX
-- user input event - text for text entries
eventText :: TextCtrl w -> Moment t (Event t String)
eventText w = do
-- Should probably be wxEVT_COMMAND_TEXT_UPDATED ,
-- but that's missing from wxHaskell.
-- Note: Observing keyUp events does create a small lag
addHandler <- liftIO $ event1ToAddHandler w keyboardUp
fromAddHandler $ mapIO (const $ get w text) addHandler
-- observe "key up" events (many thanks to Abu Alam)
-- this should probably be in the wxHaskell library
keyboardUp :: WX.Event (Window a) (EventKey -> IO ())
keyboardUp = WX.newEvent "keyboardUp" WXCore.windowGetOnKeyUp WXCore.windowOnKeyUp
-- user input event - selection marker for list events
eventSelection :: SingleListBox b -> Moment t (Event t Int)
eventSelection w = do
liftIO $ fixSelectionEvent w
addHandler <- liftIO $ event1ToAddHandler w (event0ToEvent1 select)
fromAddHandler $ mapIO (const $ get w selection) addHandler
-- 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
-}