Make G815 leds controllable from qd

package.yaml

@@ -23,11 +23,16 @@ dependencies:
 - base >= 4.7 && < 5
 - async
 - brick
+- conduit
 - JuicyPixels
-- lens
+- microlens-platform
+- mtl
 - optparse-applicative
+- qd
+- template-haskell
 - text
 - typed-process
+- unordered-containers
 - vty
 
 default-extensions:

src/Q/Cli.hs

@@ -10,18 +10,8 @@ import qualified Q.G815
 import Control.Monad (join)
 import Options.Applicative
 
-mainParser :: Parser (IO ())
-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."))
-  )
-
-parser :: ParserInfo (IO ())
-parser = info (mainParser <**> helper)
-  (fullDesc <> header "q - queezles tools")
+main :: IO ()
+main = join parse
 
 parserPrefs :: ParserPrefs
 parserPrefs = prefs showHelpOnEmpty
@@ -29,8 +19,17 @@ parserPrefs = prefs showHelpOnEmpty
 parse :: IO (IO ())
 parse = customExecParser parserPrefs parser
 
-main :: IO ()
-main = join parse
+parser :: ParserInfo (IO ())
+parser = info (mainParser <**> helper)
+  (fullDesc <> header "q - queezles tools")
+
+mainParser :: Parser (IO ())
+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."))
+  )
 
 pomodoroOptionsParser :: Parser String
 pomodoroOptionsParser = strArgument (metavar "TASK" <> help "foobar")

src/Q/G815.hs

-module Q.G815 where
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Q.G815 (
+  run
+) where
 
-import Control.Concurrent (threadDelay)
---import Control.Monad (forever)
-import System.IO (stdout, hFlush, hPutStrLn)
+import Conduit
+import Control.Concurrent.MVar
+import Control.Monad.State.Lazy
+import System.IO (stdout, hFlush)
+import Data.Either (fromRight)
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Tuple (swap)
+import qualified Data.Text.IO as T
+import qualified Data.HashMap.Strict as HM
+import Language.Haskell.TH.Syntax (mkName, nameBase)
+import Lens.Micro.Platform
+import Qd
+import Qd.Interface
+import Qd.QdProtocol.Client (withConnectTCP)
+
+
+type Color = Text
+
+data G815 = G815 (MVar G815State) (G815State -> IO ())
+data G815State = G815State {
+  defaultColor :: Maybe Color,
+  groups :: HM.HashMap Text Color,
+  keys :: HM.HashMap Text Color
+}
+  deriving (Eq, Show)
+
+makeLensesWith (lensRules & lensField .~ (\_ _ -> pure . TopName . mkName . ("_" <>) . nameBase)) ''G815State
 
 run :: IO ()
-run = do
-  do
-    hPutStrLn stdout $ "a ff0000"
-    hPutStrLn stdout $ "k logo 000000"
-    hPutStrLn stdout $ "k h 0000ff"
-    hPutStrLn stdout $ "k j 0000ff"
-    hPutStrLn stdout $ "k k 0000ff"
-    hPutStrLn stdout $ "k l 0000ff"
-    --hPutStrLn stdout $ "k G1 ff0050"
-    --hPutStrLn stdout $ "k G2 ff0050"
-    --hPutStrLn stdout $ "k G3 ff0050"
-    --hPutStrLn stdout $ "k G4 ff0050"
-    --hPutStrLn stdout $ "k G5 ff0050"
-    hPutStrLn stdout $ "g multimedia ff5000"
-    hPutStrLn stdout $ "g indicators ff5000"
-    --hPutStrLn stdout $ "g arrows 400000"
-    hPutStrLn stdout $ "c"
-    hFlush stdout
-    threadDelay (1000000 `div` 60)
+run = withConnectTCP $ \qdInterface -> do
+  outboxMVar <- newMVar defaultState
+  g815 <- G815 <$> newMVar defaultState <*> return (putMVar outboxMVar)
+
+  join $ runActorSetup qdInterface [] defaultActorConfiguration{actorName=Just "g815"} $ setup g815
+
+  runConduit $ source (takeMVar outboxMVar) .| filterDuplicates .| output
+  where
+    source :: IO G815State -> ConduitT () G815State IO ()
+    source getStateUpdate = forever $ yield =<< liftIO getStateUpdate
+    keys :: [Text]
+    keys = ["logo", "esc", "g1", "g2", "g3", "g4", "g5"] <> (T.singleton <$> ['a'..'z'] <> ['0'..'9']) <> (T.cons 'f' . T.pack . show <$> ([1..12] :: [Int]))
+    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)
+      where
+        setupKey :: Text -> ActorSetup (IO ())
+        setupKey key = do
+          property <- createProperty key
+          return $ void $ subscribe property $ updateG815 g815 . setKey key . fromRight Nothing . snd
+
+
+updateG815' :: G815 -> (G815State -> (G815State, a)) -> IO a
+updateG815' (G815 stateMVar renderState) fn = do
+  modifyMVar stateMVar $ \oldState -> do
+    let (newState, x) = fn oldState
+    renderState newState
+    return (newState, x)
+
+updateG815 :: G815 -> State G815State a -> IO a
+updateG815 g815 = updateG815' g815 . fmap swap . runState
+
+setDefaultColor :: Maybe Color -> State G815State ()
+setDefaultColor = assign _defaultColor
+
+setKey :: Text -> Maybe Color -> State G815State ()
+setKey key color = _keys . at key .= color
+
+
+defaultState :: G815State
+defaultState = G815State {
+  defaultColor = Nothing,
+  groups = HM.fromList [("multimedia", "ff5000"), ("indicators", "ff5000")],
+  keys = HM.empty
+}
+
+filterDuplicates :: forall a. Eq a => ConduitT a a IO ()
+filterDuplicates = do
+  first <- await
+  case first of
+    Just first' -> yield first' >> filterDuplicates' first'
+    Nothing -> return ()
+  where
+    filterDuplicates' :: a -> ConduitT a a IO ()
+    filterDuplicates' previous = do
+      next <- await
+      case next of
+        Just next' -> do
+          when (previous /= next') $ yield next'
+          filterDuplicates' next'
+        Nothing -> return ()
+
+output :: ConduitT G815State Void IO ()
+output = awaitForever $ \s -> render s .| outputFrame
+  where
+    outputFrame :: ConduitT Text Void IO ()
+    outputFrame = do
+      awaitForever $ liftIO . T.hPutStrLn stdout
+      liftIO $ T.hPutStrLn stdout "c" -- Commit
+      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)

stack.yaml

@@ -39,7 +39,10 @@ packages:
 # - git: https://github.com/commercialhaskell/stack.git
 #   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
 #
-# extra-deps: []
+extra-deps:
+- git: https://git.c3pb.de/jens/qd.git
+  commit: ec42f49c3c12855022fcaaff007ff9172472f63e
+- net-mqtt-0.7.0.1@sha256:07f966e800f9a5a5803fa72bd9145d832517e4adea34ee84234056d53ffea3d4,4131
 
 # Override default flag values for local packages and extra-deps
 # flags: {}