Making the controllers more linear

Basically, the idea of `(oneBranch <> secondBranch)` instead of

```
do
x <- foo
case x of
  ...
```

src/AFRP.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE TypeOperators #-}
 
 module AFRP
   ( Mealy(..)
@@ -18,8 +20,10 @@ module AFRP
   , changes
   , whenA
   , filterA
+  , filterEvent
   , thenA
   , (>>|)
+  , (>>||)
   , toEvent
   , lMerge
   , Pair(..)
@@ -271,7 +275,7 @@ data Mealy eff a b = Mealy
 
 -- Provide a name
 named :: Text -> Mealy eff a b -> Mealy eff a b
-named n f = f{runDiagramC = \run -> run (Step n (emptyDiagram run))}
+named n f = f{runDiagramC = \run -> run (Step n (runDiagramC f run))}
 
 instance Semigroup b => Semigroup (Mealy eff a b) where
   Mealy ast ad af <> Mealy bst bd bf = Mealy (ast <> bst) (combineDiagram Merge ad bd) $ \nt -> af nt <> bf nt
@@ -290,15 +294,19 @@ eff f = Mealy mempty emptyDiagram $ \nt -> do
 instance Category (Mealy eff) where
   {- HLINT ignore "Use const" -}
   id = Mealy mempty emptyDiagram $ \_nt -> id
-  (Mealy ast ad f) . (Mealy bst bd g) = Mealy (ast <> bst) (combineDiagram Then ad bd) $ \nt -> do
+  (Mealy ast ad f) . (Mealy bst bd g) = Mealy (ast <> bst) (combineDiagram Then bd ad) $ \nt -> do
     f nt . g nt
 
 instance Arrow (Mealy eff) where
   arr f = Mealy mempty emptyDiagram $ \_nt -> arr f
   first (Mealy st d f) = Mealy st d $ \nt -> first (f nt)
+  (Mealy ast ad f) &&& (Mealy bst bd g) = Mealy (ast <> bst) (combineDiagram Both ad bd) $ \nt -> do
+    f nt &&& g nt
 
 instance ArrowChoice (Mealy eff) where
   left (Mealy st d f) = Mealy st d $ \nt -> left (f nt)
+  (Mealy ast ad f) +++ (Mealy bst bd g) = Mealy (ast <> bst) (combineDiagram Branch ad bd) $ \nt -> do
+    f nt +++ g nt
 
 
 instance Functor (Mealy eff a) where
@@ -486,13 +494,29 @@ whenA predicate auto = arr (\a -> if predicate a then Left a else Right ()) >>>
 filterA :: (a -> Bool) -> Mealy eff a (Either () a)
 filterA f = arr $ \a -> bool (Left ()) (Right a) (f a)
 
+-- filters events through if they match the predicate
+filterEvent :: (ArrowChoice cat, Arrow cat) => (a -> Bool) -> Event a `cat` Event a
+filterEvent predicate = proc ev -> do
+  case ev of
+       Event a | predicate a -> id -< ev
+       _ -> arr (const Tick) -< ()
+
 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 2 >>|
+infixl 2 >>||
+
+(>>||) :: (ArrowChoice cat, Arrow cat) => cat a (Event b) -> cat b c -> cat a (Event c)
+f >>|| g = proc x -> do
+  e <- f -< x
+  case e of
+       Event e' -> g >>> arr Event -< e'
+       Tick -> arr (const Tick) -< ()
+
+infixr 3 >>|
 
 toEvent :: Mealy eff (Either () a) (Event a)
 toEvent = arr (either (const Tick) Event)

src/AFRP/Diagram.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 module AFRP.Diagram where
 import Data.Text (Text)
 import qualified Text.Printf as Text
@@ -23,22 +24,26 @@ emptyDiagram :: DiagramC
 emptyDiagram r = r Empty
 
 
-renderF :: DiagramF (Maybe String) -> Maybe String
+renderF :: DiagramF (Maybe T.Text) -> Maybe T.Text
 renderF = \case
   Empty -> Nothing
-  Step n x -> Just $ T.unpack n <> maybe "" (Text.printf "( %s )") x
+  Step n x -> Just $ n <> T.pack (maybe "" (Text.printf "( %s )") x)
   Then (Just a) (Just b) -> Just $ a <> " -> " <> b
   Then (Just a) _ -> Just a
   Then _ b -> b
-  Both (Just a) (Just b) -> Just $ Text.printf "(%s, %s)" a b
+  Both (Just a) (Just b) -> Just $ T.pack $ Text.printf "(%s, %s)" a b
   Both (Just a) _ -> Just a
   Both _ b -> b
-  Branch (Just a) (Just b) -> Just $ Text.printf "(%s || %s)" a b
+  Branch (Just a) (Just b) -> Just $ T.pack $ Text.printf "(%s || %s)" a b
-  Branch (Just a) Nothing -> Just $ Text.printf "(%s || <skip>)" a
+  -- I'm leaving this here. This would be technically more correct (showing
+  -- the empty branch, ie. the full if-then-else, but often we care about a
+  -- more simplistic `when` style structure
+  -- Branch (Just a) Nothing -> Just $ T.pack $ Text.printf "(%s || <skip>)" a
+  Branch (Just a) Nothing -> Just $ T.pack $ Text.printf "%s" a
   Branch _ b -> b
-  Merge (Just a) (Just b) -> Just $ Text.printf "(%s, %s)" a b
+  Merge (Just a) (Just b) -> Just $ T.pack $ Text.printf "(%s, %s)" a b
   Merge (Just a) _ -> Just a
   Merge _ b -> b
-  Compose (Just a) (Just b) -> Just $ Text.printf "(%s, %s)" a b
+  Compose (Just a) (Just b) -> Just $ T.pack $ Text.printf "(%s, %s)" a b
   Compose (Just a) _ -> Just a
   Compose _ b -> b

src/HomeAssistant/Controller/Bedroom.hs

@@ -5,7 +5,7 @@ module HomeAssistant.Controller.Bedroom where
 
 import HomeAssistant.Controller
 import qualified Data.Text as T
-import AFRP (Event (..), lMerge, duration, edge)
+import AFRP (Event (..), lMerge, duration, edge, filterEvent, named, (>>||))
 import Data.Aeson (Value, object, (.=))
 import Control.Arrow ((>>>), returnA, arr, Arrow (..))
 import Data.Bool (bool)
@@ -134,14 +134,16 @@ drawer = entityBool "binary_sensor.bedroom_nightstand_drawer_sensor_masse_contac
   >>> arr (fmap (bool Closed Open))
 
 bedroomDrawerController :: HASS (Event Value) ()
-bedroomDrawerController = proc x -> do
+bedroomDrawerController =
-  st <- drawer >>> traceEvent -< x
+  drawer >>>
-  case st of
+  (named "Drawer opened" lightOn <> named "Drawer closed" lightOff)
-       Event Open -> callService "drawer light on" (switchService [entity] True) -< ()
+  >>> arr (const ())
-       Event Closed -> callService "drawer light off" (switchService [entity] False) -< ()
-       _ -> returnA -< ()
   where
     entity = EntityId "switch.bedroom_drawer_light_masse"
+    lightOff = filterEvent (== Closed)
+      >>|| callService "drawer light off" (switchService [entity] False)
+    lightOn = filterEvent (== Open)
+      >>|| callService "drawer light on" (switchService [entity] True)
 
 door :: HASS (Event Value) (Event DoorState)
 door = entityBool "binary_sensor.makuuhuone_ovi_contact"

src/HomeAssistant/Runtime.hs

@@ -48,6 +48,7 @@ import Text.Read (readMaybe)
 import UnliftIO.Async
 import Control.Monad.Catch (MonadCatch)
 import Control.Exception.Annotated (checkpoint, Annotation (..))
+import AFRP.Diagram (renderF)
 
 step :: (MonadIO m) => FilePath -> T.Text -> UUID -> Auto m a b -> a -> m (b, Auto m a b)
 step path name trace st a = do
@@ -122,6 +123,8 @@ defaultMain =
         rrdtool <- fromMaybe "rrdtool" <$> liftIO (lookupEnv "HA_RRDTOOL")
         metricsPort <- lookupPort
         writerLimiter <- slidingWindowLimiter rateLimitMetrics 10 20
+        forM_ controllers $ \(Controller n m) ->
+          logLocM InfoS $ ls $ n <> ": " <> fromMaybe "" (runDiagramC m renderF)
         let ents = foldMap (\(Controller _ m) -> entities m) controllers
             workers =
               [ ("reader", readerAction host 8123 token ents bus),