{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds #-}
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses
  , PatternGuards, ExistentialQuantification
  , FlexibleContexts #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.ZoomRow
-- Description :  Row layout with individually resizable elements.
-- 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 :: ZoomRow ClassEQ a
zoomRow = ClassEQ a -> Zipper (Elt a) -> ZoomRow ClassEQ a
forall (f :: * -> *) a. f a -> Zipper (Elt a) -> ZoomRow f a
ZC ClassEQ a
forall a. ClassEQ a
ClassEQ Zipper (Elt a)
forall a. Zipper a
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 a -> ZoomRow f a
zoomRowWith f a
f = f a -> Zipper (Elt a) -> ZoomRow f a
forall (f :: * -> *) a. f a -> Zipper (Elt a) -> ZoomRow f a
ZC f a
f Zipper (Elt a)
forall a. Zipper a
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 { ZoomRow f a -> f a
zoomEq ::  f a
                          -- ^ Function to compare elements for
                          -- equality, a real Eq instance might
                          -- not be what you want in some cases
                      , ZoomRow f a -> Zipper (Elt a)
zoomRatios :: Zipper (Elt a)
                          -- ^ Element specs. The zipper is so we
                          -- know what the focus is when we handle
                          --  a message
                      }
  deriving (Int -> ZoomRow f a -> ShowS
[ZoomRow f a] -> ShowS
ZoomRow f a -> String
(Int -> ZoomRow f a -> ShowS)
-> (ZoomRow f a -> String)
-> ([ZoomRow f a] -> ShowS)
-> Show (ZoomRow f a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (f :: * -> *) a.
(Show a, Show (f a)) =>
Int -> ZoomRow f a -> ShowS
forall (f :: * -> *) a.
(Show a, Show (f a)) =>
[ZoomRow f a] -> ShowS
forall (f :: * -> *) a.
(Show a, Show (f a)) =>
ZoomRow f a -> String
showList :: [ZoomRow f a] -> ShowS
$cshowList :: forall (f :: * -> *) a.
(Show a, Show (f a)) =>
[ZoomRow f a] -> ShowS
show :: ZoomRow f a -> String
$cshow :: forall (f :: * -> *) a.
(Show a, Show (f a)) =>
ZoomRow f a -> String
showsPrec :: Int -> ZoomRow f a -> ShowS
$cshowsPrec :: forall (f :: * -> *) a.
(Show a, Show (f a)) =>
Int -> ZoomRow f a -> ShowS
Show, ReadPrec [ZoomRow f a]
ReadPrec (ZoomRow f a)
Int -> ReadS (ZoomRow f a)
ReadS [ZoomRow f a]
(Int -> ReadS (ZoomRow f a))
-> ReadS [ZoomRow f a]
-> ReadPrec (ZoomRow f a)
-> ReadPrec [ZoomRow f a]
-> Read (ZoomRow f a)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall (f :: * -> *) a.
(Read a, Read (f a)) =>
ReadPrec [ZoomRow f a]
forall (f :: * -> *) a.
(Read a, Read (f a)) =>
ReadPrec (ZoomRow f a)
forall (f :: * -> *) a.
(Read a, Read (f a)) =>
Int -> ReadS (ZoomRow f a)
forall (f :: * -> *) a. (Read a, Read (f a)) => ReadS [ZoomRow f a]
readListPrec :: ReadPrec [ZoomRow f a]
$creadListPrec :: forall (f :: * -> *) a.
(Read a, Read (f a)) =>
ReadPrec [ZoomRow f a]
readPrec :: ReadPrec (ZoomRow f a)
$creadPrec :: forall (f :: * -> *) a.
(Read a, Read (f a)) =>
ReadPrec (ZoomRow f a)
readList :: ReadS [ZoomRow f a]
$creadList :: forall (f :: * -> *) a. (Read a, Read (f a)) => ReadS [ZoomRow f a]
readsPrec :: Int -> ReadS (ZoomRow f a)
$creadsPrec :: forall (f :: * -> *) a.
(Read a, Read (f a)) =>
Int -> ReadS (ZoomRow f a)
Read, ZoomRow f a -> ZoomRow f a -> Bool
(ZoomRow f a -> ZoomRow f a -> Bool)
-> (ZoomRow f a -> ZoomRow f a -> Bool) -> Eq (ZoomRow f a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (f :: * -> *) a.
(Eq a, Eq (f a)) =>
ZoomRow f a -> ZoomRow f a -> Bool
/= :: ZoomRow f a -> ZoomRow f a -> Bool
$c/= :: forall (f :: * -> *) a.
(Eq a, Eq (f a)) =>
ZoomRow f a -> ZoomRow f a -> Bool
== :: ZoomRow f a -> ZoomRow f a -> Bool
$c== :: forall (f :: * -> *) a.
(Eq a, Eq (f a)) =>
ZoomRow f a -> ZoomRow f a -> Bool
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 (Int -> ClassEQ a -> ShowS
[ClassEQ a] -> ShowS
ClassEQ a -> String
(Int -> ClassEQ a -> ShowS)
-> (ClassEQ a -> String)
-> ([ClassEQ a] -> ShowS)
-> Show (ClassEQ a)
forall a. Int -> ClassEQ a -> ShowS
forall a. [ClassEQ a] -> ShowS
forall a. ClassEQ a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClassEQ a] -> ShowS
$cshowList :: forall a. [ClassEQ a] -> ShowS
show :: ClassEQ a -> String
$cshow :: forall a. ClassEQ a -> String
showsPrec :: Int -> ClassEQ a -> ShowS
$cshowsPrec :: forall a. Int -> ClassEQ a -> ShowS
Show, ReadPrec [ClassEQ a]
ReadPrec (ClassEQ a)
Int -> ReadS (ClassEQ a)
ReadS [ClassEQ a]
(Int -> ReadS (ClassEQ a))
-> ReadS [ClassEQ a]
-> ReadPrec (ClassEQ a)
-> ReadPrec [ClassEQ a]
-> Read (ClassEQ a)
forall a. ReadPrec [ClassEQ a]
forall a. ReadPrec (ClassEQ a)
forall a. Int -> ReadS (ClassEQ a)
forall a. ReadS [ClassEQ a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ClassEQ a]
$creadListPrec :: forall a. ReadPrec [ClassEQ a]
readPrec :: ReadPrec (ClassEQ a)
$creadPrec :: forall a. ReadPrec (ClassEQ a)
readList :: ReadS [ClassEQ a]
$creadList :: forall a. ReadS [ClassEQ a]
readsPrec :: Int -> ReadS (ClassEQ a)
$creadsPrec :: forall a. Int -> ReadS (ClassEQ a)
Read, ClassEQ a -> ClassEQ a -> Bool
(ClassEQ a -> ClassEQ a -> Bool)
-> (ClassEQ a -> ClassEQ a -> Bool) -> Eq (ClassEQ a)
forall a. ClassEQ a -> ClassEQ a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClassEQ a -> ClassEQ a -> Bool
$c/= :: forall a. ClassEQ a -> ClassEQ a -> Bool
== :: ClassEQ a -> ClassEQ a -> Bool
$c== :: forall a. ClassEQ a -> ClassEQ a -> Bool
Eq)

instance Eq a => EQF ClassEQ a where
    eq :: ClassEQ a -> a -> a -> Bool
eq ClassEQ a
_ a
a a
b = a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b

-- | Size specification for an element.
data Elt a = E { Elt a -> a
elt :: a -- ^ The element
               , Elt a -> Rational
ratio :: Rational -- ^ Its size ratio
               , Elt a -> Bool
full :: Bool -- ^ Whether it should occupy all the
                              -- available space when it has focus.
               }
  deriving (Int -> Elt a -> ShowS
[Elt a] -> ShowS
Elt a -> String
(Int -> Elt a -> ShowS)
-> (Elt a -> String) -> ([Elt a] -> ShowS) -> Show (Elt a)
forall a. Show a => Int -> Elt a -> ShowS
forall a. Show a => [Elt a] -> ShowS
forall a. Show a => Elt a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Elt a] -> ShowS
$cshowList :: forall a. Show a => [Elt a] -> ShowS
show :: Elt a -> String
$cshow :: forall a. Show a => Elt a -> String
showsPrec :: Int -> Elt a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Elt a -> ShowS
Show, ReadPrec [Elt a]
ReadPrec (Elt a)
Int -> ReadS (Elt a)
ReadS [Elt a]
(Int -> ReadS (Elt a))
-> ReadS [Elt a]
-> ReadPrec (Elt a)
-> ReadPrec [Elt a]
-> Read (Elt a)
forall a. Read a => ReadPrec [Elt a]
forall a. Read a => ReadPrec (Elt a)
forall a. Read a => Int -> ReadS (Elt a)
forall a. Read a => ReadS [Elt a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Elt a]
$creadListPrec :: forall a. Read a => ReadPrec [Elt a]
readPrec :: ReadPrec (Elt a)
$creadPrec :: forall a. Read a => ReadPrec (Elt a)
readList :: ReadS [Elt a]
$creadList :: forall a. Read a => ReadS [Elt a]
readsPrec :: Int -> ReadS (Elt a)
$creadsPrec :: forall a. Read a => Int -> ReadS (Elt a)
Read, Elt a -> Elt a -> Bool
(Elt a -> Elt a -> Bool) -> (Elt a -> Elt a -> Bool) -> Eq (Elt a)
forall a. Eq a => Elt a -> Elt a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Elt a -> Elt a -> Bool
$c/= :: forall a. Eq a => Elt a -> Elt a -> Bool
== :: Elt a -> Elt a -> Bool
$c== :: forall a. Eq a => Elt a -> Elt a -> Bool
Eq)


-- * Helpers

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

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

setFocus :: Zipper a -> a -> Zipper a
setFocus :: Zipper a -> a -> Zipper a
setFocus Zipper a
Nothing a
a = Stack a -> Zipper a
forall a. a -> Maybe a
Just (Stack a -> Zipper a) -> Stack a -> Zipper a
forall a b. (a -> b) -> a -> b
$ a -> [a] -> [a] -> Stack a
forall a. a -> [a] -> [a] -> Stack a
W.Stack a
a [] []
setFocus (Just Stack a
s) a
a = Stack a -> Zipper a
forall a. a -> Maybe a
Just Stack a
s { focus :: a
W.focus = a
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 (Int -> ZoomMessage -> ShowS
[ZoomMessage] -> ShowS
ZoomMessage -> String
(Int -> ZoomMessage -> ShowS)
-> (ZoomMessage -> String)
-> ([ZoomMessage] -> ShowS)
-> Show ZoomMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ZoomMessage] -> ShowS
$cshowList :: [ZoomMessage] -> ShowS
show :: ZoomMessage -> String
$cshow :: ZoomMessage -> String
showsPrec :: Int -> ZoomMessage -> ShowS
$cshowsPrec :: Int -> ZoomMessage -> ShowS
Show)

instance Message ZoomMessage

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

-- | Decrease the size of the focused window.
-- Defined as @Zoom (2/3)@
zoomOut :: ZoomMessage
zoomOut :: ZoomMessage
zoomOut = Rational -> ZoomMessage
Zoom (Rational -> ZoomMessage) -> Rational -> ZoomMessage
forall a b. (a -> b) -> a -> b
$ Rational
2Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/Rational
3

-- | Reset the size of the focused window.
-- Defined as @ZoomTo 1@
zoomReset :: ZoomMessage
zoomReset :: ZoomMessage
zoomReset = Rational -> ZoomMessage
ZoomTo Rational
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 :: ZoomRow f a -> String
description (ZC f a
_ Maybe (Stack (Elt a))
Nothing) = String
"ZoomRow"
    description (ZC f a
_ (Just Stack (Elt a)
s)) = String
"ZoomRow" String -> ShowS
forall a. [a] -> [a] -> [a]
++ if Elt a -> Bool
forall a. Elt a -> Bool
full (Elt a -> Bool) -> Elt a -> Bool
forall a b. (a -> b) -> a -> b
$ Stack (Elt a) -> Elt a
forall a. Stack a -> a
W.focus Stack (Elt a)
s
                                                then String
" (Max)"
                                                else String
""

    emptyLayout :: ZoomRow f a
-> Rectangle -> X ([(a, Rectangle)], Maybe (ZoomRow f a))
emptyLayout (ZC f a
_ Maybe (Stack (Elt a))
Nothing) Rectangle
_ = ([(a, Rectangle)], Maybe (ZoomRow f a))
-> X ([(a, Rectangle)], Maybe (ZoomRow f a))
forall (m :: * -> *) a. Monad m => a -> m a
return ([], Maybe (ZoomRow f a)
forall a. Maybe a
Nothing)
    emptyLayout (ZC f a
f Maybe (Stack (Elt a))
_) Rectangle
_ = ([(a, Rectangle)], Maybe (ZoomRow f a))
-> X ([(a, Rectangle)], Maybe (ZoomRow f a))
forall (m :: * -> *) a. Monad m => a -> m a
return ([], ZoomRow f a -> Maybe (ZoomRow f a)
forall a. a -> Maybe a
Just (ZoomRow f a -> Maybe (ZoomRow f a))
-> ZoomRow f a -> Maybe (ZoomRow f a)
forall a b. (a -> b) -> a -> b
$ f a -> Maybe (Stack (Elt a)) -> ZoomRow f a
forall (f :: * -> *) a. f a -> Zipper (Elt a) -> ZoomRow f a
ZC f a
f Maybe (Stack (Elt a))
forall a. Maybe a
Nothing)

    doLayout :: ZoomRow f a
-> Rectangle
-> Stack a
-> X ([(a, Rectangle)], Maybe (ZoomRow f a))
doLayout (ZC f a
f Maybe (Stack (Elt a))
zelts) r :: Rectangle
r@(Rectangle Position
_ Position
_ Dimension
w Dimension
_) Stack a
s
        = let elts :: [Elt a]
elts = Maybe (Stack (Elt a)) -> [Elt a]
forall a. Maybe (Stack a) -> [a]
W.integrate' Maybe (Stack (Elt a))
zelts
              zelts' :: Maybe (Stack (Elt a))
zelts' = (a -> Elt a) -> Zipper a -> Maybe (Stack (Elt a))
forall a b. (a -> b) -> Zipper a -> Zipper b
mapZ_ (\a
a -> Elt a -> Maybe (Elt a) -> Elt a
forall a. a -> Maybe a -> a
fromMaybe (a -> Rational -> Bool -> Elt a
forall a. a -> Rational -> Bool -> Elt a
E a
a Rational
1 Bool
False)
                                    (Maybe (Elt a) -> Elt a) -> Maybe (Elt a) -> Elt a
forall a b. (a -> b) -> a -> b
$ (a -> a -> Bool) -> a -> [Elt a] -> Maybe (Elt a)
forall a. (a -> a -> Bool) -> a -> [Elt a] -> Maybe (Elt a)
lookupBy (f a -> a -> a -> Bool
forall (f :: * -> *) a. EQF f a => f a -> a -> a -> Bool
eq f a
f) a
a [Elt a]
elts) (Zipper a -> Maybe (Stack (Elt a)))
-> Zipper a -> Maybe (Stack (Elt a))
forall a b. (a -> b) -> a -> b
$ Stack a -> Zipper a
forall a. a -> Maybe a
Just Stack a
s
              elts' :: [Elt a]
elts' = Maybe (Stack (Elt a)) -> [Elt a]
forall a. Maybe (Stack a) -> [a]
W.integrate' Maybe (Stack (Elt a))
zelts'

              maybeL' :: Maybe (ZoomRow f a)
maybeL' = if Maybe (Stack (Elt a))
zelts Maybe (Stack (Elt a)) -> Maybe (Stack (Elt a)) -> Bool
`noChange` Maybe (Stack (Elt a))
zelts'
                          then Maybe (ZoomRow f a)
forall a. Maybe a
Nothing
                          else ZoomRow f a -> Maybe (ZoomRow f a)
forall a. a -> Maybe a
Just (ZoomRow f a -> Maybe (ZoomRow f a))
-> ZoomRow f a -> Maybe (ZoomRow f a)
forall a b. (a -> b) -> a -> b
$ f a -> Maybe (Stack (Elt a)) -> ZoomRow f a
forall (f :: * -> *) a. f a -> Zipper (Elt a) -> ZoomRow f a
ZC f a
f Maybe (Stack (Elt a))
zelts'

              total :: Rational
total = [Rational] -> Rational
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum  ([Rational] -> Rational) -> [Rational] -> Rational
forall a b. (a -> b) -> a -> b
$ (Elt a -> Rational) -> [Elt a] -> [Rational]
forall a b. (a -> b) -> [a] -> [b]
map Elt a -> Rational
forall a. Elt a -> Rational
ratio [Elt a]
elts'

              widths :: [(a, Rational)]
widths =  (Elt a -> (a, Rational)) -> [Elt a] -> [(a, Rational)]
forall a b. (a -> b) -> [a] -> [b]
map ((Rational -> Rational) -> (a, Rational) -> (a, Rational)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Dimension -> Rational
forall a b. (Integral a, Num b) => a -> b
fi Dimension
w) (Rational -> Rational)
-> (Rational -> Rational) -> Rational -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/Rational
total)) ((a, Rational) -> (a, Rational))
-> (Elt a -> (a, Rational)) -> Elt a -> (a, Rational)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Elt a -> (a, Rational)
forall a. Elt a -> (a, Rational)
getRatio) [Elt a]
elts'

          in case Maybe (Stack (Elt a)) -> Maybe (Elt a)
