{-----------------------------------------------------------------------------
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 qualified Data.Map as Map
import Graphics.UI.WX hiding (Event)
import Reactive.Banana
import Reactive.Banana.WX
import Tidings
{-----------------------------------------------------------------------------
Main
------------------------------------------------------------------------------}
main :: IO ()
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 = isJust <$> 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 a
emptydb = Database 0 Map.empty
keys :: Database a -> [DatabaseKey]
keys = Map.keys . db
create :: a -> Database a -> Database a
create x (Database newkey db) = Database (newkey+1) $ Map.insert newkey x db
update :: DatabaseKey -> a -> Database a -> Database a
update key x (Database newkey db) = Database newkey $ Map.insert key x db
delete :: DatabaseKey -> Database a -> Database a
delete key (Database newkey db) = Database newkey $ Map.delete key db
lookup :: DatabaseKey -> Database a -> Maybe a
lookup key (Database _ db) = Map.lookup key db
{-----------------------------------------------------------------------------
Data items that are stored in the data base
------------------------------------------------------------------------------}
type DataItem = (String, String)
showDataItem :: ([Char], [Char]) -> [Char]
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
etext <- changes btext
let
etext2 = fst $ split $ unionWith (curry snd) (Left () <$ etext) (Right () <$ eUser)
btext2 = imposeChanges btext 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 . fromMaybe ("","") <$> binput)
t2 <- reactiveTextEntry lastname (snd . fromMaybe ("","") <$> 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
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 -> fromMaybe (-1) $ 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
-}