    -----------------------------------------------------------------------------
    -- |
    -- 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
    $cshowsPrec :: Int -> KeymapTable -> ShowS
    showsPrec :: Int -> KeymapTable -> ShowS
    $cshow :: KeymapTable -> String
    show :: KeymapTable -> String
    $cshowList :: [KeymapTable] -> ShowS
    showList :: [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
      table <- X KeymapTable
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
    XS.get
      let (insertMask, insertSym) = extractKeyMapping table mask sym
      sendKey insertMask 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 oldtable <- X KeymapTable
    forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
    XS.get
      XConf { display = dpy, theRoot = rootw } <- ask

      let 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
    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

      forM_ oldtable $ \((KeyMask
    mask, KeySym
    sym), (KeyMask, KeySym)
    _) -> do
        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."
        when (kc /= 0) $ ungrab kc mask

      forM_ newtable $ \((KeyMask
    mask, KeySym
    sym), (KeyMask, KeySym)
    _) -> do
        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."
        when (kc /= 0) $ grab kc mask

      XS.put 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 a b. [a] -> (a -> [b]) -> [b]
    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