{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, LambdaCase, DeriveFunctor #-}
module Reactive.Banana.Automation (
Automation,
runAutomation,
observeAutomation,
EventSource,
newEventSource,
fromEventSource,
gotEvent,
getEventFrom,
Sensed (..),
sensedEvent,
sensedBehavior,
sensed,
(=:),
sensorUnavailable,
sensedEventBehavior,
automationStepper,
Timestamped(..),
Timestamp(..),
sensedNow,
sensedAt,
elapsedTimeSince,
ClockSignal(..),
clockSignal,
clockSignalAt,
clockSignalBehavior,
PowerChange(..),
actuateEvent,
actuateBehavior,
actuateBehaviorMaybe,
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
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)
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
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
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
atomically $ putTMVar lck ()
() <- a sensors
l <- atomically $ do
takeTMVar lck
swapTVar tv []
return (reverse l)
return runner
data EventSource a v = EventSource
{ getEventSource :: (AddHandler a, a -> IO ())
, fromEventSource :: v
}
newEventSource :: v -> IO (EventSource a v)
newEventSource v = EventSource <$> newAddHandler <*> pure v
addHandler :: EventSource a v -> AddHandler a
addHandler = fst . getEventSource
gotEvent :: EventSource a v -> a -> IO ()
gotEvent = snd . getEventSource
getEventFrom :: (sensors -> EventSource a v) -> Automation sensors actuators (Event a)
getEventFrom getsensor = Automation $ do
sensor <- getsensor . fst <$> ask
lift $ fromAddHandler $ addHandler sensor
data Sensed a = SensorUnavailable | Sensed a
deriving (Show, Functor, Ord, Eq)
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
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
automationStepper :: a -> Event a -> Automation sensors actuators (Behavior a)
automationStepper a e = Automation $ lift $ stepper a e
sensed :: EventSource (Sensed a) v -> a -> IO ()
sensed s = gotEvent s . Sensed
(=:) :: EventSource (Sensed a) v -> a -> IO ()
(=:) = sensed
sensorUnavailable :: EventSource (Sensed a) v -> IO ()
sensorUnavailable s = gotEvent s SensorUnavailable
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 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
sensedNow :: Timestamp t => EventSource (Sensed (Timestamped t a)) v -> a -> IO ()
sensedNow es a = do
now <- getCurrentTimestamp
gotEvent es (Sensed (Timestamped now a))
sensedAt :: Timestamp t => t -> EventSource (Sensed (Timestamped t a)) v -> a -> IO ()
sensedAt ts es a = gotEvent es (Sensed (Timestamped ts a))
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
data ClockSignal a = ClockSignal a
deriving (Show, Eq, Ord, Functor)
clockSignal :: Timestamp t => EventSource (ClockSignal t) v -> IO ()
clockSignal es = gotEvent es . ClockSignal =<< getCurrentTimestamp
clockSignalAt :: Timestamp t => t -> EventSource (ClockSignal t) v -> IO ()
clockSignalAt t es = gotEvent es (ClockSignal t)
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
data PowerChange = PowerOff | PowerOn
deriving (Show)
actuateEvent :: Event a -> (a -> actuators) -> Automation sensors actuators ()
actuateEvent e getactuator = Automation $ do
actuators <- snd <$> ask
lift $ reactimate $ fmap (actuators . getactuator) e
actuateBehavior :: Behavior a -> (a -> actuators) -> Automation sensors actuators ()
actuateBehavior b getactuator = Automation $ do
actuators <- snd <$> ask
c <- lift $ changes b
lift $ reactimate' $
fmap (actuators . getactuator) <$> c
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
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
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)
belowRange :: Ord t => t -> Range t -> Bool
belowRange p (Range a b) = p < a && p < b
aboveRange :: Ord t => t -> Range t -> Bool
aboveRange p (Range a b) = p > a && p > b
inRange :: Ord t => t -> Range t -> Bool
inRange p r = not (belowRange p r) && not (aboveRange p r)
extendRange :: Ord t => Range t -> t -> Range t
extendRange r@(Range a _) t = r <> Range a t