-----------------------------------------------------------------------------
-- |
-- 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)
import Data.Maybe (fromMaybe)
import Data.Char (toLower)
import Control.Monad (forever)
import Control.Applicative ((<|>))
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
"compose", String
"pc", String
"ctrl", String
"terminate"]


-- splits the layout string into the actual layouts
splitLayout :: String -> [String]
splitLayout :: String -> [String]
splitLayout String
s
  = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
flt
  ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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
$ (Char -> Bool) -> String -> [String]
split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'+') String
s
  where
  flt :: String -> Bool
flt String
"" = Bool
False
  flt String
s' = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s') [String]
noLaySymbols

-- split String at each Char
split :: (Char -> Bool) -> String -> [String]
split :: (Char -> Bool) -> String -> [String]
split Char -> Bool
p String
s = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
p String
s of
  (String
pref, Char
_:String
suf) -> String
pref String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Char -> Bool) -> String -> [String]
split Char -> Bool
p String
suf
  (String
pref, String
"") -> [String
pref]

-- 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 = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
s (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> KbdOpts -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
s KbdOpts
opts

-- returns the active layout
getKbdLay :: Display -> KbdOpts -> IO String
getKbdLay :: Display -> KbdOpts -> IO String
getKbdLay Display
dpy KbdOpts
opts = do
  lay <- String -> [String]
splitLayout (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> IO String
getLayoutStr Display
dpy
  grps <- map (map toLower . take 2) <$> getGrpNames dpy
  curLay <- getKbdLayout dpy
  return $ searchReplaceLayout opts
         $ fromMaybe "??"
         $ (lay !!? curLay) <|> (grps !!? curLay)

(!!?) :: [a] -> Int -> Maybe a
!!? :: forall a. [a] -> Int -> Maybe a
(!!?) []       Int
_ = Maybe a
forall a. Maybe a
Nothing
(!!?) (a
x : [a]
_)  Int
0 = a -> Maybe a
forall a. a -> Maybe a
Just a
x
(!!?) (a
_ : [a]
xs) Int
i = [a]
xs [a] -> Int -> Maybe a
forall a. [a] -> Int -> Maybe a
!!? (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

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

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

            -- initial set of layout
            cb =<< getKbdLay dpy opts

            -- enable listing for
            -- group changes
            _ <- xkbSelectEventDetails dpy xkbUseCoreKbd xkbStateNotify xkbAllStateComponentsMask xkbGroupStateMask
            -- layout/geometry changes
            _ <- xkbSelectEvents dpy  xkbUseCoreKbd xkbNewKeyboardNotifyMask xkbNewKeyboardNotifyMask

            allocaXEvent $ \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
                _ <- XEventPtr -> IO Event
getEvent XEventPtr
e
                cb =<< getKbdLay dpy opts

            closeDisplay dpy
            return ()