1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
{-# OPTIONS_GHC -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module : XMonad.Layout.MultiToggle
-- Copyright : (c) Lukas Mai
-- License : BSD-style (see LICENSE)
--
-- Maintainer : <l.mai@web.de>
-- Stability : unstable
-- Portability : unportable
module XMonad.Layout.MultiToggle (
EL(..),
unEL,
LayoutTransformer(..),
Toggle(..),
(.*.),
HNil(..),
mkToggle
) where
import XMonad
import Control.Arrow
import Data.Typeable
import Data.Maybe
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
class (Eq t, Typeable t) => LayoutTransformer t a | t -> a where
transform :: t -> EL a -> EL a
data Toggle a = forall t. (LayoutTransformer 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
data HNil = HNil deriving (Read, Show)
data HCons a b = HCons a b deriving (Read, Show)
infixr 0 .*.
(.*.) :: (HList b w) => a -> b -> HCons a b
(.*.) = HCons
class HList c a where
find :: (LayoutTransformer t a) => c -> t -> Maybe Int
resolve :: c -> Int -> b -> (forall t. (LayoutTransformer t a) => t -> b) -> b
instance HList HNil w where
find HNil _ = Nothing
resolve HNil _ d _ = d
instance (LayoutTransformer 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 _ = "MultiToggle"
pureLayout mt r s = currLayout mt `unEL` \l -> pureLayout l r s
doLayout mt r s = currLayout mt `unEL` \l -> acceptChange mt (fmap . fmap) (doLayout l r s)
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' }
|
