From 77df1ac30fa7af5948f7ff64f5fee9aed64552b3 Mon Sep 17 00:00:00 2001 From: jao Date: Sun, 25 Nov 2018 15:10:29 +0000 Subject: Back to app/src, since it seems they're the default convention for stack --- src/Xmobar/System/Kbd.hsc | 321 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 321 insertions(+) create mode 100644 src/Xmobar/System/Kbd.hsc (limited to 'src/Xmobar/System/Kbd.hsc') diff --git a/src/Xmobar/System/Kbd.hsc b/src/Xmobar/System/Kbd.hsc new file mode 100644 index 0000000..b9e1d57 --- /dev/null +++ b/src/Xmobar/System/Kbd.hsc @@ -0,0 +1,321 @@ +{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface, MultiParamTypeClasses, DeriveDataTypeable, FlexibleInstances, PatternGuards #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Kbd +-- Copyright : (c) Martin Perner +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Martin Perner +-- Stability : unstable +-- Portability : unportable +-- +-- A keyboard layout indicator for Xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.System.Kbd where + +import Foreign +import Foreign.C.Types +import Foreign.C.String + +import Graphics.X11.Xlib + +#include +#include +#include + +-- +-- 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)] + +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!" -- cgit v1.2.3