{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, PatternGuards #-}
----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.BorderResize
-- Description :  Resize windows by dragging their borders with the mouse.
-- Copyright   :  (c) Jan Vornberger 2009
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  jan.vornberger@informatik.uni-oldenburg.de
-- Stability   :  unstable
-- Portability :  not portable
--
-- This layout modifier will allow to resize windows by dragging their
-- borders with the mouse. However, it only works in layouts or modified
-- layouts that react to the 'SetGeometry' message.
-- "XMonad.Layout.WindowArranger" can be used to create such a setup,
-- but it is probably must useful in a floating layout such as
-- "XMonad.Layout.PositionStoreFloat" with which it has been mainly tested.
-- See the documentation of PositionStoreFloat for a typical usage example.
--
-----------------------------------------------------------------------------

module XMonad.Layout.BorderResize
    ( -- * Usage
      -- $usage
      borderResize
    , borderResizeNear
    , BorderResize (..)
    , RectWithBorders, BorderInfo,
    ) where

import XMonad
import XMonad.Layout.Decoration
import XMonad.Layout.WindowArranger
import XMonad.Util.XUtils
import XMonad.Prelude(when)
import qualified Data.Map as M

-- $usage
-- You can use this module with the following in your
-- @xmonad.hs@:
--
-- > import XMonad.Layout.BorderResize
-- > myLayout = borderResize (... layout setup that reacts to SetGeometry ...)
-- > main = xmonad def { layoutHook = myLayout }
--

type BorderBlueprint = (Rectangle, Glyph, BorderType)

data BorderType = RightSideBorder
                    | LeftSideBorder
                    | TopSideBorder
                    | BottomSideBorder
                    deriving (Int -> BorderType -> ShowS
[BorderType] -> ShowS
BorderType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BorderType] -> ShowS
$cshowList :: [BorderType] -> ShowS
show :: BorderType -> String
$cshow :: BorderType -> String
showsPrec :: Int -> BorderType -> ShowS
$cshowsPrec :: Int -> BorderType -> ShowS
Show, ReadPrec [BorderType]
ReadPrec BorderType
Int -> ReadS BorderType
ReadS [BorderType]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BorderType]
$creadListPrec :: ReadPrec [BorderType]
readPrec :: ReadPrec BorderType
$creadPrec :: ReadPrec BorderType
readList :: ReadS [BorderType]
$creadList :: ReadS [BorderType]
readsPrec :: Int -> ReadS BorderType
$creadsPrec :: Int -> ReadS BorderType
Read, BorderType -> BorderType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BorderType -> BorderType -> Bool
$c/= :: BorderType -> BorderType -> Bool
== :: BorderType -> BorderType -> Bool
$c== :: BorderType -> BorderType -> Bool
Eq)
data BorderInfo = BI { BorderInfo -> Window
bWin :: Window,
                        BorderInfo -> Rectangle
bRect :: Rectangle,
                        BorderInfo -> BorderType
bType :: BorderType
                     } deriving (Int -> BorderInfo -> ShowS
[BorderInfo] -> ShowS
BorderInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BorderInfo] -> ShowS
$cshowList :: [BorderInfo] -> ShowS
show :: BorderInfo -> String
$cshow :: BorderInfo -> String
showsPrec :: Int -> BorderInfo -> ShowS
$cshowsPrec :: Int -> BorderInfo -> ShowS
Show, ReadPrec [BorderInfo]
ReadPrec BorderInfo
Int -> ReadS BorderInfo
ReadS [BorderInfo]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BorderInfo]
$creadListPrec :: ReadPrec [BorderInfo]
readPrec :: ReadPrec BorderInfo
$creadPrec :: ReadPrec BorderInfo
readList :: ReadS [BorderInfo]
$creadList :: ReadS [BorderInfo]
readsPrec :: Int -> ReadS BorderInfo
$creadsPrec :: Int -> ReadS BorderInfo
Read)

type RectWithBorders = (Rectangle, [BorderInfo])

