-----------------------------------------------------------------------------
-- |
-- Module      :  Plugins.Kbd
-- Copyright   :  (c) Martin Perner
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Martin Perner <martin@perner.cc>
-- Stability   :  unstable
-- Portability :  unportable
--
-- A keyboard layout indicator for Xmobar
--
-----------------------------------------------------------------------------

module Xmobar.Plugins.Kbd(Kbd(..)) where

import Data.List (isPrefixOf, findIndex)
import Data.Maybe (fromJust)
import Control.Monad (forever)
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras

import Xmobar.Run.Exec
import Xmobar.X11.Events (nextEvent')
import Xmobar.System.Kbd


-- 'Bad' prefixes of layouts
noLaySymbols :: [String]
noLaySymbols :: [String]
noLaySymbols = [String
"group", String
"inet", String
"ctr", String
"pc", String
"ctrl", String
"terminate"]


-- splits the layout string into the actual layouts
splitLayout :: String -> [String]
splitLayout :: String -> [String]
splitLayout String
s = [String] -> [String] -> [String]
splitLayout' [String]
noLaySymbols ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Char -> [String]
split String
s Char
'+'

splitLayout' :: [String] ->  [String] -> [String]
--                  end of recursion, remove empty strings
splitLayout' :: [String] -> [String] -> [String]
splitLayout' [] [String]
s = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':')) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [String]
s
--                    remove current string if it has a 'bad' prefix
splitLayout' [String]
bad [String]
s  =
  [String] -> [String] -> [String]
splitLayout' ([String] -> [String]
forall a. [a] -> [a]
tail [String]
bad) [String
x | String
x <- [String]
s, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf ([String] -> String
forall a. [a] -> a
head [String]
bad) String
x]

-- split String at each Char
split :: String -> Char -> [String]
split :: String -> Char -> [String]
split [] Char
_ = [String
""]
split (Char
c:String
cs) Char
delim
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
delim = String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
rest
    | Bool
otherwise = (Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: [String] -> String
forall a. [a] -> a
head [String]
rest) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
forall a. [a] -> [a]
tail [String]
rest
        where
            rest :: [String]
rest = String -> Char -> [String]
split String
cs Char
delim

-- replaces input string if on search list (exact match) with corresponding
-- element on replacement list.
--
-- if not found, return string unchanged
searchReplaceLayout :: KbdOpts -> String -> String
searchReplaceLayout :: KbdOpts -> String -> String
searchReplaceLayout KbdOpts
opts String
s = let c :: Maybe Int
c = ((String, String) -> Bool) -> KbdOpts -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (\(String, String)
x -> (String, String) -> String
forall a b. (a, b) -> a
fst (String, String)
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s) KbdOpts
opts in
    case Maybe Int
c of
        Maybe Int
Nothing -> String
s
        Maybe Int
x -> let i :: Int
i = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Int
x in (String, String) -> String
forall a b. (a, b) -> b
snd ((String, String) -> String) -> (String, String) -> String
forall a b. (a -> b) -> a -> b
$ KbdOpts
optsKbdOpts -> Int -> (String, String)
forall a. [a] -> Int -> a
!!Int
i

-- returns the active layout
getKbdLay :: Display -> KbdOpts -> IO String
getKbdLay :: Display -> KbdOpts -> IO String
getKbdLay Display
dpy KbdOpts
opts = do
        String
lay <- Display -> IO String
getLayoutStr Display
dpy
        Int
curLay <- Display -> IO Int
getKbdLayout Display
dpy
        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
$ KbdOpts -> String -> String
searchReplaceLayout KbdOpts
opts (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> [String]
splitLayout String
lay[String] -> Int -> String
forall a. [a] -> Int -> a
!!Int
curLay



newtype Kbd = Kbd [(String, String)]
  deriving (ReadPrec [Kbd]
ReadPrec Kbd
Int -> ReadS Kbd
ReadS [Kbd]
(Int -> ReadS Kbd)
-> ReadS [Kbd] -> ReadPrec Kbd -> ReadPrec [Kbd] -> Read Kbd
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Kbd]
$creadListPrec :: ReadPrec [Kbd]
readPrec :: ReadPrec Kbd
$creadPrec :: ReadPrec Kbd
readList :: ReadS [Kbd]
$creadList :: ReadS [Kbd]
readsPrec :: Int -> ReadS Kbd
$creadsPrec :: Int -> ReadS Kbd
Read, Int -> Kbd -> String -> String
[Kbd] -> String -> String
Kbd -> String
(Int -> Kbd -> String -> String)
-> (Kbd -> String) -> ([Kbd] -> String -> String) -> Show Kbd
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Kbd] -> String -> String
$cshowList :: [Kbd] -> String -> String
show :: Kbd -> String
$cshow :: Kbd -> String
showsPrec :: Int -> Kbd -> String -> String
$cshowsPrec :: Int -> Kbd -> String -> String
Show)

instance Exec Kbd where
        alias :: Kbd -> String
alias (Kbd KbdOpts
_) = String
"kbd"
        start :: Kbd -> (String -> IO ()) -> IO ()
start (Kbd KbdOpts
opts) String -> IO ()
cb = do

            Display
dpy <- String -> IO Display
openDisplay String
""

            -- initial set of layout
            String -> IO ()
cb (String -> IO ()) -> IO String -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Display -> KbdOpts -> IO String
getKbdLay Display
dpy KbdOpts
opts

            -- enable listing for
            -- group changes
            CUInt
_ <- Display -> CUInt -> CUInt -> CULong -> CULong -> IO CUInt
xkbSelectEventDetails Display
dpy CUInt
xkbUseCoreKbd CUInt
xkbStateNotify CULong
xkbAllStateComponentsMask CULong
xkbGroupStateMask
            -- layout/geometry changes
            CUInt
_ <- Display -> CUInt -> CUInt -> CUInt -> IO CUInt
xkbSelectEvents Display
dpy  CUInt
xkbUseCoreKbd CUInt
xkbNewKeyboardNotifyMask CUInt
xkbNewKeyboardNotifyMask

            (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
e -> IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ do
                Display -> XEventPtr -> IO ()
nextEvent' Display
dpy XEventPtr
e
                Event
_ <- XEventPtr -> IO Event
getEvent XEventPtr
e
                String -> IO ()
cb (String -> IO ()) -> IO String -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Display -> KbdOpts -> IO String
getKbdLay Display
dpy KbdOpts
opts

            Display -> IO ()
closeDisplay Display
dpy
            () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()