{-# LANGUAGE FlexibleContexts #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.Prefix
-- Description :  Use an Emacs-style prefix argument for commands.
-- Copyright   :  (c) Matus Goljer <matus.goljer@gmail.com>
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  Matus Goljer <matus.goljer@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- A module that allows the user to use a prefix argument (raw or numeric).
--
-----------------------------------------------------------------------------

module XMonad.Actions.Prefix
       (
      -- * Usage
      -- $usage

      -- * Installation
      -- $installation

         PrefixArgument(..)
       , usePrefixArgument
       , useDefaultPrefixArgument
       , withPrefixArgument
       , isPrefixRaw
       , isPrefixNumeric
       , 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)

{- $usage

This module implements Emacs-style prefix argument.  The argument
comes in two flavours, "Raw" and "Numeric".

To initiate the "prefix mode" you hit the prefix keybinding (default
C-u).  This sets the Raw argument value to 1.  Repeatedly hitting this
key increments the raw value by 1.  The Raw argument is usually used
as a toggle, changing the behaviour of the function called in some way.

An example might be calling "mpc add" to add new song to the playlist,
but with C-u we also clean up the playlist beforehand.

When in the "Raw mode", you can hit numeric keys 0..9 (with no
modifier) to enter a "Numeric argument".  Numeric argument represents
a natural number.  Hitting numeric keys in sequence produces the
decimal number that would result from typing them.  That is, the
sequence C-u 4 2 sets the Numeric argument value to the number 42.

If you have a function which understands the prefix argument, for example:

>    addMaybeClean :: PrefixArgument -> X ()
>    addMaybeClean (Raw _) = spawn "mpc clear" >> spawn "mpc add <file>"
>    addMaybeClean _ = spawn "mpc add <file>"

you can turn it into an X action with the function 'withPrefixArgument'.

Binding it in your config

>    ((modm, xK_a), withPrefixArgument addMaybeClean)

Hitting MOD-a will add the <file> to the playlist while C-u MOD-a will
clear the playlist and then add the file.

You can of course use an anonymous action, like so:

>    ((modm, xK_a), withPrefixArgument $ \prefix -> do
>        case prefix of ...
>    )

If the prefix key is followed by a binding which is unknown to XMonad,
the prefix along with that binding is sent to the active window.

There is one caveat: when you use an application which has a nested
C-u binding, for example C-c C-u in Emacs org-mode, you have to hit
C-g (or any other non-recognized key really) to get out of the "xmonad
grab" and let the C-c C-u be sent to the application.

-}

{- $installation

The simplest way to enable this is to use 'useDefaultPrefixArgument'

>    xmonad $ useDefaultPrefixArgument $ def { .. }

The default prefix argument is C-u.  If you want to customize the
prefix argument, 'usePrefixArgument' can be used:

>    xmonad $ usePrefixArgument "M-u" $ def { .. }

where the key is entered in Emacs style (or "XMonad.Util.EZConfig"
style) notation.  The letter `M` stands for your chosen modifier.  The
function defaults to C-u if the argument could not be parsed.
-}

data PrefixArgument = Raw Int | Numeric Int | None
                      deriving (ReadPrec [PrefixArgument]
ReadPrec PrefixArgument
Int -> ReadS PrefixArgument
ReadS [PrefixArgument]
(Int -> ReadS PrefixArgument)
-> ReadS [PrefixArgument]
-> ReadPrec PrefixArgument
-> ReadPrec [PrefixArgument]
-> Read 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
(Int -> PrefixArgument -> ShowS)
-> (PrefixArgument -> String)
-> ([PrefixArgument] -> ShowS)
-> Show PrefixArgument
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 = PrefixArgument -> StateExtension
forall a. (Read a, Show a, ExtensionClass a) => a -> StateExtension
PersistentExtension

-- | Run 'job' in the 'X' monad and then execute 'cleanup'.  In case
-- of exception, 'cleanup' is executed anyway.
--
-- Return the return value of 'job'.
finallyX :: X a -> X a -> X a
finallyX :: forall a. X a -> X a -> X a
finallyX X a
job X a
cleanup = X a -> X a -> X a
forall a. X a -> X a -> X a
catchX (X a
job X a -> (a -> X a) -> X a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
r -> X a
cleanup X a -> X a -> X a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r) X a
cleanup

-- | Set up Prefix.  Defaults to C-u when given an invalid key.
--
-- See usage section.
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 (KeyMask, Window) (X ())
keys = (KeyMask, Window)
-> X ()
-> Map (KeyMask, Window) (X ())
-> Map (KeyMask, Window) (X ())
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (KeyMask, Window)
binding ([(KeyMask, Window)] -> X ()
handlePrefixArg [(KeyMask, Window)
binding]) (Map (KeyMask, Window) (X ()) -> Map (KeyMask, Window) (X ()))
-> (XConfig Layout -> Map (KeyMask, Window) (X ()))
-> XConfig Layout
-> Map (KeyMask, Window) (X ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConfig l -> XConfig Layout -> Map (KeyMask, Window) (X ())
forall (l :: * -> *).
XConfig l -> XConfig Layout -> Map (KeyMask, Window) (X ())
keys XConfig l
conf }
 where
  binding :: (KeyMask, Window)
binding = case XConfig l -> String -> Maybe [(KeyMask, Window)]
forall (l :: * -> *).
XConfig l -> String -> Maybe [(KeyMask, Window)]
readKeySequence XConfig l
conf String
prefix of
    Just [(KeyMask, Window)
key] -> (KeyMask, Window)
key
    Maybe [(KeyMask, Window)]
_          -> (KeyMask
controlMask, Window
xK_u)

-- | Set Prefix up with default prefix key (C-u).
useDefaultPrefixArgument :: LayoutClass l Window
                         => XConfig l
                         -> XConfig l
useDefaultPrefixArgument :: forall (l :: * -> *).
LayoutClass l Window =>
XConfig l -> XConfig l
useDefaultPrefixArgument = String -> XConfig l -> XConfig l
forall (l :: * -> *).
LayoutClass l Window =>
String -> XConfig l -> XConfig l
usePrefixArgument String
"C-u"

handlePrefixArg :: [(KeyMask, KeySym)] -> X ()
handlePrefixArg :: [(KeyMask, Window)] -> X ()
handlePrefixArg [(KeyMask, Window)]
events = do
  Map (KeyMask, Window) (X ())
ks <- (XConf -> Map (KeyMask, Window) (X ()))
-> X (Map (KeyMask, Window) (X ()))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Map (KeyMask, Window) (X ())
keyActions
  X ()
logger <- (XConf -> X ()) -> X (X ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XConfig Layout -> X ()
forall (l :: * -> *). XConfig l -> X ()
logHook (XConfig Layout -> X ())
-> (XConf -> XConfig Layout) -> XConf -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config)
  (X () -> X () -> X ()) -> X () -> X () -> X ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip X () -> X () -> X ()
forall a. X a -> X a -> X a
finallyX (PrefixArgument -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put PrefixArgument
None X () -> X () -> X ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> X ()
logger) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
    PrefixArgument
prefix <- X PrefixArgument
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
    case PrefixArgument
prefix of
      Raw Int
a -> PrefixArgument -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (PrefixArgument -> X ()) -> PrefixArgument -> X ()
forall a b. (a -> b) -> a -> b
$ Int -> PrefixArgument
Raw (Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
      PrefixArgument
None -> PrefixArgument -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (PrefixArgument -> X ()) -> PrefixArgument -> X ()
forall a b. (a -> b) -> a -> b
$ Int -> PrefixArgument
Raw Int
1
      PrefixArgument
_ -> () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    X ()
logger
    ((KeyMask, Window) -> X ()) -> Map (KeyMask, Window) (X ()) -> X ()
submapDefaultWithKey (KeyMask, Window) -> X ()
defaultKey Map (KeyMask, Window) (X ())
ks
  where defaultKey :: (KeyMask, Window) -> X ()
defaultKey key :: (KeyMask, Window)
key@(KeyMask
m, Window
k) =
          if Window
k Window -> [Window] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Window
xK_0 Window -> [Window] -> [Window]
forall a. a -> [a] -> [a]
: [Window
xK_1 .. Window
xK_9]) Bool -> Bool -> Bool
&& KeyMask
m KeyMask -> KeyMask -> Bool
forall a. Eq a => a -> a -> Bool
== KeyMask
noModMask
          then do
            PrefixArgument
prefix <- X PrefixArgument
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
            let x :: Int
x = Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Window -> [(Window, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Prelude.lookup Window
k [(Window, Int)]
keyToNum)
            case PrefixArgument
prefix of
              Raw Int
_ -> PrefixArgument -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (PrefixArgument -> X ()) -> PrefixArgument -> X ()
forall a b. (a -> b) -> a -> b
$ Int -> PrefixArgument
Numeric Int
x
              Numeric Int
a -> PrefixArgument -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (PrefixArgument -> X ()) -> PrefixArgument -> X ()
forall a b. (a -> b) -> a -> b
$ Int -> PrefixArgument
Numeric (Int -> PrefixArgument) -> Int -> PrefixArgument
forall a b. (a -> b) -> a -> b
$ Int
a Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
x
              PrefixArgument
None -> () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- should never happen
            [(KeyMask, Window)] -> X ()
handlePrefixArg ((KeyMask, Window)
key(KeyMask, Window) -> [(KeyMask, Window)] -> [(KeyMask, Window)]
forall a. a -> [a] -> [a]
:[(KeyMask, Window)]
events)
          else do
            PrefixArgument
prefix <- X PrefixArgument
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
            ((KeyMask, Window) -> X ()) -> [(KeyMask, Window)] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((KeyMask -> Window -> X ()) -> (KeyMask, Window) -> X ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry KeyMask -> Window -> X ()
sendKey) ([(KeyMask, Window)] -> X ()) -> [(KeyMask, Window)] -> X ()
forall a b. (a -> b) -> a -> b
$ case PrefixArgument
prefix of
              Raw Int
a -> Int -> (KeyMask, Window) -> [(KeyMask, Window)]
forall a. Int -> a -> [a]
replicate Int
a ([(KeyMask, Window)] -> (KeyMask, Window)
forall a. [a] -> a
head [(KeyMask, Window)]
events) [(KeyMask, Window)] -> [(KeyMask, Window)] -> [(KeyMask, Window)]
forall a. [a] -> [a] -> [a]
++ [(KeyMask, Window)
key]
              PrefixArgument
_ -> [(KeyMask, Window)] -> [(KeyMask, Window)]
forall a. [a] -> [a]
reverse ((KeyMask, Window)
key(KeyMask, Window) -> [(KeyMask, Window)] -> [(KeyMask, Window)]
forall a. a -> [a] -> [a]
:[(KeyMask, Window)]
events)
        keyToNum :: [(Window, Int)]
keyToNum = (Window
xK_0, Int
0) (Window, Int) -> [(Window, Int)] -> [(Window, Int)]
forall a. a -> [a] -> [a]
: [Window] -> [Int] -> [(Window, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Window
xK_1 .. Window
xK_9] [Int
1..Int
9]

-- | Turn a prefix-aware X action into an X-action.
--
-- First, fetch the current prefix, then pass it as argument to the
-- original function.  You should use this to "run" your commands.
withPrefixArgument :: (PrefixArgument -> X ()) -> X ()
withPrefixArgument :: (PrefixArgument -> X ()) -> X ()
withPrefixArgument = X PrefixArgument -> (PrefixArgument -> X ()) -> X ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=) X PrefixArgument
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get

-- | Test if 'PrefixArgument' is 'Raw' or not.
isPrefixRaw :: PrefixArgument -> Bool
isPrefixRaw :: PrefixArgument -> Bool
isPrefixRaw (Raw Int
_) = Bool
True
isPrefixRaw PrefixArgument
_ = Bool
False

-- | Test if 'PrefixArgument' is 'Numeric' or not.
isPrefixNumeric :: PrefixArgument -> Bool
isPrefixNumeric :: PrefixArgument -> Bool
isPrefixNumeric (Numeric Int
_) = Bool
True
isPrefixNumeric PrefixArgument
_ = Bool
False

-- | Format the prefix using the Emacs convetion for use in a
-- statusbar, like xmobar.
--
-- To add this formatted prefix to printer output, you can set it up
-- like so
--
-- > myPrinter :: PP
-- > myPrinter = def { ppExtras = [ppFormatPrefix] }
--
-- And then add to your status bar using "XMonad.Hooks.StatusBar":
--
-- > mySB = statusBarProp "xmobar" myPrinter
-- > main = xmonad $ withEasySB mySB defToggleStrutsKey def
--
-- Or, directly in your 'logHook' configuration
--
-- > logHook = dynamicLogWithPP myPrinter
ppFormatPrefix :: X (Maybe String)
ppFormatPrefix :: X (Maybe String)
ppFormatPrefix = do
  PrefixArgument
prefix <- X PrefixArgument
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
  Maybe String -> X (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> X (Maybe String))
-> Maybe String -> X (Maybe String)
forall a b. (a -> b) -> a -> b
$ case PrefixArgument
prefix of
    Raw Int
n -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ (String -> ShowS) -> [String] -> String
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\String
a String
b -> String
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
b) ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> [String]
forall a. Int -> a -> [a]
replicate Int
n String
"C-u"
    Numeric Int
n -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"C-u " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
    PrefixArgument
None -> Maybe String
forall a. Maybe a
Nothing