{-# 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 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 Semigroup (Automation sensors actuators ()) where
Automation a <> Automation b = Automation (a >> b)
instance Monoid (Automation sensors actuators ()) where
mempty = Automation (return ())
instance Functor (Automation sensors actuators) where
fmap f = Automation . fmap f . unAutomation
instance Applicative (Automation sensors actuators) where
pure = Automation . pure
f <*> a = Automation $ unAutomation f <*> unAutomation a
instance Monad (Automation sensors actuators) where
m >>= g = Automation $ unAutomation m >>= unAutomation . g
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 => 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