-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.KeyRemap
-- Description :  Remap Keybinding on the fly.
-- Copyright   :  (c) Christian Dietrich
-- License     :  BSD-style (as xmonad)
--
-- Maintainer  :  stettberger@dokucde.de
-- Stability   :  unstable
-- Portability :  unportable
--
-- Remap Keybinding on the fly, e.g having Dvorak char, but everything with Control/Shift
-- is left us Layout
--
-----------------------------------------------------------------------------

module XMonad.Actions.KeyRemap (
  -- * Usage
  -- $usage
  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
(Int -> KeymapTable -> ShowS)
-> (KeymapTable -> String)
-> ([KeymapTable] -> ShowS)
-> Show KeymapTable
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 []

-- $usage
-- Provides the possibility to remap parts of the keymap to generate different keys
--
-- * E.g You want to type Programmers Dvorak, but your keybindings should be the normal us layout
--   after all
--
-- First, you must add all possible keybindings for all layout you want to use:
--
-- >   keys = myKeys ++ buildKeyRemapBindings [dvorakProgrammerKeyRemap,emptyKeyRemap]
--
-- Then you must add setDefaultKeyRemap to your startup hook (e.g. you want to set the
-- empty keyremap (no remapping is done) as default after startup):
--
-- > myStartupHook :: X()
-- > myStartupHook = do
-- >   setWMName "LG3D"
-- >   setDefaultKeyRemap emptyKeyRemap [dvorakProgrammerKeyRemap, emptyKeyRemap]
--
-- Then you add keybindings for changing keyboard layouts;
--
-- > , ((0                    , xK_F1    ), setKeyRemap emptyKeyRemap)
-- > , ((0                    , xK_F2    ), setKeyRemap dvorakProgrammerKeyRemap)
--
-- When defining your own keymappings, please be aware of:
--
-- * If you want to emulate a key that is shifted on us you must emulate that keypress:
--
-- > KeymapTable [((0, xK_a), (shiftMask, xK_5))] -- would bind 'a' to '%'
-- > KeymapTable [((shiftMask, xK_a), (0, xK_5))] -- would bind 'A' to '5'
--
-- * the dvorakProgrammerKeyRemap uses the original us layout as lookuptable to generate
--   the KeymapTable
--
-- * KeySym and (ord Char) are incompatible, therefore the magic numbers in dvorakProgrammerKeyRemap
--   are nessesary

doKeyRemap :: KeyMask -> KeySym -> X()
doKeyRemap :: KeyMask -> KeySym -> X ()
doKeyRemap KeyMask
mask KeySym
sym = do
  KeymapTable
table <- X KeymapTable
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

-- | Using this in the keybindings to set the actual Key Translation table
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 <- X KeymapTable
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
  XConf { display :: XConf -> Display
display = Display
dpy, theRoot :: XConf -> KeySym
theRoot = KeySym
rootw } <- X XConf
forall r (m :: * -> *). MonadReader r m => m r
ask

  let grab :: KeyCode -> KeyMask -> m ()
grab KeyCode
kc KeyMask
m = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
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 = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Display -> KeyCode -> KeyMask -> KeySym -> IO ()
ungrabKey Display
dpy KeyCode
kc KeyMask
m KeySym
rootw

  [((KeyMask, KeySym), (KeyMask, KeySym))]
-> (((KeyMask, KeySym), (KeyMask, KeySym)) -> X ()) -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [((KeyMask, KeySym), (KeyMask, KeySym))]
oldtable ((((KeyMask, KeySym), (KeyMask, KeySym)) -> X ()) -> X ())
-> (((KeyMask, KeySym), (KeyMask, KeySym)) -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \((KeyMask
mask, KeySym
sym), (KeyMask, KeySym)
_) -> do
    KeyCode
kc <- IO KeyCode -> X KeyCode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO KeyCode -> X KeyCode) -> IO KeyCode -> X KeyCode
forall a b. (a -> b) -> a -> b
$ Display -> KeySym -> IO KeyCode
keysymToKeycode Display
dpy KeySym
sym
    -- "If the specified KeySym is not defined for any KeyCode,
    -- XKeysymToKeycode() returns zero."
    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeyCode
kc KeyCode -> KeyCode -> Bool
forall a. Eq a => a -> a -> Bool
/= KeyCode
0) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ KeyCode -> KeyMask -> X ()
forall {m :: * -> *}. MonadIO m => KeyCode -> KeyMask -> m ()
ungrab KeyCode
kc KeyMask
mask

  [((KeyMask, KeySym), (KeyMask, KeySym))]
