{-# 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
       , 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 ((<|))

{- $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]
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

-- | 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 = 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

-- | 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 (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)

-- | 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 = 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 () -- should never happen
            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]

-- | 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 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

-- | 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

-- | Execute the first action, unless any prefix argument is given,
-- in which case the second action is chosen instead.
--
-- > action1 `orIfPrefixed` action2
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

-- | 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 <- 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