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:
- 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:
......
......@@ -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")
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)
......@@ -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: {}
......
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