-> (((KeyMask, KeySym), (KeyMask, KeySym)) -> X ()) -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [((KeyMask, KeySym), (KeyMask, KeySym))]
newtable ((((KeyMask, KeySym), (KeyMask, KeySym)) -> X ()) -> X ())
-> (((KeyMask, KeySym), (KeyMask, KeySym)) -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \((KeyMask
mask, KeySym
sym), (KeyMask, KeySym)
_) -> do
    KeyCode
kc <- IO KeyCode -> X KeyCode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO KeyCode -> X KeyCode) -> IO KeyCode -> X KeyCode
forall a b. (a -> b) -> a -> b
$ Display -> KeySym -> IO KeyCode
keysymToKeycode Display
dpy KeySym
sym
    -- "If the specified KeySym is not defined for any KeyCode,
    -- XKeysymToKeycode() returns zero."
    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeyCode
kc KeyCode -> KeyCode -> Bool
forall a. Eq a => a -> a -> Bool
/= KeyCode
0) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ KeyCode -> KeyMask -> X ()
forall {m :: * -> *}. MonadIO m => KeyCode -> KeyMask -> m ()
grab KeyCode
kc KeyMask
mask

  KeymapTable -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put KeymapTable
table

-- | Adding this to your startupHook, to select your default Key Translation table.
--   You also must give it all the KeymapTables you are willing to use
setDefaultKeyRemap  :: KeymapTable -> [KeymapTable] -> X()
setDefaultKeyRemap :: KeymapTable -> [KeymapTable] -> X ()
setDefaultKeyRemap KeymapTable
dflt [KeymapTable]
keyremaps = do
  KeymapTable -> X ()
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 = [((KeyMask, KeySym), (KeyMask, KeySym))]
-> [((KeyMask, KeySym), (KeyMask, KeySym))]
forall a. Eq a => [a] -> [a]
nub ([KeymapTable]
keyremaps [KeymapTable]
-> (KeymapTable -> [((KeyMask, KeySym), (KeyMask, KeySym))])
-> [((KeyMask, KeySym), (KeyMask, KeySym))]
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)
extractKeyMapping :: KeymapTable -> KeyMask -> KeySym -> (KeyMask, KeySym)
extractKeyMapping (KeymapTable [((KeyMask, KeySym), (KeyMask, KeySym))]
table) KeyMask
mask KeySym
sym =
  [((KeyMask, KeySym), (KeyMask, KeySym))] -> (KeyMask, KeySym)
forall {a}. [(a, (KeyMask, KeySym))] -> (KeyMask, KeySym)
insertKey [((KeyMask, KeySym), (KeyMask, KeySym))]
filtered
  where filtered :: [((KeyMask, KeySym), (KeyMask, KeySym))]
