module XMonad.Actions.KeyRemap (
setKeyRemap,
buildKeyRemapBindings,
setDefaultKeyRemap,
KeymapTable (KeymapTable),
emptyKeyRemap,
dvorakProgrammerKeyRemap
) where
import XMonad
import XMonad.Prelude
import XMonad.Util.Paste
import qualified XMonad.Util.ExtensibleState as XS
newtype KeymapTable = KeymapTable [((KeyMask, KeySym), (KeyMask, KeySym))] deriving (Int -> KeymapTable -> ShowS
[KeymapTable] -> ShowS
KeymapTable -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeymapTable] -> ShowS
$cshowList :: [KeymapTable] -> ShowS
show :: KeymapTable -> String
$cshow :: KeymapTable -> String
showsPrec :: Int -> KeymapTable -> ShowS
$cshowsPrec :: Int -> KeymapTable -> ShowS
Show)
instance ExtensionClass KeymapTable where
initialValue :: KeymapTable
initialValue = [((KeyMask, KeySym), (KeyMask, KeySym))] -> KeymapTable
KeymapTable []
doKeyRemap :: KeyMask -> KeySym -> X()
doKeyRemap :: KeyMask -> KeySym -> X ()
doKeyRemap KeyMask
mask KeySym
sym = do
KeymapTable
table <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
let (KeyMask
insertMask, KeySym
insertSym) = KeymapTable -> KeyMask -> KeySym -> (KeyMask, KeySym)
extractKeyMapping KeymapTable
table KeyMask
mask KeySym
sym
KeyMask -> KeySym -> X ()
sendKey KeyMask
insertMask KeySym
insertSym
setKeyRemap :: KeymapTable -> X()
setKeyRemap :: KeymapTable -> X ()
setKeyRemap KeymapTable
table = do
let KeymapTable [((KeyMask, KeySym), (KeyMask, KeySym))]
newtable = KeymapTable
table
KeymapTable [((KeyMask, KeySym), (KeyMask, KeySym))]
oldtable <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
XConf { display :: XConf -> Display
display = Display
dpy, theRoot :: XConf -> KeySym
theRoot = KeySym
rootw } <- forall r (m :: * -> *). MonadReader r m => m r
ask
let grab :: KeyCode -> KeyMask -> m ()
grab KeyCode
kc KeyMask
m = forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display
-> KeyCode
-> KeyMask
-> KeySym
-> Bool
-> GrabMode
-> GrabMode
-> IO ()
grabKey Display
dpy KeyCode
kc KeyMask
m KeySym
rootw Bool
True GrabMode
grabModeAsync GrabMode
grabModeAsync
let ungrab :: KeyCode -> KeyMask -> m ()
ungrab KeyCode
kc KeyMask
m = forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> KeyCode -> KeyMask -> KeySym -> IO ()
ungrabKey Display
dpy KeyCode
kc KeyMask
m KeySym
rootw
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [((KeyMask, KeySym), (KeyMask, KeySym))]
oldtable forall a b. (a -> b) -> a -> b
$ \((KeyMask
mask, KeySym
sym), (KeyMask, KeySym)
_) -> do
KeyCode
kc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> KeySym -> IO KeyCode
keysymToKeycode Display
dpy KeySym
sym
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeyCode
kc forall a. Eq a => a -> a -> Bool
/= KeyCode
0) forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *}. MonadIO m => KeyCode -> KeyMask -> m ()
ungrab KeyCode
kc KeyMask
mask
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [((KeyMask, KeySym), (KeyMask, KeySym))]
newtable forall a b. (a -> b) -> a -> b
$ \((KeyMask
mask, KeySym
sym), (KeyMask, KeySym)
_) -> do
KeyCode
kc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> KeySym -> IO KeyCode
keysymToKeycode Display
dpy KeySym
sym
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeyCode
kc forall a. Eq a => a -> a -> Bool
/= KeyCode
0) forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *}. MonadIO m => KeyCode -> KeyMask -> m ()
grab KeyCode
kc KeyMask
mask
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put KeymapTable
table
setDefaultKeyRemap :: KeymapTable -> [KeymapTable] -> X()
setDefaultKeyRemap :: KeymapTable -> [KeymapTable] -> X ()
setDefaultKeyRemap KeymapTable
dflt [KeymapTable]
keyremaps = do
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put ([((KeyMask, KeySym), (KeyMask, KeySym))] -> KeymapTable
KeymapTable [((KeyMask, KeySym), (KeyMask, KeySym))]
mappings)
KeymapTable -> X ()
setKeyRemap KeymapTable
dflt
where
mappings :: [((KeyMask, KeySym), (KeyMask, KeySym))]
mappings = forall a. Eq a => [a] -> [a]
nub ([KeymapTable]
keyremaps forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(KeymapTable [((KeyMask, KeySym), (KeyMask, KeySym))]
table) -> [((KeyMask, KeySym), (KeyMask, KeySym))]
table)
extractKeyMapping :: KeymapTable -> KeyMask -> KeySym -> (KeyMask, KeySym)
(KeymapTable [((KeyMask, KeySym), (KeyMask, KeySym))]
table) KeyMask
mask KeySym
sym =
forall {a}. [(a, (KeyMask, KeySym))] -> (KeyMask, KeySym)
insertKey [((KeyMask, KeySym), (KeyMask, KeySym))]
filtered
where filtered :: [((KeyMask, KeySym), (KeyMask, KeySym))]
filtered = forall a. (a -> Bool) -> [a] -> [a]
filter (\((KeyMask
m, KeySym
s),(KeyMask, KeySym)
_) -> KeyMask
m forall a. Eq a => a -> a -> Bool
== KeyMask
mask Bool -> Bool -> Bool
&& KeySym
s forall a. Eq a => a -> a -> Bool
== KeySym
sym) [((KeyMask, KeySym), (KeyMask, KeySym))]
table
insertKey :: [(a, (KeyMask, KeySym))] -> (KeyMask, KeySym)
insertKey [] = (KeyMask
mask, KeySym
sym)
insertKey ((a
_, (KeyMask, KeySym)
to):[(a, (KeyMask, KeySym))]
_) = (KeyMask, KeySym)
to
buildKeyRemapBindings :: [KeymapTable] -> [((KeyMask, KeySym), X ())]
buildKeyRemapBindings :: [KeymapTable] -> [((KeyMask, KeySym), X ())]
buildKeyRemapBindings [KeymapTable]
keyremaps =
[((KeyMask
mask, KeySym
sym), KeyMask -> KeySym -> X ()
doKeyRemap KeyMask
mask KeySym
sym) | (KeyMask
mask, KeySym
sym) <- [(KeyMask, KeySym)]
bindings]
where mappings :: [((KeyMask, KeySym), (KeyMask, KeySym))]
mappings = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(KeymapTable [((KeyMask, KeySym), (KeyMask, KeySym))]
table) -> [((KeyMask, KeySym), (KeyMask, KeySym))]
table) [KeymapTable]
keyremaps
bindings :: [(KeyMask, KeySym)]
bindings = forall a. Eq a => [a] -> [a]
nub (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [((KeyMask, KeySym), (KeyMask, KeySym))]
mappings)
emptyKeyRemap :: KeymapTable
emptyKeyRemap :: KeymapTable
emptyKeyRemap = [((KeyMask, KeySym), (KeyMask, KeySym))] -> KeymapTable
KeymapTable []
dvorakProgrammerKeyRemap :: KeymapTable
dvorakProgrammerKeyRemap :: KeymapTable
dvorakProgrammerKeyRemap =
[((KeyMask, KeySym), (KeyMask, KeySym))] -> KeymapTable
KeymapTable [((Char -> KeyMask
charToMask Char
maskFrom, KeySym
from), (Char -> KeyMask
charToMask Char
maskTo, KeySym
to)) |
(Char
maskFrom, KeySym
from, Char
maskTo, KeySym
to) <- forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 String
layoutUsShift [KeySym]
layoutUsKey String
layoutDvorakShift [KeySym]
layoutDvorakKey]
where
layoutUs :: [KeySym]
layoutUs = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum) String
"`1234567890-=qwertyuiop[]\\asdfghjkl;'zxcvbnm,./~!@#$%^&*()_+QWERTYUIOP{}|ASDFGHJKL:\"ZXCVBNM<>?" :: [KeySym]
layoutUsKey :: [KeySym]
layoutUsKey = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum) String
"`1234567890-=qwertyuiop[]\\asdfghjkl;'zxcvbnm,./`1234567890-=qwertyuiop[]\\asdfghjkl;'zxcvbnm,./" :: [KeySym]
layoutUsShift :: String
layoutUsShift = String
"0000000000000000000000000000000000000000000000011111111111111111111111111111111111111111111111"
layoutDvorak :: [KeySym]
layoutDvorak = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum) String
"$&[{}(=*)+]!#;,.pyfgcrl/@\\aoeuidhtns-'qjkxbmwvz~%7531902468`:<>PYFGCRL?^|AOEUIDHTNS_\"QJKXBMWVZ" :: [KeySym]
layoutDvorakShift :: String
layoutDvorakShift = forall a b. (a -> b) -> [a] -> [b]
map KeySym -> Char
getShift [KeySym]
layoutDvorak
layoutDvorakKey :: [KeySym]
layoutDvorakKey = forall a b. (a -> b) -> [a] -> [b]
map KeySym -> KeySym
getKey [KeySym]
layoutDvorak
getKey :: KeySym -> KeySym
getKey KeySym
char = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ ([KeySym]
layoutUsKey forall a. [a] -> Int -> Maybe a
!?) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Eq a => a -> [a] -> Maybe Int
elemIndex KeySym
char [KeySym]
layoutUs
getShift :: KeySym -> Char
getShift KeySym
char = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ (String
layoutUsShift forall a. [a] -> Int -> Maybe a
!?) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Eq a => a -> [a] -> Maybe Int
elemIndex KeySym
char [KeySym]
layoutUs
charToMask :: Char -> KeyMask
charToMask Char
char = if [Char
char] forall a. Eq a => a -> a -> Bool
== String
"0" then KeyMask
0 else KeyMask
shiftMask