Split MyLib into AFRP, Controller, Runtime

src/HomeAssistant/Controller.hs

@@ -0,0 +1,135 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE GADTs #-}
+
+module HomeAssistant.Controller
+  ( Service(..)
+  , HASSEff(..)
+  , HASS
+  , callService
+  , entityChangeEvent
+  , entityChangeEvent'
+  , entityRead
+  , entityRead'
+  , entityBool
+  , entityBool'
+  , Ruuvi(..)
+  , ruuvi
+  , ruuviTemperatures
+  , ruuviPressures
+  , DoorState(..)
+  , door
+  , light
+  , lightController
+  ) where
+
+import AFRP (Mealy, eff, Event(..), hold, events, changes, mapAccum, filterA, (>>|), toEvent)
+import Control.Arrow (Arrow(..), ArrowChoice(..), returnA)
+import Control.Category ((>>>))
+import Data.Aeson (Value)
+import qualified Data.Text as T
+import Control.Lens (has, only, (^?), to)
+import Data.Aeson.Lens (key, _String)
+import qualified Data.Text.Lens as TL
+import Data.Bool (bool)
+
+data Service = Service
+  { serviceDomain :: T.Text
+  , serviceName :: T.Text
+  , serviceData :: Maybe Value
+  , serviceTarget :: T.Text
+  }
+  deriving Show
+
+data HASSEff a where
+  CallService :: Service -> HASSEff ()
+  Pure :: a -> HASSEff a
+
+type HASS a b = Mealy HASSEff a b
+
+callService :: Service -> HASS a ()
+callService service = eff (\_ -> CallService service)
+
+ruuviTemperatures :: Mealy eff (Event Value) Double
+ruuviTemperatures = entityRead @Double "sensor.ruuvitag_b168_temperature" >>> hold 0
+
+ruuviPressures :: Mealy eff (Event Value) Double
+ruuviPressures = entityRead "sensor.ruuvitag_b168_pressure" >>> hold 0
+
+data Ruuvi = Ruuvi { ruuviTemperature :: Double, ruuviPressure :: Double }
+            deriving (Show, Eq)
+
+ruuvi :: Mealy eff (Event Value) (Event Ruuvi)
+ruuvi = (Ruuvi <$> ruuviTemperatures <*> ruuviPressures) >>> changes
+
+data Direction = Increase | Decrease | Steady
+  deriving (Show, Eq)
+
+numericDirection = mapAccum go (Nothing, Nothing) extract
+  where
+    go (_, old) new = (old, new)
+    extract :: (Maybe Double, Maybe Double) -> Direction
+    extract (old, new) = maybe Steady (\x -> if x >  0 then Increase else Decrease) $ (-) <$> old <*> new
+
+data DoorState = Open | Closed
+  deriving (Show, Eq)
+
+door :: HASS (Event Value) (Event DoorState)
+door = entityBool "binary_sensor.makuuhuone_ovi_contact"
+  >>> arr (fmap (bool Closed Open))
+  >>> hold Open
+  >>> changes
+
+-- Turn off lights when door is closed
+light :: Bool -> Service
+light b = Service
+  { serviceDomain="light"
+  , serviceName= bool "turn_off" "turn_on" b
+  , serviceData=Nothing
+  , serviceTarget="light.bedroom_masse"
+  }
+
+lightController :: HASS (Event Value) (Event DoorState)
+lightController = proc ev -> do
+  doorState <- door -< ev
+  case doorState of
+       Event Open -> callService (light False) -< ()
+       Event Closed -> callService (light True) -< ()
+       _ -> returnA -< ()
+  returnA -< doorState
+
+entityChangeEvent :: T.Text -> Mealy eff (Event Value) (Event Value)
+entityChangeEvent entityId = entityChangeEvent' entityId >>> toEvent
+  where
+    isEntity :: Value -> Bool
+    isEntity = has (key "event" . key "data" . key "entity_id" . _String . only entityId)
+
+entityChangeEvent' :: T.Text -> Mealy eff (Event Value) (Either () Value)
+entityChangeEvent' entityId = events >>| filterA isEntity
+  where
+    isEntity :: Value -> Bool
+    isEntity = has (key "event" . key "data" . 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 "data" . key "new_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 "data" . key "new_state" . key "state" . _String . TL.unpacked . to toBool
+    toBool = \case
+      "on" -> True
+      "off" -> False
+
+entityRead :: (Read a) => T.Text -> Mealy eff (Event Value) (Event a)
+entityRead entityId = entityRead' entityId >>> toEvent
+  where
+    state v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . TL.unpacked . to read
+
+entityBool :: T.Text -> Mealy eff (Event Value) (Event Bool)
+entityBool entityId = entityBool' entityId >>> toEvent
+  where
+    state v = v ^? key "event" . key "data" . key "new_state" . key "state" . _String . TL.unpacked . to read