Add module split implementation plan
This commit is contained in:
@@ -0,0 +1,732 @@
|
||||
# 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`**
|
||||
|
||||
```haskell
|
||||
{-# 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.
|
||||
|
||||
```haskell
|
||||
{-# 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.
|
||||
|
||||
```haskell
|
||||
{-# 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:
|
||||
|
||||
```haskell
|
||||
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**
|
||||
|
||||
```bash
|
||||
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`:
|
||||
|
||||
```haskell
|
||||
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:
|
||||
|
||||
```haskell
|
||||
import AFRP (Mealy, eff, Event(..), hold, events, changes, mapAccum, filterA, (>>|), toEvent)
|
||||
```
|
||||
|
||||
to:
|
||||
|
||||
```haskell
|
||||
import AFRP (Mealy, eff, Event(..), hold, events, changes, filterA, (>>|), toEvent)
|
||||
```
|
||||
|
||||
- [ ] **Step 3: Delete dead `isEntity` from `entityChangeEvent` in `Controller.hs`**
|
||||
|
||||
Change:
|
||||
|
||||
```haskell
|
||||
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:
|
||||
|
||||
```haskell
|
||||
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:
|
||||
|
||||
```haskell
|
||||
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:
|
||||
|
||||
```haskell
|
||||
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:
|
||||
|
||||
```haskell
|
||||
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:
|
||||
|
||||
```haskell
|
||||
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:
|
||||
|
||||
```haskell
|
||||
toBool = \case
|
||||
"on" -> True
|
||||
"off" -> False
|
||||
```
|
||||
|
||||
to:
|
||||
|
||||
```haskell
|
||||
toBool = \case
|
||||
"on" -> True
|
||||
"off" -> False
|
||||
_ -> False
|
||||
```
|
||||
|
||||
- [ ] **Step 7: Add `dryRunHassEval` and fix `hassEval` in `Runtime.hs`**
|
||||
|
||||
In `src/HomeAssistant/Runtime.hs`, change:
|
||||
|
||||
```haskell
|
||||
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:
|
||||
|
||||
```haskell
|
||||
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:
|
||||
|
||||
```haskell
|
||||
module HomeAssistant.Runtime
|
||||
( defaultMain
|
||||
, app
|
||||
, step
|
||||
, CallIdGen
|
||||
, mkCallIdGen
|
||||
, hassEval
|
||||
, receiveJSON
|
||||
, wsCallService
|
||||
) where
|
||||
```
|
||||
|
||||
to:
|
||||
|
||||
```haskell
|
||||
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:
|
||||
|
||||
```haskell
|
||||
(x, f') <- step (hassEval gen conn) f decoded
|
||||
```
|
||||
|
||||
to:
|
||||
|
||||
```haskell
|
||||
(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**
|
||||
|
||||
```bash
|
||||
git add src/HomeAssistant/Controller.hs src/HomeAssistant/Runtime.hs
|
||||
git commit -m "Fix warnings"
|
||||
```
|
||||
Reference in New Issue
Block a user