-----------------------------------------------------------------------------
-- |
-- Module       : XMonad.Actions.MessageFeedback
-- Description :  An alternative @sendMessage@.
-- Copyright    : (c) --   Quentin Moser <moserq@gmail.com>
--                    2018 Yclept Nemo
-- License      : BSD3
--
-- Maintainer   : orphaned
-- Stability    : unstable
-- Portability  : unportable
--
-- Alternative to 'XMonad.Operations.sendMessage' that provides knowledge
-- of whether the message was handled, and utility functions based on
-- this facility.
-----------------------------------------------------------------------------

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

      -- * Messaging variants

      -- ** 'SomeMessage'
      sendSomeMessageB, sendSomeMessage
    , sendSomeMessageWithNoRefreshB, sendSomeMessageWithNoRefresh
    , sendSomeMessageWithNoRefreshToCurrentB, sendSomeMessageWithNoRefreshToCurrent

      -- ** 'Message'
    , sendMessageB
    , sendMessageWithNoRefreshB
    , sendMessageWithNoRefreshToCurrentB, sendMessageWithNoRefreshToCurrent

      -- * Utility Functions

      -- ** Send All
    , sendSomeMessagesB, sendSomeMessages, sendMessagesB, sendMessages

      -- ** Send Until
    , tryInOrderB, tryInOrderWithNoRefreshToCurrentB, tryInOrderWithNoRefreshToCurrent
    , tryMessageB, tryMessageWithNoRefreshToCurrentB, tryMessageWithNoRefreshToCurrent

      -- ** Aliases
    , sm
    ) where

import XMonad               ( Window )
import XMonad.Core          ( X(), Message, SomeMessage(..), LayoutClass(..), windowset, catchX, WorkspaceId, Layout, whenJust )
import XMonad.Operations    ( updateLayout, windowBracket, modifyWindowSet )
import XMonad.Prelude
import XMonad.StackSet      ( Workspace, current, workspace, layout, tag )

import Control.Monad.State  ( gets )

-- $usage
-- You can use this module with the following in your @xmonad.hs@:
--
-- > import XMonad.Actions.MessageFeedback
--
-- You can then use this module's functions wherever an action is expected. All
-- feedback variants are supported:
--
-- * message to any workspace with no refresh
-- * message to current workspace with no refresh
-- * message to current workspace with refresh
--
-- Except "message to any workspace with refresh" which makes little sense.
--
-- Note that most functions in this module have a return type of @X Bool@
-- whereas configuration options will expect a @X ()@ action. For example, the
-- key binding:
--
-- > -- Shrink the master area of a tiled layout, or move the focused window
-- > -- to the left in a WindowArranger-based layout
-- > ((modKey, xK_Left), tryMessageWithNoRefreshToCurrentB Shrink (MoveLeft 50))
--
-- is mis-typed. For this reason, this module provides alternatives (not ending
-- with an uppercase \"B\", e.g. 'XMonad.Operations.sendMessage' rather than
-- 'sendMessageB') that discard their boolean result and return an @X ()@. For
-- example, to correct the previous example:
--
-- > ((modKey, xK_Left), tryMessageWithNoRefreshToCurrent Shrink (MoveLeft 50))
--
-- This module also provides 'SomeMessage' variants of each 'Message' function
-- for when the messages are of differing types (but still instances of
-- 'Message'). First box each message using 'SomeMessage' or the convenience
-- alias 'sm'. Then, for example, to send each message:
--
-- > sendSomeMessages [sm messageOfTypeA, sm messageOfTypeB]
--
-- This is /not/ equivalent to the following example, which will not refresh
-- the workspace unless the last message is handled:
--
-- > sendMessageWithNoRefreshToCurrent messageOfTypeA >> sendMessage messageOfTypeB


-- | Variant of 'XMonad.Operations.sendMessage'. Accepts 'SomeMessage'; to use
-- 'Message' see 'sendMessageB'. Returns @True@ if the message was handled,
-- @False@ otherwise. Instead of using 'sendSomeMessageWithNoRefreshToCurrentB'
-- for efficiency this is pretty much an exact copy of the
-- 'XMonad.Operations.sendMessage' code - foregoes the O(n) 'updateLayout'.
sendSomeMessageB :: SomeMessage -> X Bool
sendSomeMessageB :: SomeMessage -> X Bool
sendSomeMessageB SomeMessage
m = forall a. (a -> Bool) -> X a -> X a
windowBracket forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ do
    Workspace WorkspaceId (Layout Window) Window
