home-assistant-controller/docs/superpowers/plans/2026-08-20-module-split.md

Module Split & Warning Cleanup Implementation Plan

For agentic workers: REQUIRED SUB-SKILL: Use superpowers:subagent-driven-development (recommended) or superpowers:executing-plans to implement this plan task-by-task. Steps use checkbox (- [ ]) syntax for tracking.

Goal: Split the monolithic src/MyLib.hs into three vertically-separated modules and fix all compiler warnings, committing between changes.

Architecture: Three modules: AFRP (generic Mealy/Event FRP machinery), HomeAssistant.Controller (HA domain: effects, entity parsers, controllers), HomeAssistant.Runtime (IO interpreter, websocket client, defaultMain). Two commits: mechanical split, then warning fixes.

Tech Stack: Haskell, GHC 9.10.3, cabal, GHC2024 default language

Global Constraints

• Build tool: cabal build
• GHC 9.10.3, default-language: GHC2024 (provides RankNTypes, TypeApplications, GADTSyntax — do not re-declare these)
• Warning baseline: cabal common warnings uses -Wall; verify with cabal build --ghc-options="-Wall -Wincomplete-uni-patterns -Wincomplete-record-updates"
• No test framework (test suite is a placeholder; testing is out of scope per spec)
• Commit between every change (user instruction)
• The only behavioral change: dormant wsCallService call is activated inside real hassEval, but app wires to dryRunHassEval to preserve current print-only behavior

---

File Structure

File	Responsibility	Created/Modified
src/AFRP.hs	Generic Mealy/Event FRP machinery — zero HA knowledge	Created in Task 1
src/HomeAssistant/Controller.hs	HA domain: HASSEff, Service, entity parsers, controllers	Created in Task 1, edited in Task 2
src/HomeAssistant/Runtime.hs	IO interpreter, websocket client, defaultMain	Created in Task 1, edited in Task 2
src/MyLib.hs	(deleted)	Deleted in Task 1
app/Main.hs	Entry point; import updated	Modified in Task 1
home-assistant-controller.cabal	exposed-modules updated	Modified in Task 1

---

Task 1: Split MyLib into AFRP, Controller, Runtime

Files:

• Create: src/AFRP.hs
• Create: src/HomeAssistant/Controller.hs
• Create: src/HomeAssistant/Runtime.hs
• Delete: src/MyLib.hs
• Modify: app/Main.hs
• Modify: home-assistant-controller.cabal

Interfaces:

• AFRP produces: Mealy(..), eff, Event(..), hold, events, switch, preMapAccum, preMapAccumUTCTime, mapAccum, mapAccumUTCTime, changes, whenA, filterA, thenA, (>>|), toEvent
• HomeAssistant.Controller consumes from AFRP: Mealy, eff, Event(..), hold, events, changes, mapAccum, filterA, (>>|), toEvent
• HomeAssistant.Controller produces: Service(..), HASSEff(..), HASS, callService, entity helpers, domain types/values, lightController
• HomeAssistant.Runtime consumes from AFRP: Mealy(..), Event(..); from HomeAssistant.Controller: HASSEff(..), lightController, Service(..)
• HomeAssistant.Runtime produces: defaultMain, app, step, CallIdGen, mkCallIdGen, hassEval, receiveJSON, wsCallService

After this task: build succeeds, 6 warnings remain (numericDirection, isEntity, state x2, toBool, conn).

• Step 1: Create src/AFRP.hs

