{-# LANGUAGE TypeSynonymInstances, LambdaCase, DeriveFunctor #-}
module Reactive.Banana.Automation (
Automation,
MomentAutomation,
runAutomation,
observeAutomation,
EventSource,
gotEvent,
getEventFrom,
onEvent,
Sensed (..),
sensedEvent,
sensedBehavior,
sensed,
(=:),
Timestamped(..),
Timestamp(..),
sensedNow,
sensedAt,
elapsedTimeSince,
ClockSignal(..),
clockSignal,
clockSignalAt,
clockSignalBehavior,
PowerChange(..),
onBehaviorChange,
onBehaviorChangeMaybe,
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
type Automation sensors actuators = sensors -> (actuators -> IO ()) -> MomentAutomation ()
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 mksensors actutators = do
sensors <- mksensors
network <- compile $ unMomentAutomation $ automation sensors actutators
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
type EventSource a = (AddHandler a, a -> IO ())
addHandler :: EventSource a -> AddHandler a
addHandler = fst
gotEvent :: EventSource a -> a -> IO ()
gotEvent = snd
getEventFrom :: EventSource a -> MomentAutomation (Event a)
getEventFrom = MomentAutomation . fromAddHandler . addHandler
onEvent :: Event a -> (a -> IO ()) -> MomentAutomation ()
onEvent e a = MomentAutomation . reactimate $ fmap a e
data Sensed a = SensorUnavailable | Sensed a
deriving (Show, Functor)
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
sensedBehavior :: EventSource (Sensed a) -> MomentAutomation (Behavior (Sensed a))
sensedBehavior s =
MomentAutomation . stepper SensorUnavailable =<< getEventFrom s
sensed :: EventSource (Sensed a) -> a -> IO ()
sensed s = gotEvent s . Sensed
(=:) :: EventSource (Sensed a) -> a -> IO ()
(=:) = sensed
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)) -> a -> IO ()
sensedNow es a = do
now <- getCurrentTimestamp
gotEvent es (Sensed (Timestamped now a))
sensedAt :: Timestamp t => t -> EventSource (Sensed (Timestamped t a)) -> a -> IO ()
sensedAt ts es a = gotEvent es (Sensed (Timestamped ts a))
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
data ClockSignal a = ClockSignal a
deriving (Show, Eq, Ord, Functor)
clockSignal :: Timestamp t => EventSource (ClockSignal t) -> IO ()
clockSignal es = gotEvent es . ClockSignal =<< getCurrentTimestamp
clockSignalAt :: Timestamp t => t -> EventSource (ClockSignal t) -> IO ()
clockSignalAt t es = gotEvent es (ClockSignal t)
clockSignalBehavior :: Timestamp t => EventSource (ClockSignal t) -> MomentAutomation (Behavior (Maybe (ClockSignal t)))
clockSignalBehavior s = MomentAutomation . stepper Nothing
=<< fmap Just <$> getEventFrom s
data PowerChange = PowerOff | PowerOn
deriving (Show)
onBehaviorChange :: Behavior a -> (a -> IO ()) -> MomentAutomation ()
onBehaviorChange b a = MomentAutomation $ do
c <- changes b
reactimate' $ fmap a <$> c
onBehaviorChangeMaybe :: Behavior (Maybe a) -> (a -> IO ()) -> MomentAutomation ()
onBehaviorChangeMaybe b a = MomentAutomation $ do
c <- changes b
reactimate' $ fmap (maybe (return ()) a) <$> 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