module XMonad.Layout.MultiToggle (
Transformer(..),
Toggle(..),
(??),
EOT(..),
single,
mkToggle,
mkToggle1
) where
import XMonad
import XMonad.StackSet (Workspace(..))
import Control.Arrow
import Data.Typeable
import Data.Maybe
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 -> b) -> b
data EL a = forall l. (LayoutClass l a) => EL (l a)
unEL :: EL a -> (forall l. (LayoutClass l a) => l a -> b) -> b
unEL (EL x) k = k x
transform' :: (Transformer t a) => t -> EL a -> EL a
transform' t el = el `unEL` \l -> transform t l EL
data Toggle a = forall t. (Transformer t a) => Toggle t
deriving (Typeable)
instance (Typeable a) => Message (Toggle a)
data MultiToggleS ts l a = MultiToggleS (l a) (Maybe Int) ts
deriving (Read, Show)
data MultiToggle ts l a = MultiToggle{
baseLayout :: l a,
currLayout :: EL a,
currIndex :: Maybe Int,
currTrans :: EL a -> EL a,
transformers :: ts
}
expand :: (LayoutClass l a, HList ts a) => MultiToggleS ts l a -> MultiToggle ts l a
expand (MultiToggleS b i ts) =
resolve ts (fromMaybe (1) i) id
(\x mt ->
let g = transform' x in
mt{
currLayout = g . EL $ baseLayout mt,
currTrans = g
}
)
(MultiToggle b (EL b) i id ts)
collapse :: MultiToggle ts l a -> MultiToggleS ts l a
collapse mt = MultiToggleS (baseLayout mt) (currIndex mt) (transformers mt)
instance (LayoutClass l a, Read (l a), HList ts a, Read ts) => Read (MultiToggle ts l a) where
readsPrec p s = map (first expand) $ readsPrec p s
instance (Show ts, Show (l a)) => Show (MultiToggle ts l a) where
showsPrec p = showsPrec p . collapse
mkToggle :: (LayoutClass l a) => ts -> l a -> MultiToggle ts l a
mkToggle ts l = MultiToggle l (EL l) Nothing id ts
mkToggle1 :: (LayoutClass l a) => t -> l a -> MultiToggle (HCons t EOT) l a
mkToggle1 t = mkToggle (single t)
data EOT = EOT deriving (Read, Show)
data HCons a b = HCons a b deriving (Read, Show)
infixr 0 ??
(??) :: (HList b w) => a -> b -> HCons a b
(??) = HCons
single :: a -> HCons a EOT
single = (?? 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 EOT _ = Nothing
resolve EOT _ d _ = d
instance (Transformer a w, HList b w) => HList (HCons a b) w where
find (HCons x xs) t
| t `geq` x = Just 0
| otherwise = fmap succ (find xs t)
resolve (HCons x xs) n d k =
case n `compare` 0 of
LT -> d
EQ -> k x
GT -> resolve xs (pred n) d k
geq :: (Typeable a, Eq a, Typeable b) => a -> b -> Bool
geq a b = Just a == cast b
acceptChange :: (LayoutClass l' a) => MultiToggle ts l a -> ((l' a -> MultiToggle ts l a) -> b -> c) -> X b -> X c
acceptChange mt f = fmap (f (\x -> mt{ currLayout = EL x }))
instance (Typeable a, Show ts, HList ts a, LayoutClass l a) => LayoutClass (MultiToggle ts l) a where
description mt = currLayout mt `unEL` \l -> description l
runLayout (Workspace i mt s) r
| isNothing (currIndex mt) =
acceptChange mt (fmap . fmap . \f x -> (f x){ baseLayout = x }) $ runLayout (Workspace i (baseLayout mt) s) r
| otherwise = currLayout mt `unEL` \l ->
acceptChange mt (fmap . fmap) $ runLayout (Workspace i l s) r
handleMessage mt m
| Just (Toggle t) <- fromMessage m
, i@(Just _) <- find (transformers mt) t
= currLayout mt `unEL` \l ->
if i == currIndex mt
then do
handleMessage l (SomeMessage ReleaseResources)
return . Just $
mt{
currLayout = EL $ baseLayout mt,
currIndex = Nothing,
currTrans = id
}
else do
handleMessage l (SomeMessage ReleaseResources)
let f = transform' t
return . Just $
mt{
currLayout = f . EL $ baseLayout mt,
currIndex = i,
currTrans = f
}
| fromMessage m == Just ReleaseResources ||
fromMessage m == Just Hide
= currLayout mt `unEL` \l -> acceptChange mt fmap (handleMessage l m)
| otherwise = do
ml <- handleMessage (baseLayout mt) m
case ml of
Nothing -> return Nothing
Just b' -> currLayout mt `unEL` \l -> do
handleMessage l (SomeMessage ReleaseResources)
return . Just $
mt{ baseLayout = b', currLayout = currTrans mt . EL $ b' }