data BorderResize a = BR
  { forall a. BorderResize a -> EventType
brBorderSize  :: !Dimension
  -- ^ Still resize when this number of pixels around the border.
  , forall a. BorderResize a -> Map Window RectWithBorders
brWrsLastTime :: !(M.Map Window RectWithBorders)
  }
  deriving (Int -> BorderResize a -> ShowS
forall a. Int -> BorderResize a -> ShowS
forall a. [BorderResize a] -> ShowS
forall a. BorderResize a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BorderResize a] -> ShowS
$cshowList :: forall a. [BorderResize a] -> ShowS
show :: BorderResize a -> String
$cshow :: forall a. BorderResize a -> String
showsPrec :: Int -> BorderResize a -> ShowS
$cshowsPrec :: forall a. Int -> BorderResize a -> ShowS
Show, ReadPrec [BorderResize a]
ReadPrec (BorderResize a)
ReadS [BorderResize a]
forall a. ReadPrec [BorderResize a]
forall a. ReadPrec (BorderResize a)
forall a. Int -> ReadS (BorderResize a)
forall a. ReadS [BorderResize a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BorderResize a]
$creadListPrec :: forall a. ReadPrec [BorderResize a]
readPrec :: ReadPrec (BorderResize a)
$creadPrec :: forall a. ReadPrec (BorderResize a)
readList :: ReadS [BorderResize a]
$creadList :: forall a. ReadS [BorderResize a]
readsPrec :: Int -> ReadS (BorderResize a)
$creadsPrec :: forall a. Int -> ReadS (BorderResize a)
Read)

borderResize :: l a -> ModifiedLayout BorderResize l a
borderResize :: forall (l :: * -> *) a. l a -> ModifiedLayout BorderResize l a
borderResize = forall (l :: * -> *) a.
EventType -> l a -> ModifiedLayout BorderResize l a
borderResizeNear EventType
2

-- | Like 'borderResize', but takes the number of pixels near the border
-- up to which dragging still resizes a window.
borderResizeNear :: Dimension -> l a -> ModifiedLayout BorderResize l a
borderResizeNear :: forall (l :: * -> *) a.
EventType -> l a -> ModifiedLayout BorderResize l a
borderResizeNear EventType
borderSize = forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (forall a. EventType -> Map Window RectWithBorders -> BorderResize a
BR EventType
borderSize forall k a. Map k a
M.empty)

instance LayoutModifier BorderResize Window where
    redoLayout :: BorderResize Window
-> Rectangle
-> Maybe (Stack Window)
-> [(Window, Rectangle)]
-> X ([(Window, Rectangle)], Maybe (BorderResize Window))
redoLayout BorderResize Window
_       Rectangle
_ Maybe (Stack Window)
Nothing  [(Window, Rectangle)]
wrs = forall (m :: * -> *) a. Monad m => a -> m a
return ([(Window, Rectangle)]
wrs, forall a. Maybe a
Nothing)
    redoLayout (BR EventType
borderSize Map Window RectWithBorders
wrsLastTime) Rectangle
_ Maybe (Stack Window)
_ [(Window, Rectangle)]
wrs = do
            let correctOrder :: [Window]
correctOrder = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Window, Rectangle)]
wrs
                wrsCurrent :: Map Window Rectangle
wrsCurrent = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Window, Rectangle)]
wrs
                wrsGone :: Map Window RectWithBorders
wrsGone = forall k a b. Ord k => Map k a -> Map k b -> Map k a
M.difference Map Window RectWithBorders
wrsLastTime Map Window Rectangle
wrsCurrent
                wrsAppeared :: Map Window Rectangle
wrsAppeared = forall k a b. Ord k => Map k a -> Map k b -> Map k a
M.difference Map Window Rectangle
wrsCurrent Map Window RectWithBorders
wrsLastTime
                wrsStillThere :: Map Window (Maybe Rectangle, RectWithBorders)
wrsStillThere = forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith forall {a} {b}. Eq a => (a, b) -> a -> (Maybe a, (a, b))
testIfUnchanged Map Window RectWithBorders
wrsLastTime Map Window Rectangle
wrsCurrent
            Map Window RectWithBorders -> X ()
handleGone Map Window RectWithBorders
wrsGone
            Map Window RectWithBorders
wrsCreated <- EventType -> Map Window Rectangle -> X (Map Window RectWithBorders)
handleAppeared EventType
borderSize Map Window Rectangle
wrsAppeared
            let wrsChanged :: Map Window RectWithBorders
