path: root/src/Plugins/Kbd.hsc

{-# 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 Plugins.Kbd where

import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras
import Foreign
import Foreign.C.Types
import Foreign.C.String
import Plugins
import Control.Monad (forever)
import 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)
    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)
    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)
    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)
    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)
    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: