{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.MouseResizableTile
-- Description :  Like "XMonad.Layout.ResizableTile", but use the mouse to adjust the layout.
-- Copyright   :  (c) Jan Vornberger 2009
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  jan.vornberger@informatik.uni-oldenburg.de
-- Stability   :  unstable
-- Portability :  not portable
--
-- A layout in the spirit of "XMonad.Layout.ResizableTile", but with the option
-- to use the mouse to adjust the layout.
--
-----------------------------------------------------------------------------

module XMonad.Layout.MouseResizableTile (
                                    -- * Usage
                                    -- $usage
                                    mouseResizableTile,
                                    mouseResizableTileMirrored,
                                    MRTMessage (ShrinkSlave, ExpandSlave, SetMasterFraction, SetLeftSlaveFraction, SetRightSlaveFraction),

                                    -- * Parameters
                                    -- $mrtParameters
                                    nmaster,
                                    masterFrac,
                                    slaveFrac,
                                    fracIncrement,
                                    isMirrored,
                                    draggerType,
                                    DraggerType (..),
                                    MouseResizableTile,
                                   ) where

import XMonad hiding (tile, splitVertically, splitHorizontallyBy)
import XMonad.Prelude
import qualified XMonad.StackSet as W
import XMonad.Util.XUtils
import Graphics.X11 as X

-- $usage
-- You can use this module with the following in your @xmonad.hs@:
--
-- > import XMonad.Layout.MouseResizableTile
--
-- Then edit your @layoutHook@ by adding the MouseResizableTile layout.
-- Either in its normal form or the mirrored version. (The mirror layout modifier
-- will not work correctly here because of the use of the mouse.)
--
-- > myLayout = mouseResizableTile ||| etc..
-- > main = xmonad def { layoutHook = myLayout }
--
--
-- For more detailed instructions on editing the layoutHook see
-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and
-- "XMonad.Doc.Extending#Editing_the_layout_hook".
--
-- You may also want to add the following key bindings:
--
-- > , ((modm,               xK_u), sendMessage ShrinkSlave) -- %! Shrink a slave area
-- > , ((modm,               xK_i), sendMessage ExpandSlave) -- %! Expand a slave area
--
-- For detailed instruction on editing the key binding see:
--
-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial>.

-- $mrtParameters
-- The following functions are also labels for updating the @data@ (whose
-- representation is otherwise hidden) produced by 'mouseResizableTile'.
--
-- Usage:
--
-- > myLayout = mouseResizableTile{ masterFrac = 0.7,
-- >                                fracIncrement = 0.05,
-- >                                draggerType = BordersDragger }
-- >                |||  etc..

data MRTMessage = SetMasterFraction Rational
                    | SetLeftSlaveFraction Int Rational
                    | SetRightSlaveFraction Int Rational
                    | ShrinkSlave
                    | ExpandSlave
instance Message MRTMessage

data DraggerInfo = MasterDragger Position Rational
                    | LeftSlaveDragger Position Rational Int
                    | RightSlaveDragger Position Rational Int
                    deriving (Int -> DraggerInfo -> ShowS
[DraggerInfo] -> ShowS
DraggerInfo -> String
(Int -> DraggerInfo -> ShowS)
-> (DraggerInfo -> String)
-> ([DraggerInfo] -> ShowS)
-> Show DraggerInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DraggerInfo -> ShowS
showsPrec :: Int -> DraggerInfo -> ShowS
$cshow :: DraggerInfo -> String
show :: DraggerInfo -> String
$cshowList :: [DraggerInfo] -> ShowS
showList :: [DraggerInfo] -> ShowS
Show, ReadPrec [DraggerInfo]
ReadPrec DraggerInfo
Int -> ReadS DraggerInfo
ReadS [DraggerInfo]
(Int -> ReadS DraggerInfo)
-> ReadS [DraggerInfo]
-> ReadPrec DraggerInfo
-> ReadPrec [DraggerInfo]
-> Read DraggerInfo
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS DraggerInfo
readsPrec :: Int -> ReadS DraggerInfo
$creadList :: ReadS [DraggerInfo]
readList :: ReadS [DraggerInfo]
$creadPrec :: ReadPrec DraggerInfo
readPrec :: ReadPrec DraggerInfo
$creadListPrec :: ReadPrec [DraggerInfo]
readListPrec :: ReadPrec [DraggerInfo]
Read)
type DraggerWithRect = (Rectangle, Glyph, DraggerInfo)
type DraggerWithWin = (Window, DraggerInfo)

-- | Specifies the size of the clickable area between windows.
data DraggerType = FixedDragger
                    { DraggerType -> EventType
gapWidth :: Dimension -- ^ width of a gap between windows
                    , DraggerType -> EventType
draggerWidth :: Dimension -- ^ width of the dragger itself
                                                -- (will overlap windows if greater than gap)
                    }
                    | BordersDragger -- ^ no gaps, draggers overlap window borders
                    deriving (Int -> DraggerType -> ShowS
[DraggerType] -> ShowS
DraggerType -> String
(Int -> DraggerType -> ShowS)
-> (DraggerType -> String)
-> ([DraggerType] -> ShowS)
-> Show DraggerType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DraggerType -> ShowS
showsPrec :: Int -> DraggerType -> ShowS
$cshow :: DraggerType -> String
show :: DraggerType -> String
$cshowList :: [DraggerType] -> ShowS
showList :: [DraggerType] -> ShowS
Show, ReadPrec [DraggerType]
ReadPrec DraggerType
Int -> ReadS DraggerType
ReadS [DraggerType]
(Int -> ReadS DraggerType)
-> ReadS [DraggerType]
-> ReadPrec DraggerType
-> ReadPrec [DraggerType]
-> Read DraggerType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS DraggerType
readsPrec :: Int -> ReadS DraggerType
$creadList :: ReadS [DraggerType]
readList :: ReadS [DraggerType]
$creadPrec :: ReadPrec DraggerType
readPrec :: ReadPrec DraggerType
$creadListPrec :: ReadPrec [DraggerType]
readListPrec :: ReadPrec [DraggerType]
Read)
type DraggerGeometry = (Position, Dimension, Position, Dimension)

data MouseResizableTile a = MRT { forall a. MouseResizableTile a -> Int
nmaster :: Int,
                                    -- ^ Get/set the number of windows in
                                    -- master pane (default: 1).
                                    forall a. MouseResizableTile a -> Rational
masterFrac :: Rational,
                                    -- ^ Get/set the proportion of screen
                                    -- occupied by master pane (default: 1/2).
                                    forall a. MouseResizableTile a -> Rational
slaveFrac :: Rational,
                                    -- ^ Get/set the proportion of remaining
                                    -- space in a column occupied by a slave
                                    -- window (default: 1/2).
                                    forall a. MouseResizableTile a -> Rational
fracIncrement :: Rational,
                                    -- ^ Get/set the increment used when
                                    -- modifying masterFrac/slaveFrac by the
                                    -- Shrink, Expand, etc. messages (default:
                                    -- 3/100).
                                    forall a. MouseResizableTile a -> [Rational]
leftFracs :: [Rational],
                                    forall a. MouseResizableTile a -> [Rational]
rightFracs :: [Rational],
                                    forall a. MouseResizableTile a -> [DraggerWithWin]
draggers :: [DraggerWithWin],
                                    forall a. MouseResizableTile a -> DraggerType
draggerType :: DraggerType,
                                    -- ^ Get/set dragger and gap dimensions
                                    -- (default: FixedDragger 6 6).
                                    forall a. MouseResizableTile a -> Int
focusPos :: Int,
                                    forall a. MouseResizableTile a -> Int
numWindows :: Int,
                                    forall a. MouseResizableTile a -> Bool
isMirrored :: Bool
                                    -- ^ Get/set whether the layout is
                                    -- mirrored (default: False).
                                } deriving (Int -> MouseResizableTile a -> ShowS
[MouseResizableTile a] -> ShowS
MouseResizableTile a -> String
(Int -> MouseResizableTile a -> ShowS)
-> (MouseResizableTile a -> String)
-> ([MouseResizableTile a] -> ShowS)
-> Show (MouseResizableTile a)
forall a. Int -> MouseResizableTile a -> ShowS
forall a. [MouseResizableTile a] -> ShowS
forall a. MouseResizableTile a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Int -> MouseResizableTile a -> ShowS
showsPrec :: Int -> MouseResizableTile a -> ShowS
$cshow :: forall a. MouseResizableTile a -> String
show :: MouseResizableTile a -> String
$cshowList :: forall a. [MouseResizableTile a] -> ShowS
showList :: [MouseResizableTile a] -> ShowS
Show, ReadPrec [MouseResizableTile a]
ReadPrec (MouseResizableTile a)
Int -> ReadS (MouseResizableTile a)
ReadS [MouseResizableTile a]
(Int -> ReadS (MouseResizableTile a))
-> ReadS [MouseResizableTile a]
-> ReadPrec (MouseResizableTile a)
-> ReadPrec [MouseResizableTile a]
-> Read (MouseResizableTile a)
forall a. ReadPrec [MouseResizableTile a]
forall a. ReadPrec (MouseResizableTile a)
forall a. Int -> ReadS (MouseResizableTile a)
forall a. ReadS [MouseResizableTile a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall a. Int -> ReadS (MouseResizableTile a)
readsPrec :: Int -> ReadS (MouseResizableTile a)
$creadList :: forall a. ReadS [MouseResizableTile a]
readList :: ReadS [MouseResizableTile a]
$creadPrec :: forall a. ReadPrec (MouseResizableTile a)
readPrec :: ReadPrec (MouseResizableTile a)
$creadListPrec :: forall a. ReadPrec [MouseResizableTile a]
readListPrec :: ReadPrec [MouseResizableTile a]
Read)

mouseResizableTile :: MouseResizableTile a
mouseResizableTile :: forall a. MouseResizableTile a
mouseResizableTile = Int
-> Rational
-> Rational
-> Rational
-> [Rational]
-> [Rational]
-> [DraggerWithWin]
-> DraggerType
-> Int
-> Int
-> Bool
-> MouseResizableTile a
forall a.
Int
-> Rational
-> Rational
-> Rational
-> [Rational]
-> [Rational]
-> [DraggerWithWin]
-> DraggerType
-> Int
-> Int
-> Bool
-> MouseResizableTile a
MRT Int
1 Rational
0.5 Rational
0.5 Rational
0.03 [] [] [] (EventType -> EventType -> DraggerType
FixedDragger EventType
6 EventType
6) Int
0 Int
0 Bool
False

-- | May be removed in favor of @mouseResizableTile { isMirrored = True }@
mouseResizableTileMirrored :: MouseResizableTile a
mouseResizableTileMirrored :: forall a. MouseResizableTile a
mouseResizableTileMirrored = MouseResizableTile Any
forall a. MouseResizableTile a
mouseResizableTile { isMirrored = True }

instance LayoutClass MouseResizableTile Window where
    doLayout :: MouseResizableTile EventMask
-> Rectangle
-> Stack EventMask
-> X ([(EventMask, Rectangle)],
      Maybe (MouseResizableTile EventMask))
doLayout MouseResizableTile EventMask
st Rectangle
sr (W.Stack EventMask
w [EventMask]
l [EventMask]
r) = do
        DraggerGeometry
drg <- DraggerType -> X DraggerGeometry
draggerGeometry (DraggerType -> X DraggerGeometry)
-> DraggerType -> X DraggerGeometry
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask -> DraggerType
forall a. MouseResizableTile a -> DraggerType
draggerType MouseResizableTile EventMask
st
        let wins :: [EventMask]
wins = [EventMask] -> [EventMask]
forall a. [a] -> [a]
reverse [EventMask]
l [EventMask] -> [EventMask] -> [EventMask]
forall a. [a] -> [a] -> [a]
++ EventMask
w EventMask -> [EventMask] -> [EventMask]
forall a. a -> [a] -> [a]
: [EventMask]
r
            num :: Int
num = [EventMask] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EventMask]
wins
            sr' :: Rectangle
sr' = Rectangle -> Rectangle -> Rectangle
forall {p}. p -> p -> p
mirrorAdjust Rectangle
sr (Rectangle -> Rectangle
mirrorRect Rectangle
sr)
            ([Rectangle]
rects, [DraggerWithRect]
preparedDraggers) = Int
-> Rational
-> [Rational]
-> [Rational]
-> Rectangle
-> Int
-> DraggerGeometry
-> ([Rectangle], [DraggerWithRect])
tile (MouseResizableTile EventMask -> Int
forall a. MouseResizableTile a -> Int
nmaster MouseResizableTile EventMask
st) (MouseResizableTile EventMask -> Rational
forall a. MouseResizableTile a -> Rational
masterFrac MouseResizableTile EventMask
st)
                                            (MouseResizableTile EventMask -> [Rational]
forall a. MouseResizableTile a -> [Rational]
leftFracs MouseResizableTile EventMask
st [Rational] -> [Rational] -> [Rational]
forall a. [a] -> [a] -> [a]
++ Rational -> [Rational]
forall a. a -> [a]
repeat (MouseResizableTile EventMask -> Rational
forall a. MouseResizableTile a -> Rational
slaveFrac MouseResizableTile EventMask
st))
                                            (MouseResizableTile EventMask -> [Rational]
forall a. MouseResizableTile a -> [Rational]
rightFracs MouseResizableTile EventMask
st [Rational] -> [Rational] -> [Rational]
forall a. [a] -> [a] -> [a]
++ Rational -> [Rational]
forall a. a -> [a]
repeat (MouseResizableTile EventMask -> Rational
forall a. MouseResizableTile a -> Rational
slaveFrac MouseResizableTile EventMask
st)) Rectangle
sr' Int
num DraggerGeometry
drg
            rects' :: [Rectangle]
rects' = (Rectangle -> Rectangle) -> [Rectangle] -> [Rectangle]
forall a b. (a -> b) -> [a] -> [b]
map ((Rectangle -> Rectangle)
-> (Rectangle -> Rectangle) -> Rectangle -> Rectangle
forall {p}. p -> p -> p
mirrorAdjust Rectangle -> Rectangle
forall a. a -> a
id Rectangle -> Rectangle
mirrorRect (Rectangle -> Rectangle)
-> (Rectangle -> Rectangle) -> Rectangle -> Rectangle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rectangle -> Rectangle -> Rectangle
sanitizeRectangle Rectangle
sr') [Rectangle]
rects
        (DraggerWithWin -> X ()) -> [DraggerWithWin] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DraggerWithWin -> X ()
deleteDragger ([DraggerWithWin] -> X ()) -> [DraggerWithWin] -> X ()
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask -> [DraggerWithWin]
forall a. MouseResizableTile a -> [DraggerWithWin]
draggers MouseResizableTile EventMask
st
        ([(EventMask, Rectangle)]
draggerWrs, [DraggerWithWin]
newDraggers) <- (DraggerWithRect -> X ((EventMask, Rectangle), DraggerWithWin))
-> [DraggerWithRect]
-> X ([(EventMask, Rectangle)], [DraggerWithWin])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM
                                        (Rectangle
-> DraggerWithRect -> X ((EventMask, Rectangle), DraggerWithWin)
createDragger Rectangle
sr (DraggerWithRect -> X ((EventMask, Rectangle), DraggerWithWin))
-> (DraggerWithRect -> DraggerWithRect)
-> DraggerWithRect
-> X ((EventMask, Rectangle), DraggerWithWin)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> DraggerWithRect -> DraggerWithRect
adjustForMirror (MouseResizableTile EventMask -> Bool
forall a. MouseResizableTile a -> Bool
isMirrored MouseResizableTile EventMask
st))
                                        [DraggerWithRect]
preparedDraggers
        ([(EventMask, Rectangle)], Maybe (MouseResizableTile EventMask))
-> X ([(EventMask, Rectangle)],
      Maybe (MouseResizableTile EventMask))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(EventMask, Rectangle)]
draggerWrs [(EventMask, Rectangle)]
-> [(EventMask, Rectangle)] -> [(EventMask, Rectangle)]
forall a. [a] -> [a] -> [a]
++ [EventMask] -> [Rectangle] -> [(EventMask, Rectangle)]
forall a b. [a] -> [b] -> [(a, b)]
zip [EventMask]
wins [Rectangle]
rects', MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a. a -> Maybe a
Just (MouseResizableTile EventMask
 -> Maybe (MouseResizableTile EventMask))
-> MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask
st { draggers = newDraggers,
                                                              focusPos = length l,
                                                              numWindows = length wins })
        where
            mirrorAdjust :: p -> p -> p
mirrorAdjust p
a p
b = if MouseResizableTile EventMask -> Bool
forall a. MouseResizableTile a -> Bool
isMirrored MouseResizableTile EventMask
st
                                then p
b
                                else p
a

    handleMessage :: MouseResizableTile EventMask
-> SomeMessage -> X (Maybe (MouseResizableTile EventMask))
handleMessage MouseResizableTile EventMask
st SomeMessage
m
        | Just (IncMasterN Int
d) <- SomeMessage -> Maybe IncMasterN
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m =
            Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MouseResizableTile EventMask)
 -> X (Maybe (MouseResizableTile EventMask)))
-> Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a. a -> Maybe a
Just (MouseResizableTile EventMask
 -> Maybe (MouseResizableTile EventMask))
-> MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask
st { nmaster = max 0 (nmaster st + d) }
        | Just Resize
Shrink <- SomeMessage -> Maybe Resize
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m =
            Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MouseResizableTile EventMask)
 -> X (Maybe (MouseResizableTile EventMask)))
-> Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a. a -> Maybe a
Just (MouseResizableTile EventMask
 -> Maybe (MouseResizableTile EventMask))
-> MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask
st { masterFrac = max 0 (masterFrac st - fracIncrement st) }
        | Just Resize
Expand <- SomeMessage -> Maybe Resize
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m =
            Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MouseResizableTile EventMask)
 -> X (Maybe (MouseResizableTile EventMask)))
-> Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a. a -> Maybe a
Just (MouseResizableTile EventMask
 -> Maybe (MouseResizableTile EventMask))
-> MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask
st { masterFrac = min 1 (masterFrac st + fracIncrement st) }
        | Just MRTMessage
ShrinkSlave <- SomeMessage -> Maybe MRTMessage
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m =
            Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MouseResizableTile EventMask)
 -> X (Maybe (MouseResizableTile EventMask)))
-> Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a. a -> Maybe a
Just (MouseResizableTile EventMask
 -> Maybe (MouseResizableTile EventMask))
-> MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask
-> Rational -> MouseResizableTile EventMask
forall a. MouseResizableTile a -> Rational -> MouseResizableTile a
modifySlave MouseResizableTile EventMask
st (- MouseResizableTile EventMask -> Rational
forall a. MouseResizableTile a -> Rational
fracIncrement MouseResizableTile EventMask
st)
        | Just MRTMessage
ExpandSlave <- SomeMessage -> Maybe MRTMessage
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m =
            Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MouseResizableTile EventMask)
 -> X (Maybe (MouseResizableTile EventMask)))
-> Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a. a -> Maybe a
Just (MouseResizableTile EventMask
 -> Maybe (MouseResizableTile EventMask))
-> MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask
-> Rational -> MouseResizableTile EventMask
forall a. MouseResizableTile a -> Rational -> MouseResizableTile a
modifySlave MouseResizableTile EventMask
st (MouseResizableTile EventMask -> Rational
forall a. MouseResizableTile a -> Rational
fracIncrement MouseResizableTile EventMask
st)
        | Just (SetMasterFraction Rational
f) <- SomeMessage -> Maybe MRTMessage
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m =
            Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MouseResizableTile EventMask)
 -> X (Maybe (MouseResizableTile EventMask)))
-> Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a. a -> Maybe a
Just (MouseResizableTile EventMask
 -> Maybe (MouseResizableTile EventMask))
-> MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask
st { masterFrac = max 0 (min 1 f) }
        | Just (SetLeftSlaveFraction Int
pos Rational
f) <- SomeMessage -> Maybe MRTMessage
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m =
            Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MouseResizableTile EventMask)
 -> X (Maybe (MouseResizableTile EventMask)))
-> Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a. a -> Maybe a
Just (MouseResizableTile EventMask
 -> Maybe (MouseResizableTile EventMask))
-> MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask
st { leftFracs = replaceAtPos (slaveFrac st)
                (leftFracs st) pos (max 0 (min 1 f)) }
        | Just (SetRightSlaveFraction Int
pos Rational
f) <- SomeMessage -> Maybe MRTMessage
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m =
            Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (MouseResizableTile EventMask)
 -> X (Maybe (MouseResizableTile EventMask)))
-> Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a. a -> Maybe a
Just (MouseResizableTile EventMask
 -> Maybe (MouseResizableTile EventMask))
-> MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask
st { rightFracs = replaceAtPos (slaveFrac st)
                (rightFracs st) pos (max 0 (min 1 f)) }

        | Just Event
e <- SomeMessage -> Maybe Event
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m :: Maybe Event = [DraggerWithWin] -> Bool -> Event -> X ()
handleResize (MouseResizableTile EventMask -> [DraggerWithWin]
forall a. MouseResizableTile a -> [DraggerWithWin]
draggers MouseResizableTile EventMask
st) (MouseResizableTile EventMask -> Bool
forall a. MouseResizableTile a -> Bool
isMirrored MouseResizableTile EventMask
st) Event
e X ()
-> X (Maybe (MouseResizableTile EventMask))
-> X (Maybe (MouseResizableTile EventMask))
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (MouseResizableTile EventMask)
forall a. Maybe a
Nothing
        | Just LayoutMessages
Hide             <- SomeMessage -> Maybe LayoutMessages
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = X ()
releaseResources X ()
-> X (Maybe (MouseResizableTile EventMask))
-> X (Maybe (MouseResizableTile EventMask))
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a. a -> Maybe a
Just (MouseResizableTile EventMask
 -> Maybe (MouseResizableTile EventMask))
-> MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask
st { draggers = [] })
        | Just LayoutMessages
ReleaseResources <- SomeMessage -> Maybe LayoutMessages
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = X ()
releaseResources X ()
-> X (Maybe (MouseResizableTile EventMask))
-> X (Maybe (MouseResizableTile EventMask))
forall a b. X a -> X b -> X b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a. a -> Maybe a
Just (MouseResizableTile EventMask
 -> Maybe (MouseResizableTile EventMask))
-> MouseResizableTile EventMask
-> Maybe (MouseResizableTile EventMask)
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask
st { draggers = [] })
        where releaseResources :: X ()
releaseResources = (DraggerWithWin -> X ()) -> [DraggerWithWin] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DraggerWithWin -> X ()
deleteDragger ([DraggerWithWin] -> X ()) -> [DraggerWithWin] -> X ()
forall a b. (a -> b) -> a -> b
$ MouseResizableTile EventMask -> [DraggerWithWin]
forall a. MouseResizableTile a -> [DraggerWithWin]
draggers MouseResizableTile EventMask
st
    handleMessage MouseResizableTile EventMask
_ SomeMessage
_ = Maybe (MouseResizableTile EventMask)
-> X (Maybe (MouseResizableTile EventMask))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (MouseResizableTile EventMask)
forall a. Maybe a
Nothing

    description :: MouseResizableTile EventMask -> String
description MouseResizableTile EventMask
st = ShowS
mirror String
"MouseResizableTile"
        where mirror :: ShowS
mirror = if MouseResizableTile EventMask -> Bool
forall a. MouseResizableTile a -> Bool
isMirrored MouseResizableTile EventMask
st then (String
"Mirror " String -> ShowS
forall a. [a] -> [a] -> [a]
++) else ShowS
forall a. a -> a
id

draggerGeometry :: DraggerType -> X DraggerGeometry
draggerGeometry :: DraggerType -> X DraggerGeometry
draggerGeometry (FixedDragger EventType
g EventType
d) =
    DraggerGeometry -> X DraggerGeometry
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (EventType -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EventType -> Position) -> EventType -> Position
forall a b. (a -> b) -> a -> b
$ EventType
g EventType -> EventType -> EventType
forall a. Integral a => a -> a -> a
`div` EventType
2, EventType
g, EventType -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EventType -> Position) -> EventType -> Position
forall a b. (a -> b) -> a -> b
$ EventType
d EventType -> EventType -> EventType
forall a. Integral a => a -> a -> a
`div` EventType
2, EventType
d)
draggerGeometry DraggerType
BordersDragger = do
    WindowSet
wins <- (XState -> WindowSet) -> X WindowSet
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
    EventType
w <- case WindowSet -> Maybe EventMask
forall i l a s sd. StackSet i l a s sd -> Maybe a
W.peek WindowSet
wins of
          Just EventMask
win -> EventMask -> X EventType
getBorderWidth EventMask
win
          Maybe EventMask
_        -> (XConf -> EventType) -> X EventType
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (XConfig Layout -> EventType
forall (l :: * -> *). XConfig l -> EventType
borderWidth (XConfig Layout -> EventType)
-> (XConf -> XConfig Layout) -> XConf -> EventType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> XConfig Layout
config)
    DraggerGeometry -> X DraggerGeometry
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Position
0, EventType
0, EventType -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
w, EventType
2EventType -> EventType -> EventType
forall a. Num a => a -> a -> a
*EventType
w)

getBorderWidth :: Window -> X Dimension
getBorderWidth :: EventMask -> X EventType
getBorderWidth EventMask
win = do
    Display
d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
    (EventMask
_,Position
_,Position
_,EventType
_,EventType
_,EventType
w,CInt
_) <- IO
  (EventMask, Position, Position, EventType, EventType, EventType,
   CInt)
-> X (EventMask, Position, Position, EventType, EventType,
      EventType, CInt)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO
   (EventMask, Position, Position, EventType, EventType, EventType,
    CInt)
 -> X (EventMask, Position, Position, EventType, EventType,
       EventType, CInt))
-> IO
     (EventMask, Position, Position, EventType, EventType, EventType,
      CInt)
-> X (EventMask, Position, Position, EventType, EventType,
      EventType, CInt)
forall a b. (a -> b) -> a -> b
$ Display
-> EventMask
-> IO
     (EventMask, Position, Position, EventType, EventType, EventType,
      CInt)
X.getGeometry Display
d EventMask
win
    EventType -> X EventType
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return EventType
w

adjustForMirror :: Bool -> DraggerWithRect -> DraggerWithRect
adjustForMirror :: Bool -> DraggerWithRect -> DraggerWithRect
adjustForMirror Bool
False DraggerWithRect
dragger = DraggerWithRect
dragger
adjustForMirror Bool
True (Rectangle
draggerRect, Glyph
draggerCursor, DraggerInfo
draggerInfo) =
        (Rectangle -> Rectangle
mirrorRect Rectangle
draggerRect, Glyph
draggerCursor', DraggerInfo
draggerInfo)
    where
        draggerCursor' :: Glyph
draggerCursor' = if Glyph
draggerCursor Glyph -> Glyph -> Bool
forall a. Eq a => a -> a -> Bool
== Glyph
xC_sb_h_double_arrow
                            then Glyph
xC_sb_v_double_arrow
                            else Glyph
xC_sb_h_double_arrow

modifySlave :: MouseResizableTile a -> Rational -> MouseResizableTile a
modifySlave :: forall a. MouseResizableTile a -> Rational -> MouseResizableTile a
modifySlave MouseResizableTile a
st Rational
delta =
    let pos :: Int
pos = MouseResizableTile a -> Int
forall a. MouseResizableTile a -> Int
focusPos MouseResizableTile a
st
        num :: Int
num = MouseResizableTile a -> Int
forall a. MouseResizableTile a -> Int
numWindows MouseResizableTile a
st
        nmaster' :: Int
nmaster' = MouseResizableTile a -> Int
forall a. MouseResizableTile a -> Int
nmaster MouseResizableTile a
st
        leftFracs' :: [Rational]
leftFracs' = MouseResizableTile a -> [Rational]
forall a. MouseResizableTile a -> [Rational]
leftFracs MouseResizableTile a
st
        rightFracs' :: [Rational]
rightFracs' = MouseResizableTile a -> [Rational]
forall a. MouseResizableTile a -> [Rational]
rightFracs MouseResizableTile a
st
        slFrac :: Rational
slFrac = MouseResizableTile a -> Rational
forall a. MouseResizableTile a -> Rational
slaveFrac MouseResizableTile a
st
        draggersLeft :: Int
draggersLeft = Int
nmaster' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        draggersRight :: Int
draggersRight = (Int
num Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nmaster') Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
    in if Int
pos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
nmaster'
        then if Int
draggersLeft Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                then let draggerPos :: Int
draggerPos = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
draggersLeft Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int
pos
                         oldFraction :: Rational
oldFraction = ([Rational]
leftFracs' [Rational] -> [Rational] -> [Rational]
forall a. [a] -> [a] -> [a]
++ Rational -> [Rational]
forall a. a -> [a]
repeat Rational
slFrac) [Rational] -> Int -> Rational
forall a. HasCallStack => [a] -> Int -> a
!! Int
draggerPos
                     in MouseResizableTile a
st { leftFracs = replaceAtPos slFrac leftFracs' draggerPos
                                            (max 0 (min 1 (oldFraction + delta))) }
                else MouseResizableTile a
st
        else if Int
draggersRight Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                then let draggerPos :: Int
draggerPos = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int
draggersRight Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nmaster')
                         oldFraction :: Rational
oldFraction = ([Rational]
rightFracs' [Rational] -> [Rational] -> [Rational]
forall a. [a] -> [a] -> [a]
++ Rational -> [Rational]
forall a. a -> [a]
repeat Rational
slFrac) [Rational] -> Int -> Rational
forall a. HasCallStack => [a] -> Int -> a
!! Int
draggerPos
                     in MouseResizableTile a
st { rightFracs = replaceAtPos slFrac rightFracs' draggerPos
                                            (max 0 (min 1 (oldFraction + delta))) }
                else MouseResizableTile a
st

replaceAtPos :: (Num t, Eq t) => Rational -> [Rational] -> t -> Rational -> [Rational]
replaceAtPos :: forall t.
(Num t, Eq t) =>
Rational -> [Rational] -> t -> Rational -> [Rational]
replaceAtPos Rational
_ [] t
0 Rational
x' = [Rational
x']
replaceAtPos Rational
d [] t
pos Rational
x' = Rational
d Rational -> [Rational] -> [Rational]
forall a. a -> [a] -> [a]
: Rational -> [Rational] -> t -> Rational -> [Rational]
forall t.
(Num t, Eq t) =>
Rational -> [Rational] -> t -> Rational -> [Rational]
replaceAtPos Rational
d [] (t
pos t -> t -> t
forall a. Num a => a -> a -> a
- t
1) Rational
x'
replaceAtPos Rational
_ (Rational
_:[Rational]
xs) t
0 Rational
x' = Rational
x' Rational -> [Rational] -> [Rational]
forall a. a -> [a] -> [a]
: [Rational]
xs
replaceAtPos Rational
d (Rational
x:[Rational]
xs) t
pos Rational
x' = Rational
x Rational -> [Rational] -> [Rational]
forall a. a -> [a] -> [a]
: Rational -> [Rational] -> t -> Rational -> [Rational]
forall t.
(Num t, Eq t) =>
Rational -> [Rational] -> t -> Rational -> [Rational]
replaceAtPos Rational
d [Rational]
xs (t
pos t -> t -> t
forall a. Num a => a -> a -> a
-t
1 ) Rational
x'

sanitizeRectangle :: Rectangle -> Rectangle -> Rectangle
sanitizeRectangle :: Rectangle -> Rectangle -> Rectangle
sanitizeRectangle (Rectangle Position
sx Position
sy EventType
swh EventType
sht) (Rectangle Position
x Position
y EventType
wh EventType
ht) =
    Position -> Position -> EventType -> EventType -> Rectangle
Rectangle (Position -> Position -> Position -> Position
forall a. Ord a => a -> a -> a -> a
within Position
0 (Position
sx Position -> Position -> Position
forall a. Num a => a -> a -> a
+ EventType -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
swh) Position
x) (Position -> Position -> Position -> Position
forall a. Ord a => a -> a -> a -> a
within Position
0 (Position
sy Position -> Position -> Position
forall a. Num a => a -> a -> a
+ EventType -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
sht) Position
y)
                (EventType -> EventType -> EventType -> EventType
forall a. Ord a => a -> a -> a -> a
within EventType
1 EventType
swh EventType
wh) (EventType -> EventType -> EventType -> EventType
forall a. Ord a => a -> a -> a -> a
within EventType
1 EventType
sht EventType
ht)

within :: (Ord a) => a -> a -> a -> a
within :: forall a. Ord a => a -> a -> a -> a
within a
low a
high a
a = a -> a -> a
forall a. Ord a => a -> a -> a
max a
low (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a -> a -> a
forall a. Ord a => a -> a -> a
min a
high a
a

tile :: Int -> Rational -> [Rational] -> [Rational] -> Rectangle -> Int -> DraggerGeometry -> ([Rectangle], [DraggerWithRect])
tile :: Int
-> Rational
-> [Rational]
-> [Rational]
-> Rectangle
-> Int
-> DraggerGeometry
-> ([Rectangle], [DraggerWithRect])
tile Int
nmaster' Rational
masterFrac' [Rational]
leftFracs' [Rational]
rightFracs' Rectangle
sr Int
num DraggerGeometry
drg
    | Int
num Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
nmaster'       = [Rational]
-> Rectangle
-> Bool
-> Int
-> DraggerGeometry
-> ([Rectangle], [DraggerWithRect])
forall r.
RealFrac r =>
[r]
-> Rectangle
-> Bool
-> Int
-> DraggerGeometry
-> ([Rectangle], [DraggerWithRect])
splitVertically (Int -> [Rational] -> [Rational]
forall a. Int -> [a] -> [a]
take (Int
num Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Rational]
leftFracs') Rectangle
sr Bool
True Int
0 DraggerGeometry
drg
    | Int
nmaster' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0         = [Rational]
-> Rectangle
-> Bool
-> Int
-> DraggerGeometry
-> ([Rectangle], [DraggerWithRect])
forall r.
RealFrac r =>
[r]
-> Rectangle
-> Bool
-> Int
-> DraggerGeometry
-> ([Rectangle], [DraggerWithRect])
splitVertically (Int -> [Rational] -> [Rational]
forall a. Int -> [a] -> [a]
take (Int
num Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Rational]
rightFracs') Rectangle
sr Bool
False Int
0 DraggerGeometry
drg
    | Bool
otherwise             = ([Rectangle]
leftRects [Rectangle] -> [Rectangle] -> [Rectangle]
forall a. [a] -> [a] -> [a]
++ [Rectangle]
rightRects, DraggerWithRect
masterDragger DraggerWithRect -> [DraggerWithRect] -> [DraggerWithRect]
forall a. a -> [a] -> [a]
: [DraggerWithRect]
leftDraggers [DraggerWithRect] -> [DraggerWithRect] -> [DraggerWithRect]
forall a. [a] -> [a] -> [a]
++ [DraggerWithRect]
rightDraggers)
    where ((Rectangle
sr1, Rectangle
sr2), DraggerWithRect
masterDragger) = Rational
-> Rectangle
-> DraggerGeometry
-> ((Rectangle, Rectangle), DraggerWithRect)
forall r.
RealFrac r =>
r
-> Rectangle
-> DraggerGeometry
-> ((Rectangle, Rectangle), DraggerWithRect)
splitHorizontallyBy Rational
masterFrac' Rectangle
sr DraggerGeometry
drg
          ([Rectangle]
leftRects, [DraggerWithRect]
leftDraggers) = [Rational]
-> Rectangle
-> Bool
-> Int
-> DraggerGeometry
-> ([Rectangle], [DraggerWithRect])
forall r.
RealFrac r =>
[r]
-> Rectangle
-> Bool
-> Int
-> DraggerGeometry
-> ([Rectangle], [DraggerWithRect])
splitVertically (Int -> [Rational] -> [Rational]
forall a. Int -> [a] -> [a]
take (Int
nmaster' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Rational]
leftFracs') Rectangle
sr1 Bool
True Int
0 DraggerGeometry
drg
          ([Rectangle]
rightRects, [DraggerWithRect]
rightDraggers) = [Rational]
-> Rectangle
-> Bool
-> Int
-> DraggerGeometry
-> ([Rectangle], [DraggerWithRect])
forall r.
RealFrac r =>
[r]
-> Rectangle
-> Bool
-> Int
-> DraggerGeometry
-> ([Rectangle], [DraggerWithRect])
splitVertically (Int -> [Rational] -> [Rational]
forall a. Int -> [a] -> [a]
take (Int
num Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nmaster' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Rational]
rightFracs') Rectangle
sr2 Bool
False Int
0 DraggerGeometry
drg

splitVertically :: RealFrac r => [r] -> Rectangle -> Bool -> Int -> DraggerGeometry -> ([Rectangle], [DraggerWithRect])
splitVertically :: forall r.
RealFrac r =>
[r]
-> Rectangle
-> Bool
-> Int
-> DraggerGeometry
-> ([Rectangle], [DraggerWithRect])
splitVertically [] Rectangle
r Bool
_ Int
_ DraggerGeometry
_ = ([Rectangle
r], [])
splitVertically (r
f:[r]
fx) (Rectangle Position
sx Position
sy EventType
sw EventType
sh) Bool
isLeft Int
num drg :: DraggerGeometry
drg@(Position
drOff, EventType
drSz, Position
drOff2, EventType
drSz2) =
    let nextRect :: Rectangle
nextRect = Position -> Position -> EventType -> EventType -> Rectangle
Rectangle Position
sx Position
sy EventType
sw (EventType -> Rectangle) -> EventType -> Rectangle
forall a b. (a -> b) -> a -> b
$ EventType
smallh EventType -> EventType -> EventType
forall a. Num a => a -> a -> a
- EventType -> EventType -> EventType
forall a. Integral a => a -> a -> a
div EventType
drSz EventType
2
        ([Rectangle]
otherRects, [DraggerWithRect]
otherDragger) = [r]
-> Rectangle
-> Bool
-> Int
-> DraggerGeometry
-> ([Rectangle], [DraggerWithRect])
forall r.
RealFrac r =>
[r]
-> Rectangle
-> Bool
-> Int
-> DraggerGeometry
-> ([Rectangle], [DraggerWithRect])
splitVertically [r]
fx
                                        (Position -> Position -> EventType -> EventType -> Rectangle
Rectangle Position
sx (Position
sy Position -> Position -> Position
forall a. Num a => a -> a -> a
+ EventType -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
smallh Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
drOff)
                                                    EventType
sw (EventType
sh EventType -> EventType -> EventType
forall a. Num a => a -> a -> a
- EventType
smallh EventType -> EventType -> EventType
forall a. Num a => a -> a -> a
- EventType -> EventType -> EventType
forall a. Integral a => a -> a -> a
div EventType
drSz EventType
2))
                                        Bool
isLeft (Int
num Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) DraggerGeometry
drg
        draggerRect :: Rectangle
draggerRect = Position -> Position -> EventType -> EventType -> Rectangle
Rectangle Position
sx (Position
sy Position -> Position -> Position
forall a. Num a => a -> a -> a
+ EventType -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
smallh Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
drOff2) EventType
sw EventType
drSz2
        draggerInfo :: DraggerInfo
draggerInfo = if Bool
isLeft
                        then Position -> Rational -> Int -> DraggerInfo
LeftSlaveDragger Position
sy (EventType -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
sh) Int
num
                        else Position -> Rational -> Int -> DraggerInfo
RightSlaveDragger Position
sy (EventType -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
sh) Int
num
        nextDragger :: DraggerWithRect
nextDragger = (Rectangle
draggerRect, Glyph
xC_sb_v_double_arrow, DraggerInfo
draggerInfo)
    in (Rectangle
nextRect Rectangle -> [Rectangle] -> [Rectangle]
forall a. a -> [a] -> [a]
: [Rectangle]
otherRects, DraggerWithRect
nextDragger DraggerWithRect -> [DraggerWithRect] -> [DraggerWithRect]
forall a. a -> [a] -> [a]
: [DraggerWithRect]
otherDragger)
  where smallh :: EventType
smallh = r -> EventType
forall b. Integral b => r -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (r -> EventType) -> r -> EventType
forall a b. (a -> b) -> a -> b
$ EventType -> r
forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
sh r -> r -> r
forall a. Num a => a -> a -> a
* r
f

splitHorizontallyBy :: RealFrac r => r -> Rectangle -> DraggerGeometry -> ((Rectangle, Rectangle), DraggerWithRect)
splitHorizontallyBy :: forall r.
RealFrac r =>
r
-> Rectangle
-> DraggerGeometry
-> ((Rectangle, Rectangle), DraggerWithRect)
splitHorizontallyBy r
f (Rectangle Position
sx Position
sy EventType
sw EventType
sh) (Position
drOff, EventType
drSz, Position
drOff2, EventType
drSz2) =
    ((Rectangle
leftHalf, Rectangle
rightHalf), (Rectangle
draggerRect, Glyph
xC_sb_h_double_arrow, DraggerInfo
draggerInfo))
  where leftw :: EventType
leftw = r -> EventType
forall b. Integral b => r -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (r -> EventType) -> r -> EventType
forall a b. (a -> b) -> a -> b
$ EventType -> r
forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
sw r -> r -> r
forall a. Num a => a -> a -> a
* r
f
        leftHalf :: Rectangle
leftHalf = Position -> Position -> EventType -> EventType -> Rectangle
Rectangle Position
sx Position
sy (EventType
leftw EventType -> EventType -> EventType
forall a. Num a => a -> a -> a
- EventType
drSz EventType -> EventType -> EventType
forall a. Integral a => a -> a -> a
`div` EventType
2) EventType
sh
        rightHalf :: Rectangle
rightHalf = Position -> Position -> EventType -> EventType -> Rectangle
Rectangle (Position
sx Position -> Position -> Position
forall a. Num a => a -> a -> a
+ EventType -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
leftw Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
drOff) Position
sy
                                (EventType
sw EventType -> EventType -> EventType
forall a. Num a => a -> a -> a
- EventType -> EventType
forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
leftw EventType -> EventType -> EventType
forall a. Num a => a -> a -> a
- EventType
drSz EventType -> EventType -> EventType
forall a. Integral a => a -> a -> a
`div` EventType
2) EventType
sh
        draggerRect :: Rectangle
draggerRect = Position -> Position -> EventType -> EventType -> Rectangle
Rectangle (Position
sx Position -> Position -> Position
forall a. Num a => a -> a -> a
+ EventType -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
leftw Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
drOff2) Position
sy EventType
drSz2 EventType
sh
        draggerInfo :: DraggerInfo
draggerInfo = Position -> Rational -> DraggerInfo
MasterDragger Position
sx (EventType -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
sw)

createDragger :: Rectangle -> DraggerWithRect -> X ((Window, Rectangle), DraggerWithWin)
createDragger :: Rectangle
-> DraggerWithRect -> X ((EventMask, Rectangle), DraggerWithWin)
createDragger Rectangle
sr (Rectangle
draggerRect, Glyph
draggerCursor, DraggerInfo
draggerInfo) = do
        let draggerRect' :: Rectangle
draggerRect' = Rectangle -> Rectangle -> Rectangle
sanitizeRectangle Rectangle
sr Rectangle
draggerRect
        EventMask
draggerWin <- Glyph -> Rectangle -> X EventMask
createInputWindow Glyph
draggerCursor Rectangle
draggerRect'
        ((EventMask, Rectangle), DraggerWithWin)
-> X ((EventMask, Rectangle), DraggerWithWin)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ((EventMask
draggerWin, Rectangle
draggerRect'), (EventMask
draggerWin, DraggerInfo
draggerInfo))

deleteDragger :: DraggerWithWin -> X ()
deleteDragger :: DraggerWithWin -> X ()
deleteDragger (EventMask
draggerWin, DraggerInfo
_) = EventMask -> X ()
deleteWindow EventMask
draggerWin

handleResize :: [DraggerWithWin] -> Bool -> Event -> X ()
handleResize :: [DraggerWithWin] -> Bool -> Event -> X ()
handleResize [DraggerWithWin]
draggers' Bool
isM ButtonEvent { ev_window :: Event -> EventMask
ev_window = EventMask
ew, ev_event_type :: Event -> EventType
ev_event_type = EventType
et }
    | EventType
et EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
buttonPress, Just DraggerInfo
x <- EventMask -> [DraggerWithWin] -> Maybe DraggerInfo
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup EventMask
ew [DraggerWithWin]
draggers' = case DraggerInfo
x of
        MasterDragger     Position
lb Rational
r     -> ((Position -> Position -> Position)
 -> Position -> Position -> Position)
-> Position -> Rational -> (Rational -> MRTMessage) -> X ()
forall {a} {t} {t} {p}.
(Message a, Fractional t, Integral t) =>
((p -> p -> p) -> Position -> Position -> t)
-> t -> t -> (t -> a) -> X ()
mouseDrag' (Position -> Position -> Position)
-> Position -> Position -> Position
forall a. a -> a
id   Position
lb Rational
r  Rational -> MRTMessage
SetMasterFraction
        LeftSlaveDragger  Position
lb Rational
r Int
num -> ((Position -> Position -> Position)
 -> Position -> Position -> Position)
-> Position -> Rational -> (Rational -> MRTMessage) -> X ()
forall {a} {t} {t} {p}.
(Message a, Fractional t, Integral t) =>
((p -> p -> p) -> Position -> Position -> t)
-> t -> t -> (t -> a) -> X ()
mouseDrag' (Position -> Position -> Position)
-> Position -> Position -> Position
forall a b c. (a -> b -> c) -> b -> a -> c
flip Position
lb Rational
r (Int -> Rational -> MRTMessage
SetLeftSlaveFraction Int
num)
        RightSlaveDragger Position
lb Rational
r Int
num -> ((Position -> Position -> Position)
 -> Position -> Position -> Position)
-> Position -> Rational -> (Rational -> MRTMessage) -> X ()
forall {a} {t} {t} {p}.
(Message a, Fractional t, Integral t) =>
((p -> p -> p) -> Position -> Position -> t)
-> t -> t -> (t -> a) -> X ()
mouseDrag' (Position -> Position -> Position)
-> Position -> Position -> Position
forall a b c. (a -> b -> c) -> b -> a -> c
flip Position
lb Rational
r (Int -> Rational -> MRTMessage
SetRightSlaveFraction Int
num)
    where
        chooseAxis :: Bool -> p -> p -> p
chooseAxis Bool
isM' p
axis1 p
axis2 = if Bool
isM' then p
axis2 else p
axis1
        mouseDrag' :: ((p -> p -> p) -> Position -> Position -> t)
-> t -> t -> (t -> a) -> X ()
mouseDrag' (p -> p -> p) -> Position -> Position -> t
flp t
lowerBound t
range t -> a
msg = ((Position -> Position -> X ()) -> X () -> X ())
-> X () -> (Position -> Position -> X ()) -> X ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Position -> Position -> X ()) -> X () -> X ()
mouseDrag (() -> X ()
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((Position -> Position -> X ()) -> X ())
-> (Position -> Position -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Position
x Position
y -> do
                let axis :: t
axis = (p -> p -> p) -> Position -> Position -> t
flp (Bool -> p -> p -> p
forall {p}. Bool -> p -> p -> p
chooseAxis Bool
isM) Position
x Position
y
                    fraction :: t
fraction = t -> t
forall a b. (Integral a, Num b) => a -> b
fromIntegral (t
axis t -> t -> t
forall a. Num a => a -> a -> a
- t
lowerBound) t -> t -> t
forall a. Fractional a => a -> a -> a
/ t
range
                a -> X ()
forall a. Message a => a -> X ()
sendMessage (t -> a
msg t
fraction)

handleResize [DraggerWithWin]
_ Bool
_ Event
_ = () -> X ()
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

createInputWindow :: Glyph -> Rectangle -> X Window
createInputWindow :: Glyph -> Rectangle -> X EventMask
createInputWindow Glyph
cursorGlyph Rectangle
r = (Display -> X EventMask) -> X EventMask
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X EventMask) -> X EventMask)
-> (Display -> X EventMask) -> X EventMask
forall a b. (a -> b) -> a -> b
$ \Display
d -> do
    EventMask
win <- Display -> Rectangle -> X EventMask
mkInputWindow Display
d Rectangle
r
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> EventMask -> EventMask -> IO ()
selectInput Display
d EventMask
win (EventMask
exposureMask EventMask -> EventMask -> EventMask
forall a. Bits a => a -> a -> a
.|. EventMask
buttonPressMask)
    EventMask
cursor <- IO EventMask -> X EventMask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO EventMask -> X EventMask) -> IO EventMask -> X EventMask
forall a b. (a -> b) -> a -> b
$ Display -> Glyph -> IO EventMask
createFontCursor Display
d Glyph
cursorGlyph
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> EventMask -> EventMask -> IO ()
defineCursor Display
d EventMask
win EventMask
cursor
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Display -> EventMask -> IO ()
freeCursor Display
d EventMask
cursor
    EventMask -> X ()
showWindow EventMask
win
    EventMask -> X EventMask
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return EventMask
win

mkInputWindow :: Display -> Rectangle -> X Window
mkInputWindow :: Display -> Rectangle -> X EventMask
mkInputWindow Display
d (Rectangle Position
x Position
y EventType
w EventType
h) = do
  EventMask
rw <- (XConf -> EventMask) -> X EventMask
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> EventMask
theRoot
  let screen :: Screen
screen   = Display -> Screen
defaultScreenOfDisplay Display
d
      visual :: Visual
visual   = Screen -> Visual
defaultVisualOfScreen Screen
screen
      attrmask :: EventMask
attrmask = EventMask
cWOverrideRedirect
  IO EventMask -> X EventMask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO EventMask -> X EventMask) -> IO EventMask -> X EventMask
forall a b. (a -> b) -> a -> b
$ (Ptr SetWindowAttributes -> IO EventMask) -> IO EventMask
forall a. (Ptr SetWindowAttributes -> IO a) -> IO a
allocaSetWindowAttributes ((Ptr SetWindowAttributes -> IO EventMask) -> IO EventMask)
-> (Ptr SetWindowAttributes -> IO EventMask) -> IO EventMask
forall a b. (a -> b) -> a -> b
$
         \Ptr SetWindowAttributes
attributes -> do
           Ptr SetWindowAttributes -> Bool -> IO ()
set_override_redirect Ptr SetWindowAttributes
attributes Bool
True
           Display
-> EventMask
-> Position
-> Position
-> EventType
-> EventType
-> CInt
-> CInt
-> CInt
-> Visual
-> EventMask
-> Ptr SetWindowAttributes
-> IO EventMask
createWindow Display
d EventMask
rw Position
x Position
y EventType
w EventType
h CInt
0 CInt
0 CInt
inputOnly Visual
visual EventMask
attrmask Ptr SetWindowAttributes
attributes