wrsChanged = EventType
-> Map Window (Maybe Rectangle, RectWithBorders)
-> Map Window RectWithBorders
handleStillThere EventType
borderSize Map Window (Maybe Rectangle, RectWithBorders)
wrsStillThere
                wrsThisTime :: Map Window RectWithBorders
wrsThisTime = forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map Window RectWithBorders
wrsChanged Map Window RectWithBorders
wrsCreated
            forall (m :: * -> *) a. Monad m => a -> m a
return (Map Window RectWithBorders -> [Window] -> [(Window, Rectangle)]
compileWrs Map Window RectWithBorders
wrsThisTime [Window]
correctOrder, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. EventType -> Map Window RectWithBorders -> BorderResize a
BR EventType
borderSize Map Window RectWithBorders
wrsThisTime)
            -- What we return is the original wrs with the new border
            -- windows inserted at the correct positions - this way, the core
            -- will restack the borders correctly.
            -- We also return information about our borders, so that we
            -- can handle events that they receive and destroy them when
            -- they are no longer needed.
        where
            testIfUnchanged :: (a, b) -> a -> (Maybe a, (a, b))
testIfUnchanged entry :: (a, b)
entry@(a
rLastTime, b
_) a
rCurrent =
                if a
rLastTime forall a. Eq a => a -> a -> Bool
== a
rCurrent
                    then (forall a. Maybe a
Nothing, (a, b)
entry)
                    else (forall a. a -> Maybe a
Just a
rCurrent, (a, b)
entry)

    handleMess :: BorderResize Window
-> SomeMessage -> X (Maybe (BorderResize Window))
handleMess (BR EventType
borderSize Map Window RectWithBorders
wrsLastTime) SomeMessage
m
        | Just Event
e <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m :: Maybe Event =
            [(Window, (BorderType, Window, Rectangle))] -> Event -> X ()
handleResize (Map Window RectWithBorders
-> [(Window, (BorderType, Window, Rectangle))]
createBorderLookupTable Map Window RectWithBorders
wrsLastTime) 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
_ <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m :: Maybe LayoutMessages =
            Map Window RectWithBorders -> X ()
handleGone Map Window RectWithBorders
wrsLastTime 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
$ forall a. EventType -> Map Window RectWithBorders -> BorderResize a
BR EventType
borderSize forall k a. Map k a
M.empty)
    handleMess BorderResize Window
_ SomeMessage
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

compileWrs :: M.Map Window RectWithBorders -> [Window] -> [(Window, Rectangle)]
compileWrs :: Map Window RectWithBorders -> [Window] -> [(Window, Rectangle)]
compileWrs Map Window RectWithBorders
wrsThisTime [Window]
correctOrder = let wrs :: [(Window, RectWithBorders)]
wrs = forall a b. Eq a => [(a, b)] -> [a] -> [(a, b)]
reorder (forall k a. Map k a -> [(k, a)]
M.toList Map Window RectWithBorders
wrsThisTime) [Window]
correctOrder
                                      in forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Window, RectWithBorders) -> [(Window, Rectangle)]
compileWr [(Window, RectWithBorders)]
wrs

compileWr :: (Window, RectWithBorders) -> [(Window, Rectangle)]
compileWr :: (Window, RectWithBorders) -> [(Window, Rectangle)]
compileWr (Window
w, (Rectangle
r, [BorderInfo]
borderInfos)) =
    let borderWrs :: [(Window, Rectangle)]
borderWrs = forall a b. [a] -> (a -> b) -> [b]
for [BorderInfo]
borderInfos forall a b. (a -> b) -> a -> b
$ \BorderInfo
bi -> (BorderInfo -> Window
bWin BorderInfo
bi, BorderInfo -> Rectangle
bRect BorderInfo
bi)
    in [(Window, Rectangle)]
borderWrs forall a. [a] -> [a] -> [a]
++ [(Window
w, Rectangle
r)]

handleGone :: M.Map Window RectWithBorders -> X ()
handleGone :: Map Window RectWithBorders -> X ()
handleGone Map Window RectWithBorders
wrsGone = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Window -> X ()
deleteWindow [Window]
borderWins
    where
        borderWins :: [Window]
borderWins = forall a b. (a -> b) -> [a] -> [b]
map BorderInfo -> Window
bWin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
M.elems forall a b. (a -> b) -> a -> b
$ Map Window RectWithBorders
wrsGone

