summaryrefslogtreecommitdiff
path: root/Reactive/Banana/Automation.hs
blob: e90fd26e0b0bf039ef0b7a9b0471b1808aae039e (plain)
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
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
{-# LANGUAGE TypeSynonymInstances, LambdaCase, DeriveFunctor #-}

-- | Home (etc) automation using reactive-banana.
--
-- Functional Reactive Programming is a natural fit for home automation,
-- which involves sensor values that vary over time and are used to control
-- actuators.
--
-- This library provides a framework and some useful types for
-- using the reactive-banana FRP library for home automation.
-- 
-- Its main abstraction is the `Automation` which describes how to process
-- `Event`s from `Sensor`s and how to drive actuators such as lights,
-- and relays in response.
--
-- See "Reactive.Banana.Automation.Examples" for several examples
-- of using this library.
module Reactive.Banana.Automation (
	-- * Framework
	Automation(..),
	MomentAutomation,
	runAutomation,
	observeAutomation,
	-- * Events
	EventSource,
	gotEvent,
	getEventFrom,
	onEvent,
	-- * Sensors
	Sensed (..),
	sensedEvent,
	sensedBehavior,
	sensed,
	(=:),
	-- * Time
	Timestamped(..),
	Timestamp(..),
	sensedNow,
	sensedAt,
	elapsedTimeSince,
	ClockSignal(..),
	clockSignal,
	clockSignalAt,
	clockSignalBehavior,
	-- * Actuators
	PowerChange(..),
	onBehaviorChange,
	onBehaviorChangeMaybe,
	-- * Ranges
	Range(..),
	belowRange,
	aboveRange,
	inRange,
	extendRange
) where

import Reactive.Banana
import Reactive.Banana.Frameworks
import Data.Semigroup as Sem
import Control.Monad.Fix
import Control.Concurrent.STM
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Time.LocalTime

-- | An Automation receives `Event`s from some sensors and decides what
-- to do, controlling the actuators. It is implemented as a reactive-banana
-- event network description.
--
-- For example, let's make an automation for a fridge, which has a
-- temperature sensor and a relay controlling its power, and should
-- run as needed to keep the temperature in a safe range, while
-- minimizing compressor starts.
--
-- > data Sensors = Sensors { fridgeTemperature :: EventSource (Sensed Double) }
-- > data Actuators = FridgePower PowerChange deriving (Show)
-- > 
-- > fridge :: Automation Sensors Actuators
-- > fridge = Automation $ \sensors actuators -> do
-- >	btemperature <- sensedBehavior (fridgeTemperature sensors)
-- >	let bpowerchange = calcpowerchange <$> btemperature
-- >	onBehaviorChange bpowerchange (actuators . FridgePower)
-- >   where
-- >	calcpowerchange (Sensed temp)
-- >		| temp `belowRange` allowedtemp = Just PowerOff
-- >		| temp `aboveRange` allowedtemp = Just PowerOn
-- >		| otherwise = Nothing
-- >	calcpowerchange SensorUnavailable = Nothing
-- >	allowedtemp = Range 1 4
newtype Automation sensors actuators = Automation (sensors -> (actuators -> IO ()) -> MomentAutomation ())

instance Sem.Semigroup (Automation sensors actuators) where
	Automation a <> Automation b = Automation $ \sensors actuators -> do
		a sensors actuators
		b sensors actuators

instance Monoid (Automation sensors actuators) where
	mempty = Automation $ \_sensors _actuators -> return ()
	mappend = (Sem.<>)

-- | This is simply a wrapper around reactive-banana's `MomentIO`,
-- but without the `MonadIO` instance, so an `Automation` using this monad
-- is limited to using its sensors and actuators for IO. That allows
-- it to be fully tested using `observeAutomation`.
--
-- All of "Reactive.Banana.Combinators" can be used with this monad.
newtype MomentAutomation a = MomentAutomation
	{ unMomentAutomation :: MomentIO a }

instance Functor MomentAutomation where
	fmap f = MomentAutomation . fmap f . unMomentAutomation

instance Monad MomentAutomation where
	return  = MomentAutomation . return
	m >>= g = MomentAutomation $
		unMomentAutomation m >>= unMomentAutomation . g
instance Applicative MomentAutomation where
	pure = MomentAutomation . pure
	f <*> a = MomentAutomation $
		unMomentAutomation f <*> unMomentAutomation a
instance MonadFix MomentAutomation where
	mfix f = MomentAutomation $ mfix (unMomentAutomation . f)

instance MonadMoment MomentAutomation where
	liftMoment = MomentAutomation . liftMoment

setupAutomation :: Automation sensors actuators -> IO sensors -> (actuators -> IO ()) -> IO sensors
setupAutomation (Automation automation) mksensors actutators = do
	sensors <- mksensors
	network <- compile $ unMomentAutomation $ automation sensors actutators
	actuate network
	return sensors

-- | Runs an Automation, given a constructor for the sensors, an IO
-- action to drive the actuators, and an IO action that feeds data into
-- the sensors.
-- 
-- Continuing the above example of a fridge, here's how to run it:
-- 
-- > mkSensors :: IO Sensors
-- > mkSensors = Sensors <$> newAddHandler
-- > 
-- > driveActuators :: Actuators -> IO ()
-- > driveActuators = print
-- >
-- > getFridgeTemperature :: IO Double
-- > getFridgeTemperature = ...
-- > 
-- > main = runAutomation fridge mkSensors driveActuators $ \sensors -> do
-- > 	getFridgeTemperature >>= sensed (fridgeTemperature sensors)
--
-- Note that this function does not return; the sensor feeding action is
-- run in a loop.
runAutomation :: Automation sensors actuators -> IO sensors -> (actuators -> IO ()) -> (sensors -> IO ()) -> IO ()
runAutomation automation mksensors actuators poller = do
	sensors <- setupAutomation automation mksensors actuators
	mainloop sensors
  where
	mainloop sensors = do
		poller sensors
		mainloop sensors

-- | Allows observing what an Automation does. Designed to be especially
-- useful for testing.
--
-- The Automation is started, and a runner action is returned.
-- The runner allows updating the sensors, and returns what the
-- Automation wants to do in response.
--
-- For example, in ghci:
--
-- > > runner <- observeAutomation fridge mkSensors
-- > > runner $ \sensors -> fridgeTemperature sensors =: 6
-- > [FridgeRelay PowerOn]
-- > > runner $ \sensors -> fridgeTemperature sensors =: 3
-- > []
-- > > runner $ \sensors -> fridgeTemperature sensors =: 0.5
-- > [FridgeRelay PowerOff]
--
-- Note that internal state is maintained between calls to the runner.
observeAutomation :: Automation sensors actuators -> IO sensors -> IO ((sensors -> IO ()) -> IO [actuators])
observeAutomation automation mksensors = do
	tv <- newTVarIO []
	lck <- newEmptyTMVarIO
	let addeffect e = atomically $ modifyTVar' tv (e:)
	sensors <- setupAutomation automation mksensors addeffect
	let runner a = do
		-- Avoid concurrent calls, since there is only one
		-- tv to collect effects.
		atomically $ putTMVar lck ()
		() <- a sensors
		l <- atomically $ do
			takeTMVar lck
			swapTVar tv []
		return (reverse l)
	return runner

-- | A source of events.
type EventSource a = (AddHandler a, a -> IO ())

addHandler :: EventSource a -> AddHandler a
addHandler = fst

-- | Call this to trigger an event.
gotEvent :: EventSource a -> a -> IO ()
gotEvent = snd

-- | Get an Event from an EventSource.
getEventFrom :: EventSource a -> MomentAutomation (Event a)
getEventFrom = MomentAutomation . fromAddHandler . addHandler

-- | Runs an action when an event occurs.
onEvent :: Event a -> (a -> IO ()) -> MomentAutomation ()
onEvent e a = MomentAutomation . reactimate $ fmap a e

-- | A value read from a sensor.
--
-- Sensors are sometimes not available, or have not provided a value
-- yet.
data Sensed a = SensorUnavailable | Sensed a
	deriving (Show, Functor)

-- | Create an Event from sensed values.
--
-- The Event only contains values when the sensor provided a reading,
-- not times when it was unavailable.
sensedEvent :: EventSource (Sensed a) -> MomentAutomation (Event a)
sensedEvent s = do
	e <- getEventFrom s
	return $ filterJust $ flip fmap e $ \case
		SensorUnavailable -> Nothing
		Sensed a -> Just a

-- | Create a Behavior from sensed values.
sensedBehavior :: EventSource (Sensed a) -> MomentAutomation (Behavior (Sensed a))
sensedBehavior s = 
	MomentAutomation . stepper SensorUnavailable =<< getEventFrom s

-- | Call when a sensor has sensed a value.
--
-- > getFridgeTemperature >>= sensed (fridgeTemperature sensors)
sensed :: EventSource (Sensed a) -> a -> IO ()
sensed s = gotEvent s . Sensed

-- | Same as `sensed`
-- 
-- > fridgeTemperature sensors =: 0
(=:) :: EventSource (Sensed a) -> a -> IO ()
(=:) = sensed

-- | A timestamped value.
--
-- In reactive-banana, an `Event` is tagged with its time of occurrence,
-- but that internal representation of time is never exposed. It can be
-- useful to have an `Event` timestamped as occurring at a specific wall
-- clock time.
--
-- See `Reactive.Banana.Examples.motionActivatedLight` for an example
-- of using timestamped values, and how to test code that uses them.
data Timestamped t a = Timestamped
	{ timestamp :: t
	, value :: a
	}

instance (Show t, Show a) => Show (Timestamped t a) where
	show (Timestamped t a) = show t ++ " " ++ show a

instance Functor (Timestamped t) where
	fmap f (Timestamped t a) = Timestamped t (f a)

-- | Class of values that are timestamps.
class Timestamp t where
	getCurrentTimestamp :: IO t

instance Timestamp POSIXTime where
	getCurrentTimestamp = getPOSIXTime

instance Timestamp UTCTime where
	getCurrentTimestamp = getCurrentTime

instance Timestamp ZonedTime where
	getCurrentTimestamp = getZonedTime

instance Timestamp LocalTime where
	getCurrentTimestamp = zonedTimeToLocalTime <$> getZonedTime

instance Timestamp TimeOfDay where
	getCurrentTimestamp = localTimeOfDay <$> getCurrentTimestamp

-- | Call when a sensor has sensed a value, which will be `Timestamped` with
-- the current time.
sensedNow :: Timestamp t => EventSource (Sensed (Timestamped t a)) -> a -> IO ()
sensedNow es a = do
	now <- getCurrentTimestamp
	gotEvent es (Sensed (Timestamped now a))

-- | Call when a sensor sensed a value with a particular timestamp.
sensedAt :: Timestamp t => t -> EventSource (Sensed (Timestamped t a)) -> a -> IO ()
sensedAt ts es a = gotEvent es (Sensed (Timestamped ts a))

-- | Given a `Timestamped` `Event` and a function, produces an `Event`
-- that contains the elapsed time since the function last matched the
-- event's value.
--
-- `Reactive.Banana.Examples.motionActivatedLight` has a good example
-- of using this.
elapsedTimeSince
	:: (Num t, Timestamp t)
	=> (a -> Bool)
	-> Event (Timestamped t a)
	-> MomentAutomation (Event t)
elapsedTimeSince f event = fmap (fmap reduce) $ accumE Nothing $ go <$> event
  where
	go v' (Just (t, _v))
		| f (value v') = Just (timestamp v', v')
		| otherwise = Just (t, v')
	go v Nothing
		| f (value v) = Just (0, v)
		| otherwise = Nothing
	reduce (Just (t, v)) = timestamp v - t
	reduce Nothing = 0

-- | A clock signal.
--
-- See `Reactive.Banana.Examples.nightLight` for an example
-- of using clock signals, and how to test code that uses them.
--
-- It's recommended that any `Behavior` that contains a `ClockSignal`
-- be constructed to update whenever the clock signals an update.
data ClockSignal a = ClockSignal a
	deriving (Show, Eq, Ord, Functor)

-- | Call repeatedly to feed a clock signal to an `Automation`
-- that needs to know what time it is.
clockSignal :: Timestamp t => EventSource (ClockSignal t) -> IO ()
clockSignal es = gotEvent es . ClockSignal =<< getCurrentTimestamp

-- | Call to feed a particular time to an `Automation`.
clockSignalAt :: Timestamp t => t -> EventSource (ClockSignal t) -> IO ()
clockSignalAt t es = gotEvent es (ClockSignal t)

-- | Create a Behavior from a ClockSignal. It will initially be Nothing,
-- and then updates with each incoming clock signal.
clockSignalBehavior :: Timestamp t => EventSource (ClockSignal t) -> MomentAutomation (Behavior (Maybe (ClockSignal t)))
clockSignalBehavior s = MomentAutomation . stepper Nothing 
	=<< fmap Just <$> getEventFrom s

-- | For controlling relays and other things that can have
-- their power turned on and off.
data PowerChange = PowerOff | PowerOn
	deriving (Show)

-- | Runs an action when a behavior's value changes.
onBehaviorChange :: Behavior a -> (a -> IO ()) -> MomentAutomation ()
onBehaviorChange b a = MomentAutomation $ do
	c <- changes b
	reactimate' $ fmap a <$> c

-- | Variant of `onBehaviorChange` that does nothing when a behavior
-- changes to Nothing.
onBehaviorChangeMaybe :: Behavior (Maybe a) -> (a -> IO ()) -> MomentAutomation ()
onBehaviorChangeMaybe b a = MomentAutomation $ do
	c <- changes b
	reactimate' $ fmap (maybe (return ()) a) <$> c

-- | The range between two values (inclusive).
--
-- Note that the position of the two values in the Range constructor 
-- is not significant; Range 1 10 == Range 10 1
data Range t = Range t t

instance Eq t => Eq (Range t) where
	(Range a1 b1) == (Range a2 b2) = 
		a1 == a2 && b1 == b2 ||
		a1 == b2 && b1 == a2

instance Show t => Show (Range t) where
	show (Range a b) = "Range " ++ show a ++ " " ++ show b

-- | Combining two ranges yields a range between their respective lowest
-- and highest values.
instance Ord t => Sem.Semigroup (Range t) where
	Range a1 b1 <> Range a2 b2 = 
		let vals = [a1, b1, a2, b2]
		in Range (minimum vals) (maximum vals)

-- | Check if a value is below a range.
belowRange :: Ord t => t -> Range t -> Bool
belowRange p (Range a b) = p < a && p < b

-- | Check if a value is above a range.
aboveRange :: Ord t => t -> Range t -> Bool
aboveRange p (Range a b) = p > a && p > b

-- | Check if a value is within a range.
inRange :: Ord t => t -> Range t -> Bool
inRange p r = not (belowRange p r) && not (aboveRange p r)

-- | Extends a range up/down to a value.
extendRange :: Ord t => Range t -> t -> Range t
extendRange r@(Range a _) t = r <> Range a t