{-# LANGUAGE FlexibleContexts #-}
module XMonad.Actions.Prefix
(
PrefixArgument(..)
, usePrefixArgument
, useDefaultPrefixArgument
, withPrefixArgument
, isPrefixRaw
, isPrefixNumeric
, orIfPrefixed
, ppFormatPrefix
) where
import qualified Data.Map as M
import XMonad.Prelude
import XMonad
import XMonad.Util.ExtensibleState as XS
import XMonad.Util.Paste (sendKey)
import XMonad.Actions.Submap (submapDefaultWithKey)
import XMonad.Util.EZConfig (readKeySequence)
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty ((<|))
data PrefixArgument = Raw Int | Numeric Int | None
deriving (ReadPrec [PrefixArgument]
ReadPrec PrefixArgument
Int -> ReadS PrefixArgument
ReadS [PrefixArgument]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PrefixArgument]
$creadListPrec :: ReadPrec [PrefixArgument]
readPrec :: ReadPrec PrefixArgument
$creadPrec :: ReadPrec PrefixArgument
readList :: ReadS [PrefixArgument]
$creadList :: ReadS [PrefixArgument]
readsPrec :: Int -> ReadS PrefixArgument
$creadsPrec :: Int -> ReadS PrefixArgument
Read, Int -> PrefixArgument -> ShowS
[PrefixArgument] -> ShowS
PrefixArgument -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PrefixArgument] -> ShowS
$cshowList :: [PrefixArgument] -> ShowS
show :: PrefixArgument -> String
$cshow :: PrefixArgument -> String
showsPrec :: Int -> PrefixArgument -> ShowS
$cshowsPrec :: Int -> PrefixArgument -> ShowS
Show)
instance ExtensionClass PrefixArgument where
initialValue :: PrefixArgument
initialValue = PrefixArgument
None
extensionType :: PrefixArgument -> StateExtension
extensionType = forall a. (Read a, Show a, ExtensionClass a) => a -> StateExtension
PersistentExtension
finallyX :: X a -> X a -> X a
finallyX :: forall a. X a -> X a -> X a
finallyX X a
job X a
cleanup = forall a. X a -> X a -> X a
catchX (X a
job forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
r -> X a
cleanup forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return a
r) X a
cleanup
usePrefixArgument :: LayoutClass l Window
=> String
-> XConfig l
-> XConfig l
usePrefixArgument :: forall (l :: * -> *).
LayoutClass l Window =>
String -> XConfig l -> XConfig l
usePrefixArgument String
prefix XConfig l
conf =
XConfig l
conf{ keys :: XConfig Layout -> Map (ButtonMask, Window) (X ())
keys = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (ButtonMask, Window)
binding (NonEmpty (ButtonMask, Window) -> X ()
handlePrefixArg ((ButtonMask, Window)
binding forall a. a -> [a] -> NonEmpty a
:| [])) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (l :: * -> *).
XConfig l -> XConfig Layout -> Map (ButtonMask, Window) (X ())
keys XConfig l
conf }
where
binding :: (ButtonMask, Window)
binding = case forall (l :: * -> *).
XConfig l -> String -> Maybe (NonEmpty (ButtonMask, Window))
readKeySequence XConfig l
conf String
prefix of
Just ((ButtonMask, Window)
key :| []) -> (ButtonMask, Window)
key
Maybe (NonEmpty (ButtonMask, Window))
_ -> (ButtonMask
controlMask, Window
xK_u)
useDefaultPrefixArgument :: LayoutClass l Window
=> XConfig l
-> XConfig l
useDefaultPrefixArgument :: forall (l :: * -> *).
LayoutClass l Window =>
XConfig l -> XConfig l
useDefaultPrefixArgument = forall (l :: * -> *).
LayoutClass l Window =>
String -> XConfig l -> XConfig l
usePrefixArgument String
"C-u"
handlePrefixArg :: NonEmpty (KeyMask, KeySym) -> X ()
handlePrefixArg :: NonEmpty (ButtonMask, Window) -> X ()
handlePrefixArg NonEmpty (ButtonMask, Window)
events = do
Map (ButtonMask, Window) (X ())
ks <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Map (ButtonMask, Window) (X ())
keyActions
X ()
logger <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall (l :: * -> *). XConfig l -> X ()
logHook forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config)
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. X a -> X a -> X a
finallyX (forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put PrefixArgument
None forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> X ()
logger) forall a b. (a -> b) -> a -> b
$ do
PrefixArgument
prefix <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
case PrefixArgument
prefix of
Raw Int
a -> forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put forall a b. (a -> b) -> a -> b
$ Int -> PrefixArgument
Raw (Int
a forall a. Num a => a -> a -> a
+ Int
1)
PrefixArgument
None -> forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put forall a b. (a -> b) -> a -> b
$ Int -> PrefixArgument
Raw Int
1
PrefixArgument
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
X ()
logger
((ButtonMask, Window) -> X ())
-> Map (ButtonMask, Window) (X ()) -> X ()
submapDefaultWithKey (ButtonMask, Window) -> X ()
defaultKey Map (ButtonMask, Window) (X ())
ks
where defaultKey :: (ButtonMask, Window) -> X ()
defaultKey key :: (ButtonMask, Window)
key@(ButtonMask
m, Window
k) =
if Window
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Window
xK_0 forall a. a -> [a] -> [a]
: [Window
xK_1 .. Window
xK_9]) Bool -> Bool -> Bool
&& ButtonMask
m forall a. Eq a => a -> a -> Bool
== ButtonMask
noModMask
then do
PrefixArgument
prefix <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
let x :: Int
x = forall a. HasCallStack => Maybe a -> a
fromJust (forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup Window
k [(Window, Int)]
keyToNum)
case PrefixArgument
prefix of
Raw Int
_ -> forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put forall a b. (a -> b) -> a -> b
$ Int -> PrefixArgument
Numeric Int
x
Numeric Int
a -> forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put forall a b. (a -> b) -> a -> b
$ Int -> PrefixArgument
Numeric forall a b. (a -> b) -> a -> b
$ Int
a forall a. Num a => a -> a -> a
* Int
10 forall a. Num a => a -> a -> a
+ Int
x
PrefixArgument
None -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
NonEmpty (ButtonMask, Window) -> X ()
handlePrefixArg ((ButtonMask, Window)
key forall a. a -> NonEmpty a -> NonEmpty a
<| NonEmpty (ButtonMask, Window)
events)
else do
PrefixArgument
prefix <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ButtonMask -> Window -> X ()
sendKey) forall a b. (a -> b) -> a -> b
$ case PrefixArgument
prefix of
Raw Int
a -> forall a. Int -> a -> [a]
replicate Int
a (forall a. NonEmpty a -> a
NE.head NonEmpty (ButtonMask, Window)
events) forall a. [a] -> [a] -> [a]
++ [(ButtonMask, Window)
key]
PrefixArgument
_ -> forall a. [a] -> [a]
reverse ((ButtonMask, Window)
key forall a. a -> [a] -> [a]
: forall l. IsList l => l -> [Item l]
toList NonEmpty (ButtonMask, Window)
events)
keyToNum :: [(Window, Int)]
keyToNum = (Window
xK_0, Int
0) forall a. a -> [a] -> [a]
: forall a b. [a] -> [b] -> [(a, b)]
zip [Window
xK_1 .. Window
xK_9] [Int
1..Int
9]
withPrefixArgument :: (PrefixArgument -> X a) -> X a
withPrefixArgument :: forall a. (PrefixArgument -> X a) -> X a
withPrefixArgument = forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=) forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
isPrefixRaw :: PrefixArgument -> Bool
isPrefixRaw :: PrefixArgument -> Bool
isPrefixRaw (Raw Int
_) = Bool
True
isPrefixRaw PrefixArgument
_ = Bool
False
isPrefixNumeric :: PrefixArgument -> Bool
isPrefixNumeric :: PrefixArgument -> Bool
isPrefixNumeric (Numeric Int
_) = Bool
True
isPrefixNumeric PrefixArgument
_ = Bool
False
orIfPrefixed :: X a -> X a -> X a
orIfPrefixed :: forall a. X a -> X a -> X a
orIfPrefixed X a
xa X a
xb = forall a. (PrefixArgument -> X a) -> X a
withPrefixArgument forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> Bool -> a
bool X a
xa X a
xb forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrefixArgument -> Bool
isPrefixRaw
ppFormatPrefix :: X (Maybe String)
ppFormatPrefix :: X (Maybe String)
ppFormatPrefix = do
PrefixArgument
prefix <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case PrefixArgument
prefix of
Raw Int
n -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\String
a String
b -> String
a forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
b) forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
n String
"C-u"
Numeric Int
n -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
"C-u " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n
PrefixArgument
None -> forall a. Maybe a
Nothing