Skip to content
Snippets Groups Projects
Commit 4040e763 authored by Jens Nolte's avatar Jens Nolte
Browse files

Make G815 leds controllable from qd

parent 15b26892
No related branches found
No related tags found
No related merge requests found
...@@ -23,11 +23,16 @@ dependencies: ...@@ -23,11 +23,16 @@ dependencies:
- base >= 4.7 && < 5 - base >= 4.7 && < 5
- async - async
- brick - brick
- conduit
- JuicyPixels - JuicyPixels
- lens - microlens-platform
- mtl
- optparse-applicative - optparse-applicative
- qd
- template-haskell
- text - text
- typed-process - typed-process
- unordered-containers
- vty - vty
default-extensions: default-extensions:
......
...@@ -10,18 +10,8 @@ import qualified Q.G815 ...@@ -10,18 +10,8 @@ import qualified Q.G815
import Control.Monad (join) import Control.Monad (join)
import Options.Applicative import Options.Applicative
mainParser :: Parser (IO ()) main :: IO ()
mainParser = hsubparser main = join parse
(
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")
parserPrefs :: ParserPrefs parserPrefs :: ParserPrefs
parserPrefs = prefs showHelpOnEmpty parserPrefs = prefs showHelpOnEmpty
...@@ -29,8 +19,17 @@ parserPrefs = prefs showHelpOnEmpty ...@@ -29,8 +19,17 @@ parserPrefs = prefs showHelpOnEmpty
parse :: IO (IO ()) parse :: IO (IO ())
parse = customExecParser parserPrefs parser parse = customExecParser parserPrefs parser
main :: IO () parser :: ParserInfo (IO ())
main = join parse 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 :: Parser String
pomodoroOptionsParser = strArgument (metavar "TASK" <> help "foobar") pomodoroOptionsParser = strArgument (metavar "TASK" <> help "foobar")
module Q.G815 where {-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE TemplateHaskell #-}
module Q.G815 (
run
) where
import Control.Concurrent (threadDelay) import Conduit
--import Control.Monad (forever) import Control.Concurrent.MVar
import System.IO (stdout, hFlush, hPutStrLn) 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 :: IO ()
run = do run = withConnectTCP $ \qdInterface -> do
do outboxMVar <- newMVar defaultState
hPutStrLn stdout $ "a ff0000" g815 <- G815 <$> newMVar defaultState <*> return (putMVar outboxMVar)
hPutStrLn stdout $ "k logo 000000"
hPutStrLn stdout $ "k h 0000ff" join $ runActorSetup qdInterface [] defaultActorConfiguration{actorName=Just "g815"} $ setup g815
hPutStrLn stdout $ "k j 0000ff"
hPutStrLn stdout $ "k k 0000ff" runConduit $ source (takeMVar outboxMVar) .| filterDuplicates .| output
hPutStrLn stdout $ "k l 0000ff" where
--hPutStrLn stdout $ "k G1 ff0050" source :: IO G815State -> ConduitT () G815State IO ()
--hPutStrLn stdout $ "k G2 ff0050" source getStateUpdate = forever $ yield =<< liftIO getStateUpdate
--hPutStrLn stdout $ "k G3 ff0050" keys :: [Text]
--hPutStrLn stdout $ "k G4 ff0050" keys = ["logo", "esc", "g1", "g2", "g3", "g4", "g5"] <> (T.singleton <$> ['a'..'z'] <> ['0'..'9']) <> (T.cons 'f' . T.pack . show <$> ([1..12] :: [Int]))
--hPutStrLn stdout $ "k G5 ff0050" setup :: G815 -> ActorSetup (IO ())
hPutStrLn stdout $ "g multimedia ff5000" setup g815 = do
hPutStrLn stdout $ "g indicators ff5000" keysSetupAction <- sequence_ <$> traverse setupKey keys
--hPutStrLn stdout $ "g arrows 400000" property <- createProperty "default"
hPutStrLn stdout $ "c" return $ keysSetupAction >> void (subscribe property $ updateG815 g815 . setDefaultColor . fromRight Nothing . snd)
hFlush stdout where
threadDelay (1000000 `div` 60) 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)
...@@ -39,7 +39,10 @@ packages: ...@@ -39,7 +39,10 @@ packages:
# - git: https://github.com/commercialhaskell/stack.git # - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # 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 # Override default flag values for local packages and extra-deps
# flags: {} # flags: {}
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment