summaryrefslogtreecommitdiffhomepage
path: root/src/Plugins/Kbd.hsc
diff options
context:
space:
mode:
Diffstat (limited to 'src/Plugins/Kbd.hsc')
-rw-r--r--src/Plugins/Kbd.hsc415
1 files changed, 415 insertions, 0 deletions
diff --git a/src/Plugins/Kbd.hsc b/src/Plugins/Kbd.hsc
new file mode 100644
index 0000000..8e87af6
--- /dev/null
+++ b/src/Plugins/Kbd.hsc
@@ -0,0 +1,415 @@
+{-# LANGUAGE ScopedTypeVariables, ForeignFunctionInterface, MultiParamTypeClasses, DeriveDataTypeable, FlexibleInstances, PatternGuards #-}
+
+module Plugins.Kbd where
+
+import Graphics.X11.Xlib
+import Graphics.X11.Xlib.Extras
+import Foreign
+import Foreign.C.Types (CUInt,CULong,CInt,CUShort,CChar,CUChar)
+import Foreign.C.String
+import Plugins
+import Control.Monad (forever)
+import XUtil (nextEvent')
+import Data.List (isPrefixOf, elemIndex)
+import Data.Maybe (fromJust)
+import System.Console.GetOpt
+
+#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
+
+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
+
+data KbdOpts = KbdOpts
+ { errorString :: String
+ , src :: [String]
+ , rpl :: [String]
+ }
+
+defaultOpts :: KbdOpts
+defaultOpts = KbdOpts
+ { errorString = "Err"
+ , src = []
+ , rpl = []
+ }
+
+options :: [OptDescr (KbdOpts -> KbdOpts)]
+options =
+ [ Option ['e'] ["error"] (ReqArg (\x o -> o { errorString = x }) "") ""
+ , Option ['s'] ["src"] (ReqArg (\x o -> o { src = [x] ++ src o }) "") ""
+ , Option ['r'] ["rpl"] (ReqArg (\x o -> o { rpl = [x] ++ rpl o }) "") ""
+ ]
+
+parseOpts :: [String] -> IO KbdOpts
+parseOpts argv =
+ case getOpt Permute options argv of
+ (o, _, []) -> return $ foldr id defaultOpts o
+ (_, _, errs) -> ioError . userError $ concat errs
+
+
+-- gets the layout string
+getLayoutStr :: KbdOpts -> Display -> IO String
+getLayoutStr opts dpy = do
+ kbdDescPtr <- xkbAllocKeyboard
+ status <- xkbGetNames dpy xkbSymbolsNameMask kbdDescPtr
+ str <- getLayoutStr' opts status dpy kbdDescPtr
+ xkbFreeNames kbdDescPtr xkbGroupNamesMask 1
+ xkbFreeKeyboard kbdDescPtr 0 1
+ return str
+
+getLayoutStr' :: KbdOpts -> Status -> Display -> (Ptr XkbDescRec) -> IO String
+getLayoutStr' opts 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 (errorString opts)
+
+
+-- '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 = elemIndex s (src opts) in
+ case c of
+ Nothing -> s
+ x -> let i = (fromJust x) in
+ if i >= length (rpl opts) then
+ s
+ else
+ (rpl opts)!!i
+
+-- returns the active layout
+getKbdLay :: Display -> KbdOpts -> IO String
+getKbdLay dpy opts = do
+ lay <- getLayoutStr opts dpy
+ curLay <- getKbdLayout dpy
+ return $ searchReplaceLayout opts $ (splitLayout lay)!!(curLay)
+
+
+
+data Kbd = Kbd [String]
+ deriving (Read, Show)
+
+instance Exec Kbd where
+ alias (Kbd _) = "kbd"
+ start (Kbd s) cb = do
+
+ dpy <- openDisplay ""
+ -- parse parameters
+ opts <- parseOpts s
+
+ -- 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:
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-13 22:23:23 +0000