1{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface, MultiParamTypeClasses, DeriveDataTypeable, FlexibleInstances, PatternGuards #-} 2----------------------------------------------------------------------------- 3-- | 4-- Module : Plugins.Kbd 5-- Copyright : (c) Martin Perner 6-- License : BSD-style (see LICENSE) 7-- 8-- Maintainer : Martin Perner <martin@perner.cc> 9-- Stability : unstable 10-- Portability : unportable 11-- 12-- A keyboard layout indicator for Xmobar 13-- 14----------------------------------------------------------------------------- 15 16module Xmobar.System.Kbd where 17 18import Control.Monad ((<=<)) 19 20import Foreign 21import Foreign.C.Types 22import Foreign.C.String 23 24import Graphics.X11.Xlib 25import Graphics.X11.Xlib.Extras (none) 26 27#include <X11/XKBlib.h> 28#include <X11/extensions/XKB.h> 29#include <X11/extensions/XKBstr.h> 30 31-- 32-- Definition for XkbStaceRec and getKbdLayout taken from 33-- XMonad.Layout.XKBLayout 34-- 35data XkbStateRec = XkbStateRec { 36 group :: CUChar, 37 locked_group :: CUChar, 38 base_group :: CUShort, 39 latched_group :: CUShort, 40 mods :: CUChar, 41 base_mods :: CUChar, 42 latched_mods :: CUChar, 43 locked_mods :: CUChar, 44 compat_state :: CUChar, 45 grab_mods :: CUChar, 46 compat_grab_mods :: CUChar, 47 lookup_mods :: CUChar, 48 compat_lookup_mods :: CUChar, 49 ptr_buttons :: CUShort 50} 51 52instance Storable XkbStateRec where 53 sizeOf _ = (#size XkbStateRec) 54 alignment _ = alignment (undefined :: CUShort) 55 poke _ _ = undefined 56 peek ptr = do 57 r_group <- (#peek XkbStateRec, group) ptr 58 r_locked_group <- (#peek XkbStateRec, locked_group) ptr 59 r_base_group <- (#peek XkbStateRec, base_group) ptr 60 r_latched_group <- (#peek XkbStateRec, latched_group) ptr 61 r_mods <- (#peek XkbStateRec, mods) ptr 62 r_base_mods <- (#peek XkbStateRec, base_mods) ptr 63 r_latched_mods <- (#peek XkbStateRec, latched_mods) ptr 64 r_locked_mods <- (#peek XkbStateRec, locked_mods) ptr 65 r_compat_state <- (#peek XkbStateRec, compat_state) ptr 66 r_grab_mods <- (#peek XkbStateRec, grab_mods) ptr 67 r_compat_grab_mods <- (#peek XkbStateRec, compat_grab_mods) ptr 68 r_lookup_mods <- (#peek XkbStateRec, lookup_mods) ptr 69 r_compat_lookup_mods <- (#peek XkbStateRec, compat_lookup_mods) ptr 70 r_ptr_buttons <- (#peek XkbStateRec, ptr_buttons) ptr 71 return XkbStateRec { 72 group = r_group, 73 locked_group = r_locked_group, 74 base_group = r_base_group, 75 latched_group = r_latched_group, 76 mods = r_mods, 77 base_mods = r_base_mods, 78 latched_mods = r_latched_mods, 79 locked_mods = r_locked_mods, 80 compat_state = r_compat_state, 81 grab_mods = r_grab_mods, 82 compat_grab_mods = r_compat_grab_mods, 83 lookup_mods = r_lookup_mods, 84 compat_lookup_mods = r_compat_lookup_mods, 85 ptr_buttons = r_ptr_buttons 86 } 87 88foreign import ccall unsafe "X11/XKBlib.h XkbGetState" 89 xkbGetState :: Display -> CUInt -> Ptr XkbStateRec -> IO CInt 90 91 92getKbdLayout :: Display -> IO Int 93getKbdLayout d = alloca $ \stRecPtr -> do 94 xkbGetState d 0x100 stRecPtr 95 st <- peek stRecPtr 96 return $ fromIntegral (group st) 97 98data XkbKeyNameRec = XkbKeyNameRec { 99 name :: Ptr CChar -- array 100} 101 102-- 103-- the t_ before alias is just because of name collisions 104-- 105data XkbKeyAliasRec = XkbKeyAliasRec { 106 real :: Ptr CChar, -- array 107 t_alias :: Ptr CChar -- array 108} 109 110-- 111-- the t_ before geometry is just because of name collisions 112-- 113data XkbNamesRec = XkbNamesRec { 114 keycodes :: Atom, 115 t_geometry :: Atom, 116 symbols :: Atom, 117 types :: Atom, 118 compat :: Atom, 119 vmods :: [Atom], -- Atom vmods[XkbNumVirtualMods]; 120 indicators :: [Atom], -- Atom indicators[XkbNumIndicators]; 121 groups :: [Atom], -- Atom groups[XkbNumKbdGroups]; 122 keys :: Ptr XkbKeyNameRec, 123 key_aliases :: Ptr CChar, -- dont care XkbKeyAliasRec, 124 radio_groups :: Ptr Atom, 125 phys_symbols :: Atom, 126 num_keys :: CUChar, 127 num_key_aliases :: CUChar, 128 num_rg :: CUShort 129} 130 131-- 132-- the t_ before map, indicators and compat are just because of name collisions 133-- 134data XkbDescRec = XkbDescRec { 135 t_dpy :: Ptr CChar, -- struct _XDisplay* ; don't care 136 flags :: CUShort, 137 device_spec :: CUShort, 138 min_key_code :: KeyCode, 139 max_key_code :: KeyCode, 140 ctrls :: Ptr CChar, -- XkbControlsPtr ; dont' care 141 server :: Ptr CChar, -- XkbServerMapPtr ; dont' care 142 t_map :: Ptr CChar, --XkbClientMapPtr ; dont' care 143 t_indicators :: Ptr CChar, -- XkbIndicatorPtr ; dont' care 144 names :: Ptr XkbNamesRec, -- array 145 t_compat :: Ptr CChar, -- XkbCompatMap ; dont' care 146 geom :: Ptr CChar -- XkbGeometryPtr ; dont' care 147 148} 149 150instance Storable XkbKeyNameRec where 151 sizeOf _ = (#size XkbKeyNameRec) 152 alignment _ = alignment (undefined :: CUShort) 153 poke _ _ = undefined 154 peek ptr = do 155 r_name <- (#peek XkbKeyNameRec, name) ptr 156 157 return XkbKeyNameRec { 158 name = r_name 159 } 160 161instance Storable XkbKeyAliasRec where 162 sizeOf _ = (#size XkbKeyAliasRec) 163 alignment _ = alignment (undefined :: CUShort) 164 poke _ _ = undefined 165 peek ptr = do 166 r_real <- (#peek XkbKeyAliasRec, real) ptr 167 r_alias <- (#peek XkbKeyAliasRec, alias) ptr 168 169 return XkbKeyAliasRec { 170 real = r_real, 171 t_alias = r_alias 172 } 173 174instance Storable XkbNamesRec where 175 sizeOf _ = (#size XkbNamesRec) 176 alignment _ = alignment (undefined :: CUShort) 177 poke _ _ = undefined 178 peek ptr = do 179 r_keycodes <- (#peek XkbNamesRec, keycodes) ptr 180 r_geometry <- (#peek XkbNamesRec, geometry) ptr 181 r_symbols <- (#peek XkbNamesRec, symbols ) ptr 182 r_types <- (#peek XkbNamesRec, types ) ptr 183 r_compat <- (#peek XkbNamesRec, compat ) ptr 184 r_vmods <- peekArray (#const XkbNumVirtualMods) $ (#ptr XkbNamesRec, vmods ) ptr 185 r_indicators <- peekArray (#const XkbNumIndicators) $ (#ptr XkbNamesRec, indicators ) ptr 186 r_groups <- peekArray (#const XkbNumKbdGroups) $ (#ptr XkbNamesRec, groups ) ptr 187 r_keys <- (#peek XkbNamesRec, keys ) ptr 188 r_key_aliases <- (#peek XkbNamesRec, key_aliases ) ptr 189 r_radio_groups <- (#peek XkbNamesRec, radio_groups ) ptr 190 r_phys_symbols <- (#peek XkbNamesRec, phys_symbols ) ptr 191 r_num_keys <- (#peek XkbNamesRec,num_keys ) ptr 192 r_num_key_aliases <- (#peek XkbNamesRec, num_key_aliases ) ptr 193 r_num_rg <- (#peek XkbNamesRec, num_rg ) ptr 194 195 return XkbNamesRec { 196 keycodes = r_keycodes, 197 t_geometry = r_geometry, 198 symbols = r_symbols, 199 types = r_types, 200 compat = r_compat, 201 vmods = r_vmods, 202 indicators = r_indicators, 203 groups = r_groups, 204 keys = r_keys, 205 key_aliases = r_key_aliases, 206 radio_groups = r_radio_groups, 207 phys_symbols = r_phys_symbols, 208 num_keys = r_num_keys, 209 num_key_aliases = r_num_key_aliases, 210 num_rg = r_num_rg 211 } 212 213instance Storable XkbDescRec where 214 sizeOf _ = (#size XkbDescRec) 215 alignment _ = alignment (undefined :: CUShort) 216 poke _ _ = undefined 217 peek ptr = do 218 r_dpy <- (#peek XkbDescRec, dpy) ptr 219 r_flags <- (#peek XkbDescRec, flags) ptr 220 r_device_spec <- (#peek XkbDescRec, device_spec) ptr 221 r_min_key_code <- (#peek XkbDescRec, min_key_code) ptr 222 r_max_key_code <- (#peek XkbDescRec, max_key_code) ptr 223 r_ctrls <- (#peek XkbDescRec, ctrls) ptr 224 r_server <- (#peek XkbDescRec, server) ptr 225 r_map <- (#peek XkbDescRec, map) ptr 226 r_indicators <- (#peek XkbDescRec, indicators) ptr 227 r_names <- (#peek XkbDescRec, names) ptr 228 r_compat <- (#peek XkbDescRec, compat) ptr 229 r_geom <- (#peek XkbDescRec, geom) ptr 230 231 return XkbDescRec { 232 t_dpy = r_dpy, 233 flags = r_flags, 234 device_spec = r_device_spec, 235 min_key_code = r_min_key_code, 236 max_key_code = r_max_key_code, 237 ctrls = r_ctrls, 238 server = r_server, 239 t_map = r_map, 240 t_indicators = r_indicators, 241 names = r_names, 242 t_compat = r_compat, 243 geom = r_geom 244 } 245 246-- 247-- C bindings 248-- 249 250foreign import ccall unsafe "X11/XKBlib.h XkbAllocKeyboard" 251 xkbAllocKeyboard :: IO (Ptr XkbDescRec) 252 253foreign import ccall unsafe "X11/XKBlib.h XkbGetNames" 254 xkbGetNames :: Display -> CUInt -> (Ptr XkbDescRec) -> IO Status 255 256foreign import ccall unsafe "X11/XKBlib.h XGetAtomName" 257 xGetAtomName :: Display -> Atom -> IO CString 258 259foreign import ccall unsafe "X11/XKBlib.h XkbFreeNames" 260 xkbFreeNames :: (Ptr XkbDescRec) -> CUInt -> CInt -> IO () 261 262foreign import ccall unsafe "X11/XKBlib.h XkbFreeKeyboard" 263 xkbFreeKeyboard :: (Ptr XkbDescRec) -> CUInt -> CInt -> IO () 264 265foreign import ccall unsafe "X11/XKBlib.h XkbSelectEventDetails" 266 xkbSelectEventDetails :: Display -> CUInt -> CUInt -> CULong -> CULong -> IO CUInt 267 268foreign import ccall unsafe "X11/XKBlib.h XkbSelectEvents" 269 xkbSelectEvents :: Display -> CUInt -> CUInt -> CUInt -> IO CUInt 270 271 272xkbUseCoreKbd :: CUInt 273xkbUseCoreKbd = #const XkbUseCoreKbd 274 275xkbStateNotify :: CUInt 276xkbStateNotify = #const XkbStateNotify 277 278xkbIndicatorStateNotify :: CUInt 279xkbIndicatorStateNotify = #const XkbIndicatorStateNotify 280 281xkbMapNotify :: CUInt 282xkbMapNotify = #const XkbMapNotify 283 284xkbMapNotifyMask :: CUInt 285xkbMapNotifyMask = #const XkbMapNotifyMask 286 287xkbNewKeyboardNotifyMask :: CUInt 288xkbNewKeyboardNotifyMask = #const XkbNewKeyboardNotifyMask 289 290xkbAllStateComponentsMask :: CULong 291xkbAllStateComponentsMask = #const XkbAllStateComponentsMask 292 293xkbGroupStateMask :: CULong 294xkbGroupStateMask = #const XkbGroupStateMask 295 296xkbSymbolsNameMask :: CUInt 297xkbSymbolsNameMask = #const XkbSymbolsNameMask 298 299xkbGroupNamesMask :: CUInt 300xkbGroupNamesMask = #const XkbGroupNamesMask 301 302type KbdOpts = [(String, String)] 303 304getLayoutStr :: Display -> IO String 305getLayoutStr dpy = do 306 kbdDescPtr <- xkbAllocKeyboard 307 status <- xkbGetNames dpy xkbSymbolsNameMask kbdDescPtr 308 str <- getLayoutStr' status dpy kbdDescPtr 309 xkbFreeNames kbdDescPtr xkbSymbolsNameMask 1 310 xkbFreeKeyboard kbdDescPtr 0 1 311 return str 312 313getLayoutStr' :: Status -> Display -> (Ptr XkbDescRec) -> IO String 314getLayoutStr' st dpy kbdDescPtr = 315 if st == 0 then -- Success 316 do 317 kbdDesc <- peek kbdDescPtr 318 nameArray <- peek (names kbdDesc) 319 atom <- xGetAtomName dpy (symbols nameArray) 320 str <- peekCString atom 321 return str 322 else -- Behaviour on error 323 do 324 return "Error while requesting layout!" 325 326getGrpNames :: Display -> IO [String] 327getGrpNames dpy = do 328 kbdDescPtr <- xkbAllocKeyboard 329 status <- xkbGetNames dpy xkbGroupNamesMask kbdDescPtr 330 str <- getGrpNames' status dpy kbdDescPtr 331 xkbFreeNames kbdDescPtr xkbGroupNamesMask 1 332 xkbFreeKeyboard kbdDescPtr 0 1 333 return str 334 335getGrpNames' :: Status -> Display -> (Ptr XkbDescRec) -> IO [String] 336getGrpNames' st dpy kbdDescPtr = 337 if st == 0 then -- Success 338 do 339 kbdDesc <- peek kbdDescPtr 340 nameArray <- peek (names kbdDesc) 341 let grpsArr = groups nameArray 342 let grps = takeWhile (/=none) grpsArr 343 mapM (peekCString <=< xGetAtomName dpy) grps 344 else return ["Error while requesting layout!"] 345