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