handleAppeared :: Dimension -> M.Map Window Rectangle -> X (M.Map Window RectWithBorders)
handleAppeared :: EventType -> Map Window Rectangle -> X (Map Window RectWithBorders)
handleAppeared EventType
borderSize Map Window Rectangle
wrsAppeared = do
    let wrs :: [(Window, Rectangle)]
wrs = forall k a. Map k a -> [(k, a)]
M.toList Map Window Rectangle
wrsAppeared
    [(Window, RectWithBorders)]
wrsCreated <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (EventType -> (Window, Rectangle) -> X (Window, RectWithBorders)
handleSingleAppeared EventType
borderSize) [(Window, Rectangle)]
wrs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Window, RectWithBorders)]
wrsCreated

handleSingleAppeared :: Dimension ->(Window, Rectangle) -> X (Window, RectWithBorders)
handleSingleAppeared :: EventType -> (Window, Rectangle) -> X (Window, RectWithBorders)
handleSingleAppeared EventType
borderSize (Window
w, Rectangle
r) = do
    let borderBlueprints :: [BorderBlueprint]
borderBlueprints = EventType -> Rectangle -> [BorderBlueprint]
prepareBorders EventType
borderSize Rectangle
r
    [BorderInfo]
borderInfos <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM BorderBlueprint -> X BorderInfo
createBorder [BorderBlueprint]
borderBlueprints
    forall (m :: * -> *) a. Monad m => a -> m a
return (Window
w, (Rectangle
r, [BorderInfo]
borderInfos))

handleStillThere :: Dimension -> M.Map Window (Maybe Rectangle, RectWithBorders) -> M.Map Window RectWithBorders
handleStillThere :: EventType
-> Map Window (Maybe Rectangle, RectWithBorders)
-> Map Window RectWithBorders
handleStillThere EventType
borderSize = forall a b k. (a -> b) -> Map k a -> Map k b
M.map (EventType -> (Maybe Rectangle, RectWithBorders) -> RectWithBorders
handleSingleStillThere EventType
borderSize)

handleSingleStillThere :: Dimension -> (Maybe Rectangle, RectWithBorders) -> RectWithBorders
handleSingleStillThere :: EventType -> (Maybe Rectangle, RectWithBorders) -> RectWithBorders
handleSingleStillThere EventType
_            (Maybe Rectangle
Nothing, RectWithBorders
entry)                  = RectWithBorders
entry
handleSingleStillThere EventType
borderSize (Just Rectangle
rCurrent, (Rectangle
_, [BorderInfo]
borderInfos)) = (Rectangle
rCurrent, [BorderInfo]
updatedBorderInfos)
    where
        changedBorderBlueprints :: [BorderBlueprint]
changedBorderBlueprints = EventType -> Rectangle -> [BorderBlueprint]
prepareBorders EventType
borderSize Rectangle
rCurrent
        updatedBorderInfos :: [BorderInfo]
updatedBorderInfos = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall a b c. ((a, b) -> c) -> a -> b -> c
curry (BorderInfo, BorderBlueprint) -> BorderInfo
updateBorderInfo) [BorderInfo]
borderInfos [BorderBlueprint]
changedBorderBlueprints
          -- assuming that the four borders are always in the same order

updateBorderInfo :: (BorderInfo, BorderBlueprint) -> BorderInfo
updateBorderInfo :: (BorderInfo, BorderBlueprint) -> BorderInfo
updateBorderInfo (BorderInfo
borderInfo, (Rectangle
r, Glyph
_, BorderType
_)) = BorderInfo
borderInfo { bRect :: Rectangle
bRect = Rectangle
r }

createBorderLookupTable :: M.Map Window RectWithBorders -> [(Window, (BorderType, Window, Rectangle))]
createBorderLookupTable :: Map Window RectWithBorders
-> [(Window, (BorderType, Window, Rectangle))]
createBorderLookupTable Map Window RectWithBorders
wrsLastTime = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Window, RectWithBorders)
-> [(Window, (BorderType, Window, Rectangle))]
processSingleEntry (forall k a. Map k a -> [(k, a)]
M.toList Map Window RectWithBorders
wrsLastTime)
    where
        processSingleEntry :: (Window, RectWithBorders) -> [(Window, (BorderType, Window, Rectangle))]
        processSingleEntry :: (Window, RectWithBorders)
-> [(Window, (BorderType, Window, Rectangle))]
processSingleEntry (Window
w, (Rectangle
r, [BorderInfo]
borderInfos)) = forall a b. [a] -> (a -> b) -> [b]
for [BorderInfo]
borderInfos forall a b. (a -> b) -> a -> b
$ \BorderInfo
bi -> (BorderInfo -> Window
bWin BorderInfo
bi, (BorderInfo -> BorderType
bType BorderInfo
bi, Window
w, Rectangle
r))

prepareBorders :: Dimension -> Rectangle -> [BorderBlueprint]
prepareBorders :: EventType -> Rectangle -> [BorderBlueprint]
prepareBorders EventType
borderSize (Rectangle Position
x Position
y EventType
wh EventType
ht) =
    [(Position -> Position -> EventType -> EventType -> Rectangle
Rectangle (Position
x forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi EventType
wh forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fi EventType
borderSize) Position
y EventType
borderSize EventType
ht, Glyph
xC_right_side , BorderType
RightSideBorder),
     (Position -> Position -> EventType -> EventType -> Rectangle
Rectangle Position
x Position
y EventType
borderSize EventType
ht                          , Glyph
xC_left_side  , BorderType
LeftSideBorder),
     (Position -> Position -> EventType -> EventType -> Rectangle
Rectangle Position
x Position
y EventType
wh EventType
borderSize                          , Glyph
xC_top_side   , BorderType
TopSideBorder),
     (Position -> Position -> EventType -> EventType -> Rectangle
Rectangle Position
x (Position
y forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi EventType
ht forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fi EventType
borderSize) EventType
wh EventType
borderSize, Glyph
xC_bottom_side, BorderType
BottomSideBorder)
    ]

handleResize :: [(Window, (BorderType, Window, Rectangle))] -> Event -> X ()
handleResize :: [(Window, (BorderType, Window, Rectangle))] -> Event -> X ()
handleResize [(Window, (BorderType, Window, Rectangle))]
borders 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 (BorderType, Window, Rectangle)
edge <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Window
ew [(Window, (BorderType, Window, Rectangle))]
borders =
    case (BorderType, Window, Rectangle)
edge of
        (BorderType
RightSideBorder, Window
hostWin, Rectangle Position
hx Position
hy EventType
_ EventType
hht) ->
            (Position -> Position -> X ()) -> X () -> X ()
mouseDrag (\Position
x Position
_ -> do
                            let nwh :: EventType
nwh = forall a. Ord a => a -> a -> a
max EventType
1 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fi (Position
x forall a. Num a => a -> a -> a
- Position
hx)
                                rect :: Rectangle
rect = Position -> Position -> EventType -> EventType -> Rectangle
Rectangle Position
hx Position
hy EventType
nwh EventType
hht
                            Window -> X ()
focus Window
hostWin
                            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Position
x forall a. Num a => a -> a -> a
- Position
hx forall a. Ord a => a -> a -> Bool
> Position
0) forall a b. (a -> b) -> a -> b
$ forall a. Message a => a -> X ()
sendMessage (Rectangle -> WindowArrangerMsg
SetGeometry Rectangle
rect)) (Window -> X ()
focus Window
hostWin)
        (BorderType
LeftSideBorder, Window
hostWin, Rectangle Position
hx Position
hy EventType
hwh EventType
hht) ->
            (Position -> Position -> X ()) -> X () -> X ()
mouseDrag (\Position
x Position
_ -> do
                            let nx :: Position
nx = forall a. Ord a => a -> a -> a
max Position
0 forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
min (Position
hx forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi EventType
hwh) Position
x
                                nwh :: EventType
nwh = forall a. Ord a => a -> a -> a
max EventType
1 forall a b. (a -> b) -> a -> b
$ EventType
hwh forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi (Position
hx forall a. Num a => a -> a -> a
- Position
x)
                                rect :: Rectangle
rect = Position -> Position -> EventType -> EventType -> Rectangle
Rectangle Position
nx Position
hy EventType
nwh EventType
hht
                            Window -> X ()
focus Window
hostWin
                            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Position
x forall a. Ord a => a -> a -> Bool
< Position
hx forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi EventType
hwh) forall a b. (a -> b) -> a -> b
$ forall a. Message a => a -> X ()
sendMessage (Rectangle -> WindowArrangerMsg
SetGeometry Rectangle
rect)) (Window -> X ()
focus Window
hostWin)
        (BorderType
TopSideBorder, Window
hostWin, Rectangle Position
hx Position
hy EventType
hwh EventType
hht) ->
            (Position -> Position -> X ()) -> X () -> X ()
