aboutsummaryrefslogtreecommitdiffstats
path: root/XMonad/Layout/ZoomRow.hs
blob: 8c0989542137cca1df8fbb1629c7cc144a318724 (plain) (blame)
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
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds #-}
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses
  , PatternGuards, DeriveDataTypeable, ExistentialQuantification
  , FlexibleContexts #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.ZoomRow
-- Copyright   :  Quentin Moser <moserq@gmail.com>
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Quentin Moser <moserq@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- Row layout with individually resizable elements.
--
-----------------------------------------------------------------------------

module XMonad.Layout.ZoomRow ( -- * Usage
                               -- $usage
                               ZoomRow
                               -- * Creation
                             , zoomRow
                               -- * Messages
                             , ZoomMessage(..)
                             , zoomIn
                             , zoomOut
                             , zoomReset
                               -- * Use with non-'Eq' elements
                               -- $noneq
                             , zoomRowWith
                             , EQF(..)
                             , ClassEQ(..)
                             ) where

import XMonad
import qualified XMonad.StackSet as W

import XMonad.Util.Stack
import XMonad.Layout.Decoration (fi)

import Data.Maybe (fromMaybe)
import Control.Arrow (second)
 
-- $usage
-- This module provides a layout which places all windows in a single
-- row; the size occupied by each individual window can be increased
-- and decreased, and a window can be set to use the whole available
-- space whenever it has focus.
--
-- You can use this module by including  the following in your @~\/.xmonad/xmonad.hs@:
--
-- > import XMonad.Layout.ZoomRow
--
-- and using 'zoomRow' somewhere in your 'layoutHook', for example:
--
-- > myLayout = zoomRow ||| Mirror zoomRow
--
-- To be able to resize windows, you can create keybindings to send
-- the relevant 'ZoomMessage's:
--
-- >   -- Increase the size occupied by the focused window
-- > , ((modMask .|. shifMask, xK_minus), sendMessage zoomIn)
-- >   -- Decrease the size occupied by the focused window
-- > , ((modMayk             , xK_minus), sendMessage zoomOut)
-- >   -- Reset the size occupied by the focused window
-- > , ((modMask             , xK_equal), sendMessage zoomReset)
-- >   -- (Un)Maximize the focused window
-- > , ((modMask             , xK_f    ), sendMessage ToggleZoomFull)
--
-- For more information on editing your layout hook and key bindings,
-- see "XMonad.Doc.Extending".

-- * Creation functions

-- | 'ZoomRow' layout for laying out elements which are instances of
-- 'Eq'. Perfect for 'Window's.
zoomRow :: (Eq a, Show a, Read a) => ZoomRow ClassEQ a
zoomRow = ZC ClassEQ emptyZ

-- $noneq
-- Haskell's 'Eq' class is usually concerned with structural equality, whereas 
-- what this layout really wants is for its elements to have a unique identity,
-- even across changes. There are cases (such as, importantly, 'Window's) where 
-- the 'Eq' instance for a type actually does that, but if you want to lay
-- out something more exotic than windows and your 'Eq' means something else,
-- you can use the following.

-- | ZoomRow layout with a custom equality predicate. It should
-- of course satisfy the laws for 'Eq', and you should also make
-- sure that the layout never has to handle two \"equal\" elements
-- at the same time (it won't do any huge damage, but might behave
-- a bit strangely).
zoomRowWith :: (EQF f a, Show (f a), Read (f a), Show a, Read a) 
               => f a -> ZoomRow f a
zoomRowWith f = ZC f emptyZ


-- * The datatypes

-- | A layout that arranges its windows in a horizontal row,
-- and allows to change the relative size of each element
-- independently.
data ZoomRow f a = ZC { zoomEq ::  f a
                          -- ^ Function to compare elements for
                          -- equality, a real Eq instance might
                          -- not be what you want in some cases
                      , zoomRatios :: (Zipper (Elt a))
                          -- ^ Element specs. The zipper is so we
                          -- know what the focus is when we handle
                          --  a message
                      }
  deriving (Show, Read, Eq)

-- | Class for equivalence relations. Must be transitive, reflexive.
class EQF f a where
    eq :: f a -> a -> a -> Bool

-- | To use the usual '==':
data ClassEQ a = ClassEQ
  deriving (Show, Read, Eq)

instance Eq a => EQF ClassEQ a where
    eq _ a b = a == b

-- | Size specification for an element.
data Elt a = E { elt :: a -- ^ The element
               , ratio :: Rational -- ^ Its size ratio
               , full :: Bool -- ^ Whether it should occupy all the
                              -- available space when it has focus.
               }
  deriving (Show, Read, Eq)


-- * Helpers

getRatio :: Elt a -> (a, Rational)
getRatio (E a r _) = (a,r)

