{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
module XMonad.Hooks.Modal
(
modal
, modeWithExit
, mode
, Mode
, mkKeysEz
, setMode
, exitMode
, noModModeLabel
, noModMode
, floatModeLabel
, floatMode
, overlayedFloatModeLabel
, overlayedFloatMode
, floatMap
, overlay
, logMode
) where
import XMonad
import Data.Bits ( (.&.)
, complement
)
import Data.List
import qualified Data.Map.Strict as M
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 )
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
data Mode = Mode
{ Mode -> String
label :: !String
, Mode -> XConfig Layout -> Map (ButtonMask, KeySym) (X ())
boundKeys :: !(XConfig Layout -> M.Map (ButtonMask, KeySym) (X ()))
}
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 CurrentMode = CurrentMode
{ CurrentMode -> Maybe Mode
currentMode :: Maybe Mode
}
instance ExtensionClass CurrentMode where
initialValue :: CurrentMode
initialValue = Maybe Mode -> CurrentMode
CurrentMode forall a. Maybe a
Nothing
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
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
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
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)
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
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)
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>"
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
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
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
noModModeLabel, floatModeLabel, overlayedFloatModeLabel :: String
noModModeLabel :: String
noModModeLabel = String
"NoMod"
floatModeLabel :: String
floatModeLabel = String
"Float"
overlayedFloatModeLabel :: String
overlayedFloatModeLabel = String
"Overlayed Float"
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)
floatMap
:: KeyMask
-> KeyMask
-> KeyMask
-> Int
-> 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
[
((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)))
, ((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)))
, ((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)
]
floatMode
:: Int
-> 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
overlayedFloatMode
:: Int
-> Mode
overlayedFloatMode :: Int -> Mode
overlayedFloatMode = String -> Mode -> Mode
overlay String
overlayedFloatModeLabel forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Mode
floatMode
overlay
:: String
-> 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
stripModifier
:: ButtonMask
-> M.Map (ButtonMask, KeySym) (X ())
-> 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)