mouseDrag (\Position
_ Position
y -> do
                            let ny :: Position
ny = forall a. Ord a => a -> a -> a
max Position
0 forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
min (Position
hy forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi EventType
hht) Position
y
                                nht :: EventType
nht = forall a. Ord a => a -> a -> a
max EventType
1 forall a b. (a -> b) -> a -> b
$ EventType
hht forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi (Position
hy forall a. Num a => a -> a -> a
- Position
y)
                                rect :: Rectangle
rect = Position -> Position -> EventType -> EventType -> Rectangle
Rectangle Position
hx Position
ny EventType
hwh EventType
nht
                            Window -> X ()
focus Window
hostWin
                            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Position
y forall a. Ord a => a -> a -> Bool
< Position
hy forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi EventType
hht) forall a b. (a -> b) -> a -> b
$ forall a. Message a => a -> X ()
sendMessage (Rectangle -> WindowArrangerMsg
SetGeometry Rectangle
rect)) (Window -> X ()
focus Window
hostWin)
        (BorderType
BottomSideBorder, Window
hostWin, Rectangle Position
hx Position
hy EventType
hwh EventType
_) ->
            (Position -> Position -> X ()) -> X () -> X ()
mouseDrag (\Position
_ Position
y -> do
                            let nht :: EventType
nht = forall a. Ord a => a -> a -> a
max EventType
1 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fi (Position
y forall a. Num a => a -> a -> a
- Position
hy)
                                rect :: Rectangle
rect = Position -> Position -> EventType -> EventType -> Rectangle
Rectangle Position
hx Position
hy EventType
hwh EventType
nht
                            Window -> X ()
focus Window
hostWin
                            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Position
y forall a. Num a => a -> a -> a
- Position
hy forall a. Ord a => a -> a -> Bool
> Position
0) forall a b. (a -> b) -> a -> b
$ forall a. Message a => a -> X ()
sendMessage (Rectangle -> WindowArrangerMsg
SetGeometry Rectangle
rect)) (Window -> X ()
focus Window
hostWin)
handleResize [(Window, (BorderType, Window, Rectangle))]
_ Event
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

createBorder :: BorderBlueprint -> X BorderInfo
createBorder :: BorderBlueprint -> X BorderInfo
createBorder (Rectangle
borderRect, Glyph
borderCursor, BorderType
borderType) = do
    Window
borderWin <- Glyph -> Rectangle -> X Window
createInputWindow Glyph
borderCursor Rectangle
borderRect
    forall (m :: * -> *) a. Monad m => a -> m a
return BI { bWin :: Window
bWin = Window
borderWin, bRect :: Rectangle
bRect = Rectangle
borderRect, bType :: BorderType
bType = BorderType
borderType }

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

for :: [a] -> (a -> b) -> [b]
for :: forall a b. [a] -> (a -> b) -> [b]
for = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map

reorder :: (Eq a) => [(a, b)] -> [a] -> [(a, b)]
reorder :: forall a b. Eq a => [(a, b)] -> [a] -> [(a, b)]
reorder [(a, b)]
wrs [a]
order =
    let ordered :: [(a, b)]
ordered = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall {a} {b}. Eq a => [(a, b)] -> a -> [(a, b)]
pickElem [(a, b)]
wrs) [a]
order
        rest :: [(a, b)]
rest = forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
w, b
_) -> a
w forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
order) [(a, b)]
wrs
    in [(a, b)]
ordered forall a. [a] -> [a] -> [a]
++ [(a, b)]
rest
    where
        pickElem :: [(a, b)] -> a -> [(a, b)]
pickElem [(a, b)]
list a
e = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
e [(a, b)]
list of
                                Just b
result -> [(a
e, b
result)]
                                Maybe b
Nothing -> []