{-# 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,
	liftMomentIO,
	-- * 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 = liftMomentIO . liftMoment

-- | Allows "Reactive.Banana.Framework" to be used with this monad.
liftMomentIO :: MomentIO a -> Automation sensors actuators a
liftMomentIO = Automation . lift

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 = liftMomentIO $ stepper a e

-- | `changes` lifted into `Automation`
automationChanges :: Behavior a -> Automation sensors actuators (Event (Future a))
automationChanges = liftMomentIO . 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