lookupBy :: (a -> a -> Bool) -> a -> [Elt a] -> Maybe (Elt a)
lookupBy _ _ [] = Nothing
lookupBy f a (E a' r b : _) | f a a' = Just $ E a r b
lookupBy f a (_:es) = lookupBy f a es

setFocus :: Zipper a -> a -> Zipper a
setFocus Nothing a = Just $ W.Stack a [] []
setFocus (Just s) a = Just s { W.focus = a }


-- * Messages

-- | The type of messages accepted by a 'ZoomRow' layout
data ZoomMessage = Zoom Rational
                 -- ^ Multiply the focused window's size factor
                 -- by the given number.
                 | ZoomTo Rational
                 -- ^ Set the focused window's size factor to the
                 -- given number.
                 | ZoomFull Bool
                 -- ^ Set whether the focused window should occupy
                 -- all available space when it has focus
                 | ZoomFullToggle
                 -- ^ Toggle whether the focused window should
                 -- occupy all available space when it has focus
  deriving (Typeable, Show)

instance Message ZoomMessage

-- | Increase the size of the focused window.
-- Defined as @Zoom 1.5@
zoomIn :: ZoomMessage
zoomIn = Zoom 1.5

-- | Decrease the size of the focused window.
-- Defined as @Zoom (2/3)@
zoomOut :: ZoomMessage
zoomOut = Zoom $ 2/3

-- | Reset the size of the focused window.
-- Defined as @ZoomTo 1@
zoomReset :: ZoomMessage
zoomReset = ZoomTo 1


-- * LayoutClass instance

instance (EQF f a, Show a, Read a, Show (f a), Read (f a)) 
    => LayoutClass (ZoomRow f) a where
    description (ZC _ Nothing) = "ZoomRow"
    description (ZC _ (Just s)) = "ZoomRow" ++ if full $ W.focus s
                                                then " (Max)"
                                                else ""

    emptyLayout (ZC _ Nothing) _ = return ([], Nothing)
    emptyLayout (ZC f _) _ = return ([], Just $ ZC f Nothing)

    doLayout (ZC f zelts) r@(Rectangle _ _ w _) s
        = let elts = W.integrate' zelts
              zelts' = mapZ_ (\a -> fromMaybe (E a 1 False) 
                                    $ lookupBy (eq f) a elts) $ Just s
              elts' = W.integrate' zelts'

              maybeL' = if zelts `noChange` zelts'
                          then Nothing
                          else Just $ ZC f zelts'

              total = sum  $ map ratio elts'

              widths =  map (second ((* fi w) . (/total)) . getRatio) elts'

          in case getFocusZ zelts' of
               Just (E a _ True) -> return ([(a, r)], maybeL')
               _ -> return (makeRects r widths, maybeL')

        where makeRects :: Rectangle -> [(a, Rational)] -> [(a, Rectangle)]
              makeRects r pairs = let as = map fst pairs
                                      widths = map snd pairs
                                      discreteWidths = snd $ foldr discretize (0, []) widths
                                      rectangles = snd $ foldr makeRect (r, []) discreteWidths
                                  in zip as rectangles

              -- | Make a new rectangle by substracting the given width from the available
              -- space (from the right, since this is a foldr)
              makeRect :: Dimension -> (Rectangle, [Rectangle]) -> (Rectangle, [Rectangle])
              makeRect w (Rectangle x y w0 h, rs) = ( Rectangle x y (w0-w) h
                                                    , Rectangle (x+fi w0-fi w) y w h : rs )

              -- | Round a list of fractions in a way that maintains the total.
              -- If you know a better way to do this I'm very interested.
              discretize :: Rational -> (Rational, [Dimension]) -> (Rational, [Dimension])
              discretize r (carry, ds) = let (d, carry') = properFraction $ carry+r
                                         in (carry', d:ds)

              noChange z1 z2 = toTags z1 `helper` toTags z2
                  where helper [] [] = True
                        helper (Right a:as) (Right b:bs) = a `sameAs` b && as `helper` bs
                        helper (Left a:as) (Left b:bs) = a `sameAs` b && as `helper` bs
                        helper _ _ = False
                        E a1 r1 b1 `sameAs` E a2 r2 b2 = (eq f a1 a2) && (r1 == r2) && (b1 == b2)

    pureMessage (ZC f zelts) sm | Just (ZoomFull False) <- fromMessage sm
                                , Just (E a r True) <- getFocusZ zelts
        = Just $ ZC f $ setFocus zelts $ E a r False

    pureMessage (ZC f zelts) sm | Just (ZoomFull True) <- fromMessage sm
                                , Just (E a r False) <- getFocusZ zelts
        = Just $ ZC f $ setFocus zelts $ E a r True

    pureMessage (ZC f zelts) sm | Just (E a r b) <- getFocusZ zelts
        = case fromMessage sm of
            Just (Zoom r') -> Just $ ZC f $ setFocus zelts $ E a (r*r') b
            Just (ZoomTo r') -> Just $ ZC f $ setFocus zelts $ E a r' b
            Just ZoomFullToggle -> pureMessage (ZC f zelts) 
                                     $ SomeMessage $ ZoomFull $ not b
            _ -> Nothing

    pureMessage _ _ = Nothing