forall a. Zipper a -> Maybe a
getFocusZ Maybe (Stack (Elt a))
zelts' of
               Just (E a
a Rational
_ Bool
True) -> ([(a, Rectangle)], Maybe (ZoomRow f a))
-> X ([(a, Rectangle)], Maybe (ZoomRow f a))
forall (m :: * -> *) a. Monad m => a -> m a
return ([(a
a, Rectangle
r)], Maybe (ZoomRow f a)
maybeL')
               Maybe (Elt a)
_ -> ([(a, Rectangle)], Maybe (ZoomRow f a))
-> X ([(a, Rectangle)], Maybe (ZoomRow f a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Rectangle -> [(a, Rational)] -> [(a, Rectangle)]
forall a. Rectangle -> [(a, Rational)] -> [(a, Rectangle)]
makeRects Rectangle
r [(a, Rational)]
widths, Maybe (ZoomRow f a)
maybeL')

        where makeRects :: Rectangle -> [(a, Rational)] -> [(a, Rectangle)]
              makeRects :: Rectangle -> [(a, Rational)] -> [(a, Rectangle)]
makeRects Rectangle
r [(a, Rational)]
pairs = let as :: [a]
as = ((a, Rational) -> a) -> [(a, Rational)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, Rational) -> a
forall a b. (a, b) -> a
fst [(a, Rational)]
pairs
                                      widths :: [Rational]
widths = ((a, Rational) -> Rational) -> [(a, Rational)] -> [Rational]
forall a b. (a -> b) -> [a] -> [b]
map (a, Rational) -> Rational
forall a b. (a, b) -> b
snd [(a, Rational)]
pairs
                                      discreteWidths :: [Dimension]
discreteWidths = (Rational, [Dimension]) -> [Dimension]
forall a b. (a, b) -> b
snd ((Rational, [Dimension]) -> [Dimension])
-> (Rational, [Dimension]) -> [Dimension]
forall a b. (a -> b) -> a -> b
$ (Rational -> (Rational, [Dimension]) -> (Rational, [Dimension]))
-> (Rational, [Dimension]) -> [Rational] -> (Rational, [Dimension])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Rational -> (Rational, [Dimension]) -> (Rational, [Dimension])
discretize (Rational
0, []) [Rational]
widths
                                      rectangles :: [Rectangle]
rectangles = (Rectangle, [Rectangle]) -> [Rectangle]
forall a b. (a, b) -> b
snd ((Rectangle, [Rectangle]) -> [Rectangle])
-> (Rectangle, [Rectangle]) -> [Rectangle]
forall a b. (a -> b) -> a -> b
$ (Dimension -> (Rectangle, [Rectangle]) -> (Rectangle, [Rectangle]))
-> (Rectangle, [Rectangle])
-> [Dimension]
-> (Rectangle, [Rectangle])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Dimension -> (Rectangle, [Rectangle]) -> (Rectangle, [Rectangle])
makeRect (Rectangle
r, []) [Dimension]
discreteWidths
                                  in [a] -> [Rectangle] -> [(a, Rectangle)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
as [Rectangle]
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 :: Dimension -> (Rectangle, [Rectangle]) -> (Rectangle, [Rectangle])
makeRect Dimension
w (Rectangle Position
x Position
y Dimension
w0 Dimension
h, [Rectangle]
rs) = ( Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
x Position
y (Dimension
w0Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
-Dimension
w) Dimension
h
                                                    , Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle (Position
xPosition -> Position -> Position
forall a. Num a => a -> a -> a
+Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
w0Position -> Position -> Position
forall a. Num a => a -> a -> a
-Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
w) Position
y Dimension
w Dimension
h Rectangle -> [Rectangle] -> [Rectangle]
forall a. a -> [a] -> [a]
: [Rectangle]
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 :: Rational -> (Rational, [Dimension]) -> (Rational, [Dimension])
discretize Rational
r (Rational
carry, [Dimension]
ds) = let (Dimension
d, Rational
carry') = Rational -> (Dimension, Rational)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction (Rational -> (Dimension, Rational))
-> Rational -> (Dimension, Rational)
forall a b. (a -> b) -> a -> b
$ Rational
carryRational -> Rational -> Rational
forall a. Num a => a -> a -> a
+Rational
r
                                         in (Rational
carry', Dimension
dDimension -> [Dimension] -> [Dimension]
forall a. a -> [a] -> [a]
:[Dimension]
ds)

              noChange :: Maybe (Stack (Elt a)) -> Maybe (Stack (Elt a)) -> Bool
noChange Maybe (Stack (Elt a))
z1 Maybe (Stack (Elt a))
z2 = Maybe (Stack (Elt a)) -> [Either (Elt a) (Elt a)]
forall a. Zipper a -> [Either a a]
toTags Maybe (Stack (Elt a))
z1 [Either (Elt a) (Elt a)] -> [Either (Elt a) (Elt a)] -> Bool
`helper` Maybe (Stack (Elt a)) -> [Either (Elt a) (Elt a)]
forall a. Zipper a -> [Either a a]
toTags Maybe (Stack (Elt a))
z2
                  where helper :: [Either (Elt a) (Elt a)] -> [Either (Elt a) (Elt a)] -> Bool
helper [] [] = Bool
True
                        helper (Right Elt a
a:[Either (Elt a) (Elt a)]
as) (Right Elt a
b:[Either (Elt a) (Elt a)]
bs) = Elt a
a Elt a -> Elt a -> Bool
`sameAs` Elt a
b Bool -> Bool -> Bool
&& [Either (Elt a) (Elt a)]
as [Either (Elt a) (Elt a)] -> [Either (Elt a) (Elt a)] -> Bool
`helper` [Either (Elt a) (Elt a)]
bs
                        helper (Left Elt a
a:[Either (Elt a) (Elt a)]
as) (Left Elt a
b:[Either (Elt a) (Elt a)]
bs) = Elt a
a Elt a -> Elt a -> Bool
`sameAs` Elt a
b Bool -> Bool -> Bool
&& [Either (Elt a) (Elt a)]
as [Either (Elt a) (Elt a)] -> [Either (Elt a) (Elt a)] -> Bool
`helper` [Either (Elt a) (Elt a)]
bs
                        helper [Either (Elt a) (Elt a)]
_ [Either (Elt a) (Elt a)]
_ = Bool
False
                        E a
a1 Rational
r1 Bool
b1 sameAs :: Elt a -> Elt a -> Bool
`sameAs` E a
a2 Rational
r2 Bool
b2 = f a -> a -> a -> Bool
forall (f :: * -> *) a. EQF f a => f a -> a -> a -> Bool
eq f a
f a
a1 a
a2 Bool -> Bool -> Bool
&& (Rational
r1 Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
r2) Bool -> Bool -> Bool
&& (Bool
b1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b2)

    pureMessage :: ZoomRow f a -> SomeMessage -> Maybe (ZoomRow f a)
pureMessage (ZC f a
f Maybe (Stack (Elt a))
zelts) SomeMessage
sm | Just (ZoomFull Bool
False) <- SomeMessage -> Maybe ZoomMessage
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
sm
                                , Just (E a
a Rational
r Bool
True) <- Maybe (Stack (Elt a)) -> Maybe (Elt a)
forall a. Zipper a -> Maybe a
getFocusZ Maybe (Stack (Elt a))
zelts
        = ZoomRow f a -> Maybe (ZoomRow f a)
forall a. a -> Maybe a
Just (ZoomRow f a -> Maybe (ZoomRow f a))
-> ZoomRow f a -> Maybe (ZoomRow f a)
forall a b. (a -> b) -> a -> b
$ f a -> Maybe (Stack (Elt a)) -> ZoomRow f a
forall (f :: * -> *) a. f a -> Zipper (Elt a) -> ZoomRow f a
ZC f a
f (Maybe (Stack (Elt a)) -> ZoomRow f a)
-> Maybe (Stack (Elt a)) -> ZoomRow f a
forall a b. (a -> b) -> a -> b
$ Maybe (Stack (Elt a)) -> Elt a -> Maybe (Stack (Elt a))
forall a. Zipper a -> a -> Zipper a
setFocus Maybe (Stack (Elt a))
zelts (Elt a -> Maybe (Stack (Elt a))) -> Elt a -> Maybe (Stack (Elt a))
forall a b. (a -> b) -> a -> b
$ a -> Rational -> Bool -> Elt a
forall a. a -> Rational -> Bool -> Elt a
E a
a Rational
r Bool
False

    pureMessage (ZC f a
f Maybe (Stack (Elt a))
zelts) SomeMessage
sm | Just (ZoomFull Bool
True) <- SomeMessage -> Maybe ZoomMessage
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
sm
                                , Just (E a
a Rational
r Bool
False) <- Maybe (Stack (Elt a)) -> Maybe (Elt a)
forall a. Zipper a -> Maybe a
getFocusZ Maybe (Stack (Elt a))
zelts
        = ZoomRow f a -> Maybe (ZoomRow f a)
forall a. a -> Maybe a
Just (ZoomRow f a -> Maybe (ZoomRow f a))
-> ZoomRow f a -> Maybe (ZoomRow f a)
forall a b. (a -> b) -> a -> b
$ f a -> Maybe (Stack (Elt a)) -> ZoomRow f a
forall (f :: * -> *) a. f a -> Zipper (Elt a) -> ZoomRow f a
ZC f a
f (Maybe (Stack (Elt a)) -> ZoomRow f a)
-> Maybe (Stack (Elt a)) -> ZoomRow f a
forall a b. (a -> b) -> a -> b
$ Maybe (Stack (Elt a)) -> Elt a -> Maybe (Stack (Elt a))
forall a. Zipper a -> a -> Zipper a
setFocus Maybe (Stack (Elt a))
zelts (Elt a -> Maybe (Stack (Elt a))) -> Elt a -> Maybe (Stack (Elt a))
forall a b. (a -> b) -> a -> b
$ a -> Rational -> Bool -> Elt a
forall a. a -> Rational -> Bool -> Elt a
E a
a Rational
r Bool
True

    pureMessage (ZC f a
f Maybe (Stack (Elt a))
zelts) SomeMessage
sm | Just (E a
a Rational
r Bool
b) <- Maybe (Stack (Elt a)) -> Maybe (Elt a)
forall a. Zipper a -> Maybe a
getFocusZ Maybe (Stack (Elt a))
zelts
        = case SomeMessage -> Maybe ZoomMessage
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
sm of
            Just (Zoom Rational
r') -> ZoomRow f a -> Maybe (ZoomRow f a)
forall a. a -> Maybe a
Just (ZoomRow f a -> Maybe (ZoomRow f a))
-> ZoomRow f a -> Maybe (ZoomRow f a)
forall a b. (a -> b) -> a -> b
$ f a -> Maybe (Stack (Elt a)) -> ZoomRow f a
forall (f :: * -> *) a. f a -> Zipper (Elt a) -> ZoomRow f a
ZC f a
f (Maybe (Stack (Elt a)) -> ZoomRow f a)
-> Maybe (Stack (Elt a)) -> ZoomRow f a
forall a b. (a -> b) -> a -> b
$ Maybe (Stack (Elt a)) -> Elt a -> Maybe (Stack (Elt a))
forall a. Zipper a -> a -> Zipper a
setFocus Maybe (Stack (Elt a))
zelts (Elt a -> Maybe (Stack (Elt a))) -> Elt a -> Maybe (Stack (Elt a))
forall a b. (a -> b) -> a -> b
$ a -> Rational -> Bool -> Elt a
forall a. a -> Rational -> Bool -> Elt a
E a
a (Rational
rRational -> Rational -> Rational
forall a. Num a => a -> a -> a
*Rational
r') Bool
b
            Just (ZoomTo Rational
r') -> ZoomRow f a -> Maybe (ZoomRow f a)
forall a. a -> Maybe a
Just (ZoomRow f a -> Maybe (ZoomRow f a))
-> ZoomRow f a -> Maybe (ZoomRow f a)
forall a b. (a -> b) -> a -> b
$ f a -> Maybe (Stack (Elt a)) -> ZoomRow f a
forall (f :: * -> *) a. f a -> Zipper (Elt a) -> ZoomRow f a
ZC f a
f (Maybe (Stack (Elt a)) -> ZoomRow f a)
-> Maybe (Stack (Elt a)) -> ZoomRow f a
forall a b. (a -> b) -> a -> b
$ Maybe (Stack (Elt a)) -> Elt a -> Maybe (Stack (Elt a))
forall a. Zipper a -> a -> Zipper a
setFocus Maybe (Stack (Elt a))
zelts (Elt a -> Maybe (Stack (Elt a))) -> Elt a -> Maybe (Stack (Elt a))
forall a b. (a -> b) -> a -> b
$ a -> Rational -> Bool -> Elt a
forall a. a -> Rational -> Bool -> Elt a
E a
a Rational
r' Bool
b
            Just ZoomMessage
ZoomFullToggle -> ZoomRow f a -> SomeMessage -> Maybe (ZoomRow f a)
forall (layout :: * -> *) a.
LayoutClass layout a =>
layout a -> SomeMessage -> Maybe (layout a)
pureMessage (f a -> Maybe (Stack (Elt a)) -> ZoomRow f a
forall (f :: * -> *) a. f a -> Zipper (Elt a) -> ZoomRow f a
ZC f a
f Maybe (Stack (Elt a))
zelts)
                                     (SomeMessage -> Maybe (ZoomRow f a))
-> SomeMessage -> Maybe (ZoomRow f a)
forall a b. (a -> b) -> a -> b
$ ZoomMessage -> SomeMessage
forall a. Message a => a -> SomeMessage
SomeMessage (ZoomMessage -> SomeMessage) -> ZoomMessage -> SomeMessage
forall a b. (a -> b) -> a -> b
$ Bool -> ZoomMessage
ZoomFull (Bool -> ZoomMessage) -> Bool -> ZoomMessage
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
b
            Maybe ZoomMessage
_ -> Maybe (ZoomRow f a)
forall a. Maybe a
Nothing

    pureMessage ZoomRow f a
_ SomeMessage
_ = Maybe (ZoomRow f a)
forall a. Maybe a
Nothing