{-# LANGUAGE LambdaCase #-}

module AFRP
  ( Mealy(..)
  , eff
  , Event(..)
  , hold
  , events
  , switch
  , preMapAccum
  , preMapAccumUTCTime
  , mapAccum
  , mapAccumUTCTime
  , changes
  , whenA
  , filterA
  , thenA
  , (>>|)
  , toEvent
  ) where

import Control.Category (Category(..), (>>>))
import Prelude hiding ((.), id)
import Control.Arrow (Arrow(..), ArrowChoice(..), ArrowLoop(..), returnA)
import Data.Time (UTCTime)
import Control.Monad.Fix (MonadFix (mfix))
import Data.Either (fromLeft)
import Data.Bool (bool)

newtype Mealy eff a b = Mealy
  { runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> UTCTime -> a -> m (b, Mealy eff a b) }

eff :: (a -> eff b) -> Mealy eff a b
eff f = Mealy $ \nt _ x ->
  nt (f x) >>= \b -> pure (b, eff f)

instance Category (Mealy eff) where
  id = Mealy (\_ _ x -> pure (x, id))
  (Mealy f) . (Mealy g) = Mealy $ \nt t a -> do
    (b, g') <- g nt t a
    (c, f') <- f nt t b
    pure (c, f' . g')

instance Arrow (Mealy eff) where
  arr f = Mealy $ \_ _ b -> pure (f b, arr f)
  first (Mealy f) = Mealy $ \nt t (b,d) -> do
    (c, f') <- f nt t b
    pure ((c, d), first f')

instance ArrowChoice (Mealy eff) where
  left (Mealy f) = Mealy $ \nt t -> \case
    Left b -> do
      (c, f') <- f nt t b
      pure (Left c, left f')
    Right d -> pure (Right d, left (Mealy f))

instance ArrowLoop (Mealy eff) where
  loop (Mealy f) = Mealy $ \nt t b -> do
    ((c,_), f') <- mfix $ \((_,d), _) -> f nt t (b,d)
    pure (c, loop f')

instance Functor (Mealy eff a) where
  fmap f (Mealy g) = Mealy $ \nt t a -> do
    (b, g') <- g nt t a
    pure (f b, fmap f g')

instance Applicative (Mealy eff a) where
  pure b = Mealy $ \_ _ _ -> pure (b, pure b)
  Mealy f <*> Mealy x = Mealy $ \nt t a -> do
    (f', fNext) <- f nt t a
    (x', xNext) <- x nt t a
    pure (f' x', fNext <*> xNext)

data Event a
  = Tick
  | Event a
  deriving (Show, Functor, Foldable, Traversable)

hold :: a -> Mealy eff (Event a) a
hold a = Mealy $ \_ _ -> \case
  Tick -> pure (a, hold a)
  Event a' -> pure (a', hold a')

events :: Mealy eff (Event a) (Either () a)
events = arr $ \case
  Tick -> Left ()
  Event a -> Right a

switch :: Mealy eff a (b, Event c) -> (c -> Mealy eff a b) -> Mealy eff a b
switch (Mealy f) s = Mealy $ \nt t a -> do
  ((b, ev), f') <- f nt t a
  case ev of
          Tick -> pure (b, switch f' s)
          Event x -> runMealy (s x) nt t a

preMapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
preMapAccum f x extract = go x
  where
    go b = Mealy $ \_ _ a ->
      let next = f b a
      in pure (extract b, go next)

preMapAccumUTCTime :: (UTCTime -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
preMapAccumUTCTime f x extract = go x
  where
    go b = Mealy $ \_ t a ->
      let next = f t b a
      in pure (extract b, go next)

mapAccum :: (x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
mapAccum f x extract = go x
  where
    go b = Mealy $ \_ _ a ->
      let next = f b a
      in pure (extract next, go next)

mapAccumUTCTime :: (UTCTime -> x -> a -> x) -> x -> (x -> b) -> Mealy eff a b
mapAccumUTCTime f x extract = go x
  where
    go b = Mealy $ \_ t a ->
      let next = f t b a
      in pure (extract next, go next)

changes :: Eq a => Mealy eff a (Event a)
changes = mapAccum go Nothing (maybe Tick snd)
  where
    go :: Eq a => Maybe (a, Event a) -> a -> Maybe (a, Event a)
    -- The first observed value is not a change I think
    go Nothing x = Just (x, Tick)
    go (Just (y, _)) x | x == y = Just (x, Tick)
                       | otherwise = Just (x, Event x)

whenA :: (a -> Bool) -> Mealy eff a () -> Mealy eff a ()
whenA predicate auto = arr (\a -> if predicate a then Left a else Right ()) >>> left auto >>> arr (fromLeft ())

filterA :: (a -> Bool) -> Mealy eff a (Either () a)
filterA f = arr $ \a -> bool (Left ()) (Right a) (f a)

thenA :: (ArrowChoice cat, Arrow cat) => cat a (Either b1 c) -> cat c (Either b1 b2) -> cat a (Either b1 b2)
thenA f g = f >>> arr Left ||| g

(>>|) :: (ArrowChoice cat, Arrow cat) => cat a (Either b1 c) -> cat c (Either b1 b2) -> cat a (Either b1 b2)
(>>|) = thenA

infixl 1 >>|

toEvent :: Mealy eff (Either () a) (Event a)
toEvent = arr (either (const Tick) Event)

• Step 2: Create the src/HomeAssistant/ directory

Run: mkdir -p src/HomeAssistant

• Step 3: Create src/HomeAssistant/Controller.hs

Note: This is the Task 1 version — it still contains numericDirection, dead where clauses, and non-exhaustive toBool. Those are fixed in Task 2.

{-# 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

• Step 4: Create src/HomeAssistant/Runtime.hs

Note: This is the Task 1 version — hassEval still has the commented-out wsCallService call and conn is unused. dryRunHassEval does not exist yet. Both are addressed in Task 2.

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

module HomeAssistant.Runtime
  ( defaultMain
  , app
  , step
  , CallIdGen
  , mkCallIdGen
  , hassEval
  , receiveJSON
  , wsCallService
  ) where

import AFRP (Mealy(..), Event(..))
import HomeAssistant.Controller (HASSEff(..), lightController, Service(..))
import Data.Aeson ((.=), Value (Null), encode, eitherDecode, object)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Network.WebSockets as WS
import Network.Socket (withSocketsDo)
import System.Environment (getEnv)
import Data.Time (UTCTime, getCurrentTime)
import Data.IORef (newIORef, atomicModifyIORef')

step :: (forall x. eff x -> IO x) -> Mealy eff a b -> a -> IO (b, Mealy eff a b)
step nt (Mealy f) a = do
  now <- getCurrentTime
  f nt now a

defaultMain :: IO ()
defaultMain = withSocketsDo $ do
    token <- getEnv "HA_TOKEN"
    gen <- mkCallIdGen 0
    WS.runClient "last-resort-redux" 8123 "/api/websocket" (app gen token)

app :: CallIdGen -> String -> WS.ClientApp ()
app gen token conn = do
    -- HA speaks first: {"type":"auth_required", ...}
    authRequired <- receiveJSON conn
    print authRequired

    WS.sendTextData conn $ encode $ object
        [ "type"         .= ("auth" :: T.Text)
        , "access_token" .= token
        ]

    -- Expect {"type":"auth_ok", ...}
    authResult <- receiveJSON conn
    print authResult

    getStateId <- generateCallId gen
    WS.sendTextData conn $ encode $ object
      [ "id" .= getStateId
      , "type" .= ("get_states" :: T.Text)
      ]
    msg <- WS.receiveData conn :: IO BL.ByteString
    BL.writeFile "/tmp/states.json" msg

    subscribeId <- generateCallId gen
    -- Subscription 1: all entity state changes
    WS.sendTextData conn $ encode $ object
        [ "id"         .= subscribeId
        , "type"       .= ("subscribe_events" :: T.Text)
        , "event_type" .= ("state_changed" :: T.Text)
        ]

    go lightController

  where
    go f = do
      msg <- WS.receiveData conn :: IO BL.ByteString
      let decoded = Event $ either (const Null) id $ eitherDecode @Value msg
      (x, f') <- step (hassEval gen conn) f decoded
      mapM_ print x
      go f'

receiveJSON :: WS.Connection -> IO Value
receiveJSON conn = do
    msg <- WS.receiveData conn
    case eitherDecode msg of
        Left err -> fail $ "Invalid JSON from Home Assistant: " ++ err
        Right x  -> pure x

wsCallService
  :: WS.Connection
  -> Int
  -> T.Text
  -> T.Text
  -> T.Text
  -> IO ()
wsCallService conn requestId domain service entityId =
  WS.sendTextData conn $ encode $ object
    [ "id"      .= requestId
    , "type"    .= ("call_service" :: T.Text)
    , "domain"  .= domain
    , "service" .= service
    , "target"  .= object
        [ "entity_id" .= entityId
        ]
    ]

newtype CallIdGen = CallIdGen { generateCallId :: IO Int  }

mkCallIdGen :: Int -> IO CallIdGen
mkCallIdGen start = do
  gen <- newIORef start
  pure $ CallIdGen $ atomicModifyIORef' gen (\old -> let new = old + 1 in new `seq` (new, new))

hassEval :: CallIdGen -> WS.Connection -> HASSEff a -> IO a
hassEval gen conn = \case
  CallService x -> do
    callId <- generateCallId gen
    print (callId, x)
    -- wsCallService conn callId (serviceDomain x) (serviceName x) (serviceTarget x)
  Pure a -> pure a

• Step 5: Delete src/MyLib.hs

Run: git rm src/MyLib.hs

• Step 6: Update app/Main.hs

Replace the entire file content with:

module Main (main) where

import qualified HomeAssistant.Runtime (defaultMain)

main :: IO ()
main = do
  putStrLn "Hello, Haskell!"
  HomeAssistant.Runtime.defaultMain

• Step 7: Update home-assistant-controller.cabal

In the library section, replace:

    exposed-modules:  MyLib

with:

    exposed-modules:  AFRP
                    , HomeAssistant.Controller
                    , HomeAssistant.Runtime

• Step 8: Build to verify it compiles

Run: cabal build Expected: Build succeeds. Warnings appear for: numericDirection, isEntity, state (x2), toBool (non-exhaustive), conn (unused match). The entityChangeEvent, entityRead', entityRead, and wsCallService warnings are resolved by the export lists.

If the build fails, read the error, fix the issue, and rebuild before proceeding.

• Step 9: Commit

git add src/AFRP.hs src/HomeAssistant/Controller.hs src/HomeAssistant/Runtime.hs app/Main.hs home-assistant-controller.cabal
git commit -m "Split MyLib into AFRP, Controller, Runtime"

---

Task 2: Fix warnings

Files:

• Modify: src/HomeAssistant/Controller.hs
• Modify: src/HomeAssistant/Runtime.hs

Interfaces:

• HomeAssistant.Runtime new export: dryRunHassEval :: CallIdGen -> HASSEff a -> IO a
• HomeAssistant.Runtime changed export list: add dryRunHassEval

After this task: cabal build --ghc-options="-Wall -Wincomplete-uni-patterns -Wincomplete-record-updates" produces zero warnings.

• Step 1: Delete Direction and numericDirection from Controller.hs

Remove these lines from src/HomeAssistant/Controller.hs:

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

• Step 2: Remove mapAccum from the AFRP import in Controller.hs

In src/HomeAssistant/Controller.hs, change:

import AFRP (Mealy, eff, Event(..), hold, events, changes, mapAccum, filterA, (>>|), toEvent)

to:

import AFRP (Mealy, eff, Event(..), hold, events, changes, filterA, (>>|), toEvent)

• Step 3: Delete dead isEntity from entityChangeEvent in Controller.hs

Change:

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)

to:

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

• Step 4: Delete dead state from entityRead in Controller.hs

Change:

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

to:

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

• Step 5: Delete dead state from entityBool in Controller.hs

Change:

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

to:

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

• Step 6: Add catch-all to toBool in entityBool' in Controller.hs

Change:

    toBool = \case
      "on" -> True
      "off" -> False

to:

    toBool = \case
      "on" -> True
      "off" -> False
      _ -> False

• Step 7: Add dryRunHassEval and fix hassEval in Runtime.hs

In src/HomeAssistant/Runtime.hs, change:

hassEval :: CallIdGen -> WS.Connection -> HASSEff a -> IO a
hassEval gen conn = \case
  CallService x -> do
    callId <- generateCallId gen
    print (callId, x)
    -- wsCallService conn callId (serviceDomain x) (serviceName x) (serviceTarget x)
  Pure a -> pure a

to:

hassEval :: CallIdGen -> WS.Connection -> HASSEff a -> IO a
hassEval gen conn = \case
  CallService x -> do
    callId <- generateCallId gen
    wsCallService conn callId (serviceDomain x) (serviceName x) (serviceTarget x)
  Pure a -> pure a

dryRunHassEval :: CallIdGen -> HASSEff a -> IO a
dryRunHassEval gen = \case
  CallService x -> do
    callId <- generateCallId gen
    print (callId, x)
  Pure a -> pure a

• Step 8: Add dryRunHassEval to the export list in Runtime.hs

In src/HomeAssistant/Runtime.hs, change:

module HomeAssistant.Runtime
  ( defaultMain
  , app
  , step
  , CallIdGen
  , mkCallIdGen
  , hassEval
  , receiveJSON
  , wsCallService
  ) where

to:

module HomeAssistant.Runtime
  ( defaultMain
  , app
  , step
  , CallIdGen
  , mkCallIdGen
  , hassEval
  , dryRunHassEval
  , receiveJSON
  , wsCallService
  ) where

• Step 9: Wire app to use dryRunHassEval in Runtime.hs

In src/HomeAssistant/Runtime.hs, inside the go function in app, change:

      (x, f') <- step (hassEval gen conn) f decoded

to:

      (x, f') <- step (dryRunHassEval gen) f decoded

• Step 10: Build with full warning flags to verify zero warnings

Run: cabal build --ghc-options="-Wall -Wincomplete-uni-patterns -Wincomplete-record-updates" Expected: Build succeeds with zero warnings. If any warnings remain, read them, fix, and rebuild.

• Step 11: Commit

git add src/HomeAssistant/Controller.hs src/HomeAssistant/Runtime.hs
git commit -m "Fix warnings"