1 files changed, 404 insertions, 0 deletions
diff --git a/src/lib/Xmobar/Plugins/Kbd.hsc b/src/lib/Xmobar/Plugins/Kbd.hsc
new file mode 100644
index 0000000..372386e
--- /dev/null
+++ b/src/lib/Xmobar/Plugins/Kbd.hsc
@@ -0,0 +1,404 @@
+{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface, MultiParamTypeClasses, DeriveDataTypeable, FlexibleInstances, PatternGuards #-}
+-----------------------------------------------------------------------------
+-- |
+-- 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 where
+
+import Graphics.X11.Xlib
+import Graphics.X11.Xlib.Extras
+import Foreign
+import Foreign.C.Types
+import Foreign.C.String
+import Xmobar.Plugins
+import Control.Monad (forever)
+import Xmobar.XUtil (nextEvent')
+import Data.List (isPrefixOf, findIndex)
+import Data.Maybe (fromJust)
+
+#include <X11/XKBlib.h>
+#include <X11/extensions/XKB.h>
+#include <X11/extensions/XKBstr.h>
+
+--
+-- Definition for XkbStaceRec and getKbdLayout taken from
+-- XMonad.Layout.XKBLayout
+--
+data XkbStateRec = XkbStateRec {
+    group :: CUChar,
+    locked_group :: CUChar,
+    base_group :: CUShort,
+    latched_group :: CUShort,
+    mods :: CUChar,
+    base_mods :: CUChar,
+    latched_mods :: CUChar,
+    locked_mods :: CUChar,
+    compat_state :: CUChar,
+    grab_mods :: CUChar,
+    compat_grab_mods :: CUChar,
+    lookup_mods :: CUChar,
+    compat_lookup_mods :: CUChar,
+    ptr_buttons :: CUShort
+}
+
+instance Storable XkbStateRec where
+    sizeOf _ = (#size XkbStateRec)
+    alignment _ = alignment (undefined :: CUShort)
+    poke _ _ = undefined
+    peek ptr = do
+        r_group <- (#peek XkbStateRec, group) ptr
+        r_locked_group <- (#peek XkbStateRec, locked_group) ptr
+        r_base_group <- (#peek XkbStateRec, base_group) ptr
+        r_latched_group <- (#peek XkbStateRec, latched_group) ptr
+        r_mods <- (#peek XkbStateRec, mods) ptr
+        r_base_mods <- (#peek XkbStateRec, base_mods) ptr
+        r_latched_mods <- (#peek XkbStateRec, latched_mods) ptr
+        r_locked_mods <- (#peek XkbStateRec, locked_mods) ptr
+        r_compat_state <- (#peek XkbStateRec, compat_state) ptr
+        r_grab_mods <- (#peek XkbStateRec, grab_mods) ptr
+        r_compat_grab_mods <- (#peek XkbStateRec, compat_grab_mods) ptr
+        r_lookup_mods <- (#peek XkbStateRec, lookup_mods) ptr
+        r_compat_lookup_mods <- (#peek XkbStateRec, compat_lookup_mods) ptr
+        r_ptr_buttons <- (#peek XkbStateRec, ptr_buttons) ptr
+        return XkbStateRec {
+            group = r_group,
+            locked_group = r_locked_group,
+            base_group = r_base_group,
+            latched_group = r_latched_group,
+            mods = r_mods,
+            base_mods = r_base_mods,
+            latched_mods = r_latched_mods,
+            locked_mods = r_locked_mods,
+            compat_state = r_compat_state,
+            grab_mods = r_grab_mods,
+            compat_grab_mods = r_compat_grab_mods,
+            lookup_mods = r_lookup_mods,
+            compat_lookup_mods = r_compat_lookup_mods,
+            ptr_buttons = r_ptr_buttons
+        }
+
+foreign import ccall unsafe "X11/XKBlib.h XkbGetState"
+    xkbGetState :: Display -> CUInt -> Ptr XkbStateRec -> IO CInt
+
+
+getKbdLayout :: Display -> IO Int
+getKbdLayout d = alloca $ \stRecPtr -> do
+    xkbGetState d 0x100 stRecPtr
+    st <- peek stRecPtr
+    return $ fromIntegral (group st)
+
+--
+--
+--
+
+data XkbKeyNameRec = XkbKeyNameRec {
+    name :: Ptr CChar -- array
+}
+
+--
+-- the t_ before alias is just because of name collisions
+--
+data XkbKeyAliasRec = XkbKeyAliasRec {
+    real  :: Ptr CChar, -- array
+    t_alias :: Ptr CChar  -- array
+}
+
+--
+-- the t_ before geometry is just because of name collisions
+--
+data XkbNamesRec = XkbNamesRec {
+    keycodes :: Atom,
+    t_geometry :: Atom,
+    symbols :: Atom,
+    types :: Atom,
+    compat :: Atom,
+    vmods :: Ptr Atom,
+    indicators :: Ptr Atom, -- array
+    groups :: Ptr Atom, -- array
+    keys :: Ptr XkbKeyNameRec,
+    key_aliases :: Ptr CChar, -- dont care XkbKeyAliasRec,
+    radio_groups :: Ptr Atom,
+    phys_symbols :: Atom,
+    num_keys :: CUChar,
+    num_key_aliases :: CUChar,
+    num_rg :: CUShort
+}
+
+--
+-- the t_ before map, indicators and compat are just because of name collisions
+--
+data XkbDescRec = XkbDescRec {
+    t_dpy :: Ptr CChar, -- struct _XDisplay* ; don't care
+    flags :: CUShort,
+    device_spec :: CUShort,
+    min_key_code :: KeyCode,
+    max_key_code :: KeyCode,
+    ctrls :: Ptr CChar, -- XkbControlsPtr ;  dont' care
+    server :: Ptr CChar, -- XkbServerMapPtr ;  dont' care
+    t_map :: Ptr CChar, --XkbClientMapPtr ;  dont' care
+    t_indicators :: Ptr CChar, -- XkbIndicatorPtr ;  dont' care
+    names :: Ptr XkbNamesRec, -- array
+    t_compat :: Ptr CChar, -- XkbCompatMap ;  dont' care
+    geom :: Ptr CChar -- XkbGeometryPtr ;  dont' care
+
+}
+
+instance Storable XkbKeyNameRec where
+    sizeOf _ = (#size XkbKeyNameRec)
+    alignment _ = alignment (undefined :: CUShort)
+    poke _ _ = undefined
+    peek ptr = do
+        r_name <- (#peek XkbKeyNameRec, name) ptr
+
+        return XkbKeyNameRec {
+            name = r_name
+        }
+
+instance Storable XkbKeyAliasRec where
+    sizeOf _ = (#size XkbKeyAliasRec)
+    alignment _ = alignment (undefined :: CUShort)
+    poke _ _ = undefined
+    peek ptr = do
+        r_real <- (#peek XkbKeyAliasRec, real) ptr
+        r_alias <- (#peek XkbKeyAliasRec, alias) ptr
+
+        return XkbKeyAliasRec {
+            real = r_real,
+            t_alias = r_alias
+        }
+
+instance Storable XkbNamesRec where
+    sizeOf _ = (#size XkbNamesRec)
+    alignment _ = alignment (undefined :: CUShort)
+    poke _ _ = undefined
+    peek ptr = do
+        r_keycodes <- (#peek XkbNamesRec, keycodes) ptr
+        r_geometry <- (#peek XkbNamesRec, geometry) ptr
+        r_symbols <- (#peek XkbNamesRec, symbols ) ptr
+        r_types <- (#peek XkbNamesRec, types ) ptr
+        r_compat <- (#peek XkbNamesRec, compat ) ptr
+        r_vmods <- (#peek XkbNamesRec,  vmods ) ptr
+        r_indicators <- (#peek XkbNamesRec, indicators ) ptr
+        r_groups <- (#peek XkbNamesRec, groups ) ptr
+        r_keys <- (#peek XkbNamesRec, keys ) ptr
+        r_key_aliases <- (#peek XkbNamesRec, key_aliases  ) ptr
+        r_radio_groups <- (#peek XkbNamesRec, radio_groups  ) ptr
+        r_phys_symbols <- (#peek XkbNamesRec, phys_symbols ) ptr
+        r_num_keys <- (#peek XkbNamesRec,num_keys  ) ptr
+        r_num_key_aliases <- (#peek XkbNamesRec, num_key_aliases  ) ptr
+        r_num_rg <- (#peek XkbNamesRec, num_rg ) ptr
+
+        return XkbNamesRec {
+            keycodes = r_keycodes,
+            t_geometry = r_geometry,
+            symbols = r_symbols,
+            types = r_types,
+            compat = r_compat,
+            vmods = r_vmods,
+            indicators = r_indicators,
+            groups = r_groups,
+            keys = r_keys,
+            key_aliases = r_key_aliases,
+            radio_groups = r_radio_groups,
+            phys_symbols = r_phys_symbols,
+            num_keys = r_num_keys,
+            num_key_aliases = r_num_key_aliases,
+            num_rg = r_num_rg
+       }
+
+instance Storable XkbDescRec where
+    sizeOf _ = (#size XkbDescRec)
+    alignment _ = alignment (undefined :: CUShort)
+    poke _ _ = undefined
+    peek ptr = do
+        r_dpy <- (#peek XkbDescRec, dpy) ptr
+        r_flags <- (#peek XkbDescRec, flags) ptr
+        r_device_spec <- (#peek XkbDescRec, device_spec) ptr
+        r_min_key_code <- (#peek XkbDescRec, min_key_code) ptr
+        r_max_key_code <- (#peek XkbDescRec, max_key_code) ptr
+        r_ctrls <- (#peek XkbDescRec, ctrls) ptr
+        r_server <- (#peek XkbDescRec, server) ptr
+        r_map <- (#peek XkbDescRec, map) ptr
+        r_indicators <- (#peek XkbDescRec, indicators) ptr
+        r_names <- (#peek XkbDescRec, names) ptr
+        r_compat <- (#peek XkbDescRec, compat) ptr
+        r_geom <- (#peek XkbDescRec, geom) ptr
+
+        return XkbDescRec {
+            t_dpy = r_dpy,
+            flags = r_flags,
+            device_spec = r_device_spec,
+            min_key_code = r_min_key_code,
+            max_key_code = r_max_key_code,
+            ctrls = r_ctrls,
+            server = r_server,
+            t_map = r_map,
+            t_indicators = r_indicators,
+            names = r_names,
+            t_compat = r_compat,
+            geom = r_geom
+        }
+
+--
+-- C bindings
+--
+
+foreign import ccall unsafe "X11/XKBlib.h XkbAllocKeyboard"
+    xkbAllocKeyboard :: IO (Ptr XkbDescRec)
+
+foreign import ccall unsafe "X11/XKBlib.h XkbGetNames"
+    xkbGetNames :: Display -> CUInt -> (Ptr XkbDescRec)  -> IO Status
+
+foreign import ccall unsafe "X11/XKBlib.h XGetAtomName"
+    xGetAtomName :: Display -> Atom -> IO CString
+
+foreign import ccall unsafe "X11/XKBlib.h XkbFreeNames"
+    xkbFreeNames :: (Ptr XkbDescRec) -> CUInt -> CInt -> IO ()
+
+foreign import ccall unsafe "X11/XKBlib.h XkbFreeKeyboard"
+    xkbFreeKeyboard :: (Ptr XkbDescRec) -> CUInt -> CInt -> IO ()
+
+foreign import ccall unsafe "X11/XKBlib.h XkbSelectEventDetails"
+    xkbSelectEventDetails :: Display -> CUInt -> CUInt -> CULong -> CULong -> IO CUInt
+
+foreign import ccall unsafe "X11/XKBlib.h XkbSelectEvents"
+    xkbSelectEvents :: Display -> CUInt -> CUInt -> CUInt -> IO CUInt
+
+
+xkbUseCoreKbd :: CUInt
+xkbUseCoreKbd = #const XkbUseCoreKbd
+
+xkbStateNotify :: CUInt
+xkbStateNotify = #const XkbStateNotify
+
+xkbIndicatorStateNotify :: CUInt
+xkbIndicatorStateNotify = #const XkbIndicatorStateNotify
+
+xkbMapNotify :: CUInt
+xkbMapNotify = #const XkbMapNotify
+
+xkbMapNotifyMask :: CUInt
+xkbMapNotifyMask = #const XkbMapNotifyMask
+
+xkbNewKeyboardNotifyMask :: CUInt
+xkbNewKeyboardNotifyMask  = #const XkbNewKeyboardNotifyMask
+
+xkbAllStateComponentsMask :: CULong
+xkbAllStateComponentsMask = #const XkbAllStateComponentsMask
+
+xkbGroupStateMask :: CULong
+xkbGroupStateMask = #const XkbGroupStateMask
+
+xkbSymbolsNameMask :: CUInt
+xkbSymbolsNameMask = #const XkbSymbolsNameMask
+
+xkbGroupNamesMask :: CUInt
+xkbGroupNamesMask = #const XkbGroupNamesMask
+
+type KbdOpts = [(String, String)]
+
+-- gets the layout string
+getLayoutStr :: Display -> IO String
+getLayoutStr dpy =  do
+        kbdDescPtr <- xkbAllocKeyboard
+        status <- xkbGetNames dpy xkbSymbolsNameMask kbdDescPtr
+        str <- getLayoutStr' status dpy kbdDescPtr
+        xkbFreeNames kbdDescPtr xkbGroupNamesMask 1
+        xkbFreeKeyboard kbdDescPtr 0 1
+        return str
+
+getLayoutStr' :: Status -> Display -> (Ptr XkbDescRec) -> IO String
+getLayoutStr' st dpy kbdDescPtr =
+        if st == 0 then -- Success
+            do
+            kbdDesc <- peek kbdDescPtr
+            nameArray <- peek (names kbdDesc)
+            atom <- xGetAtomName dpy (symbols nameArray)
+            str <- peekCString atom
+            return str
+        else -- Behaviour on error
+            do
+                return "Error while requesting layout!"
+
+
+-- 'Bad' prefixes of layouts
+noLaySymbols :: [String]
+noLaySymbols = ["group", "inet", "ctr", "pc", "ctrl"]
+
+
+-- splits the layout string into the actual layouts
+splitLayout :: String -> [String]
+splitLayout s = splitLayout' noLaySymbols $ split s '+'
+
+splitLayout' :: [String] ->  [String] -> [String]
+--                  end of recursion, remove empty strings
+splitLayout' [] s = map (takeWhile (\x -> x /= ':')) $ filter (\x -> length x > 0) s
+--                    remove current string if it has a 'bad' prefix
+splitLayout' bad s  = splitLayout' (tail bad) [x | x <- s, not $ isPrefixOf (head bad) x]
+
+-- split String at each Char
+split :: String -> Char -> [String]
+split [] _ = [""]
+split (c:cs) delim
+    | c == delim = "" : rest
+    | otherwise = (c : head rest) : tail rest
+        where
+            rest = split cs 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 opts s = let c = findIndex (\x -> fst x == s) opts in
+    case c of
+        Nothing -> s
+        x -> let i = (fromJust x) in
+            snd $ opts!!i
+
+-- returns the active layout
+getKbdLay :: Display -> KbdOpts -> IO String
+getKbdLay dpy opts = do
+        lay <- getLayoutStr dpy
+        curLay <- getKbdLayout dpy
+        return $ searchReplaceLayout opts $ (splitLayout lay)!!(curLay)
+
+
+
+data Kbd = Kbd [(String, String)]
+        deriving (Read, Show)
+
+instance Exec Kbd where
+        alias (Kbd _) = "kbd"
+        start (Kbd opts) cb = do
+
+            dpy <- openDisplay ""
+
+            -- 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 $ \e -> forever $ do
+                nextEvent' dpy e
+                _ <- getEvent e
+                cb =<< getKbdLay dpy opts
+
+            closeDisplay dpy
+            return ()
+
+-- vim:ft=haskell:ts=4:shiftwidth=4:softtabstop=4:expandtab:foldlevel=20: