{-# 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DraggerInfo] -> ShowS
$cshowList :: [DraggerInfo] -> ShowS
show :: DraggerInfo -> String
$cshow :: DraggerInfo -> String
showsPrec :: Int -> DraggerInfo -> ShowS
$cshowsPrec :: Int -> DraggerInfo -> ShowS
Show, ReadPrec [DraggerInfo]
ReadPrec DraggerInfo
Int -> ReadS DraggerInfo
ReadS [DraggerInfo]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DraggerInfo]
$creadListPrec :: ReadPrec [DraggerInfo]
readPrec :: ReadPrec DraggerInfo
$creadPrec :: ReadPrec DraggerInfo
readList :: ReadS [DraggerInfo]
$creadList :: ReadS [DraggerInfo]
readsPrec :: Int -> ReadS DraggerInfo
$creadsPrec :: Int -> ReadS 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DraggerType] -> ShowS
$cshowList :: [DraggerType] -> ShowS
show :: DraggerType -> String
$cshow :: DraggerType -> String
showsPrec :: Int -> DraggerType -> ShowS
$cshowsPrec :: Int -> DraggerType -> ShowS
Show, ReadPrec [DraggerType]
ReadPrec DraggerType
Int -> ReadS DraggerType
ReadS [DraggerType]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DraggerType]
$creadListPrec :: ReadPrec [DraggerType]
readPrec :: ReadPrec DraggerType
$creadPrec :: ReadPrec DraggerType
readList :: ReadS [DraggerType]
$creadList :: ReadS [DraggerType]
readsPrec :: Int -> ReadS DraggerType
$creadsPrec :: Int -> ReadS 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
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
showList :: [MouseResizableTile a] -> ShowS
$cshowList :: forall a. [MouseResizableTile a] -> ShowS
show :: MouseResizableTile a -> String
$cshow :: forall a. MouseResizableTile a -> String
showsPrec :: Int -> MouseResizableTile a -> ShowS
$cshowsPrec :: forall a. Int -> MouseResizableTile a -> ShowS
Show, ReadPrec [MouseResizableTile a]
ReadPrec (MouseResizableTile a)
ReadS [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
readListPrec :: ReadPrec [MouseResizableTile a]
$creadListPrec :: forall a. ReadPrec [MouseResizableTile a]
readPrec :: ReadPrec (MouseResizableTile a)
$creadPrec :: forall a. ReadPrec (MouseResizableTile a)
readList :: ReadS [MouseResizableTile a]
$creadList :: forall a. ReadS [MouseResizableTile a]
readsPrec :: Int -> ReadS (MouseResizableTile a)
$creadsPrec :: forall a. Int -> ReadS (MouseResizableTile a)
Read)

mouseResizableTile :: MouseResizableTile a
mouseResizableTile :: forall a. MouseResizableTile a
mouseResizableTile = 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 = forall a. MouseResizableTile a
mouseResizableTile { isMirrored :: Bool
isMirrored = Bool
True }

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

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

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

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

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

getBorderWidth :: Window -> X Dimension
getBorderWidth :: Window -> X EventType
getBorderWidth Window
win = do
    Display
d <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
    (Window
_,Position
_,Position
_,EventType
_,EventType
_,EventType
w,CInt
_) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display
-> Window
-> IO
     (Window, Position, Position, EventType, EventType, EventType, CInt)
X.getGeometry Display
d Window
win
    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 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 = forall a. MouseResizableTile a -> Int
focusPos MouseResizableTile a
st
        num :: Int
num = forall a. MouseResizableTile a -> Int
numWindows MouseResizableTile a
st
        nmaster' :: Int
nmaster' = forall a. MouseResizableTile a -> Int
nmaster MouseResizableTile a
st
        leftFracs' :: [Rational]
leftFracs' = forall a. MouseResizableTile a -> [Rational]
leftFracs MouseResizableTile a
st
        rightFracs' :: [Rational]
rightFracs' = forall a. MouseResizableTile a -> [Rational]
rightFracs MouseResizableTile a
st
        slFrac :: Rational
slFrac = forall a. MouseResizableTile a -> Rational
slaveFrac MouseResizableTile a
st
        draggersLeft :: Int
draggersLeft = Int
nmaster' forall a. Num a => a -> a -> a
- Int
1
        draggersRight :: Int
draggersRight = (Int
num forall a. Num a => a -> a -> a
- Int
nmaster') forall a. Num a => a -> a -> a
- Int
1
    in if Int
pos forall a. Ord a => a -> a -> Bool
< Int
nmaster'
        then if Int
draggersLeft forall a. Ord a => a -> a -> Bool
> Int
0
                then let draggerPos :: Int
draggerPos = forall a. Ord a => a -> a -> a
min (Int
draggersLeft forall a. Num a => a -> a -> a
- Int
1) Int
pos
                         oldFraction :: Rational
oldFraction = ([Rational]
leftFracs' forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat Rational
slFrac) forall a. [a] -> Int -> a
!! Int
draggerPos
                     in MouseResizableTile a
st { leftFracs :: [Rational]
leftFracs = forall t.
(Num t, Eq t) =>
Rational -> [Rational] -> t -> Rational -> [Rational]
replaceAtPos Rational
slFrac [Rational]
leftFracs' Int
draggerPos
                                            (forall a. Ord a => a -> a -> a
max Rational
0 (forall a. Ord a => a -> a -> a
min Rational
1 (Rational
oldFraction forall a. Num a => a -> a -> a
+ Rational
delta))) }
                else MouseResizableTile a
st
        else if Int
draggersRight forall a. Ord a => a -> a -> Bool
> Int
0
                then let draggerPos :: Int
draggerPos = forall a. Ord a => a -> a -> a
min (Int
draggersRight forall a. Num a => a -> a -> a
- Int
1) (Int
pos forall a. Num a => a -> a -> a
- Int
nmaster')
                         oldFraction :: Rational
oldFraction = ([Rational]
rightFracs' forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat Rational
slFrac) forall a. [a] -> Int -> a
!! Int
draggerPos
                     in MouseResizableTile a
st { rightFracs :: [Rational]
rightFracs = forall t.
(Num t, Eq t) =>
Rational -> [Rational] -> t -> Rational -> [Rational]
replaceAtPos Rational
slFrac [Rational]
rightFracs' Int
draggerPos
                                            (forall a. Ord a => a -> a -> a
max Rational
0 (forall a. Ord a => a -> a -> a
min Rational
1 (Rational
oldFraction forall a. Num a => a -> a -> a
+ Rational
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 forall a. a -> [a] -> [a]
: forall t.
(Num t, Eq t) =>
Rational -> [Rational] -> t -> Rational -> [Rational]
replaceAtPos Rational
d [] (t
pos forall a. Num a => a -> a -> a
- t
1) Rational
x'
replaceAtPos Rational
_ (Rational
_:[Rational]
xs) t
0 Rational
x' = Rational
x' forall a. a -> [a] -> [a]
: [Rational]
xs
replaceAtPos Rational
d (Rational
x:[Rational]
xs) t
pos Rational
x' = Rational
x forall a. a -> [a] -> [a]
: forall t.
(Num t, Eq t) =>
Rational -> [Rational] -> t -> Rational -> [Rational]
replaceAtPos Rational
d [Rational]
xs (t
pos 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 (forall a. Ord a => a -> a -> a -> a
within Position
0 (Position
sx forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
swh) Position
x) (forall a. Ord a => a -> a -> a -> a
within Position
0 (Position
sy forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
sht) Position
y)
                (forall a. Ord a => a -> a -> a -> a
within EventType
1 EventType
swh EventType
wh) (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 = forall a. Ord a => a -> a -> a
max a
low forall a b. (a -> b) -> a -> b
$ 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 forall a. Ord a => a -> a -> Bool
<= Int
nmaster'       = forall r.
RealFrac r =>
[r]
-> Rectangle
-> Bool
-> Int
-> DraggerGeometry
-> ([Rectangle], [DraggerWithRect])
splitVertically (forall a. Int -> [a] -> [a]
take (Int
num forall a. Num a => a -> a -> a
- Int
1) [Rational]
leftFracs') Rectangle
sr Bool
True Int
0 DraggerGeometry
drg
    | Int
nmaster' forall a. Eq a => a -> a -> Bool
== Int
0         = forall r.
RealFrac r =>
[r]
-> Rectangle
-> Bool
-> Int
-> DraggerGeometry
-> ([Rectangle], [DraggerWithRect])
splitVertically (forall a. Int -> [a] -> [a]
take (Int
num forall a. Num a => a -> a -> a
- Int
1) [Rational]
rightFracs') Rectangle
sr Bool
False Int
0 DraggerGeometry
drg
    | Bool
otherwise             = ([Rectangle]
leftRects forall a. [a] -> [a] -> [a]
++ [Rectangle]
rightRects, DraggerWithRect
masterDragger forall a. a -> [a] -> [a]
: [DraggerWithRect]
leftDraggers forall a. [a] -> [a] -> [a]
++ [DraggerWithRect]
rightDraggers)
    where ((Rectangle
sr1, Rectangle
sr2), DraggerWithRect
masterDragger) = forall r.
RealFrac r =>
r
-> Rectangle
-> DraggerGeometry
-> ((Rectangle, Rectangle), DraggerWithRect)
splitHorizontallyBy Rational
masterFrac' Rectangle
sr DraggerGeometry
drg
          ([Rectangle]
leftRects, [DraggerWithRect]
leftDraggers) = forall r.
RealFrac r =>
[r]
-> Rectangle
-> Bool
-> Int
-> DraggerGeometry
-> ([Rectangle], [DraggerWithRect])
splitVertically (forall a. Int -> [a] -> [a]
take (Int
nmaster' forall a. Num a => a -> a -> a
- Int
1) [Rational]
leftFracs') Rectangle
sr1 Bool
True Int
0 DraggerGeometry
drg
          ([Rectangle]
rightRects, [DraggerWithRect]
rightDraggers) = forall r.
RealFrac r =>
[r]
-> Rectangle
-> Bool
-> Int
-> DraggerGeometry
-> ([Rectangle], [DraggerWithRect])
splitVertically (forall a. Int -> [a] -> [a]
take (Int
num forall a. Num a => a -> a -> a
- Int
nmaster' 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 forall a b. (a -> b) -> a -> b
$ EventType
smallh forall a. Num a => a -> a -> a
- forall a. Integral a => a -> a -> a
div EventType
drSz EventType
2
        ([Rectangle]
otherRects, [DraggerWithRect]
otherDragger) = forall r.
RealFrac r =>
[r]
-> Rectangle
-> Bool
-> Int
-> DraggerGeometry
-> ([Rectangle], [DraggerWithRect])
splitVertically [r]
fx
                                        (Position -> Position -> EventType -> EventType -> Rectangle
Rectangle Position
sx (Position
sy forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
smallh forall a. Num a => a -> a -> a
+ Position
drOff)
                                                    EventType
sw (EventType
sh forall a. Num a => a -> a -> a
- EventType
smallh forall a. Num a => a -> a -> a
- forall a. Integral a => a -> a -> a
div EventType
drSz EventType
2))
                                        Bool
isLeft (Int
num forall a. Num a => a -> a -> a
+ Int
1) DraggerGeometry
drg
        draggerRect :: Rectangle
draggerRect = Position -> Position -> EventType -> EventType -> Rectangle
Rectangle Position
sx (Position
sy forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
smallh 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
sh) Int
num
                        else Position -> Rational -> Int -> DraggerInfo
RightSlaveDragger Position
sy (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 forall a. a -> [a] -> [a]
: [Rectangle]
otherRects, DraggerWithRect
nextDragger forall a. a -> [a] -> [a]
: [DraggerWithRect]
otherDragger)
  where smallh :: EventType
smallh = forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
sh 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 = forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
sw forall a. Num a => a -> a -> a
* r
f
        leftHalf :: Rectangle
leftHalf = Position -> Position -> EventType -> EventType -> Rectangle
Rectangle Position
sx Position
sy (EventType
leftw forall a. Num a => a -> a -> a
- EventType
drSz forall a. Integral a => a -> a -> a
`div` EventType
2) EventType
sh
        rightHalf :: Rectangle
rightHalf = Position -> Position -> EventType -> EventType -> Rectangle
Rectangle (Position
sx forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
leftw forall a. Num a => a -> a -> a
+ Position
drOff) Position
sy
                                (EventType
sw forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
leftw forall a. Num a => a -> a -> a
- EventType
drSz forall a. Integral a => a -> a -> a
`div` EventType
2) EventType
sh
        draggerRect :: Rectangle
draggerRect = Position -> Position -> EventType -> EventType -> Rectangle
Rectangle (Position
sx forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
leftw forall a. Num a => a -> a -> a
- Position
drOff2) Position
sy EventType
drSz2 EventType
sh
        draggerInfo :: DraggerInfo
draggerInfo = Position -> Rational -> DraggerInfo
MasterDragger Position
sx (forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
sw)

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

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

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

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

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

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