{-# LANGUAGE Arrows #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-}

module HomeAssistant.Controller
  ( Service(..)
  , HASSEff(..)
  , HASS
  , callService
  , callServiceDyn
  , entityChangeEvent
  , entityChangeEvent'
  , entityRead
  , entityRead'
  , entityBool
  , entityBool'
  , DoorState(..)
  , light
  , Presence(..)
  , presence
  , motion
  , motionToPresence
  , debug
  , traceEvent
  , traceValue
  , switch
  , Target(..)
  , brightness
  , Light(..)
  , ikeaQuickButton
  , IkeaButton(..)
  , IkeaGesture(..)
  , activateScene
  , ikeaBoxRemote
  , IkeaController(..)
  ) where

import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request, hold, lMerge, waitFor, tag, edge)
import Control.Arrow (Arrow(..), returnA)
import Control.Category ((>>>))
import Data.Aeson (Value, object, (.=))
import qualified Data.Text as T
import qualified Data.Set as S
import Control.Lens (has, only, (^?), to, traversed)
import Data.Aeson.Lens (key, _String, _Integral)
import qualified Data.Text.Lens as TL
import Data.Bool (bool)
import Data.Serialize (Serialize)
import GHC.Generics (Generic)
import Data.Time (NominalDiffTime)

data Target = EntityId !T.Text | AreaId !T.Text
  deriving (Show,Eq,Ord)

data Service = Service
  { serviceDomain :: T.Text
  , serviceName :: T.Text
  , serviceData :: Maybe Value
  , serviceTarget :: [Target]
  }
  deriving (Show, Eq)

data HASSEff a where
  CallService :: Request -> Service -> HASSEff ()
  Debug :: Show a => a -> HASSEff ()
  Trace :: Show a => Request -> a -> HASSEff ()

type HASS a b = Mealy HASSEff a b

callService :: Service -> HASS a ()
callService service = eff (\req _ -> CallService req service)

callServiceDyn :: (a -> Service) -> HASS a ()
callServiceDyn mkService = eff (\req a -> CallService req (mkService a))

debug :: Show a => HASS a a
debug = proc x -> do
  eff (const Debug) -< x
  returnA -< x

traceEvent :: Show a => HASS (Event a) (Event a)
traceEvent = proc ev -> do
  case ev of
       Event a -> eff Trace -< a
       Tick -> returnA -< ()
  returnA -< ev

traceValue :: Show a => HASS a a
traceValue = proc x -> do
  eff Trace -< x
  returnA -< x

data DoorState = Open | Closed
  deriving (Show, Eq, Generic)

instance Serialize DoorState

data Presence = Occupied | Unoccupied
  deriving (Show, Eq, Generic)

instance Serialize Presence

presence :: T.Text -> HASS (Event Value) (Event Presence)
presence entityId = entityBool entityId
  >>> arr (fmap (bool Unoccupied Occupied))


data Motion = MotionDetected | MotionNotDetected | MotionUnknown
  deriving (Show, Eq, Generic)


motion :: T.Text -> HASS (Event Value) Motion
motion entityId = entityBool entityId
  >>> arr (fmap (bool MotionNotDetected MotionDetected))
  >>> hold MotionUnknown


-- Convert a motion status into a simulated presence
--
-- A motion tracker detects _motion_, but if you are still, it can't detect you.
-- A simple and cheap heuristic is to assume the person is a bit longer there
motionToPresence :: NominalDiffTime -> HASS Motion Presence
motionToPresence delay = (eventOccupied &&& eventUnoccupied)
  >>> arr (uncurry lMerge)
  >>> AFRP.hold Unoccupied
  where
    eventOccupied :: HASS Motion (Event Presence)
    eventOccupied = arr (== MotionDetected) >>> edge >>> arr (fmap (const Occupied))
    eventUnoccupied :: HASS Motion (Event Presence)
    eventUnoccupied = arr (== MotionNotDetected) >>> waitFor delay >>> arr (tag Unoccupied)

instance Serialize Motion

data Light
  = Off
  | On { brightnessPercentage :: Maybe Double }

-- Turn off lights when door is closed
light :: [Target] -> Light -> Service
light targets (On {brightnessPercentage}) = Service
  { serviceDomain="light"
  , serviceName= "turn_on"
  , serviceData=fmap (\pct -> object ["brightness_pct" .= pct]) brightnessPercentage
  , serviceTarget=targets
  }
light targets Off = Service
  { serviceDomain="light"
  , serviceName= "turn_off"
  , serviceData=Nothing
  , serviceTarget=targets
  }

-- Name conflict with AFRP
switch :: [Target] -> Bool -> Service
switch targets b = Service
  { serviceDomain="switch"
  , serviceName= bool "turn_off" "turn_on" b
  , serviceData=Nothing
  , serviceTarget=targets
  }


entityChangeEvent :: T.Text -> Mealy eff (Event Value) (Event Value)
entityChangeEvent entityId = entityChangeEvent' entityId >>> toEvent

entityChangeEvent' :: T.Text -> Mealy eff (Event Value) (Either () Value)
entityChangeEvent' entityId = Mealy (S.singleton entityId) $ runMealy (events >>| filterA isEntity)
  where
    isEntity :: Value -> Bool
    isEntity = has (key "event" . key "variables" . key "trigger" . key "entity_id" . _String . only entityId)

entityRead' :: (Read a) => T.Text -> Mealy eff (Event Value) (Either () a)
entityRead' entityId = entityChangeEvent' entityId >>| (arr state >>> arr (maybe (Left ()) Right))
  where
    state v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "state" . _String . TL.unpacked . to read

entityBool' :: T.Text -> Mealy eff (Event Value) (Either () Bool)
entityBool' entityId = entityChangeEvent' entityId >>| (arr state >>> arr (maybe (Left ()) Right))
  where
    state v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "state" . _String . TL.unpacked . to toBool
    toBool = \case
      "on" -> True
      "off" -> False
      _ -> False

entityRead :: (Read a) => T.Text -> Mealy eff (Event Value) (Event a)
entityRead entityId = entityRead' entityId >>> toEvent

entityBool :: T.Text -> Mealy eff (Event Value) (Event Bool)
entityBool entityId = entityBool' entityId >>> toEvent

brightness :: T.Text -> HASS (Event Value) (Event Int)
brightness entityId =
  entityChangeEvent' entityId
  >>| arr (maybe (Left ()) Right . eventBrightness)
  >>> AFRP.toEvent
  where
    eventBrightness v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "brightness" . _Integral

data IkeaGesture
  = ShortClick
  | ShortRelease
  | DoubleClick
  | LongClick
  deriving Show

data IkeaButton a = OnButton !a | OffButton !a
  deriving Show


toIkeaQuickButton :: T.Text -> Maybe (IkeaButton IkeaGesture)
toIkeaQuickButton = \case
  -- 1 is on, 2 is off side of the button
  "1_initial_press" -> Just $ OnButton ShortClick
  "1_short_release" -> Just $ OnButton ShortRelease
  "1_double_press" -> Just $ OnButton DoubleClick
  "1_long_press" -> Just $ OnButton LongClick
  "2_initial_press" -> Just $ OffButton ShortClick
  "2_short_release" -> Just $ OffButton ShortRelease
  "2_double_press" -> Just $ OffButton DoubleClick
  "2_long_press" -> Just $ OffButton LongClick
  _ -> Nothing

ikeaQuickButton :: T.Text -> HASS (Event Value) (Event (IkeaButton IkeaGesture))
ikeaQuickButton entityId =
  entityChangeEvent' entityId
  >>| arr (maybe (Left ()) Right . eventType)
  >>> toEvent
  where
    eventType v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "event_type" . _String . to toIkeaQuickButton . traversed

data IkeaController
  = ControllerOn -- Short press on
  | ControllerOff -- Short press off
  | ControllerBrighnessUp -- Turn brightness up
  | ControllerBrighnessDown -- Turn brighness down
  | ControllerArrowRight -- Turn brighness down
  | ControllerArrowLeft -- Turn brighness down
  | ControllerBrighnessStop
  deriving Show

toIkeaController :: T.Text -> Maybe IkeaController
toIkeaController = \case
  "on" -> Just ControllerOn
  "off" -> Just ControllerOff
  "brightness_move_up" -> Just ControllerBrighnessUp
  "brightness_move_down" -> Just ControllerBrighnessDown
  "brightness_stop" -> Just ControllerBrighnessStop
  "arrow_right_click" -> Just ControllerArrowRight
  "arrow_left_click" -> Just ControllerArrowLeft
  _ -> Nothing

ikeaBoxRemote :: T.Text -> HASS (Event Value) (Event IkeaController)
ikeaBoxRemote entityId = entityChangeEvent' entityId
  >>| arr (maybe (Left ()) Right . eventType)
  >>> toEvent
  where
    eventType v = v ^? key "event" . key "variables" . key "trigger" . key "to_state" . key "attributes" . key "event_type" . _String . to toIkeaController . traversed

activateScene :: T.Text -> Service
activateScene sceneId = Service
  { serviceDomain="scene"
  , serviceName= "turn_on"
  , serviceTarget= [EntityId sceneId]
  , serviceData = Nothing
  }