xmonad-contrib/XMonad/Layout/ZoomRow.hs

{-# 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  :  orphaned
-- 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 XMonad.Prelude (fromMaybe, fi)
import qualified XMonad.StackSet as W

import XMonad.Util.Stack

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), Typeable f)
    => 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