filtered = (((KeyMask, KeySym), (KeyMask, KeySym)) -> Bool)
-> [((KeyMask, KeySym), (KeyMask, KeySym))]
-> [((KeyMask, KeySym), (KeyMask, KeySym))]
forall a. (a -> Bool) -> [a] -> [a]
filter (\((KeyMask
m, KeySym
s),(KeyMask, KeySym)
_) -> KeyMask
m KeyMask -> KeyMask -> Bool
forall a. Eq a => a -> a -> Bool
== KeyMask
mask Bool -> Bool -> Bool
&& KeySym
s KeySym -> KeySym -> Bool
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

-- | Append the output of this function to your keybindings with ++
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 = (KeymapTable -> [((KeyMask, KeySym), (KeyMask, KeySym))])
-> [KeymapTable] -> [((KeyMask, KeySym), (KeyMask, KeySym))]
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 = [(KeyMask, KeySym)] -> [(KeyMask, KeySym)]
forall a. Eq a => [a] -> [a]
nub ((((KeyMask, KeySym), (KeyMask, KeySym)) -> (KeyMask, KeySym))
-> [((KeyMask, KeySym), (KeyMask, KeySym))] -> [(KeyMask, KeySym)]
forall a b. (a -> b) -> [a] -> [b]
map ((KeyMask, KeySym), (KeyMask, KeySym)) -> (KeyMask, KeySym)
forall a b. (a, b) -> a
fst [((KeyMask, KeySym), (KeyMask, KeySym))]
mappings)


-- Here come the Keymappings
-- | The empty KeymapTable, does no translation
emptyKeyRemap :: KeymapTable
emptyKeyRemap :: KeymapTable
emptyKeyRemap = [((KeyMask, KeySym), (KeyMask, KeySym))] -> KeymapTable
KeymapTable []

-- | The dvorak Programmers keymap, translates from us keybindings to dvorak programmers
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) <- String
-> [KeySym] -> String -> [KeySym] -> [(Char, KeySym, Char, KeySym)]
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    = (Char -> KeySym) -> String -> [KeySym]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> KeySym
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> KeySym) -> (Char -> Int) -> Char -> KeySym
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum) String
"`1234567890-=qwertyuiop[]\\asdfghjkl;'zxcvbnm,./~!@#$%^&*()_+QWERTYUIOP{}|ASDFGHJKL:\"ZXCVBNM<>?"  :: [KeySym]
    layoutUsKey :: [KeySym]
layoutUsKey = (Char -> KeySym) -> String -> [KeySym]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> KeySym
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> KeySym) -> (Char -> Int) -> Char -> KeySym
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
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 = (Char -> KeySym) -> String -> [KeySym]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> KeySym
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> KeySym) -> (Char -> Int) -> Char -> KeySym
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum) String
"$&[{}(=*)+]!#;,.pyfgcrl/@\\aoeuidhtns-'qjkxbmwvz~%7531902468`:<>PYFGCRL?^|AOEUIDHTNS_\"QJKXBMWVZ" :: [KeySym]

    layoutDvorakShift :: String
layoutDvorakShift = (KeySym -> Char) -> [KeySym] -> String
forall a b. (a -> b) -> [a] -> [b]
map KeySym -> Char
getShift [KeySym]
layoutDvorak
    layoutDvorakKey :: [KeySym]
layoutDvorakKey   = (KeySym -> KeySym) -> [KeySym] -> [KeySym]
forall a b. (a -> b) -> [a] -> [b]
map KeySym -> KeySym
getKey [KeySym]
layoutDvorak
    getKey :: KeySym -> KeySym
getKey   KeySym
char = Maybe KeySym -> KeySym
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe KeySym -> KeySym) -> Maybe KeySym -> KeySym
forall a b. (a -> b) -> a -> b
$ ([KeySym]
layoutUsKey   [KeySym] -> Int -> Maybe KeySym
forall a. [a] -> Int -> Maybe a
!?) (Int -> Maybe KeySym) -> Maybe Int -> Maybe KeySym
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KeySym -> [KeySym] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex KeySym
char [KeySym]
layoutUs
    getShift :: KeySym -> Char
getShift KeySym
char = Maybe Char -> Char
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Char -> Char) -> Maybe Char -> Char
forall a b. (a -> b) -> a -> b
$ (String
layoutUsShift String -> Int -> Maybe Char
forall a. [a] -> Int -> Maybe a
!?) (Int -> Maybe Char) -> Maybe Int -> Maybe Char
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KeySym -> [KeySym] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex KeySym
char [KeySym]
layoutUs
    charToMask :: Char -> KeyMask
charToMask Char
char = if [Char
char] String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"0" then KeyMask
0 else KeyMask
shiftMask