summaryrefslogtreecommitdiff
path: root/Reactive/Banana/Automation.hs
blob: 24e02b593614a1ecd64efabd4c86ce54881abd96 (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
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
{-# LANGUAGE FlexibleInstances, 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,
	runAutomation,
	observeAutomation,
	-- * Events
	EventSource,
	newEventSource,
	fromEventSource,
	gotEvent,
	getEventFrom,
	-- * Sensors
	Sensed (..),
	sensedEvent,
	sensedBehavior,
	sensed,
	(=:),
	sensorUnavailable,
	sensedEventBehavior,
	-- * Combinators
	automationStepper,
	automationChanges,
	-- * Time
	Timestamped(..),
	Timestamp(..),
	sensedNow,
	sensedAt,
	elapsedTimeSince,
	ClockSignal(..),
	clockSignal,
	clockSignalAt,
	clockSignalBehavior,
	-- * Actuators
	PowerChange(..),
	actuateEvent,
	actuateFutureEvent,
	actuateBehavior,
	actuateBehaviorMaybe,
	-- * 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.Monad.Trans.Reader
import Control.Monad.Trans.Class
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 = do
-- >	btemperature <- sensedBehavior fridgeTemperature
-- >	let bpowerchange = calcpowerchange <$> btemperature
-- >	actuateBehavior bpowerchange FridgePower
-- >   where
-- >	calcpowerchange (Sensed temp)
-- >		| temp `belowRange` allowedtemp = Just PowerOff
-- >		| temp `aboveRange` allowedtemp = Just PowerOn
-- >		| otherwise = Nothing
-- >	calcpowerchange SensorUnavailable = Nothing
-- >	allowedtemp = Range 1 4
-- 
-- Automation is a wrapper around reactive-banana's `MomentIO`,
-- but without the `MonadIO` instance, so this monad
-- is limited to using its sensors and actuators for IO. That allows
-- it to be fully tested using `observeAutomation`.
newtype Automation sensors actuators a = Automation
	{ unAutomation :: ReaderT (sensors, actuators -> IO ()) MomentIO a }

instance Sem.Semigroup (Automation sensors actuators ()) where
	Automation a <> Automation b = Automation (a >> b)

instance Monoid (Automation sensors actuators ()) where
	mempty = Automation (return ())
	mappend = (Sem.<>)

instance Functor (Automation sensors actuators) where
	fmap f = Automation . fmap f . unAutomation

instance Monad (Automation sensors actuators) where
	return  = Automation . return
	m >>= g = Automation $ unAutomation m >>= unAutomation . g

instance Applicative (Automation sensors actuators) where
	pure = Automation . pure
	f <*> a = Automation $ unAutomation f <*> unAutomation a

instance MonadFix (Automation sensors actuators) where
	mfix f = Automation $ mfix (unAutomation . f)

-- | All of "Reactive.Banana.Combinators" can be used with this monad.
instance MonadMoment (Automation sensors actuators) where
	liftMoment = Automation . lift . liftMoment

setupAutomation :: Automation sensors actuators () -> IO sensors -> (actuators -> IO ()) -> IO sensors
setupAutomation automation mksensors actuators = do
	sensors <- mksensors
	network <- compile $ flip runReaderT (sensors, actuators) $ unAutomation automation
	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 <$> newEventSource ()
-- > 
-- > 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.
--
-- `v` is unused by this library, but is provided in case you
-- need a way to track some extra data about an EventSource such as, for
-- example, the timestamp of the most recent event.
data EventSource a v = EventSource
	{ getEventSource :: (AddHandler a, a -> IO ())
	, fromEventSource :: v
	-- ^ Get extra data from an EventSource.
	}

-- | Construct a new EventSource.
newEventSource :: v -> IO (EventSource a v)
newEventSource v = EventSource <$> newAddHandler <*> pure v

addHandler :: EventSource a v -> AddHandler a
addHandler = fst . getEventSource

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

-- | Get an Event from an EventSource.
getEventFrom :: (sensors -> EventSource a v) -> Automation sensors actuators (Event a)
getEventFrom getsensor = Automation $ do
	sensor <- getsensor . fst <$> ask
	lift $ fromAddHandler $ addHandler sensor

-- | 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, Ord, Eq)

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

-- | Create a Behavior from sensed values.
sensedBehavior :: (sensors -> EventSource (Sensed a) v) -> Automation sensors actuators (Behavior (Sensed a))
sensedBehavior getsensor = sensedEventBehavior =<< getEventFrom getsensor

sensedEventBehavior :: Event (Sensed a) -> Automation sensors actuators (Behavior (Sensed a))
sensedEventBehavior = automationStepper SensorUnavailable

-- | `stepper` lifted into `Automation`
automationStepper :: a -> Event a -> Automation sensors actuators (Behavior a)
automationStepper a e = Automation $ lift $ stepper a e

-- | `changes` lifted into `Automation`
automationChanges :: Behavior a -> Automation sensors actuators (Event (Future a))
automationChanges = Automation . lift . changes

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

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

-- | Call when a sensor is unavailable.
sensorUnavailable :: EventSource (Sensed a) v -> IO ()
sensorUnavailable s = gotEvent s SensorUnavailable

-- | 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)) v -> 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)) v -> 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)
	-> Automation sensors actuators (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) v -> IO ()
clockSignal es = gotEvent es . ClockSignal =<< getCurrentTimestamp

-- | Call to feed a particular time to an `Automation`.
clockSignalAt :: Timestamp t => t -> EventSource (ClockSignal t) v -> 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
	=> (sensors -> EventSource (ClockSignal t) v)
	-> Automation sensors actuators (Behavior (Maybe (ClockSignal t)))
clockSignalBehavior getsensor = Automation $ do
	sensor <- getsensor . fst <$> ask
	e <- fmap Just <$> lift (fromAddHandler $ addHandler sensor)
	lift $ stepper Nothing e

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

-- | Makes an Event drive an actuator.
actuateEvent :: Event a -> (a -> actuators) -> Automation sensors actuators ()
actuateEvent e getactuator = Automation $ do
	actuators <- snd <$> ask
	lift $ reactimate $ fmap (actuators . getactuator) e

-- | Like `actuateEvent` but with a Future, as produced by
-- `automationChanges`
actuateFutureEvent :: Event (Future a) -> (a -> actuators) -> Automation sensors actuators ()
actuateFutureEvent e getactuator = Automation $ actuateFutureEvent' e getactuator

actuateFutureEvent' :: Event (Future a) -> (a -> actuators) -> ReaderT (sensors, actuators -> IO ()) MomentIO ()
actuateFutureEvent' e getactuator = do
	actuators <- snd <$> ask
	lift $ reactimate' $ fmap (actuators . getactuator) <$> e

-- | Makes a Behavior drive an actuator. This will happen when the
-- Behavior's value changes, but possibly more often as well, depending on
-- how the Behavior is constructed.
actuateBehavior :: Behavior a -> (a -> actuators) -> Automation sensors actuators ()
actuateBehavior b getactuator = Automation $ do
	e <- lift $ changes b
	actuateFutureEvent' e getactuator

-- | Variant of `actuateBehavior` that does nothing when a behavior
-- is Nothing.
actuateBehaviorMaybe :: Behavior (Maybe a) -> (a -> actuators) -> Automation sensors actuators ()
actuateBehaviorMaybe b getactuator = Automation $ do
	actuators <- snd <$> ask
	c <- lift $ changes b
	lift $ reactimate' $
		fmap (maybe (return ()) (actuators . getactuator)) <$> 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