{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Hooks.Modal
-- Description :  Implements true modality in xmonad key-bindings.
-- Copyright   :  (c) 2018  L. S. Leary
-- License     :  BSD3-style (see LICENSE)
--
-- Author      :  L. S. Leary
-- Maintainer  :  Yecine Megdiche <yecine.megdiche@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- This module implements modal keybindings for xmonad.
--
--------------------------------------------------------------------------------

-- --< Imports & Exports >-- {{{
module XMonad.Hooks.Modal
  (
 -- * Usage
 -- $Usage
    modal
  , modeWithExit
  , mode
  , Mode
  , mkKeysEz
  , setMode
  , exitMode
 -- * Provided Modes #ProvidedModes#
 -- $ProvidedModes
  , noModModeLabel
  , noModMode
  , floatModeLabel
  , floatMode
  , overlayedFloatModeLabel
  , overlayedFloatMode
  , floatMap
  , overlay
 -- * Logger
  , logMode
  ) where

-- core
import           XMonad
-- base
import           Data.Bits                     ( (.&.)
                                               , complement
                                               )
import           Data.List
import qualified Data.Map.Strict               as M
-- contrib
import           XMonad.Actions.FloatKeys      ( keysMoveWindow
                                               , keysResizeWindow
                                               )
import           XMonad.Prelude
import           XMonad.Util.EZConfig          ( parseKeyCombo
                                               , mkKeymap
                                               )
import qualified XMonad.Util.ExtensibleConf    as XC
import qualified XMonad.Util.ExtensibleState   as XS
import           XMonad.Util.Grab
import           XMonad.Util.Loggers
import           XMonad.Util.Parser            ( runParser )

-- }}}

-- Original Draft By L.S.Leary : https://gist.github.com/LSLeary/6741b0572d62db3f0cea8e6618141b2f

-- --< Usage >-- {{{

-- $Usage
--
-- This module provides modal keybindings in xmonad. If you're not familiar with
-- modal keybindings from Vim, you can think of modes as submaps from
-- "XMonad.Actions.Submap", but after each action you execute, you land back in
-- the submap until you explicitly exit the submap. To use this module you
-- should apply the 'modal' function to the config, which will setup the list of
-- modes (or rather, @XConfig Layout -> Mode@) you provide:
--
-- >
-- > import XMonad
-- > import XMonad.Hooks.Modal
-- > import XMonad.Util.EZConfig
-- > import qualified Data.Map as M
-- >
-- > main :: IO ()
-- > main =
-- >   xmonad
-- >     . modal [noModMode, floatMode 10, overlayedFloatMode 10, sayHelloMode]
-- >     $ def
-- >     `additionalKeysP` [ ("M-S-n", setMode noModModeLabel)
-- >                       , ("M-S-r", setMode floatModeLabel)
-- >                       , ("M-S-z", setMode overlayedFloatModeLabel)
-- >                       , ("M-S-h", setMode "Hello")
-- >                       ]
-- >
-- > sayHelloMode :: Mode
-- > sayHelloMode = mode "Hello" $ mkKeysEz
-- >   [ ("h", xmessage "Hello, World!")
-- >   , ("M-g", xmessage "Goodbye, World!")
-- >   ]
--
-- Alternatively, one could have defined @sayHelloMode@ as
--
-- > sayHelloMode :: Mode
-- > sayHelloMode = mode "Hello" $ \cfg ->
-- >   M.fromList [ ((noModMask, xK_h), xmessage "Hello, World!")
-- >              , ((modMask cfg, xK_g), xmessage "Goodbye, World!")
-- >              ]
--
-- In short, a 'Mode' has a label describing its purpose, as well as
-- attached keybindings. These are of the form
--
--   - @[(String, X ())]@, or
--
--   - @XConfig Layout -> M.Map (ButtonMask, KeySym) (X ())@.
--
-- The former—accessible via 'mkKeysEz'—is how specifying keys work with
-- "XMonad.Util.EZConfig", while the latter is more geared towards how
-- defining keys works by default in xmonad. Note that, by default,
-- modes are exited with the Escape key. If one wishes to customise
-- this, the 'modeWithExit' function should be used instead of 'mode'
-- when defining a new mode.
--
-- The label of the active mode can be logged with 'logMode' to be
-- displayed in a status bar, for example (For more information check
-- "XMonad.Util.Loggers"). Some examples are included in [the provided
-- modes](#g:ProvidedModes).

-- }}}

-- --< Types >-- {{{

-- | From a list of "XMonad.Util.EZConfig"-style bindings, generate a
-- key representation.
--
-- >>> mkKeysEz [("h", xmessage "Hello, world!")]
mkKeysEz :: [(String, X ())] -> (XConfig Layout -> M.Map (ButtonMask, KeySym) (X ()))
mkKeysEz :: [(String, X ())]
-> XConfig Layout -> Map (ButtonMask, KeySym) (X ())
mkKeysEz = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (l :: * -> *).
XConfig l -> [(String, X ())] -> Map (ButtonMask, KeySym) (X ())
mkKeymap

-- | The mode type. Use 'mode' or 'modeWithExit' to create modes.
data Mode = Mode
  { Mode -> String
label     :: !String
  , Mode -> XConfig Layout -> Map (ButtonMask, KeySym) (X ())
boundKeys :: !(XConfig Layout -> M.Map (ButtonMask, KeySym) (X ()))
  }

-- | Newtype for the extensible config.
newtype ModeConfig = MC [Mode] deriving NonEmpty ModeConfig -> ModeConfig
ModeConfig -> ModeConfig -> ModeConfig
forall b. Integral b => b -> ModeConfig -> ModeConfig
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> ModeConfig -> ModeConfig
$cstimes :: forall b. Integral b => b -> ModeConfig -> ModeConfig
sconcat :: NonEmpty ModeConfig -> ModeConfig
$csconcat :: NonEmpty ModeConfig -> ModeConfig
<> :: ModeConfig -> ModeConfig -> ModeConfig
$c<> :: ModeConfig -> ModeConfig -> ModeConfig
Semigroup

-- | Newtype for the extensible state.
newtype CurrentMode = CurrentMode
  { CurrentMode -> Maybe Mode
currentMode :: Maybe Mode
  }

instance ExtensionClass CurrentMode where
  initialValue :: CurrentMode
initialValue = Maybe Mode -> CurrentMode
CurrentMode forall a. Maybe a
Nothing

-- }}}

-- --< Private >-- {{{

-- | The active keybindings corresponding to the active 'Mode' (or lack
-- thereof).
currentKeys :: X (M.Map (ButtonMask, KeySym) (X ()))
currentKeys :: X (Map (ButtonMask, KeySym) (X ()))
currentKeys = do
  XConfig Layout
cnf <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> XConfig Layout
config
  forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets CurrentMode -> Maybe Mode
currentMode forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Mode
m  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Mode -> XConfig Layout -> Map (ButtonMask, KeySym) (X ())
boundKeys Mode
m XConfig Layout
cnf)
    Maybe Mode
Nothing -> forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (l :: * -> *).
XConfig l -> XConfig Layout -> Map (ButtonMask, KeySym) (X ())
keys forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> XConfig Layout
config

-- | Grab the keys corresponding to the active 'Mode' (or lack thereof).
regrab :: X ()
regrab :: X ()
regrab = [(ButtonMask, KeySym)] -> X ()
grab forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [k]
M.keys forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< X (Map (ButtonMask, KeySym) (X ()))
currentKeys

-- | Called after changing the mode. Grabs the correct keys and runs the
-- 'logHook'.
refreshMode :: X ()
refreshMode :: X ()
refreshMode = X ()
regrab forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> XConfig Layout
config forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (l :: * -> *). XConfig l -> X ()
logHook

-- | Event hook to control the keybindings.
modalEventHook :: Event -> X All
modalEventHook :: Event -> X All
modalEventHook = X () -> Event -> X All
customRegrabEvHook X ()
regrab forall a. Semigroup a => a -> a -> a
<> \case
  KeyEvent { ev_event_type :: Event -> EventType
ev_event_type = EventType
t, ev_state :: Event -> ButtonMask
ev_state = ButtonMask
m, ev_keycode :: Event -> KeyCode
ev_keycode = KeyCode
code }
    | EventType
t forall a. Eq a => a -> a -> Bool
== EventType
keyPress -> forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
      (ButtonMask, KeySym)
kp  <- (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ButtonMask -> X ButtonMask
cleanMask ButtonMask
m forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Display -> KeyCode -> CInt -> IO KeySym
keycodeToKeysym Display
dpy KeyCode
code CInt
0)
      Map (ButtonMask, KeySym) (X ())
kbs <- X (Map (ButtonMask, KeySym) (X ()))
currentKeys
      forall a. a -> X a -> X a
userCodeDef () (forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (ButtonMask, KeySym)
kp Map (ButtonMask, KeySym) (X ())
kbs) forall a. a -> a
id)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> All
All Bool
False)
  Event
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> All
All Bool
True)

-- }}}

