Skip to content
This repository
branch: master
alexander-b December 20, 2013
file 94 lines (71 sloc) 3.431 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
{-----------------------------------------------------------------------------
reactive-banana-wx
Example: Bar tab with a variable number of widgets
------------------------------------------------------------------------------}
{-# LANGUAGE ScopedTypeVariables #-} -- allows "forall t. Moment t"
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}

import Data.Maybe (listToMaybe)

import Graphics.UI.WX hiding (Event)
import Reactive.Banana
import Reactive.Banana.WX

import Data.Traversable (sequenceA)

{-----------------------------------------------------------------------------
Main
------------------------------------------------------------------------------}
main :: IO ()
main = start $ do
    f <- frame [text := "Bar Tab"]
    msg <- staticText f [ text := "Sum:" ]
    total <- staticText f []
    add <- button f [text := "Add"]
    remove <- button f [text := "Remove"]
    
    let networkDescription :: forall t. Frameworks t => Moment t ()
        networkDescription = do
            eAdd <- event0 add command
            eRemove <- event0 remove command
            
            let
                newEntry :: Frameworks s
                         => Moment s (TextCtrl (), AnyMoment Behavior String)
                newEntry = do
                    wentry <- liftIO $ entry f []
                    bentry <- trimB =<< behaviorText wentry ""
                    return (wentry, bentry)
            
            eNewEntry <- execute $ FrameworksMoment newEntry <$ eAdd
            
            let
                eDoRemove = whenE (not . null <$> bEntries) eRemove
            
                eEntries :: Event t [(TextCtrl (), AnyMoment Behavior String)]
                eEntries = accumE [] $
                    ((\x -> (++ [x])) <$> eNewEntry) `union` (init <$ eDoRemove)
            
                bEntries = stepper [] eEntries
            
            reactimate $ ((\w -> set w [ visible := False]) . fst . last)
                <$> bEntries <@ eDoRemove
            
            let
                ePrices :: Event t [AnyMoment Behavior Number]
                ePrices = map (fmap readNumber . snd) <$> eEntries
                
                bLayout :: Behavior t Layout
                bLayout = mkLayout . map fst <$> bEntries
                
                mkLayout entries = margin 10 $ column 10 $
                    [row 10 [widget add, widget remove]] ++ map widget entries
                    ++ [row 10 [widget msg, minsize (sz 40 20) $ widget total]]
        
                bTotal :: Behavior t Number
                bTotal = switchB (pure Nothing) $
                            (fmap sum . sequenceA) <$> ePrices

            sink total [text :== showNumber <$> bTotal]
            sink f [layout :== bLayout]
            
    network <- compile networkDescription
    actuate network

{-----------------------------------------------------------------------------
Utilities
------------------------------------------------------------------------------}
type Number = Maybe Double

instance Num Number where
    (+) = liftA2 (+)
    (-) = liftA2 (-)
    (*) = liftA2 (*)
    abs = fmap abs
    signum = fmap signum
    fromInteger = pure . fromInteger

readNumber :: Read a => String -> Maybe a
readNumber s = listToMaybe [x | (x,"") <- reads s]

showNumber :: Maybe Double -> String
showNumber = maybe "--" show
Something went wrong with that request. Please try again.