New module: X.L.ZoomRow

Ignore-this: c464ae1005679484e364eb6ece31d9fc

Row layout with individually resizable elements.

darcs-hash:20100117003939-5ccef-4ae41bdfe49f01a78884e97e8054b52b346dac70.gz

1 files changed, 258 insertions, 0 deletions

diff --git a/XMonad/Layout/ZoomRow.hs b/XMonad/Layout/ZoomRow.hs
new file mode 100644
index 0000000..5d6398c
--- /dev/null
+++ b/XMonad/Layout/ZoomRow.hs
@@ -0,0 +1,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 <quentin.moser@unifr.ch>
+-- 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
\ No newline at end of file