     {-# LANGUAGE DeriveDataTypeable #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  XMonad.Actions.KeyRemap
    -- 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.Util.Paste
    import Data.List

    import qualified XMonad.Util.ExtensibleState as XS
    import Control.Monad

    data KeymapTable = KeymapTable [((KeyMask, KeySym), (KeyMask, KeySym))] deriving (Typeable, Show)

    instance ExtensionClass KeymapTable where
       initialValue = 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 mask sym = do
      table <- 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 table = do
      let KeymapTable newtable = table
      KeymapTable oldtable <- XS.get
      XConf { display = dpy, theRoot = rootw } <- ask

      let grab kc m = io $ grabKey dpy kc m rootw True grabModeAsync grabModeAsync
      let ungrab kc m = io $ ungrabKey dpy kc m rootw

      forM_ oldtable $ \((mask, sym), _) -> do
        kc <- io $ keysymToKeycode dpy sym
        -- "If the specified KeySym is not defined for any KeyCode,
        -- XKeysymToKeycode() returns zero."
        when (kc /= 0) $ ungrab kc mask

      forM_ newtable $ \((mask, sym), _) -> do
        kc <- io $ keysymToKeycode dpy 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 dflt keyremaps = do
      XS.put (KeymapTable mappings)
      setKeyRemap dflt
      where
        mappings = nub (keyremaps >>= \(KeymapTable table) -> table)

    extractKeyMapping :: KeymapTable -> KeyMask -> KeySym -> (KeyMask, KeySym)
    extractKeyMapping (KeymapTable table) mask sym =
      insertKey filtered
      where filtered = filter (\((m, s),_) -> m == mask && s == sym) table
            insertKey [] = (mask, sym)
            insertKey ((_, to):_) = to

    -- | Append the output of this function to your keybindings with ++
    buildKeyRemapBindings :: [KeymapTable] -> [((KeyMask, KeySym), X ())]
    buildKeyRemapBindings keyremaps =
      [((mask, sym), doKeyRemap mask sym) | (mask, sym) <- bindings]
      where mappings = concat (map (\(KeymapTable table) -> table) keyremaps)
            bindings = nub (map (\binding -> fst binding) mappings)

    -- Here come the Keymappings
    -- | The empty KeymapTable, does no translation
    emptyKeyRemap :: KeymapTable
    emptyKeyRemap = KeymapTable []

    -- | The dvorak Programmers keymap, translates from us keybindings to dvorak programmers
    dvorakProgrammerKeyRemap :: KeymapTable
    dvorakProgrammerKeyRemap =
      KeymapTable [((charToMask maskFrom, from), (charToMask maskTo, to)) |
                   (maskFrom, from, maskTo, to) <- (zip4 layoutUsShift layoutUsKey layoutDvorakShift layoutDvorakKey)]
      where

        layoutUs    = map (fromIntegral . fromEnum) "`1234567890-=qwertyuiop[]\\asdfghjkl;'zxcvbnm,./~!@#$%^&*()_+QWERTYUIOP{}|ASDFGHJKL:\"ZXCVBNM<>?"  :: [KeySym]
        layoutUsKey = map (fromIntegral . fromEnum) "`1234567890-=qwertyuiop[]\\asdfghjkl;'zxcvbnm,./`1234567890-=qwertyuiop[]\\asdfghjkl;'zxcvbnm,./"  :: [KeySym]
        layoutUsShift = "0000000000000000000000000000000000000000000000011111111111111111111111111111111111111111111111"

        layoutDvorak = map (fromIntegral . fromEnum) "$&[{}(=*)+]!#;,.pyfgcrl/@\\aoeuidhtns-'qjkxbmwvz~%7531902468`:<>PYFGCRL?^|AOEUIDHTNS_\"QJKXBMWVZ" :: [KeySym]

        layoutDvorakShift = map getShift layoutDvorak
        layoutDvorakKey   = map getKey layoutDvorak
        getKey  char = let Just index = elemIndex char layoutUs
                        in layoutUsKey !! index
        getShift char = let Just index = elemIndex char layoutUs
                        in layoutUsShift !! index
        charToMask char = if [char] == "0" then 0 else shiftMask