-- --< Public >-- {{{

-- | Adds the provided modes to the user's config, and sets up the bells
-- and whistles needed for them to work.
modal :: [Mode] -> XConfig l -> XConfig l
modal :: forall (l :: * -> *). [Mode] -> XConfig l -> XConfig l
modal [Mode]
modes = forall a (l :: * -> *).
(Semigroup a, Typeable a) =>
(XConfig l -> XConfig l) -> a -> XConfig l -> XConfig l
XC.once
  (\XConfig l
cnf -> XConfig l
cnf { startupHook :: X ()
startupHook     = forall (l :: * -> *). XConfig l -> X ()
startupHook XConfig l
cnf forall a. Semigroup a => a -> a -> a
<> X ()
initModes
               , handleEventHook :: Event -> X All
handleEventHook = forall (l :: * -> *). XConfig l -> Event -> X All
handleEventHook XConfig l
cnf forall a. Semigroup a => a -> a -> a
<> Event -> X All
modalEventHook
               }
  )
  ([Mode] -> ModeConfig
MC [Mode]
modes)
  where initModes :: X ()
initModes = forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (Maybe Mode -> CurrentMode
CurrentMode forall a. Maybe a
Nothing) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> X ()
refreshMode

-- | Create a 'Mode' from the given binding to 'exitMode', label and
-- keybindings.
modeWithExit :: String -> String -> (XConfig Layout -> M.Map (KeyMask, KeySym) (X ())) -> Mode
modeWithExit :: String
-> String
-> (XConfig Layout -> Map (ButtonMask, KeySym) (X ()))
-> Mode
modeWithExit String
exitKey String
mlabel XConfig Layout -> Map (ButtonMask, KeySym) (X ())
keys = String
-> (XConfig Layout -> Map (ButtonMask, KeySym) (X ())) -> Mode
Mode String
mlabel forall a b. (a -> b) -> a -> b
$ \XConfig Layout
cnf ->
  let exit :: (ButtonMask, KeySym)
exit = forall a. a -> Maybe a -> a
fromMaybe (ButtonMask
0, KeySym
xK_Escape) forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> String -> Maybe a
runParser (forall (l :: * -> *). XConfig l -> Parser (ButtonMask, KeySym)
parseKeyCombo XConfig Layout
cnf) String
exitKey
   in forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (ButtonMask, KeySym)
exit X ()
exitMode (XConfig Layout -> Map (ButtonMask, KeySym) (X ())
keys XConfig Layout
cnf)

-- | Create a 'Mode' from the given label and keybindings. Sets the
-- @escape@ key to 'exitMode'.
mode :: String -> (XConfig Layout -> M.Map (KeyMask, KeySym) (X ())) -> Mode
mode :: String
-> (XConfig Layout -> Map (ButtonMask, KeySym) (X ())) -> Mode
mode = String
-> String
-> (XConfig Layout -> Map (ButtonMask, KeySym) (X ()))
-> Mode
modeWithExit String
"<Escape>"

-- | Set the current 'Mode' based on its label.
setMode :: String -> X ()
setMode :: String -> X ()
setMode String
l = do
  forall (m :: * -> *) a b.
(MonadReader XConf m, Typeable a, Monoid b) =>
(a -> m b) -> m b
XC.with forall a b. (a -> b) -> a -> b
$ \(MC [Mode]
ls) -> case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((forall a. Eq a => a -> a -> Bool
== String
l) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mode -> String
label) [Mode]
ls of
    Maybe Mode
Nothing -> forall a. Monoid a => a
mempty
    Just Mode
m  -> do
      forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify forall a b. (a -> b) -> a -> b
$ \CurrentMode
cm -> CurrentMode
cm { currentMode :: Maybe Mode
currentMode = forall a. a -> Maybe a
Just Mode
m }
      X ()
refreshMode

-- | Exits the current mode.
exitMode :: X ()
exitMode :: X ()
exitMode = do
  forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify forall a b. (a -> b) -> a -> b
$ \CurrentMode
m -> CurrentMode
m { currentMode :: Maybe Mode
currentMode = forall a. Maybe a
Nothing }
  X ()
refreshMode

-- | A 'Logger' to display the current mode.
logMode :: Logger
logMode :: Logger
logMode = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Mode -> String
label forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets CurrentMode -> Maybe Mode
currentMode

-- Provided modes
noModModeLabel, floatModeLabel, overlayedFloatModeLabel :: String
noModModeLabel :: String
noModModeLabel = String
"NoMod"
floatModeLabel :: String
floatModeLabel = String
"Float"
overlayedFloatModeLabel :: String
overlayedFloatModeLabel = String
"Overlayed Float"

-- | In this 'Mode', all keybindings are available without the need for pressing
-- the modifier. Pressing @escape@ exits the mode.
noModMode :: Mode
noModMode :: Mode
noModMode =
  String
-> (XConfig Layout -> Map (ButtonMask, KeySym) (X ())) -> Mode
mode String
noModModeLabel forall a b. (a -> b) -> a -> b
$ \XConfig Layout
cnf -> ButtonMask
-> Map (ButtonMask, KeySym) (X ())
-> Map (ButtonMask, KeySym) (X ())
stripModifier (forall (l :: * -> *). XConfig l -> ButtonMask
modMask XConfig Layout
cnf) (forall (l :: * -> *).
XConfig l -> XConfig Layout -> Map (ButtonMask, KeySym) (X ())
keys XConfig Layout
cnf XConfig Layout
cnf)

-- | Generates the keybindings for 'floatMode' and 'overlayedFloatMode'.
floatMap
  :: KeyMask -- ^ Move mask
  -> KeyMask -- ^ Enlarge mask
  -> KeyMask -- ^ Shrink mask
  -> Int -- ^ Step size
  -> M.Map (ButtonMask, KeySym) (X ())
floatMap :: ButtonMask
-> ButtonMask
-> ButtonMask
-> Int
-> Map (ButtonMask, KeySym) (X ())
floatMap ButtonMask
move ButtonMask
enlarge ButtonMask
shrink Int
s = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  [ -- move
    ((ButtonMask
move, KeySym
xK_h)          , (KeySym -> X ()) -> X ()
withFocused (ChangeDim -> KeySym -> X ()
keysMoveWindow (-Int
s, Int
0)))
  , ((ButtonMask
move, KeySym
xK_j)          , (KeySym -> X ()) -> X ()
withFocused (ChangeDim -> KeySym -> X ()
keysMoveWindow (Int
0, Int
s)))
  , ((ButtonMask
move, KeySym
xK_k)          , (KeySym -> X ()) -> X ()
withFocused (ChangeDim -> KeySym -> X ()
keysMoveWindow (Int
0, -Int
s)))
  , ((ButtonMask
move, KeySym
xK_l)          , (KeySym -> X ()) -> X ()
withFocused (ChangeDim -> KeySym -> X ()
keysMoveWindow (Int
s, Int
0)))
  -- enlarge
  , ((ButtonMask
enlarge, KeySym
xK_h), (KeySym -> X ()) -> X ()
withFocused (ChangeDim -> G -> KeySym -> X ()
keysResizeWindow (Int
s, Int
0) (Rational
1, Rational
0)))
  , ((ButtonMask
enlarge, KeySym
xK_j), (KeySym -> X ()) -> X ()
withFocused (ChangeDim -> G -> KeySym -> X ()
keysResizeWindow (Int
0, Int
s) (Rational
0, Rational
0)))
  , ((ButtonMask
enlarge, KeySym
xK_k), (KeySym -> X ()) -> X ()
withFocused (ChangeDim -> G -> KeySym -> X ()
keysResizeWindow (Int
0, Int
s) (Rational
0, Rational
1)))
  , ((ButtonMask
enlarge, KeySym
xK_l), (KeySym -> X ()) -> X ()
withFocused (ChangeDim -> G -> KeySym -> X ()
keysResizeWindow (Int
s, Int
0) (Rational
0, Rational
0)))
  -- shrink
  , ((ButtonMask
shrink, KeySym
xK_h), (KeySym -> X ()) -> X ()
withFocused (ChangeDim -> G -> KeySym -> X ()
keysResizeWindow (-Int
s, Int
0) (Rational
0, Rational
0)))
  , ((ButtonMask
shrink, KeySym
xK_j), (KeySym -> X ()) -> X ()
withFocused (ChangeDim -> G -> KeySym -> X ()
keysResizeWindow (Int
0, -Int
s) (Rational
0, Rational
1)))
  , ((ButtonMask
shrink, KeySym
xK_k), (KeySym -> X ()) -> X ()
withFocused (ChangeDim -> G -> KeySym -> X ()
keysResizeWindow (Int
0, -Int
s) (Rational
0, Rational
0)))
  , ((ButtonMask
shrink, KeySym
xK_l), (KeySym -> X ()) -> X ()
withFocused (ChangeDim -> G -> KeySym -> X ()
keysResizeWindow (-Int
s, Int
0) (Rational
1, Rational
0)))
  , ((ButtonMask
noModMask, KeySym
xK_Escape), X ()
exitMode)
  ]

-- | A mode to control floating windows with @{hijk}@, @M-{hijk}@ and
-- @M-S-{hijk}@ in order to respectively move, enlarge and
-- shrink windows.
floatMode
  :: Int -- ^ Step size
  -> Mode
floatMode :: Int -> Mode
floatMode Int
i = String
-> (XConfig Layout -> Map (ButtonMask, KeySym) (X ())) -> Mode
mode String
floatModeLabel forall a b. (a -> b) -> a -> b
$ \XConfig { ButtonMask
modMask :: ButtonMask
modMask :: forall (l :: * -> *). XConfig l -> ButtonMask
modMask } ->
  ButtonMask
-> ButtonMask
-> ButtonMask
-> Int
-> Map (ButtonMask, KeySym) (X ())
floatMap ButtonMask
noModMask ButtonMask
modMask (ButtonMask
modMask forall a. Bits a => a -> a -> a
.|. ButtonMask
shiftMask) Int
i

-- | Similar to 'resizeMode', but keeps the bindings of the original
-- config active.
overlayedFloatMode
  :: Int -- ^ Step size
  -> Mode
overlayedFloatMode :: Int -> Mode
overlayedFloatMode = String -> Mode -> Mode
overlay String
overlayedFloatModeLabel forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Mode
floatMode

-- | Modifies a mode so that the keybindings are merged with those from
-- the config instead of replacing them.
overlay
  :: String  -- ^ Label for the new mode
  -> Mode -- ^ Base mode
  -> Mode
overlay :: String -> Mode -> Mode
overlay String
label Mode
m = String
-> (XConfig Layout -> Map (ButtonMask, KeySym) (X ())) -> Mode
Mode String
label forall a b. (a -> b) -> a -> b
$ \XConfig Layout
cnf -> Mode -> XConfig Layout -> Map (ButtonMask, KeySym) (X ())
boundKeys Mode
m XConfig Layout
cnf forall a. Semigroup a => a -> a -> a
<> forall (l :: * -> *).
XConfig l -> XConfig Layout -> Map (ButtonMask, KeySym) (X ())
keys XConfig Layout
cnf XConfig Layout
cnf

-- | Strips the modifier key from the provided keybindings.
stripModifier
  :: ButtonMask -- ^ Modifier to remove
  -> M.Map (ButtonMask, KeySym) (X ()) -- ^ Original keybinding map
  -> M.Map (ButtonMask, KeySym) (X ())
stripModifier :: ButtonMask
-> Map (ButtonMask, KeySym) (X ())
-> Map (ButtonMask, KeySym) (X ())
stripModifier ButtonMask
mask = forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys forall a b. (a -> b) -> a -> b
$ \(ButtonMask
m, KeySym
k) -> (ButtonMask
m forall a. Bits a => a -> a -> a
.&. forall a. Bits a => a -> a
complement ButtonMask
mask, KeySym
k)

-- }}}