w  <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
workspace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
current) forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet
     WorkspaceId (Layout Window) Window ScreenId ScreenDetail
windowset)
    Maybe (Layout Window)
ml <- forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage (forall i l a. Workspace i l a -> l
layout Workspace WorkspaceId (Layout Window) Window
w) SomeMessage
m forall a. X a -> X a -> X a
`catchX` forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe (Layout Window)
ml forall a b. (a -> b) -> a -> b
$ \Layout Window
l ->
        (StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
 -> StackSet
      WorkspaceId (Layout Window) Window ScreenId ScreenDetail)
-> X ()
modifyWindowSet forall a b. (a -> b) -> a -> b
$ \StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
ws -> StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
ws { current :: Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail
current = (forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
current StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
ws)
                                { workspace :: Workspace WorkspaceId (Layout Window) Window
workspace = (forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
workspace forall a b. (a -> b) -> a -> b
$ forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
current StackSet WorkspaceId (Layout Window) Window ScreenId ScreenDetail
ws)
                                    { layout :: Layout Window
layout = Layout Window
l }}}
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> Bool
isJust Maybe (Layout Window)
ml

-- | Variant of 'sendSomeMessageB' that discards the result.
sendSomeMessage :: SomeMessage -> X ()
sendSomeMessage :: SomeMessage -> X ()
sendSomeMessage = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeMessage -> X Bool
sendSomeMessageB

-- | Variant of 'XMonad.Operations.sendMessageWithNoRefresh'. Accepts
-- 'SomeMessage'; to use 'Message' see 'sendMessageWithNoRefreshB'. Returns
-- @True@ if the message was handled, @False@ otherwise.
sendSomeMessageWithNoRefreshB :: SomeMessage -> Workspace WorkspaceId (Layout Window) Window -> X Bool
sendSomeMessageWithNoRefreshB :: SomeMessage
-> Workspace WorkspaceId (Layout Window) Window -> X Bool
sendSomeMessageWithNoRefreshB SomeMessage
m Workspace WorkspaceId (Layout Window) Window
w
    =   forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage (forall i l a. Workspace i l a -> l
layout Workspace WorkspaceId (Layout Window) Window
w) SomeMessage
m forall a. X a -> X a -> X a
`catchX` forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>) (WorkspaceId -> Maybe (Layout Window) -> X ()
updateLayout forall a b. (a -> b) -> a -> b
$ forall i l a. Workspace i l a -> i
tag Workspace WorkspaceId (Layout Window) Window
w) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> Bool
isJust)

-- | Variant of 'sendSomeMessageWithNoRefreshB' that discards the result.
sendSomeMessageWithNoRefresh :: SomeMessage -> Workspace WorkspaceId (Layout Window) Window -> X ()
sendSomeMessageWithNoRefresh :: SomeMessage -> Workspace WorkspaceId (Layout Window) Window -> X ()
sendSomeMessageWithNoRefresh SomeMessage
m = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeMessage
-> Workspace WorkspaceId (Layout Window) Window -> X Bool
sendSomeMessageWithNoRefreshB SomeMessage
m

-- | Variant of 'XMonad.Operations.sendMessageWithNoRefresh' that sends the
-- message to the current layout. Accepts 'SomeMessage'; to use 'Message' see
-- 'sendMessageWithNoRefreshToCurrentB'. Returns @True@ if the message was
-- handled, @False@ otherwise. This function is somewhat of a cross between
-- 'XMonad.Operations.sendMessage' (sends to the current layout) and
-- 'XMonad.Operations.sendMessageWithNoRefresh' (does not refresh).
sendSomeMessageWithNoRefreshToCurrentB :: SomeMessage -> X Bool
sendSomeMessageWithNoRefreshToCurrentB :: SomeMessage -> X Bool
sendSomeMessageWithNoRefreshToCurrentB SomeMessage
m
    =   forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
