{-# LANGUAGE 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(..),
	MomentAutomation,
	runAutomation,
	observeAutomation,
	-- * Events
	EventSource,
	newEventSource,
	fromEventSource,
	gotEvent,
	getEventFrom,
	onEvent,
	-- * Sensors
	Sensed (..),
	sensedEvent,
	sensedBehavior,
	sensed,
	(=:),
	sensorUnavailable,
	sensedEventBehavior,
	automationStepper,
	-- * Time
	Timestamped(..),
	Timestamp(..),
	sensedNow,
	sensedAt,
	elapsedTimeSince,
	ClockSignal(..),
	clockSignal,
	clockSignalAt,
	clockSignalBehavior,
	-- * Actuators
	PowerChange(..),
	onBehaviorChange,
	onBehaviorChangeMaybe,
	-- * 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.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 = Automation $ \sensors actuators -> do
-- >	btemperature <- sensedBehavior (fridgeTemperature sensors)
-- >	let bpowerchange = calcpowerchange <$> btemperature
-- >	onBehaviorChange bpowerchange (actuators . FridgePower)
-- >   where
-- >	calcpowerchange (Sensed temp)
-- >		| temp `belowRange` allowedtemp = Just PowerOff
-- >		| temp `aboveRange` allowedtemp = Just PowerOn
-- >		| otherwise = Nothing
-- >	calcpowerchange SensorUnavailable = Nothing
-- >	allowedtemp = Range 1 4
newtype Automation sensors actuators = Automation (sensors -> (actuators -> IO ()) -> MomentAutomation ())

instance Sem.Semigroup (Automation sensors actuators) where
	Automation a <> Automation b = Automation $ \sensors actuators -> do
		a sensors actuators
		b sensors actuators

instance Monoid (Automation sensors actuators) where
	mempty = Automation $ \_sensors _actuators -> return ()
	mappend = (Sem.<>)

-- | This is simply a wrapper around reactive-banana's `MomentIO`,
-- but without the `MonadIO` instance, so an `Automation` using this monad
-- is limited to using its sensors and actuators for IO. That allows
-- it to be fully tested using `observeAutomation`.
--
-- All of "Reactive.Banana.Combinators" can be used with this monad.
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 automation) mksensors actutators = do
	sensors <- mksensors
	network <- compile $ unMomentAutomation $ automation sensors actutators
	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 :: EventSource a v -> MomentAutomation (Event a)
getEventFrom = MomentAutomation . fromAddHandler . addHandler

-- | Runs an action when an event occurs.
onEvent :: Event a -> (a -> IO ()) -> MomentAutomation ()
onEvent e a = MomentAutomation . reactimate $ fmap a e

-- | 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)

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

-- | Create a Behavior from sensed values.
sensedBehavior :: EventSource (Sensed a) v -> MomentAutomation (Behavior (Sensed a))
sensedBehavior s = sensedEventBehavior =<< getEventFrom s

sensedEventBehavior :: Event (Sensed a) -> MomentAutomation (Behavior (Sensed a))
sensedEventBehavior = automationStepper SensorUnavailable

-- | `stepper` lifted into `MomentAutomation`
automationStepper :: a -> Event a -> MomentAutomation (Behavior a)
automationStepper a e = MomentAutomation $ stepper a e

-- | 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)
	-> 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

-- | 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 => EventSource (ClockSignal t) v -> MomentAutomation (Behavior (Maybe (ClockSignal t)))
clockSignalBehavior s = MomentAutomation . stepper Nothing 
	=<< fmap Just <$> getEventFrom s

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

-- | Runs an action when a behavior's value changes.
onBehaviorChange :: Behavior a -> (a -> IO ()) -> MomentAutomation ()
onBehaviorChange b a = MomentAutomation $ do
	c <- changes b
	reactimate' $ fmap a <$> c

-- | Variant of `onBehaviorChange` that does nothing when a behavior
-- changes to Nothing.
onBehaviorChangeMaybe :: Behavior (Maybe a) -> (a -> IO ()) -> MomentAutomation ()
onBehaviorChangeMaybe b a = MomentAutomation $ do
	c <- changes b
	reactimate' $ fmap (maybe (return ()) a) <$> 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