{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TupleSections #-}
module XMonad.Layout.LayoutModifier (
LayoutModifier(..), ModifiedLayout(..)
) where
import XMonad.Prelude
import XMonad
import XMonad.StackSet ( Stack, Workspace (..) )
class (Show (m a), Read (m a)) => LayoutModifier m a where
modifyLayout :: (LayoutClass l a) =>
m a
-> Workspace WorkspaceId (l a) a
-> Rectangle
-> X ([(a, Rectangle)], Maybe (l a))
modifyLayout m a
_ Workspace WorkspaceId (l a) a
w Rectangle
r = Workspace WorkspaceId (l a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (l a))
forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace WorkspaceId (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout Workspace WorkspaceId (l a) a
w Rectangle
r
modifyLayoutWithUpdate :: (LayoutClass l a) =>
m a
-> Workspace WorkspaceId (l a) a
-> Rectangle
-> X (([(a,Rectangle)], Maybe (l a)), Maybe (m a))
modifyLayoutWithUpdate m a
m Workspace WorkspaceId (l a) a
w Rectangle
r = (, Maybe (m a)
forall a. Maybe a
Nothing) (([(a, Rectangle)], Maybe (l a))
-> (([(a, Rectangle)], Maybe (l a)), Maybe (m a)))
-> X ([(a, Rectangle)], Maybe (l a))
-> X (([(a, Rectangle)], Maybe (l a)), Maybe (m a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
-> Workspace WorkspaceId (l a) a
-> Rectangle
-> X ([(a, Rectangle)], Maybe (l a))
forall (m :: * -> *) a (l :: * -> *).
(LayoutModifier m a, LayoutClass l a) =>
m a
-> Workspace WorkspaceId (l a) a
-> Rectangle
-> X ([(a, Rectangle)], Maybe (l a))
modifyLayout m a
m Workspace WorkspaceId (l a) a
w Rectangle
r
handleMess :: m a -> SomeMessage -> X (Maybe (m a))
handleMess m a
m SomeMessage
mess | Just LayoutMessages
Hide <- SomeMessage -> Maybe LayoutMessages
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
mess = X (Maybe (m a))
forall a. X (Maybe a)
doUnhook
| Just LayoutMessages
ReleaseResources <- SomeMessage -> Maybe LayoutMessages
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
mess = X (Maybe (m a))
forall a. X (Maybe a)
doUnhook
| Bool
otherwise = Maybe (m a) -> X (Maybe (m a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (m a) -> X (Maybe (m a))) -> Maybe (m a) -> X (Maybe (m a))
forall a b. (a -> b) -> a -> b
$ m a -> SomeMessage -> Maybe (m a)
forall (m :: * -> *) a.
LayoutModifier m a =>
m a -> SomeMessage -> Maybe (m a)
pureMess m a
m SomeMessage
mess
where doUnhook :: X (Maybe a)
doUnhook = do m a -> X ()
forall (m :: * -> *) a. LayoutModifier m a => m a -> X ()
unhook m a
m; Maybe a -> X (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
handleMessOrMaybeModifyIt :: m a -> SomeMessage -> X (Maybe (Either (m a) SomeMessage))
handleMessOrMaybeModifyIt m a
m SomeMessage
mess = do Maybe (m a)
mm' <- m a -> SomeMessage -> X (Maybe (m a))
forall (m :: * -> *) a.
LayoutModifier m a =>
m a -> SomeMessage -> X (Maybe (m a))
handleMess m a
m SomeMessage
mess
Maybe (Either (m a) SomeMessage)
-> X (Maybe (Either (m a) SomeMessage))
forall (m :: * -> *) a. Monad m => a -> m a
return (m a -> Either (m a) SomeMessage
forall a b. a -> Either a b
Left (m a -> Either (m a) SomeMessage)
-> Maybe (m a) -> Maybe (Either (m a) SomeMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (m a)
mm')
pureMess :: m a -> SomeMessage -> Maybe (m a)
pureMess m a
_ SomeMessage
_ = Maybe (m a)
forall a. Maybe a
Nothing
redoLayout :: m a
-> Rectangle
-> Maybe (Stack a)
-> [(a, Rectangle)]
-> X ([(a, Rectangle)], Maybe (m a))
redoLayout m a
m Rectangle
r Maybe (Stack a)
ms [(a, Rectangle)]
wrs = do m a -> X ()
forall (m :: * -> *) a. LayoutModifier m a => m a -> X ()
hook m a
m; ([(a, Rectangle)], Maybe (m a))
-> X ([(a, Rectangle)], Maybe (m a))
forall (m :: * -> *) a. Monad m => a -> m a
return (([(a, Rectangle)], Maybe (m a))
-> X ([(a, Rectangle)], Maybe (m a)))
-> ([(a, Rectangle)], Maybe (m a))
-> X ([(a, Rectangle)], Maybe (m a))
forall a b. (a -> b) -> a -> b
$ m a
-> Rectangle
-> Maybe (Stack a)
-> [(a, Rectangle)]
-> ([(a, Rectangle)], Maybe (m a))
forall (m :: * -> *) a.
LayoutModifier m a =>
m a
-> Rectangle
-> Maybe (Stack a)
-> [(a, Rectangle)]
-> ([(a, Rectangle)], Maybe (m a))
pureModifier m a
m Rectangle
r Maybe (Stack a)
ms [(a, Rectangle)]
wrs
pureModifier :: m a
-> Rectangle
-> Maybe (Stack a)
-> [(a, Rectangle)]
-> ([(a, Rectangle)], Maybe (m a))
pureModifier m a
_ Rectangle
_ Maybe (Stack a)
_ [(a, Rectangle)]
wrs = ([(a, Rectangle)]
wrs, Maybe (m a)
forall a. Maybe a
Nothing)
hook :: m a -> X ()
hook m a
_ = () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
unhook :: m a -> X ()
unhook m a
_ = () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
modifierDescription :: m a -> String
modifierDescription = WorkspaceId -> m a -> WorkspaceId
forall a b. a -> b -> a
const WorkspaceId
""
modifyDescription :: (LayoutClass l a) => m a -> l a -> String
modifyDescription m a
m l a
l = m a -> WorkspaceId
forall (m :: * -> *) a. LayoutModifier m a => m a -> WorkspaceId
modifierDescription m a
m WorkspaceId -> WorkspaceId -> WorkspaceId
`add` l a -> WorkspaceId
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> WorkspaceId
description l a
l
where WorkspaceId
"" add :: WorkspaceId -> WorkspaceId -> WorkspaceId
`add` WorkspaceId
x = WorkspaceId
x
WorkspaceId
x `add` WorkspaceId
y = WorkspaceId
x WorkspaceId -> WorkspaceId -> WorkspaceId
forall a. [a] -> [a] -> [a]
++ WorkspaceId
" " WorkspaceId -> WorkspaceId -> WorkspaceId
forall a. [a] -> [a] -> [a]
++ WorkspaceId
y
instance (LayoutModifier m a, LayoutClass l a, Typeable m) => LayoutClass (ModifiedLayout m l) a where
runLayout :: Workspace WorkspaceId (ModifiedLayout m l a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (ModifiedLayout m l a))
runLayout (Workspace WorkspaceId
i (ModifiedLayout m a
m l a
l) Maybe (Stack a)
ms) Rectangle
r =
do (([(a, Rectangle)]
ws, Maybe (l a)
ml'),Maybe (m a)
mm') <- m a
-> Workspace WorkspaceId (l a) a
-> Rectangle
-> X (([(a, Rectangle)], Maybe (l a)), Maybe (m a))
forall (m :: * -> *) a (l :: * -> *).
(LayoutModifier m a, LayoutClass l a) =>
m a
-> Workspace WorkspaceId (l a) a
-> Rectangle
-> X (([(a, Rectangle)], Maybe (l a)), Maybe (m a))
modifyLayoutWithUpdate m a
m (WorkspaceId
-> l a -> Maybe (Stack a) -> Workspace WorkspaceId (l a) a
forall i l a. i -> l -> Maybe (Stack a) -> Workspace i l a
Workspace WorkspaceId
i l a
l Maybe (Stack a)
ms) Rectangle
r
([(a, Rectangle)]
ws', Maybe (m a)
mm'') <- m a
-> Rectangle
-> Maybe (Stack a)
-> [(a, Rectangle)]
-> X ([(a, Rectangle)], Maybe (m a))
forall (m :: * -> *) a.
LayoutModifier m a =>
m a
-> Rectangle
-> Maybe (Stack a)
-> [(a, Rectangle)]
-> X ([(a, Rectangle)], Maybe (m a))
redoLayout (m a -> Maybe (m a) -> m a
forall a. a -> Maybe a -> a
fromMaybe m a
m Maybe (m a)
mm') Rectangle
r Maybe (Stack a)
ms [(a, Rectangle)]
ws
let ml'' :: Maybe (ModifiedLayout m l a)
ml'' = case Maybe (m a)
mm'' Maybe (m a) -> Maybe (m a) -> Maybe (m a)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe (m a)
mm' of
Just m a
m' -> ModifiedLayout m l a -> Maybe (ModifiedLayout m l a)
forall a. a -> Maybe a
Just (ModifiedLayout m l a -> Maybe (ModifiedLayout m l a))
-> ModifiedLayout m l a -> Maybe (ModifiedLayout m l a)
forall a b. (a -> b) -> a -> b
$ m a -> l a -> ModifiedLayout m l a
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout m a
m' (l a -> ModifiedLayout m l a) -> l a -> ModifiedLayout m l a
forall a b. (a -> b) -> a -> b
$ l a -> Maybe (l a) -> l a
forall a. a -> Maybe a -> a
fromMaybe l a
l Maybe (l a)
ml'
Maybe (m a)
Nothing -> m a -> l a -> ModifiedLayout m l a
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout m a
m (l a -> ModifiedLayout m l a)
-> Maybe (l a) -> Maybe (ModifiedLayout m l a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (l a)
ml'
([(a, Rectangle)], Maybe (ModifiedLayout m l a))
-> X ([(a, Rectangle)], Maybe (ModifiedLayout m l a))
forall (m :: * -> *) a. Monad m => a -> m a
return ([(a, Rectangle)]
ws', Maybe (ModifiedLayout m l a)
ml'')
handleMessage :: ModifiedLayout m l a
-> SomeMessage -> X (Maybe (ModifiedLayout m l a))
handleMessage (ModifiedLayout m a
m l a
l) SomeMessage
mess =
do Maybe (Either (m a) SomeMessage)
mm' <- m a -> SomeMessage -> X (Maybe (Either (m a) SomeMessage))
forall (m :: * -> *) a.
LayoutModifier m a =>
m a -> SomeMessage -> X (Maybe (Either (m a) SomeMessage))
handleMessOrMaybeModifyIt m a
m SomeMessage
mess
Maybe (l a)
ml' <- case Maybe (Either (m a) SomeMessage)
mm' of
Just (Right SomeMessage
mess') -> l a -> SomeMessage -> X (Maybe (l a))
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l a
l SomeMessage
mess'
Maybe (Either (m a) SomeMessage)
_ -> l a -> SomeMessage -> X (Maybe (l a))
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l a
l SomeMessage
mess
Maybe (ModifiedLayout m l a) -> X (Maybe (ModifiedLayout m l a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ModifiedLayout m l a) -> X (Maybe (ModifiedLayout m l a)))
-> Maybe (ModifiedLayout m l a) -> X (Maybe (ModifiedLayout m l a))
forall a b. (a -> b) -> a -> b
$ case Maybe (Either (m a) SomeMessage)
mm' of
Just (Left m a
m') -> ModifiedLayout m l a -> Maybe (ModifiedLayout m l a)
forall a. a -> Maybe a
Just (ModifiedLayout m l a -> Maybe (ModifiedLayout m l a))
-> ModifiedLayout m l a -> Maybe (ModifiedLayout m l a)
forall a b. (a -> b) -> a -> b
$ m a -> l a -> ModifiedLayout m l a
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout m a
m' (l a -> ModifiedLayout m l a) -> l a -> ModifiedLayout m l a
forall a b. (a -> b) -> a -> b
$ l a -> Maybe (l a) -> l a
forall a. a -> Maybe a -> a
fromMaybe l a
l Maybe (l a)
ml'
Maybe (Either (m a) SomeMessage)
_ -> m a -> l a -> ModifiedLayout m l a
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout m a
m (l a -> ModifiedLayout m l a)
-> Maybe (l a) -> Maybe (ModifiedLayout m l a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (l a)
ml'
description :: ModifiedLayout m l a -> WorkspaceId
description (ModifiedLayout m a
m l a
l) = m a -> l a -> WorkspaceId
forall (m :: * -> *) a (l :: * -> *).
(LayoutModifier m a, LayoutClass l a) =>
m a -> l a -> WorkspaceId
modifyDescription m a
m l a
l
data ModifiedLayout m l a = ModifiedLayout (m a) (l a) deriving ( ReadPrec [ModifiedLayout m l a]
ReadPrec (ModifiedLayout m l a)
Int -> ReadS (ModifiedLayout m l a)
ReadS [ModifiedLayout m l a]
(Int -> ReadS (ModifiedLayout m l a))
-> ReadS [ModifiedLayout m l a]
-> ReadPrec (ModifiedLayout m l a)
-> ReadPrec [ModifiedLayout m l a]
-> Read (ModifiedLayout m l a)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall (m :: * -> *) (l :: * -> *) a.
(Read (m a), Read (l a)) =>
ReadPrec [ModifiedLayout m l a]
forall (m :: * -> *) (l :: * -> *) a.
(Read (m a), Read (l a)) =>
ReadPrec (ModifiedLayout m l a)
forall (m :: * -> *) (l :: * -> *) a.
(Read (m a), Read (l a)) =>
Int -> ReadS (ModifiedLayout m l a)
forall (m :: * -> *) (l :: * -> *) a.
(Read (m a), Read (l a)) =>
ReadS [ModifiedLayout m l a]
readListPrec :: ReadPrec [ModifiedLayout m l a]
$creadListPrec :: forall (m :: * -> *) (l :: * -> *) a.
(Read (m a), Read (l a)) =>
ReadPrec [ModifiedLayout m l a]
readPrec :: ReadPrec (ModifiedLayout m l a)
$creadPrec :: forall (m :: * -> *) (l :: * -> *) a.
(Read (m a), Read (l a)) =>
ReadPrec (ModifiedLayout m l a)
readList :: ReadS [ModifiedLayout m l a]
$creadList :: forall (m :: * -> *) (l :: * -> *) a.
(Read (m a), Read (l a)) =>
ReadS [ModifiedLayout m l a]
readsPrec :: Int -> ReadS (ModifiedLayout m l a)
$creadsPrec :: forall (m :: * -> *) (l :: * -> *) a.
(Read (m a), Read (l a)) =>
Int -> ReadS (ModifiedLayout m l a)
Read, Int -> ModifiedLayout m l a -> WorkspaceId -> WorkspaceId
[ModifiedLayout m l a] -> WorkspaceId -> WorkspaceId
ModifiedLayout m l a -> WorkspaceId
(Int -> ModifiedLayout m l a -> WorkspaceId -> WorkspaceId)
-> (ModifiedLayout m l a -> WorkspaceId)
-> ([ModifiedLayout m l a] -> WorkspaceId -> WorkspaceId)
-> Show (ModifiedLayout m l a)
forall a.
(Int -> a -> WorkspaceId -> WorkspaceId)
-> (a -> WorkspaceId)
-> ([a] -> WorkspaceId -> WorkspaceId)
-> Show a
forall (m :: * -> *) (l :: * -> *) a.
(Show (m a), Show (l a)) =>
Int -> ModifiedLayout m l a -> WorkspaceId -> WorkspaceId
forall (m :: * -> *) (l :: * -> *) a.
(Show (m a), Show (l a)) =>
[ModifiedLayout m l a] -> WorkspaceId -> WorkspaceId
forall (m :: * -> *) (l :: * -> *) a.
(Show (m a), Show (l a)) =>
ModifiedLayout m l a -> WorkspaceId
showList :: [ModifiedLayout m l a] -> WorkspaceId -> WorkspaceId
$cshowList :: forall (m :: * -> *) (l :: * -> *) a.
(Show (m a), Show (l a)) =>
[ModifiedLayout m l a] -> WorkspaceId -> WorkspaceId
show :: ModifiedLayout m l a -> WorkspaceId
$cshow :: forall (m :: * -> *) (l :: * -> *) a.
(Show (m a), Show (l a)) =>
ModifiedLayout m l a -> WorkspaceId
showsPrec :: Int -> ModifiedLayout m l a -> WorkspaceId -> WorkspaceId
$cshowsPrec :: forall (m :: * -> *) (l :: * -> *) a.
(Show (m a), Show (l a)) =>
Int -> ModifiedLayout m l a -> WorkspaceId -> WorkspaceId
Show )