workspace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
current forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet
     WorkspaceId (Layout Window) Window ScreenId ScreenDetail
windowset)
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SomeMessage
-> Workspace WorkspaceId (Layout Window) Window -> X Bool
sendSomeMessageWithNoRefreshB SomeMessage
m

-- | Variant of 'sendSomeMessageWithNoRefreshToCurrentB' that discards the
-- result.
sendSomeMessageWithNoRefreshToCurrent :: SomeMessage -> X ()
sendSomeMessageWithNoRefreshToCurrent :: SomeMessage -> X ()
sendSomeMessageWithNoRefreshToCurrent = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeMessage -> X Bool
sendSomeMessageWithNoRefreshToCurrentB


-- | Variant of 'sendSomeMessageB' which like 'XMonad.Operations.sendMessage'
-- accepts 'Message' rather than 'SomeMessage'. Returns @True@ if the message
-- was handled, @False@ otherwise.
sendMessageB :: Message a => a -> X Bool
sendMessageB :: forall a. Message a => a -> X Bool
sendMessageB = SomeMessage -> X Bool
sendSomeMessageB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Message a => a -> SomeMessage
SomeMessage

-- | Variant of 'sendSomeMessageWithNoRefreshB' which like
-- 'XMonad.Operations.sendMessageWithNoRefresh' accepts 'Message' rather than
-- 'SomeMessage'. Returns @True@ if the message was handled, @False@ otherwise.
sendMessageWithNoRefreshB :: Message a => a -> Workspace WorkspaceId (Layout Window) Window -> X Bool
sendMessageWithNoRefreshB :: forall a.
Message a =>
a -> Workspace WorkspaceId (Layout Window) Window -> X Bool
sendMessageWithNoRefreshB = SomeMessage
-> Workspace WorkspaceId (Layout Window) Window -> X Bool
sendSomeMessageWithNoRefreshB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Message a => a -> SomeMessage
SomeMessage

-- | Variant of 'sendSomeMessageWithNoRefreshToCurrentB' which accepts
-- 'Message' rather than 'SomeMessage'. Returns @True@ if the message was
-- handled, @False@ otherwise.
sendMessageWithNoRefreshToCurrentB :: Message a => a -> X Bool
sendMessageWithNoRefreshToCurrentB :: forall a. Message a => a -> X Bool
sendMessageWithNoRefreshToCurrentB = SomeMessage -> X Bool
sendSomeMessageWithNoRefreshToCurrentB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Message a => a -> SomeMessage
SomeMessage

-- | Variant of 'sendMessageWithNoRefreshToCurrentB' that discards the result.
sendMessageWithNoRefreshToCurrent :: Message a => a -> X ()
sendMessageWithNoRefreshToCurrent :: forall a. Message a => a -> X ()
sendMessageWithNoRefreshToCurrent = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Message a => a -> X Bool
sendMessageWithNoRefreshToCurrentB


-- | Send each 'SomeMessage' to the current layout without refresh (using
-- 'sendSomeMessageWithNoRefreshToCurrentB') and collect the results. If any
-- message was handled, refresh. If you want to sequence a series of messages
-- that would have otherwise used 'XMonad.Operations.sendMessage' while
-- minimizing refreshes, use this.
sendSomeMessagesB :: [SomeMessage] -> X [Bool]
sendSomeMessagesB :: [SomeMessage] -> X [Bool]
sendSomeMessagesB
    = forall a. (a -> Bool) -> X a -> X a
windowBracket forall (t :: * -> *). Foldable t => t Bool -> Bool
or
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SomeMessage -> X Bool
sendSomeMessageWithNoRefreshToCurrentB

-- | Variant of 'sendSomeMessagesB' that discards the results.
sendSomeMessages :: [SomeMessage] -> X ()
sendSomeMessages :: [SomeMessage] -> X ()
sendSomeMessages = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SomeMessage] -> X [Bool]
sendSomeMessagesB

-- | Variant of 'sendSomeMessagesB' which accepts 'Message' rather than
-- 'SomeMessage'. Use this if all the messages are of the same type.
sendMessagesB :: Message a => [a] -> X [Bool]
sendMessagesB :: forall a. Message a => [a] -> X [Bool]
sendMessagesB = [SomeMessage] -> X [Bool]
sendSomeMessagesB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Message a => a -> SomeMessage
SomeMessage

-- | Variant of 'sendMessagesB' that discards the results.
sendMessages :: Message a => [a] -> X ()
sendMessages :: forall a. Message a => [a] -> X ()
sendMessages = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Message a => [a] -> X [Bool]
sendMessagesB


-- | Apply the dispatch function in order to each message of the list until one
-- is handled. Returns @True@ if so, @False@ otherwise.
tryInOrderB :: (SomeMessage -> X Bool) -> [SomeMessage] -> X Bool
tryInOrderB :: (SomeMessage -> X Bool) -> [SomeMessage] -> X Bool
tryInOrderB SomeMessage -> X Bool
_ []     = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
tryInOrderB SomeMessage -> X Bool
f (SomeMessage
m:[SomeMessage]
ms) = do Bool
b <- SomeMessage -> X Bool
f SomeMessage
m
                          if Bool
b then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else (SomeMessage -> X Bool) -> [SomeMessage] -> X Bool
tryInOrderB SomeMessage -> X Bool
f [SomeMessage]
ms

-- | Variant of 'tryInOrderB' that sends messages to the current layout without
-- refresh using 'sendSomeMessageWithNoRefreshToCurrentB'.
tryInOrderWithNoRefreshToCurrentB :: [SomeMessage] -> X Bool
tryInOrderWithNoRefreshToCurrentB :: [SomeMessage] -> X Bool
tryInOrderWithNoRefreshToCurrentB = (SomeMessage -> X Bool) -> [SomeMessage] -> X Bool
tryInOrderB SomeMessage -> X Bool
sendSomeMessageWithNoRefreshToCurrentB

-- | Variant of 'tryInOrderWithNoRefreshToCurrent' that discards the results.
tryInOrderWithNoRefreshToCurrent :: [SomeMessage] -> X ()
tryInOrderWithNoRefreshToCurrent :: [SomeMessage] -> X ()
tryInOrderWithNoRefreshToCurrent = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SomeMessage] -> X Bool
tryInOrderWithNoRefreshToCurrentB

-- | Apply the dispatch function to the first message, and if it was not
-- handled, apply it to the second. Returns @True@ if either message was
-- handled, @False@ otherwise.
tryMessageB :: (Message a, Message b) => (SomeMessage -> X Bool) -> a -> b -> X Bool
tryMessageB :: forall a b.
(Message a, Message b) =>
(SomeMessage -> X Bool) -> a -> b -> X Bool
tryMessageB SomeMessage -> X Bool
f a
m1 b
m2 = (SomeMessage -> X Bool) -> [SomeMessage] -> X Bool
tryInOrderB SomeMessage -> X Bool
f [forall a. Message a => a -> SomeMessage
sm a
m1,forall a. Message a => a -> SomeMessage
sm b
m2]

-- | Variant of 'tryMessageB' that sends messages to the current layout without
-- refresh using 'sendMessageWithNoRefreshToCurrentB'.
tryMessageWithNoRefreshToCurrentB :: (Message a, Message b) => a -> b -> X Bool
tryMessageWithNoRefreshToCurrentB :: forall a b. (Message a, Message b) => a -> b -> X Bool
tryMessageWithNoRefreshToCurrentB = forall a b.
(Message a, Message b) =>
(SomeMessage -> X Bool) -> a -> b -> X Bool
tryMessageB SomeMessage -> X Bool
sendSomeMessageWithNoRefreshToCurrentB

-- | Variant of 'tryMessage' that discards the results.
tryMessageWithNoRefreshToCurrent :: (Message a, Message b) => a -> b -> X ()
tryMessageWithNoRefreshToCurrent :: forall a b. (Message a, Message b) => a -> b -> X ()
tryMessageWithNoRefreshToCurrent a
m = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Message a, Message b) => a -> b -> X Bool
tryMessageWithNoRefreshToCurrentB a
m


-- | Convenience shorthand for 'SomeMessage'.
sm :: Message a => a -> SomeMessage
sm :: forall a. Message a => a -> SomeMessage
sm = forall a. Message a => a -> SomeMessage
SomeMessage