/
BarTab.hs
99 lines (78 loc) · 3.22 KB
/
BarTab.hs
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
{-----------------------------------------------------------------------------
reactive-banana-wx
Example: Bar tab with a variable number of widgets
------------------------------------------------------------------------------}
{-# LANGUAGE ScopedTypeVariables #-}
-- allows pattern signatures like
-- do
-- (b :: Behavior Int) <- stepper 0 ...
{-# LANGUAGE RecursiveDo #-}
-- allows recursive do notation
-- mdo
-- ...
{-# 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 :: MomentIO ()
networkDescription = mdo
eAdd <- event0 add command
eRemove <- event0 remove command
let
newEntry :: MomentIO (TextCtrl (), Behavior String)
newEntry = do
wentry <- liftIO $ entry f []
bentry <- behaviorText wentry ""
return (wentry, bentry)
eNewEntry <- execute $ newEntry <$ eAdd
let eDoRemove = whenE (not . null <$> bEntries) eRemove
(eEntries :: Event [(TextCtrl (), Behavior String)])
<- accumE [] $ unions
[ (\x -> (++ [x])) <$> eNewEntry
, init <$ eDoRemove
]
bEntries <- stepper [] eEntries
reactimate $ ((\w -> set w [ visible := False]) . fst . last)
<$> bEntries <@ eDoRemove
let
ePrices :: Event [Behavior Number]
ePrices = map (fmap readNumber . snd) <$> eEntries
bLayout :: Behavior 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 Number)
<- 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