Skip to content
GitLab
Explore
Sign in
Primary navigation
Search or go to…
Project
Q
q
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Container Registry
Model registry
Operate
Environments
Monitor
Incidents
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Jens Nolte
q
Commits
4040e763
Commit
4040e763
authored
4 years ago
by
Jens Nolte
Browse files
Options
Downloads
Patches
Plain Diff
Make G815 leds controllable from qd
parent
15b26892
No related branches found
No related tags found
No related merge requests found
Changes
4
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
package.yaml
+6
-1
6 additions, 1 deletion
package.yaml
src/Q/Cli.hs
+13
-14
13 additions, 14 deletions
src/Q/Cli.hs
src/Q/G815.hs
+113
-23
113 additions, 23 deletions
src/Q/G815.hs
stack.yaml
+4
-1
4 additions, 1 deletion
stack.yaml
with
136 additions
and
39 deletions
package.yaml
+
6
−
1
View file @
4040e763
...
...
@@ -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
:
...
...
This diff is collapsed.
Click to expand it.
src/Q/Cli.hs
+
13
−
14
View file @
4040e763
...
...
@@ -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"
)
This diff is collapsed.
Click to expand it.
src/Q/G815.hs
+
113
−
23
View file @
4040e763
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
)
This diff is collapsed.
Click to expand it.
stack.yaml
+
4
−
1
View file @
4040e763
...
...
@@ -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: {}
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment