{-# LANGUAGE TupleSections #-}
module Xmobar.Plugins.Locks(Locks(..)) where
import Graphics.X11
import Data.List
import Data.List.Extra (trim)
import Data.Bits
import Data.Maybe (fromJust)
import Control.Monad
import Control.Monad.Extra (ifM)
import Graphics.X11.Xlib.Extras
import Xmobar.Run.Exec
import Xmobar.System.Kbd
import Xmobar.X11.Events (nextEvent')
data Locks = Locks | Locks' [(String, (String, String))]
deriving (ReadPrec [Locks]
ReadPrec Locks
Int -> ReadS Locks
ReadS [Locks]
(Int -> ReadS Locks)
-> ReadS [Locks]
-> ReadPrec Locks
-> ReadPrec [Locks]
-> Read Locks
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Locks
readsPrec :: Int -> ReadS Locks
$creadList :: ReadS [Locks]
readList :: ReadS [Locks]
$creadPrec :: ReadPrec Locks
readPrec :: ReadPrec Locks
$creadListPrec :: ReadPrec [Locks]
readListPrec :: ReadPrec [Locks]
Read, Int -> Locks -> ShowS
[Locks] -> ShowS
Locks -> String
(Int -> Locks -> ShowS)
-> (Locks -> String) -> ([Locks] -> ShowS) -> Show Locks
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Locks -> ShowS
showsPrec :: Int -> Locks -> ShowS
$cshow :: Locks -> String
show :: Locks -> String
$cshowList :: [Locks] -> ShowS
showList :: [Locks] -> ShowS
Show)
locks :: [ ( KeySym, String )]
locks :: [(KeySym, String)]
locks = [ ( KeySym
xK_Caps_Lock, String
"CAPS" )
, ( KeySym
xK_Num_Lock, String
"NUM" )
, ( KeySym
xK_Scroll_Lock, String
"SCROLL" )
]
type Labels = [ ( String, (String, String) )]
defaultLabels :: Labels
defaultLabels :: [(String, (String, String))]
defaultLabels = let nms :: [String]
nms = ((KeySym, String) -> String) -> [(KeySym, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (KeySym, String) -> String
forall a b. (a, b) -> b
snd [(KeySym, String)]
locks
in [String] -> [(String, String)] -> [(String, (String, String))]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
nms ((String -> (String, String)) -> [String] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (, String
forall a. Monoid a => a
mempty) [String]
nms)
type LabelledLock = (KeySym, String, String, String)
attach :: (KeySym, String) -> Labels -> LabelledLock
(KeySym
key, String
lock) attach :: (KeySym, String) -> [(String, (String, String))] -> LabelledLock
`attach` [(String, (String, String))]
lbls = let (String
enb, String
dis) = Maybe (String, String) -> (String, String)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (String, String) -> (String, String))
-> Maybe (String, String) -> (String, String)
forall a b. (a -> b) -> a -> b
$ String -> [(String, (String, String))] -> Maybe (String, String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
lock [(String, (String, String))]
lbls
in (KeySym
key, String
lock, String
enb, String
dis)
enabled :: (a, b, c, d) -> c
enabled :: forall a b c d. (a, b, c, d) -> c
enabled (a
_, b
_, c
c, d
_) = c
c
disabled :: (a, b, c, d) -> d
disabled :: forall a b c d. (a, b, c, d) -> d
disabled (a
_, b
_, c
_, d
d) = d
d
isEnabled :: (Bits a1, Foldable t, Foldable t1, Integral a)
=> Display -> t (a, t1 KeyCode) -> a1 -> (KeySym, b, c, d) -> IO Bool
isEnabled :: forall a1 (t :: * -> *) (t1 :: * -> *) a b c d.
(Bits a1, Foldable t, Foldable t1, Integral a) =>
Display -> t (a, t1 KeyCode) -> a1 -> (KeySym, b, c, d) -> IO Bool
isEnabled Display
d t (a, t1 KeyCode)
modMap a1
m ( KeySym
ks, b
_, c
_, d
_ ) = do
kc <- Display -> KeySym -> IO KeyCode
keysymToKeycode Display
d KeySym
ks
return $ case find (elem kc . snd) modMap of
Maybe (a, t1 KeyCode)
Nothing -> Bool
False
Just ( a
i, t1 KeyCode
_ ) -> a1 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit a1
m (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i)
run' :: Display -> Window -> Labels -> IO String
run' :: Display -> KeySym -> [(String, (String, String))] -> IO String
run' Display
d KeySym
root [(String, (String, String))]
labels = do
modMap <- Display -> IO [(Modifier, [KeyCode])]
getModifierMapping Display
d
( _, _, _, _, _, _, _, m ) <- queryPointer d root
ls' <- forM (map (`attach` labels) locks)
(\LabelledLock
l -> IO Bool -> IO String -> IO String -> IO String
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Display
-> [(Modifier, [KeyCode])] -> Modifier -> LabelledLock -> IO Bool
forall a1 (t :: * -> *) (t1 :: * -> *) a b c d.
(Bits a1, Foldable t, Foldable t1, Integral a) =>
Display -> t (a, t1 KeyCode) -> a1 -> (KeySym, b, c, d) -> IO Bool
isEnabled Display
d [(Modifier, [KeyCode])]
modMap Modifier
m LabelledLock
l)
(String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LabelledLock -> String
forall a b c d. (a, b, c, d) -> c
enabled LabelledLock
l))
(String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LabelledLock -> String
forall a b c d. (a, b, c, d) -> d
disabled LabelledLock
l)))
return $ trim $ unwords ls'
instance Exec Locks where
alias :: Locks -> String
alias Locks
_ = String
"locks"
start :: Locks -> (String -> IO ()) -> IO ()
start Locks
Locks String -> IO ()
cb = Locks -> (String -> IO ()) -> IO ()
forall e. Exec e => e -> (String -> IO ()) -> IO ()
start ([(String, (String, String))] -> Locks
Locks' [(String, (String, String))]
defaultLabels) String -> IO ()
cb
start (Locks' [(String, (String, String))]
labels) String -> IO ()
cb = do
d <- String -> IO Display
openDisplay String
""
root <- rootWindow d (defaultScreen d)
_ <- xkbSelectEventDetails d xkbUseCoreKbd xkbIndicatorStateNotify m m
allocaXEvent $ \XEventPtr
ep -> IO Event -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO Event -> IO Any) -> IO Event -> IO Any
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
cb (String -> IO ()) -> IO String -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Display -> KeySym -> [(String, (String, String))] -> IO String
run' Display
d KeySym
root [(String, (String, String))]
labels
Display -> XEventPtr -> IO ()
nextEvent' Display
d XEventPtr
ep
XEventPtr -> IO Event
getEvent XEventPtr
ep
closeDisplay d
return ()
where
m :: CULong
m = CULong
xkbAllStateComponentsMask