Skip to content
This repository
tree: 675f4ef422
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 230 lines (194 sloc) 9.633 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229
{-----------------------------------------------------------------------------
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 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 [ 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
            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 $ mconcat
                    [ 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
                    ]
                    where
                    unions = foldr1 union
                
                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
    :: TextCtrl a
    -> Behavior t String -- text value
    -> NetworkDescription t
        (Tidings t String) -- user changes
reactiveTextEntry w btext = do
    sink w [ text :== btext ] -- display value
    eUser <- eventText w -- user changes
    return $ tidings btext eUser

-- whole data item (consisting of two text entries)
reactiveDataItem
    :: (TextCtrl a, TextCtrl b)
    -> Behavior t (Maybe DataItem)
    -> NetworkDescription 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
    => 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
    -> NetworkDescription 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 -> 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
------------------------------------------------------------------------------}
-- user input event - text for text entries
eventText :: TextCtrl w -> NetworkDescription 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 -> NetworkDescription 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
Something went wrong with that request. Please try again.