-----------------------------------------------------------------------------
-- |
-- Module      :  Plugins.Locks
-- Copyright   :  (c) Patrick Chilton
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Patrick Chilton <chpatrick@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- A plugin that displays the status of the lock keys.
--
-----------------------------------------------------------------------------

module Xmobar.Plugins.Locks(Locks(..)) where

import Graphics.X11
import Data.List
import Data.Bits
import Control.Monad
import Graphics.X11.Xlib.Extras
import Xmobar.Run.Exec
import Xmobar.System.Kbd
import Xmobar.X11.Events (nextEvent')

data Locks = Locks
    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
readListPrec :: ReadPrec [Locks]
$creadListPrec :: ReadPrec [Locks]
readPrec :: ReadPrec Locks
$creadPrec :: ReadPrec Locks
readList :: ReadS [Locks]
$creadList :: ReadS [Locks]
readsPrec :: Int -> ReadS Locks
$creadsPrec :: Int -> ReadS 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
showList :: [Locks] -> ShowS
$cshowList :: [Locks] -> ShowS
show :: Locks -> String
$cshow :: Locks -> String
showsPrec :: Int -> Locks -> ShowS
$cshowsPrec :: Int -> 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" )
        ]

run' :: Display -> Window -> IO String
run' :: Display -> KeySym -> IO String
run' Display
d KeySym
root = do
    [(Modifier, [KeyCode])]
modMap <- Display -> IO [(Modifier, [KeyCode])]
getModifierMapping Display
d
    ( Bool
_, KeySym
_, KeySym
_, CInt
_, CInt
_, CInt
_, CInt
_, Modifier
m ) <- Display
-> KeySym
-> IO (Bool, KeySym, KeySym, CInt, CInt, CInt, CInt, Modifier)
queryPointer Display
d KeySym
root

    [(KeySym, String)]
ls <- ((KeySym, String) -> IO Bool)
-> [(KeySym, String)] -> IO [(KeySym, String)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ( \( KeySym
ks, String
_ ) -> do
        KeyCode
kc <- Display -> KeySym -> IO KeyCode
keysymToKeycode Display
d KeySym
ks
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ case ((Modifier, [KeyCode]) -> Bool)
-> [(Modifier, [KeyCode])] -> Maybe (Modifier, [KeyCode])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (KeyCode -> [KeyCode] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem KeyCode
kc ([KeyCode] -> Bool)
-> ((Modifier, [KeyCode]) -> [KeyCode])
-> (Modifier, [KeyCode])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Modifier, [KeyCode]) -> [KeyCode]
forall a b. (a, b) -> b
snd) [(Modifier, [KeyCode])]
modMap of
            Maybe (Modifier, [KeyCode])
Nothing       -> Bool
False
            Just ( Modifier
i, [KeyCode]
_ ) -> Modifier -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Modifier
m (Modifier -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Modifier
i)
        ) [(KeySym, String)]
locks

    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((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)]
ls

instance Exec Locks where
    alias :: Locks -> String
alias Locks
Locks = String
"locks"
    start :: Locks -> (String -> IO ()) -> IO ()
start Locks
Locks String -> IO ()
cb = do
        Display
d <- String -> IO Display
openDisplay String
""
        KeySym
root <- Display -> ScreenNumber -> IO KeySym
rootWindow Display
d (Display -> ScreenNumber
defaultScreen Display
d)
        Modifier
_ <- Display -> Modifier -> Modifier -> CULong -> CULong -> IO Modifier
xkbSelectEventDetails Display
d Modifier
xkbUseCoreKbd Modifier
xkbIndicatorStateNotify CULong
m CULong
m

        (XEventPtr -> IO Any) -> IO Any
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO Any) -> IO Any)
-> (XEventPtr -> IO Any) -> IO Any
forall a b. (a -> b) -> a -> b
$ \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 -> IO String
run' Display
d KeySym
root
            Display -> XEventPtr -> IO ()
nextEvent' Display
d XEventPtr
ep
            XEventPtr -> IO Event
getEvent XEventPtr
ep

        Display -> IO ()
closeDisplay Display
d
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      where
        m :: CULong
m = CULong
xkbAllStateComponentsMask