{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.MessageControl
-- Description :  Message escaping and filtering facilities.
-- Copyright   :  (c) 2008 Quentin Moser
-- License     :  BSD3
--
-- Maintainer  :  orphaned
-- Stability   :  unstable
-- Portability :  unportable
--
-- Provides message \"escaping\" and filtering facilities which
-- help control complex nested layouts.
-----------------------------------------------------------------------------

module XMonad.Layout.MessageControl (
                               -- * Usage
                               -- $usage
                            Ignore()
                          , ignore
                          , UnEscape()
                          , unEscape
                          , EscapedMessage(Escape)
                          , escape
                          ) where

import XMonad.Core (Message, SomeMessage(..)
                   , fromMessage, LayoutClass(..))
import XMonad.StackSet (Workspace(..))

import XMonad.Layout.LayoutModifier (LayoutModifier(..), ModifiedLayout(..))

import Control.Arrow (second)

-- $usage
-- You can use this module by importing it into your @~\/.xmonad\/xmonad.hs@ file:
--
-- > import XMonad.Layout.MessageEscape
--
-- Then, if you use a modified layout where the modifier would intercept
-- a message, but you'd want to be able to send it to the inner layout
-- only, add the 'unEscape' modifier to the inner layout like so:
--
-- > import XMonad.Layout.Master (mastered)
-- > import XMonad.Layout.Tabbed (simpleTabbed)
-- >
-- > myLayout = Tall ||| unEscape (mastered 0.01 0.5 $ Full ||| simpleTabbed)
--
-- you can now send a message to the inner layout with
--  @sendMessage $ escape message@, e.g.
--
-- > -- Change the inner layout
-- > ((modm .|. controlMask, xK_space), sendMessage $ escape NextLayout)
--
-- If you want unescaped messages to be handled /only/ by the enclosing
-- layout, use the 'ignore' modifier:
--
-- > myLayout = Tall ||| (ignore NextLayout $ ignore (JumpToLayout "") $
-- >                       unEscape $ mastered 0.01 0.5
-- >                         $ Full ||| simpleTabbed)
--

-- | the Ignore layout modifier. Prevents its inner layout from receiving
-- messages of a certain type.

newtype Ignore m l w = I (l w)
                    deriving (Int -> Ignore m l w -> ShowS
[Ignore m l w] -> ShowS
Ignore m l w -> String
(Int -> Ignore m l w -> ShowS)
-> (Ignore m l w -> String)
-> ([Ignore m l w] -> ShowS)
-> Show (Ignore m l w)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall m (l :: * -> *) w.
Show (l w) =>
Int -> Ignore m l w -> ShowS
forall m (l :: * -> *) w. Show (l w) => [Ignore m l w] -> ShowS
forall m (l :: * -> *) w. Show (l w) => Ignore m l w -> String
showList :: [Ignore m l w] -> ShowS
$cshowList :: forall m (l :: * -> *) w. Show (l w) => [Ignore m l w] -> ShowS
show :: Ignore m l w -> String
$cshow :: forall m (l :: * -> *) w. Show (l w) => Ignore m l w -> String
showsPrec :: Int -> Ignore m l w -> ShowS
$cshowsPrec :: forall m (l :: * -> *) w.
Show (l w) =>
Int -> Ignore m l w -> ShowS
Show, ReadPrec [Ignore m l w]
ReadPrec (Ignore m l w)
Int -> ReadS (Ignore m l w)
ReadS [Ignore m l w]
(Int -> ReadS (Ignore m l w))
-> ReadS [Ignore m l w]
-> ReadPrec (Ignore m l w)
-> ReadPrec [Ignore m l w]
-> Read (Ignore m l w)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall m (l :: * -> *) w. Read (l w) => ReadPrec [Ignore m l w]
forall m (l :: * -> *) w. Read (l w) => ReadPrec (Ignore m l w)
forall m (l :: * -> *) w. Read (l w) => Int -> ReadS (Ignore m l w)
forall m (l :: * -> *) w. Read (l w) => ReadS [Ignore m l w]
readListPrec :: ReadPrec [Ignore m l w]
$creadListPrec :: forall m (l :: * -> *) w. Read (l w) => ReadPrec [Ignore m l w]
readPrec :: ReadPrec (Ignore m l w)
$creadPrec :: forall m (l :: * -> *) w. Read (l w) => ReadPrec (Ignore m l w)
readList :: ReadS [Ignore m l w]
$creadList :: forall m (l :: * -> *) w. Read (l w) => ReadS [Ignore m l w]
readsPrec :: Int -> ReadS (Ignore m l w)
$creadsPrec :: forall m (l :: * -> *) w. Read (l w) => Int -> ReadS (Ignore m l w)
Read)

instance (Message m, LayoutClass l w) => LayoutClass (Ignore m l) w where
    runLayout :: Workspace String (Ignore m l w) w
-> Rectangle -> X ([(w, Rectangle)], Maybe (Ignore m l w))
runLayout Workspace String (Ignore m l w) w
ws Rectangle
r = (Maybe (l w) -> Maybe (Ignore m l w))
-> ([(w, Rectangle)], Maybe (l w))
-> ([(w, Rectangle)], Maybe (Ignore m l w))
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (l w -> Ignore m l w
forall m (l :: * -> *) w. l w -> Ignore m l w
I (l w -> Ignore m l w) -> Maybe (l w) -> Maybe (Ignore m l w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([(w, Rectangle)], Maybe (l w))
 -> ([(w, Rectangle)], Maybe (Ignore m l w)))
-> X ([(w, Rectangle)], Maybe (l w))
-> X ([(w, Rectangle)], Maybe (Ignore m l w))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Workspace String (l w) w
-> Rectangle -> X ([(w, Rectangle)], Maybe (l w))
forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout (Workspace String (Ignore m l w) w -> Workspace String (l w) w
forall i m (l :: * -> *) w.
Workspace i (Ignore m l w) w -> Workspace i (l w) w
unILayout Workspace String (Ignore m l w) w
ws) Rectangle
r
        where  unILayout :: Workspace i (Ignore m l w) w -> Workspace i (l w) w
               unILayout :: forall i m (l :: * -> *) w.
Workspace i (Ignore m l w) w -> Workspace i (l w) w
unILayout w :: Workspace i (Ignore m l w) w
w@Workspace{ layout :: forall i l a. Workspace i l a -> l
layout = (I l w
l) } = Workspace i (Ignore m l w) w
w { layout :: l w
layout = l w
l }
    handleMessage :: Ignore m l w -> SomeMessage -> X (Maybe (Ignore m l w))
handleMessage l :: Ignore m l w
l@(I l w
l') SomeMessage
sm
        = case SomeMessage -> Ignore m l w -> Maybe m
forall m' (l :: * -> *) w.
Message m' =>
SomeMessage -> Ignore m' l w -> Maybe m'
fromMessageAs SomeMessage
sm Ignore m l w
l of
            Just m
_ -> Maybe (Ignore m l w) -> X (Maybe (Ignore m l w))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Ignore m l w)
forall a. Maybe a
Nothing
            Maybe m
Nothing -> (l w -> Ignore m l w
forall m (l :: * -> *) w. l w -> Ignore m l w
I (l w -> Ignore m l w) -> Maybe (l w) -> Maybe (Ignore m l w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Maybe (l w) -> Maybe (Ignore m l w))
-> X (Maybe (l w)) -> X (Maybe (Ignore m l w))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> l w -> SomeMessage -> X (Maybe (l w))
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l w
l' SomeMessage
sm
        where fromMessageAs :: Message m' => SomeMessage -> Ignore m' l w -> Maybe m'
              fromMessageAs :: forall m' (l :: * -> *) w.
Message m' =>
SomeMessage -> Ignore m' l w -> Maybe m'
fromMessageAs SomeMessage
a Ignore m' l w
_ = SomeMessage -> Maybe m'
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
a
    description :: Ignore m l w -> String
description (I l w
l) = String
"Ignore "String -> ShowS
forall a. [a] -> [a] -> [a]
++l w -> String
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> String
description l w
l

-- | the UnEscape layout modifier. Listens to 'EscapedMessage's and sends
-- their nested message to the inner layout.

data UnEscape w = UE
                deriving (Int -> UnEscape w -> ShowS
[UnEscape w] -> ShowS
UnEscape w -> String
(Int -> UnEscape w -> ShowS)
-> (UnEscape w -> String)
-> ([UnEscape w] -> ShowS)
-> Show (UnEscape w)
forall w. Int -> UnEscape w -> ShowS
forall w. [UnEscape w] -> ShowS
forall w. UnEscape w -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnEscape w] -> ShowS
$cshowList :: forall w. [UnEscape w] -> ShowS
show :: UnEscape w -> String
$cshow :: forall w. UnEscape w -> String
showsPrec :: Int -> UnEscape w -> ShowS
$cshowsPrec :: forall w. Int -> UnEscape w -> ShowS
Show, ReadPrec [UnEscape w]
ReadPrec (UnEscape w)
Int -> ReadS (UnEscape w)
ReadS [UnEscape w]
(Int -> ReadS (UnEscape w))
-> ReadS [UnEscape w]
-> ReadPrec (UnEscape w)
-> ReadPrec [UnEscape w]
-> Read (UnEscape w)
forall w. ReadPrec [UnEscape w]
forall w. ReadPrec (UnEscape w)
forall w. Int -> ReadS (UnEscape w)
forall w. ReadS [UnEscape w]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [UnEscape w]
$creadListPrec :: forall w. ReadPrec [UnEscape w]
readPrec :: ReadPrec (UnEscape w)
$creadPrec :: forall w. ReadPrec (UnEscape w)
readList :: ReadS [UnEscape w]
$creadList :: forall w. ReadS [UnEscape w]
readsPrec :: Int -> ReadS (UnEscape w)
$creadsPrec :: forall w. Int -> ReadS (UnEscape w)
Read)

instance LayoutModifier UnEscape a where
    handleMessOrMaybeModifyIt :: UnEscape a
-> SomeMessage -> X (Maybe (Either (UnEscape a) SomeMessage))
handleMessOrMaybeModifyIt UnEscape a
_ SomeMessage
mess
        = Maybe (Either (UnEscape a) SomeMessage)
-> X (Maybe (Either (UnEscape a) SomeMessage))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either (UnEscape a) SomeMessage)
 -> X (Maybe (Either (UnEscape a) SomeMessage)))
