-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.Submap
-- Description :  Create a sub-mapping of key bindings.
-- Copyright   :  (c) Jason Creighton <jcreigh@gmail.com>
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  Jason Creighton <jcreigh@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- A module that allows the user to create a sub-mapping of key bindings.
--
-----------------------------------------------------------------------------

module XMonad.Actions.Submap (
                             -- * Usage
                             -- $usage
                             submap,
                             visualSubmap,
                             visualSubmapSorted,
                             submapDefault,
                             submapDefaultWithKey,

                             -- * Utilities
                             subName,
                            ) where
import Data.Bits
import qualified Data.Map as M
import XMonad hiding (keys)
import XMonad.Prelude (fix, fromMaybe, keyToString, cleanKeyMask)
import XMonad.Util.XUtils

{- $usage

First, import this module into your @xmonad.hs@:

> import XMonad.Actions.Submap

Allows you to create a sub-mapping of keys. Example:

>    , ((modm, xK_a), submap . M.fromList $
>        [ ((0, xK_n),     spawn "mpc next")
>        , ((0, xK_p),     spawn "mpc prev")
>        , ((0, xK_z),     spawn "mpc random")
>        , ((0, xK_space), spawn "mpc toggle")
>        ])

So, for example, to run 'spawn \"mpc next\"', you would hit mod-a (to
trigger the submapping) and then 'n' to run that action. (0 means \"no
modifier\"). You are, of course, free to use any combination of
modifiers in the submapping. However, anyModifier will not work,
because that is a special value passed to XGrabKey() and not an actual
modifier.

For detailed instructions on editing your key bindings, see
<https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.

-}

-- | Given a 'Data.Map.Map' from key bindings to X () actions, return
--   an action which waits for a user keypress and executes the
--   corresponding action, or does nothing if the key is not found in
--   the map.
submap :: M.Map (KeyMask, KeySym) (X ()) -> X ()
submap :: Map (KeyMask, EventMask) (X ()) -> X ()
submap = X () -> Map (KeyMask, EventMask) (X ()) -> X ()
submapDefault (forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Like 'submap', but visualise the relevant options.
--
-- ==== __Example__
--
-- > import qualified Data.Map as Map
-- > import XMonad.Actions.Submap
-- >
-- > gotoLayout :: [(String, X ())]   -- for use with EZConfig
-- > gotoLayout =  -- assumes you have a layout named "Tall" and one named "Full".
-- >   [("M-l", visualSubmap def $ Map.fromList $ map (\(k, s, a) -> ((0, k), (s, a)))
-- >              [ (xK_t, "Tall", switchToLayout "Tall")     -- "M-l t" switches to "Tall"
-- >              , (xK_r, "Full", switchToLayout "Full")     -- "M-l r" switches to "full"
-- >              ])]
--
-- One could alternatively also write @gotoLayout@ as
--
-- > gotoLayout = [("M-l", visualSubmap def $ Map.fromList $
-- >                         [ ((0, xK_t), subName "Tall" $ switchToLayout "Tall")
-- >                         , ((0, xK_r), subName "Full" $ switchToLayout "Full")
-- >                         ])]
visualSubmap :: WindowConfig -- ^ The config for the spawned window.
             -> M.Map (KeyMask, KeySym) (String, X ())
                             -- ^ A map @keybinding -> (description, action)@.
             -> X ()
visualSubmap :: WindowConfig -> Map (KeyMask, EventMask) (String, X ()) -> X ()
visualSubmap = ([((KeyMask, EventMask), String)]
 -> [((KeyMask, EventMask), String)])
-> WindowConfig -> Map (KeyMask, EventMask) (String, X ()) -> X ()
visualSubmapSorted forall a. a -> a
id

-- | Like 'visualSubmap', but is able to sort the descriptions.
-- For example,
--
-- > import Data.Ord (comparing, Down)
-- >
-- > visualSubmapSorted (sortBy (comparing Down)) def
--
-- would sort the @(key, description)@ pairs by their keys in descending
-- order.
visualSubmapSorted :: ([((KeyMask, KeySym), String)] -> [((KeyMask, KeySym), String)])
                             -- ^ A function to resort the descriptions
             -> WindowConfig -- ^ The config for the spawned window.
             -> M.Map (KeyMask, KeySym) (String, X ())
                             -- ^ A map @keybinding -> (description, action)@.
             -> X ()
visualSubmapSorted :: ([((KeyMask, EventMask), String)]
 -> [((KeyMask, EventMask), String)])
-> WindowConfig -> Map (KeyMask, EventMask) (String, X ()) -> X ()
visualSubmapSorted [((KeyMask, EventMask), String)]
-> [((KeyMask, EventMask), String)]
sorted WindowConfig
wc Map (KeyMask, EventMask) (String, X ())
keys =
    forall a. WindowConfig -> [String] -> X a -> X a
withSimpleWindow WindowConfig
wc [String]
descriptions X (KeyMask, EventMask)
waitForKeyPress forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(KeyMask
m', EventMask
s) ->
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall a b. (a, b) -> b
snd (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (KeyMask
m', EventMask
s) Map (KeyMask, EventMask) (String, X ())
keys)
  where
    descriptions :: [String]
    descriptions :: [String]
descriptions =
        forall a b. (a -> b) -> [a] -> [b]
map (\((KeyMask, EventMask)
key, String
desc) -> (KeyMask, EventMask) -> String
keyToString (KeyMask, EventMask)
key forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> String
desc)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. [((KeyMask, EventMask), String)]
-> [((KeyMask, EventMask), String)]
sorted
            forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall k a. Map k a -> [k]
M.keys Map (KeyMask, EventMask) (String, X ())
keys) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall k a. Map k a -> [a]
M.elems Map (KeyMask, EventMask) (String, X ())
keys))

-- | Give a name to an action.
subName :: String -> X () -> (String, X ())
subName :: String -> X () -> (String, X ())
subName = (,)

-- | Like 'submap', but executes a default action if the key did not match.
submapDefault :: X () -> M.Map (KeyMask, KeySym) (X ()) -> X ()
submapDefault :: X () -> Map (KeyMask, EventMask) (X ()) -> X ()
submapDefault = ((KeyMask, EventMask) -> X ())
-> Map (KeyMask, EventMask) (X ()) -> X ()
submapDefaultWithKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

-- | Like 'submapDefault', but sends the unmatched key to the default
-- action as argument.
submapDefaultWithKey :: ((KeyMask, KeySym) -> X ())
                     -> M.Map (KeyMask, KeySym) (X ())
                     -> X ()
submapDefaultWithKey :: ((KeyMask, EventMask) -> X ())
-> Map (KeyMask, EventMask) (X ()) -> X ()
submapDefaultWithKey (KeyMask, EventMask) -> X ()
defAction Map (KeyMask, EventMask) (X ())
keys = X (KeyMask, EventMask)
waitForKeyPress forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    \(KeyMask
m', EventMask
s) -> forall a. a -> Maybe a -> a
fromMaybe ((KeyMask, EventMask) -> X ()
defAction (KeyMask
m', EventMask
s)) (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (KeyMask
m', EventMask
s) Map (KeyMask, EventMask) (X ())
keys)

-----------------------------------------------------------------------
-- Internal stuff

waitForKeyPress :: X (KeyMask, KeySym)
waitForKeyPress :: X (KeyMask, EventMask)
waitForKeyPress = do
    XConf{ theRoot :: XConf -> EventMask
theRoot = EventMask
root, display :: XConf -> Display
display = Display
dpy } <- forall r (m :: * -> *). MonadReader r m => m r
ask

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ do Display
-> EventMask -> Bool -> CInt -> CInt -> EventMask -> IO CInt
grabKeyboard Display
dpy EventMask
root Bool
False CInt
grabModeAsync CInt
grabModeAsync EventMask
currentTime
            Display
-> EventMask
-> Bool
-> EventMask
-> CInt
-> CInt
-> EventMask
-> EventMask
-> EventMask
-> IO CInt
grabPointer Display
dpy EventMask
root Bool
False EventMask
buttonPressMask CInt
grabModeAsync CInt
grabModeAsync
                        EventMask
none EventMask
none EventMask
currentTime

    (KeyMask
m, EventMask
s) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent forall a b. (a -> b) -> a -> b
$ \XEventPtr
p -> forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \IO (KeyMask, EventMask)
nextkey -> do
        Display -> EventMask -> XEventPtr -> IO ()
maskEvent Display
dpy (EventMask
keyPressMask forall a. Bits a => a -> a -> a
.|. EventMask
buttonPressMask) XEventPtr
p
        Event
ev <- XEventPtr -> IO Event
getEvent XEventPtr
p
        case Event
ev of
          KeyEvent { ev_keycode :: Event -> KeyCode
ev_keycode = KeyCode
code, ev_state :: Event -> KeyMask
ev_state = KeyMask
m } -> do
            EventMask
keysym <- Display -> KeyCode -> CInt -> IO EventMask
keycodeToKeysym Display
dpy KeyCode
code CInt
0
            if EventMask -> Bool
isModifierKey EventMask
keysym
                then IO (KeyMask, EventMask)
nextkey
                else forall (m :: * -> *) a. Monad m => a -> m a
return (KeyMask
m, EventMask
keysym)
          Event
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (KeyMask
0, EventMask
0)
    KeyMask
m' <- X (KeyMask -> KeyMask)
cleanKeyMask forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyMask
m
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ do Display -> EventMask -> IO ()
ungrabPointer Display
dpy EventMask
currentTime
            Display -> EventMask -> IO ()
ungrabKeyboard Display
dpy EventMask
currentTime
            Display -> Bool -> IO ()
sync Display
dpy Bool
False
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (KeyMask
m', EventMask
s)