g815: Implement idle property

q.cabal

@@ -47,7 +47,8 @@ library
     Q.AlarmClock
     Q.Cli
     Q.Dashboard
-    Q.G815
+    Q.Hardware.G815
+    Q.Hardware.BeatStep
     Q.Pomodoro
     Q.Wallpaper
   hs-source-dirs:

src/Q/Cli.hs

@@ -6,7 +6,8 @@ import qualified Q.AlarmClock
 import qualified Q.Dashboard
 import qualified Q.Pomodoro
 import Q.Wallpaper (generateWallpaper)
-import qualified Q.G815
+import qualified Q.Hardware.BeatStep
+import qualified Q.Hardware.G815
 
 import Control.Monad (join)
 import Options.Applicative
@@ -30,7 +31,8 @@ mainParser = hsubparser (
     command "dashboard" (info (pure Q.Dashboard.run) (progDesc "Start the dashboard tui.")) <>
     command "pomodoro" (info (Q.Pomodoro.run <$> pomodoroOptionsParser) (progDesc "Control the pomodoro timer.")) <>
     command "wallpaper" (info (pure generateWallpaper) (progDesc "Generates a new wallpaper.")) <>
-    command "g815" (info (pure Q.G815.run) (progDesc "Animate G815 keyboard leds. For consumption by g810-led."))
+    command "g815" (info (pure Q.Hardware.G815.run) (progDesc "Animate G815 keyboard leds. For consumption by g810-led.")) <>
+    command "beatstep" (info (pure Q.Hardware.BeatStep.run) (progDesc "Parses BeatStep midi dump from aseqdump."))
   )
 
 alarmClockParser :: Parser (IO ())

src/Q/Hardware/BeatStep.hs

+module Q.Hardware.BeatStep where
+
+import Control.Monad (forever)
+import Data.Text (Text)
+import System.IO (stderr, getLine, hPutStrLn)
+import Qd
+import Qd.Interface
+import Qd.QdProtocol.Client
+
+run :: IO ()
+run = withConnectTCP $ \qdInterface -> do
+  alarmTime <- runActorSetup' qdInterface [] setup
+  forever $ do
+    line <- getLine
+    case line of
+      "Waiting for data. Press Ctrl+C to end." -> return ()
+      "Source  Event                  Ch  Data" -> return ()
+      _ -> hPutStrLn stderr "Failed to parse line:"
+    hPutStrLn stderr line
+  where
+    setup :: ActorSetup (PropertyProxy Text)
+    setup = createProperty "alarmTime"

src/Q/G815.hs → src/Q/Hardware/G815.hs

 {-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE TemplateHaskell #-}
-module Q.G815 (
+
+module Q.Hardware.G815 (
   run
 ) where
 
@@ -26,6 +27,7 @@ type Color = Text
 
 data G815 = G815 (MVar G815State) (G815State -> IO ())
 data G815State = G815State {
+  idle :: Bool,
   defaultColor :: Maybe Color,
   groups :: HM.HashMap Text Color,
   keys :: HM.HashMap Text Color
@@ -50,8 +52,12 @@ run = withConnectTCP $ \qdInterface -> do
     setup :: G815 -> ActorSetup (IO ())
     setup g815 = do
       keysSetupAction <- sequence_ <$> traverse setupKey keys
-      property <- createProperty "default"
-      return $ keysSetupAction >> void (subscribe property $ updateG815 g815 . setDefaultColor . fromRight Nothing . snd)
+      defaultProperty <- createProperty "default"
+      idleProperty <- createProperty "idle"
+      return $ do
+        keysSetupAction
+        void $ subscribe defaultProperty $ updateG815 g815 . setDefaultColor . fromRight Nothing . snd
+        void $ subscribe idleProperty $ updateG815 g815 . (assign _idle) . fromRight False . snd
       where
         setupKey :: Text -> ActorSetup (IO ())
         setupKey key = do
@@ -78,6 +84,7 @@ setKey key color = _keys . at key .= color
 
 defaultState :: G815State
 defaultState = G815State {
+  idle = False,
   defaultColor = Nothing,
   groups = HM.fromList [("multimedia", "ff5000"), ("indicators", "ff5000")],
   keys = HM.empty
@@ -109,8 +116,10 @@ output = awaitForever $ \s -> render s .| outputFrame
       liftIO $ hFlush stdout
 
 render :: Monad m => G815State -> ConduitT i Text m ()
-render G815State{defaultColor, groups, keys} = do
-  yield $ "a " <> fromMaybe "000000" defaultColor
-  when (not $ HM.member "logo" keys) $ yield "k logo 000000"
-  forM_ (HM.toList groups) $ \(key, color) -> yield ("g " <> key <> " " <> color)
-  forM_ (HM.toList keys) $ \(key, color) -> yield ("k " <> key <> " " <> color)
+render G815State{idle, defaultColor, groups, keys} = if idle
+  then yield "a 000000"
+  else do
+    yield $ "a " <> fromMaybe "ff0000" defaultColor
+    when (not $ HM.member "logo" keys) $ yield "k logo 000000"
+    forM_ (HM.toList groups) $ \(key, color) -> yield ("g " <> key <> " " <> color)
+    forM_ (HM.toList keys) $ \(key, color) -> yield ("k " <> key <> " " <> color)