{----------------------------------------------------------------------------- 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 pattern signatures like -- do -- (b :: Behavior Int) <- stepper 0 ... {-# LANGUAGE RecursiveDo #-} -- allows recursive do notation -- mdo -- ... import Prelude hiding (lookup) import Data.List (isPrefixOf) import Data.Maybe import qualified Data.Map as Map import Graphics.UI.WX hiding (Event, update) 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 :: MomentIO () networkDescription = mdo -- events from buttons eCreate <- event0 createBtn command eDelete <- event0 deleteBtn command -- filter string tFilterString <- reactiveTextEntry filterEntry bFilterString bFilterString <- stepper "" $ rumors tFilterString let 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 -- database (bDatabase :: Behavior (Database DataItem)) <- accumB emptydb $ unions [ create ("Emil","Example") <$ eCreate , filterJust $ update' <$> bSelection <@> eDataItemIn , delete <$> filterJust (bSelection <@ eDelete) ] let update' mkey x = flip update x <$> mkey -- selection (bSelection :: Behavior (Maybe DatabaseKey)) <- stepper Nothing $ foldr1 (unionWith const) [ eSelection , Nothing <$ eDelete , Just . nextKey <$> bDatabase <@ eCreate , (\b s p -> b >>= \a -> if p (s a) then Just a else Nothing) <$> bSelection <*> bShowDataItem <@> eFilter ] let bLookup :: Behavior (DatabaseKey -> Maybe DataItem) bLookup = flip lookup <$> bDatabase bShowDataItem :: Behavior (DatabaseKey -> String) bShowDataItem = (maybe "" showDataItem .) <$> bLookup bListBoxItems :: Behavior [DatabaseKey] bListBoxItems = (\p show -> filter (p. show) . keys) <$> bFilter <*> bShowDataItem <*> bDatabase bSelectionDataItem :: Behavior (Maybe DataItem) bSelectionDataItem = (=<<) <$> bLookup <*> bSelection -- automatically enable / disable editing let bDisplayItem :: Behavior 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 :: TextCtrl a -> Behavior String -- text value -> MomentIO (Tidings 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 :: (TextCtrl a, TextCtrl b) -> Behavior (Maybe DataItem) -> MomentIO (Tidings 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 a b. Ord a => SingleListBox b -- ListBox widget to use -> Behavior [a] -- list of items -> Behavior (Maybe a) -- selected element -> Behavior (a -> String) -- display an item -> MomentIO (Tidings (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 (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 (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 -}