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
Branches containing commit
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:
...
@@ -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
:
...
...
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
...
@@ -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"
)
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
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
)
This diff is collapsed.
Click to expand it.
stack.yaml
+
4
−
1
View file @
4040e763
...
@@ -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: {}
...
...
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