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

module HomeAssistant.Controller
  ( Service(..)
  , HASSEff(..)
  , HASS
  , callService
  , entityChangeEvent
  , entityChangeEvent'
  , entityRead
  , entityRead'
  , entityBool
  , entityBool'
  , DoorState(..)
  , light
  , Presence(..)
  , presence
  , debug
  , traceEvent
  , traceValue
  , switch
  , Target(..)
  ) where

import AFRP (Mealy (..), eff, Event(..), events, filterA, (>>|), toEvent, Request)
import Control.Arrow (Arrow(..), returnA)
import Control.Category ((>>>))
import Data.Aeson (Value)
import qualified Data.Text as T
import qualified Data.Set as S
import Control.Lens (has, only, (^?), to)
import Data.Aeson.Lens (key, _String)
import qualified Data.Text.Lens as TL
import Data.Bool (bool)

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

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)

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 = Mealy mempty $ \nt req -> \case
  Event a -> nt (Trace req a) >>= \() -> pure (Event a, traceEvent)
  Tick -> pure (Tick, traceEvent)

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

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

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

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




-- Turn off lights when door is closed
light :: [Target] -> Bool -> Service
light targets b = Service
  { serviceDomain="light"
  , serviceName= bool "turn_off" "turn_on" b
  , 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