{-# LANGUAGE ExistentialQuantification, Rank2Types, FunctionalDependencies, FlexibleInstances, FlexibleContexts, PatternGuards, ScopedTypeVariables #-}
module XMonad.Layout.MultiToggle (
Transformer(..),
Toggle(..),
(??),
EOT(..),
single,
mkToggle,
mkToggle1,
isToggleActive,
HList,
HCons,
MultiToggle,
) where
import XMonad
import XMonad.Prelude hiding (find)
import XMonad.StackSet (Workspace(..))
import Control.Arrow
import Data.IORef
import Data.Typeable
class (Eq t, Typeable t) => Transformer t a | t -> a where
transform :: (LayoutClass l a) => t -> l a ->
(forall l'. (LayoutClass l' a) => l' a -> (l' a -> l a) -> b) -> b
data EL l a = forall l'. (LayoutClass l' a) => EL (l' a) (l' a -> l a)
unEL :: (LayoutClass l a) => EL l a -> (forall l'. (LayoutClass l' a) => l' a -> b) -> b
unEL :: forall (l :: * -> *) a b.
LayoutClass l a =>
EL l a
-> (forall (l' :: * -> *). LayoutClass l' a => l' a -> b) -> b
unEL (EL l' a
x l' a -> l a
_) forall (l' :: * -> *). LayoutClass l' a => l' a -> b
k = forall (l' :: * -> *). LayoutClass l' a => l' a -> b
k l' a
x
deEL :: (LayoutClass l a) => EL l a -> l a
deEL :: forall (l :: * -> *) a. LayoutClass l a => EL l a -> l a
deEL (EL l' a
x l' a -> l a
det) = l' a -> l a
det l' a
x
transform' :: (Transformer t a, LayoutClass l a) => t -> EL l a -> EL l a
transform' :: forall t a (l :: * -> *).
(Transformer t a, LayoutClass l a) =>
t -> EL l a -> EL l a
transform' t
t (EL l' a
l l' a -> l a
det) = forall t a (l :: * -> *) b.
(Transformer t a, LayoutClass l a) =>
t
-> l a
-> (forall (l' :: * -> *).
LayoutClass l' a =>
l' a -> (l' a -> l a) -> b)
-> b
transform t
t l' a
l (\l' a
l' l' a -> l' a
det' -> forall (l :: * -> *) a (l' :: * -> *).
LayoutClass l' a =>
l' a -> (l' a -> l a) -> EL l a
EL l' a
l' (l' a -> l a
det forall b c a. (b -> c) -> (a -> b) -> a -> c
. l' a -> l' a
det'))
data Toggle a = forall t. (Transformer t a) => Toggle t
instance (Typeable a) => Message (Toggle a)
data MultiToggleS ts l a = MultiToggleS (l a) (Maybe Int) ts
deriving (ReadPrec [MultiToggleS ts l a]
ReadPrec (MultiToggleS ts l a)
ReadS [MultiToggleS ts l a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall ts (l :: * -> *) a.
(Read ts, Read (l a)) =>
ReadPrec [MultiToggleS ts l a]
forall ts (l :: * -> *) a.
(Read ts, Read (l a)) =>
ReadPrec (MultiToggleS ts l a)
forall ts (l :: * -> *) a.
(Read ts, Read (l a)) =>
Int -> ReadS (MultiToggleS ts l a)
forall ts (l :: * -> *) a.
(Read ts, Read (l a)) =>
ReadS [MultiToggleS ts l a]
readListPrec :: ReadPrec [MultiToggleS ts l a]
$creadListPrec :: forall ts (l :: * -> *) a.
(Read ts, Read (l a)) =>
ReadPrec [MultiToggleS ts l a]
readPrec :: ReadPrec (MultiToggleS ts l a)
$creadPrec :: forall ts (l :: * -> *) a.
(Read ts, Read (l a)) =>
ReadPrec (MultiToggleS ts l a)
readList :: ReadS [MultiToggleS ts l a]
$creadList :: forall ts (l :: * -> *) a.
(Read ts, Read (l a)) =>
ReadS [MultiToggleS ts l a]
readsPrec :: Int -> ReadS (MultiToggleS ts l a)
$creadsPrec :: forall ts (l :: * -> *) a.
(Read ts, Read (l a)) =>
Int -> ReadS (MultiToggleS ts l a)
Read, Int -> MultiToggleS ts l a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall ts (l :: * -> *) a.
(Show ts, Show (l a)) =>
Int -> MultiToggleS ts l a -> ShowS
forall ts (l :: * -> *) a.
(Show ts, Show (l a)) =>
[MultiToggleS ts l a] -> ShowS
forall ts (l :: * -> *) a.
(Show ts, Show (l a)) =>
MultiToggleS ts l a -> String
showList :: [MultiToggleS ts l a] -> ShowS
$cshowList :: forall ts (l :: * -> *) a.
(Show ts, Show (l a)) =>
[MultiToggleS ts l a] -> ShowS
show :: MultiToggleS ts l a -> String
$cshow :: forall ts (l :: * -> *) a.
(Show ts, Show (l a)) =>
MultiToggleS ts l a -> String
showsPrec :: Int -> MultiToggleS ts l a -> ShowS
$cshowsPrec :: forall ts (l :: * -> *) a.
(Show ts, Show (l a)) =>
Int -> MultiToggleS ts l a -> ShowS
Show)
data MultiToggle ts l a = MultiToggle{
forall ts (l :: * -> *) a. MultiToggle ts l a -> EL l a
currLayout :: EL l a,
forall ts (l :: * -> *) a. MultiToggle ts l a -> Maybe Int
currIndex :: Maybe Int,
forall ts (l :: * -> *) a. MultiToggle ts l a -> ts
transformers :: ts
}
expand :: (LayoutClass l a, HList ts a) => MultiToggleS ts l a -> MultiToggle ts l a
expand :: forall (l :: * -> *) a ts.
(LayoutClass l a, HList ts a) =>
MultiToggleS ts l a -> MultiToggle ts l a
expand (MultiToggleS l a
b Maybe Int
i ts
ts) =
forall c a b.
HList c a =>
c -> Int -> b -> (forall t. Transformer t a => t -> b) -> b
resolve ts
ts (forall a. a -> Maybe a -> a
fromMaybe (-Int
1) Maybe Int
i) forall a. a -> a
id
(\t
x MultiToggle ts l a
mt ->
let g :: EL l a -> EL l a
g = forall t a (l :: * -> *).
(Transformer t a, LayoutClass l a) =>
t -> EL l a -> EL l a
transform' t
x in MultiToggle ts l a
mt{ currLayout :: EL l a
currLayout = EL l a -> EL l a
g forall a b. (a -> b) -> a -> b
$ forall ts (l :: * -> *) a. MultiToggle ts l a -> EL l a
currLayout MultiToggle ts l a
mt }
)
(forall ts (l :: * -> *) a.
EL l a -> Maybe Int -> ts -> MultiToggle ts l a
MultiToggle (forall (l :: * -> *) a (l' :: * -> *).
LayoutClass l' a =>
l' a -> (l' a -> l a) -> EL l a
EL l a
b forall a. a -> a
id) Maybe Int
i ts
ts)
collapse :: (LayoutClass l a) => MultiToggle ts l a -> MultiToggleS ts l a
collapse :: forall (l :: * -> *) a ts.
LayoutClass l a =>
MultiToggle ts l a -> MultiToggleS ts l a
collapse MultiToggle ts l a
mt = forall ts (l :: * -> *) a.
l a -> Maybe Int -> ts -> MultiToggleS ts l a
MultiToggleS (forall (l :: * -> *) a. LayoutClass l a => EL l a -> l a
deEL (forall ts (l :: * -> *) a. MultiToggle ts l a -> EL l a
currLayout MultiToggle ts l a
mt)) (forall ts (l :: * -> *) a. MultiToggle ts l a -> Maybe Int
currIndex MultiToggle ts l a
mt) (forall ts (l :: * -> *) a. MultiToggle ts l a -> ts
transformers MultiToggle ts l a
mt)
instance (LayoutClass l a, Read (l a), HList ts a, Read ts) => Read (MultiToggle ts l a) where
readsPrec :: Int -> ReadS (MultiToggle ts l a)
readsPrec Int
p String
s = forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall (l :: * -> *) a ts.
(LayoutClass l a, HList ts a) =>
MultiToggleS ts l a -> MultiToggle ts l a
expand) forall a b. (a -> b) -> a -> b
$ forall a. Read a => Int -> ReadS a
readsPrec Int
p String
s
instance (Show ts, Show (l a), LayoutClass l a) => Show (MultiToggle ts l a) where
showsPrec :: Int -> MultiToggle ts l a -> ShowS
showsPrec Int
p = forall a. Show a => Int -> a -> ShowS
showsPrec Int
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (l :: * -> *) a ts.
LayoutClass l a =>
MultiToggle ts l a -> MultiToggleS ts l a
collapse
mkToggle :: (LayoutClass l a) => ts -> l a -> MultiToggle ts l a
mkToggle :: forall (l :: * -> *) a ts.
LayoutClass l a =>
ts -> l a -> MultiToggle ts l a
mkToggle ts
ts l a
l = forall ts (l :: * -> *) a.
EL l a -> Maybe Int -> ts -> MultiToggle ts l a
MultiToggle (forall (l :: * -> *) a (l' :: * -> *).
LayoutClass l' a =>
l' a -> (l' a -> l a) -> EL l a
EL l a
l forall a. a -> a
id) forall a. Maybe a
Nothing ts
ts
mkToggle1 :: (LayoutClass l a) => t -> l a -> MultiToggle (HCons t EOT) l a
mkToggle1 :: forall (l :: * -> *) a t.
LayoutClass l a =>
t -> l a -> MultiToggle (HCons t EOT) l a
mkToggle1 t
t = forall (l :: * -> *) a ts.
LayoutClass l a =>
ts -> l a -> MultiToggle ts l a
mkToggle (forall a. a -> HCons a EOT
single t
t)
data EOT = EOT deriving (ReadPrec [EOT]
ReadPrec EOT
Int -> ReadS EOT
ReadS [EOT]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [EOT]
$creadListPrec :: ReadPrec [EOT]
readPrec :: ReadPrec EOT
$creadPrec :: ReadPrec EOT
readList :: ReadS [EOT]
$creadList :: ReadS [EOT]
readsPrec :: Int -> ReadS EOT
$creadsPrec :: Int -> ReadS EOT
Read, Int -> EOT -> ShowS
[EOT] -> ShowS
EOT -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EOT] -> ShowS
$cshowList :: [EOT] -> ShowS
show :: EOT -> String
$cshow :: EOT -> String
showsPrec :: Int -> EOT -> ShowS
$cshowsPrec :: Int -> EOT -> ShowS
Show)
data HCons a b = HCons a b deriving (ReadPrec [HCons a b]
ReadPrec (HCons a b)
ReadS [HCons a b]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall a b. (Read a, Read b) => ReadPrec [HCons a b]
forall a b. (Read a, Read b) => ReadPrec (HCons a b)
forall a b. (Read a, Read b) => Int -> ReadS (HCons a b)
forall a b. (Read a, Read b) => ReadS [HCons a b]
readListPrec :: ReadPrec [HCons a b]
$creadListPrec :: forall a b. (Read a, Read b) => ReadPrec [HCons a b]
readPrec :: ReadPrec (HCons a b)
$creadPrec :: forall a b. (Read a, Read b) => ReadPrec (HCons a b)
readList :: ReadS [HCons a b]
$creadList :: forall a b. (Read a, Read b) => ReadS [HCons a b]
readsPrec :: Int -> ReadS (HCons a b)
$creadsPrec :: forall a b. (Read a, Read b) => Int -> ReadS (HCons a b)
Read, Int -> HCons a b -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show a, Show b) => Int -> HCons a b -> ShowS
forall a b. (Show a, Show b) => [HCons a b] -> ShowS
forall a b. (Show a, Show b) => HCons a b -> String
showList :: [HCons a b] -> ShowS
$cshowList :: forall a b. (Show a, Show b) => [HCons a b] -> ShowS
show :: HCons a b -> String
$cshow :: forall a b. (Show a, Show b) => HCons a b -> String
showsPrec :: Int -> HCons a b -> ShowS
$cshowsPrec :: forall a b. (Show a, Show b) => Int -> HCons a b -> ShowS
Show)
infixr 0 ??
(??) :: a -> b -> HCons a b
?? :: forall a b. a -> b -> HCons a b
(??) = forall a b. a -> b -> HCons a b
HCons
single :: a -> HCons a EOT
single :: forall a. a -> HCons a EOT
single = (forall a b. a -> b -> HCons a b
?? EOT
EOT)
class HList c a where
find :: (Transformer t a) => c -> t -> Maybe Int
resolve :: c -> Int -> b -> (forall t. (Transformer t a) => t -> b) -> b
instance HList EOT w where
find :: forall t. Transformer t w => EOT -> t -> Maybe Int
find EOT
EOT t
_ = forall a. Maybe a
Nothing
resolve :: forall b.
EOT -> Int -> b -> (forall t. Transformer t w => t -> b) -> b
resolve EOT
EOT Int
_ b
d forall t. Transformer t w => t -> b
_ = b
d
instance (Transformer a w, HList b w) => HList (HCons a b) w where
find :: forall t. Transformer t w => HCons a b -> t -> Maybe Int
find (HCons a
x b
xs) t
t
| t
t forall a b. (Typeable a, Eq a, Typeable b) => a -> b -> Bool
`geq` a
x = forall a. a -> Maybe a
Just Int
0
| Bool
otherwise = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Enum a => a -> a
succ (forall c a t. (HList c a, Transformer t a) => c -> t -> Maybe Int
find b
xs t
t)
resolve :: forall b.
HCons a b -> Int -> b -> (forall t. Transformer t w => t -> b) -> b
resolve (HCons a
x b
xs) Int
n b
d forall t. Transformer t w => t -> b
k =
case Int
n forall a. Ord a => a -> a -> Ordering
`compare` Int
0 of
Ordering
LT -> b
d
Ordering
EQ -> forall t. Transformer t w => t -> b
k a
x
Ordering
GT -> forall c a b.
HList c a =>
c -> Int -> b -> (forall t. Transformer t a => t -> b) -> b
resolve b
xs (forall a. Enum a => a -> a
pred Int
n) b
d forall t. Transformer t w => t -> b
k
geq :: (Typeable a, Eq a, Typeable b) => a -> b -> Bool
geq :: forall a b. (Typeable a, Eq a, Typeable b) => a -> b -> Bool
geq a
a b
b = forall a. a -> Maybe a
Just a
a forall a. Eq a => a -> a -> Bool
== forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
b
instance (Typeable a, Show ts, Typeable ts, HList ts a, LayoutClass l a) => LayoutClass (MultiToggle ts l) a where
description :: MultiToggle ts l a -> String
description MultiToggle ts l a
mt = forall ts (l :: * -> *) a. MultiToggle ts l a -> EL l a
currLayout MultiToggle ts l a
mt forall (l :: * -> *) a b.
LayoutClass l a =>
EL l a
-> (forall (l' :: * -> *). LayoutClass l' a => l' a -> b) -> b
`unEL` \l' a
l -> forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> String
description l' a
l
runLayout :: Workspace String (MultiToggle ts l a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (MultiToggle ts l a))
runLayout (Workspace String
i MultiToggle ts l a
mt Maybe (Stack a)
s) Rectangle
r = case forall ts (l :: * -> *) a. MultiToggle ts l a -> EL l a
currLayout MultiToggle ts l a
mt of
EL l' a
l l' a -> l a
det -> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ (\l' a
x -> MultiToggle ts l a
mt { currLayout :: EL l a
currLayout = forall (l :: * -> *) a (l' :: * -> *).
LayoutClass l' a =>
l' a -> (l' a -> l a) -> EL l a
EL l' a
x l' a -> l a
det })) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout (forall i l a. i -> l -> Maybe (Stack a) -> Workspace i l a
Workspace String
i l' a
l Maybe (Stack a)
s) Rectangle
r
handleMessage :: MultiToggle ts l a -> SomeMessage -> X (Maybe (MultiToggle ts l a))
handleMessage MultiToggle ts l a
mt SomeMessage
m
| Just (Toggle t
t) <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m
, i :: Maybe Int
i@(Just Int
_) <- forall c a t. (HList c a, Transformer t a) => c -> t -> Maybe Int
find (forall ts (l :: * -> *) a. MultiToggle ts l a -> ts
transformers MultiToggle ts l a
mt) t
t
= case forall ts (l :: * -> *) a. MultiToggle ts l a -> EL l a
currLayout MultiToggle ts l a
mt of
EL l' a
l l' a -> l a
det -> do
l' a
l' <- forall a. a -> Maybe a -> a
fromMaybe l' a
l forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l' a
l (forall a. Message a => a -> SomeMessage
SomeMessage LayoutMessages
ReleaseResources)
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
MultiToggle ts l a
mt {
currLayout :: EL l a
currLayout = (if Bool
cur then forall a. a -> a
id else forall t a (l :: * -> *).
(Transformer t a, LayoutClass l a) =>
t -> EL l a -> EL l a
transform' t
t) (forall (l :: * -> *) a (l' :: * -> *).
LayoutClass l' a =>
l' a -> (l' a -> l a) -> EL l a
EL (l' a -> l a
det l' a
l') forall a. a -> a
id),
currIndex :: Maybe Int
currIndex = if Bool
cur then forall a. Maybe a
Nothing else Maybe Int
i
}
where cur :: Bool
cur = Maybe Int
i forall a. Eq a => a -> a -> Bool
== forall ts (l :: * -> *) a. MultiToggle ts l a -> Maybe Int
currIndex MultiToggle ts l a
mt
| Just (MultiToggleActiveQueryMessage t
t IORef (Maybe Bool)
ref :: MultiToggleActiveQueryMessage a) <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m
, i :: Maybe Int
i@(Just Int
_) <- forall c a t. (HList c a, Transformer t a) => c -> t -> Maybe Int
find (forall ts (l :: * -> *) a. MultiToggle ts l a -> ts
transformers MultiToggle ts l a
mt) t
t
= forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Bool)
ref (forall a. a -> Maybe a
Just (Maybe Int
i forall a. Eq a => a -> a -> Bool
== forall ts (l :: * -> *) a. MultiToggle ts l a -> Maybe Int
currIndex MultiToggle ts l a
mt)))
| Bool
otherwise
= case forall ts (l :: * -> *) a. MultiToggle ts l a -> EL l a
currLayout MultiToggle ts l a
mt of
EL l' a
l l' a -> l a
det -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\l' a
x -> MultiToggle ts l a
mt { currLayout :: EL l a
currLayout = forall (l :: * -> *) a (l' :: * -> *).
LayoutClass l' a =>
l' a -> (l' a -> l a) -> EL l a
EL l' a
x l' a -> l a
det }) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> X (Maybe (layout a))
handleMessage l' a
l SomeMessage
m
data MultiToggleActiveQueryMessage a = forall t. (Transformer t a) =>
MultiToggleActiveQueryMessage t (IORef (Maybe Bool))
instance (Typeable a) => Message (MultiToggleActiveQueryMessage a)
isToggleActive :: Transformer t Window => t -> WindowSpace -> X (Maybe Bool)
isToggleActive :: forall t.
Transformer t Window =>
t -> WindowSpace -> X (Maybe Bool)
isToggleActive t
t WindowSpace
w = do
IORef (Maybe Bool)
ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
forall a. Message a => a -> WindowSpace -> X ()
sendMessageWithNoRefresh (forall a t.
Transformer t a =>
t -> IORef (Maybe Bool) -> MultiToggleActiveQueryMessage a
MultiToggleActiveQueryMessage t
t IORef (Maybe Bool)
ref) WindowSpace
w
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef (Maybe Bool)
ref