content:  {-# 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
  