A lot of internals as I tried to do a switch based logic

src/HomeAssistant/Controller/Children.hs

@@ -1,14 +1,82 @@
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE OverloadedStrings #-}
 module HomeAssistant.Controller.Children where
-import HomeAssistant.Controller (HASS)
+import HomeAssistant.Controller (HASS, callService, Target (AreaId), light, Light(..))
 import AFRP (Event)
-import Data.Aeson (Value)
-import Control.Arrow (Arrow(..))
+import qualified AFRP
+import Control.Arrow (Arrow(..), (>>>))
+import Data.Time (Day, TimeOfDay (..), localDay, LocalTime (..))
+import Data.Time.Calendar.OrdinalDate (WeekOfYear, mondayStartWeek)
+import Data.Functor.Contravariant (Predicate (..), (>$<))
+
+-- Let's see building some reasonable interface for utctime
+dow :: Day -> (WeekOfYear, Int)
+dow = mondayStartWeek
+
+
+weekday :: Predicate Day
+weekday = Predicate (betweenInclusive 1 5 . snd . dow)
+  where
+    betweenInclusive a b c = c >= a && c <= b
+
+time :: (Int, Int) -> Predicate TimeOfDay
+time (h,m) = mconcat
+  [ Predicate (equals h . todHour)
+  , Predicate (equals m . todMin)
+  ]
+  where
+    equals a b = a == b
+
+
+atTime :: Predicate LocalTime -> HASS a (Event ())
+atTime p = AFRP.currentTime
+  >>> arr (getPredicate p)
+  >>> AFRP.edge
 
 -- I don't have any proper presence sensors in their bedroom
 -- and they are notoriously bad at changing clothes in complete darkness
 -- So I have set up an automation that attempts to turn on the lights sometime
 -- before they leave for school and turns them off a bit later
---
--- I don't have enough primitives for this yet, leaving as a placeholder
-schoolLightController :: HASS (Event Value) ()
-schoolLightController = arr (const ())
+
+-- Don't mconcat these predicates they have && behavior
+-- if you mconcat the actual arrows, they combine the behaviors of the separate branches
+-- essentially becoming || behavior
+timersOff :: [Predicate LocalTime]
+timersOff =
+  [ day 1 <> at (08,15)
+  , day 2 <> at (09,15)
+  , day 3 <> at (08,15)
+  , day 4 <> at (08,15)
+  , day 5 <> at (08,15)
+  , at (18,57) -- debug
+  ]
+  where
+    dayOfWeek = snd . mondayStartWeek . localDay
+    at (h,m) = localTimeOfDay >$< Predicate (\TimeOfDay{todHour, todMin} -> todHour == h && todMin == m)
+    day n = dayOfWeek >$< Predicate (== n)
+
+timersOn :: [Predicate LocalTime]
+timersOn =
+  [ day 1 <> at (07,30)
+  , day 2 <> at (08,30)
+  , day 3 <> at (07,30)
+  , day 4 <> at (07,30)
+  , day 5 <> at (07,30)
+  , at (18,55) -- debug
+  ]
+  where
+    dayOfWeek = snd . mondayStartWeek . localDay
+    at (h,m) = localTimeOfDay >$< Predicate (\TimeOfDay{todHour, todMin} -> todHour == h && todMin == m)
+    day n = dayOfWeek >$< Predicate (== n)
+
+schoolLightController :: HASS a ()
+schoolLightController = lightsOn <> lightsOff
+
+
+lightsOn :: HASS a ()
+lightsOn = foldMap atTime timersOn
+  >>> AFRP.onEvent (callService (light [AreaId "lasten_makuuhuone"] On{brightnessPercentage = Just 100}))
+
+lightsOff :: HASS a ()
+lightsOff = foldMap atTime timersOff
+  >>> AFRP.onEvent (callService (light [AreaId "lasten_makuuhuone"] Off))