-> Maybe (Either (UnEscape a) SomeMessage)
-> X (Maybe (Either (UnEscape a) SomeMessage))
forall a b. (a -> b) -> a -> b
$ case SomeMessage -> Maybe EscapedMessage
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
mess of
                     Just (Escape SomeMessage
mess') -> Either (UnEscape a) SomeMessage
-> Maybe (Either (UnEscape a) SomeMessage)
forall a. a -> Maybe a
Just (Either (UnEscape a) SomeMessage
 -> Maybe (Either (UnEscape a) SomeMessage))
-> Either (UnEscape a) SomeMessage
-> Maybe (Either (UnEscape a) SomeMessage)
forall a b. (a -> b) -> a -> b
$ SomeMessage -> Either (UnEscape a) SomeMessage
forall a b. b -> Either a b
Right SomeMessage
mess'
                     Maybe EscapedMessage
Nothing -> Maybe (Either (UnEscape a) SomeMessage)
forall a. Maybe a
Nothing


-- | Data type for an escaped message. Send with 'escape'.

newtype EscapedMessage = Escape SomeMessage
instance Message EscapedMessage


-- | Creates an 'EscapedMessage'.

escape :: Message m => m -> EscapedMessage
escape :: forall m. Message m => m -> EscapedMessage
escape = SomeMessage -> EscapedMessage
Escape (SomeMessage -> EscapedMessage)
-> (m -> SomeMessage) -> m -> EscapedMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m -> SomeMessage
forall a. Message a => a -> SomeMessage
SomeMessage


-- | Applies the UnEscape layout modifier to a layout.

unEscape :: LayoutClass l w => l w -> ModifiedLayout UnEscape l w
unEscape :: forall (l :: * -> *) w.
LayoutClass l w =>
l w -> ModifiedLayout UnEscape l w
unEscape = UnEscape w -> l w -> ModifiedLayout UnEscape l w
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout UnEscape w
forall w. UnEscape w
UE


-- | Applies the Ignore layout modifier to a layout, blocking
-- all messages of the same type as the one passed as its first argument.

ignore :: (Message m, LayoutClass l w)
          => m -> l w -> Ignore m l w
ignore :: forall m (l :: * -> *) w.
(Message m, LayoutClass l w) =>
m -> l w -> Ignore m l w
ignore m
_ = l w -> Ignore m l w
forall m (l :: * -> *) w. l w -> Ignore m l w
I