{-# 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
(Int -> BorderType -> ShowS)
-> (BorderType -> String)
-> ([BorderType] -> ShowS)
-> Show BorderType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BorderType -> ShowS
showsPrec :: Int -> BorderType -> ShowS
$cshow :: BorderType -> String
show :: BorderType -> String
$cshowList :: [BorderType] -> ShowS
showList :: [BorderType] -> ShowS
Show, ReadPrec [BorderType]
ReadPrec BorderType
Int -> ReadS BorderType
ReadS [BorderType]
(Int -> ReadS BorderType)
-> ReadS [BorderType]
-> ReadPrec BorderType
-> ReadPrec [BorderType]
-> Read BorderType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS BorderType
readsPrec :: Int -> ReadS BorderType
$creadList :: ReadS [BorderType]
readList :: ReadS [BorderType]
$creadPrec :: ReadPrec BorderType
readPrec :: ReadPrec BorderType
$creadListPrec :: ReadPrec [BorderType]
readListPrec :: ReadPrec [BorderType]
Read, BorderType -> BorderType -> Bool
(BorderType -> BorderType -> Bool)
-> (BorderType -> BorderType -> Bool) -> Eq BorderType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BorderType -> BorderType -> Bool
== :: BorderType -> BorderType -> Bool
$c/= :: BorderType -> BorderType -> Bool
/= :: BorderType -> BorderType -> Bool
Eq)
data BorderInfo = BI { BorderInfo -> EventMask
bWin :: Window,
                        BorderInfo -> Rectangle
bRect :: Rectangle,
                        BorderInfo -> BorderType
bType :: BorderType
                     } deriving (Int -> BorderInfo -> ShowS
[BorderInfo] -> ShowS
BorderInfo -> String
(Int -> BorderInfo -> ShowS)
-> (BorderInfo -> String)
-> ([BorderInfo] -> ShowS)
-> Show BorderInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BorderInfo -> ShowS
showsPrec :: Int -> BorderInfo -> ShowS
$cshow :: BorderInfo -> String
show :: BorderInfo -> String
$cshowList :: [BorderInfo] -> ShowS
showList :: [BorderInfo] -> ShowS
Show, ReadPrec [BorderInfo]
ReadPrec BorderInfo
Int -> ReadS BorderInfo
ReadS [BorderInfo]
(Int -> ReadS BorderInfo)
-> ReadS [BorderInfo]
-> ReadPrec BorderInfo
-> ReadPrec [BorderInfo]
-> Read BorderInfo
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS BorderInfo
readsPrec :: Int -> ReadS BorderInfo
$creadList :: ReadS [BorderInfo]
readList :: ReadS [BorderInfo]
$creadPrec :: ReadPrec BorderInfo
readPrec :: ReadPrec BorderInfo
$creadListPrec :: ReadPrec [BorderInfo]
readListPrec :: ReadPrec [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 EventMask RectWithBorders
brWrsLastTime :: !(M.Map Window RectWithBorders)
  }
  deriving (Int -> BorderResize a -> ShowS
[BorderResize a] -> ShowS
BorderResize a -> String
(Int -> BorderResize a -> ShowS)
-> (BorderResize a -> String)
-> ([BorderResize a] -> ShowS)
-> Show (BorderResize a)
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
$cshowsPrec :: forall a. Int -> BorderResize a -> ShowS
showsPrec :: Int -> BorderResize a -> ShowS
$cshow :: forall a. BorderResize a -> String
show :: BorderResize a -> String
$cshowList :: forall a. [BorderResize a] -> ShowS
showList :: [BorderResize a] -> ShowS
Show, ReadPrec [BorderResize a]
ReadPrec (BorderResize a)
Int -> ReadS (BorderResize a)
ReadS [BorderResize a]
(Int -> ReadS (BorderResize a))
-> ReadS [BorderResize a]
-> ReadPrec (BorderResize a)
-> ReadPrec [BorderResize a]
-> Read (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
$creadsPrec :: forall a. Int -> ReadS (BorderResize a)
readsPrec :: Int -> ReadS (BorderResize a)
$creadList :: forall a. ReadS [BorderResize a]
readList :: ReadS [BorderResize a]
$creadPrec :: forall a. ReadPrec (BorderResize a)
readPrec :: ReadPrec (BorderResize a)
$creadListPrec :: forall a. ReadPrec [BorderResize a]
readListPrec :: ReadPrec [BorderResize a]
Read)

borderResize :: l a -> ModifiedLayout BorderResize l a
borderResize :: forall (l :: * -> *) a. l a -> ModifiedLayout BorderResize l a
borderResize = EventType -> l a -> ModifiedLayout BorderResize l a
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 = BorderResize a -> l a -> ModifiedLayout BorderResize l a
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (EventType -> Map EventMask RectWithBorders -> BorderResize a
forall a.
EventType -> Map EventMask RectWithBorders -> BorderResize a
BR EventType
borderSize Map EventMask RectWithBorders
forall k a. Map k a
M.empty)

instance LayoutModifier BorderResize Window where
    redoLayout :: BorderResize EventMask
-> Rectangle
-> Maybe (Stack EventMask)
-> [(EventMask, Rectangle)]
-> X ([(EventMask, Rectangle)], Maybe (BorderResize EventMask))
redoLayout BorderResize EventMask
_       Rectangle
_ Maybe (Stack EventMask)
Nothing  [(EventMask, Rectangle)]
wrs = ([(EventMask, Rectangle)], Maybe (BorderResize EventMask))
-> X ([(EventMask, Rectangle)], Maybe (BorderResize EventMask))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(EventMask, Rectangle)]
wrs, Maybe (BorderResize EventMask)
forall a. Maybe a
Nothing)
    redoLayout (BR EventType
borderSize Map EventMask RectWithBorders
wrsLastTime) Rectangle
_ Maybe (Stack EventMask)
_ [(EventMask, Rectangle)]
wrs = do
            let correctOrder :: [EventMask]
correctOrder = ((EventMask, Rectangle) -> EventMask)
-> [(EventMask, Rectangle)] -> [EventMask]
forall a b. (a -> b) -> [a] -> [b]
map (EventMask, Rectangle) -> EventMask
forall a b. (a, b) -> a
fst [(EventMask, Rectangle)]
wrs
                wrsCurrent :: Map EventMask Rectangle
wrsCurrent = [(EventMask, Rectangle)] -> Map EventMask Rectangle
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(EventMask, Rectangle)]
wrs
                wrsGone :: Map EventMask RectWithBorders
wrsGone = Map EventMask RectWithBorders
-> Map EventMask Rectangle -> Map EventMask RectWithBorders
forall k a b. Ord k => Map k a -> Map k b -> Map k a
M.difference Map EventMask RectWithBorders
wrsLastTime Map EventMask Rectangle
wrsCurrent
                wrsAppeared :: Map EventMask Rectangle
wrsAppeared = Map EventMask Rectangle
-> Map EventMask RectWithBorders -> Map EventMask Rectangle
forall k a b. Ord k => Map k a -> Map k b -> Map k a
M.difference Map EventMask Rectangle
wrsCurrent Map EventMask RectWithBorders
wrsLastTime
                wrsStillThere :: Map EventMask (Maybe Rectangle, RectWithBorders)
wrsStillThere = (RectWithBorders
 -> Rectangle -> (Maybe Rectangle, RectWithBorders))
-> Map EventMask RectWithBorders
-> Map EventMask Rectangle
-> Map EventMask (Maybe Rectangle, RectWithBorders)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
M.intersectionWith RectWithBorders -> Rectangle -> (Maybe Rectangle, RectWithBorders)
forall {a} {b}. Eq a => (a, b) -> a -> (Maybe a, (a, b))
testIfUnchanged Map EventMask RectWithBorders
wrsLastTime Map EventMask Rectangle
wrsCurrent
            Map EventMask RectWithBorders -> X ()
handleGone Map EventMask RectWithBorders
wrsGone
            Map EventMask RectWithBorders
wrsCreated <- EventType
-> Map EventMask Rectangle -> X (Map EventMask RectWithBorders)
handleAppeared EventType
borderSize Map EventMask Rectangle
wrsAppeared
            let wrsChanged :: Map EventMask RectWithBorders
wrsChanged = EventType
-> Map EventMask (Maybe Rectangle, RectWithBorders)
-> Map EventMask RectWithBorders
handleStillThere EventType
borderSize Map EventMask (Maybe Rectangle, RectWithBorders)
wrsStillThere
                wrsThisTime :: Map EventMask RectWithBorders
wrsThisTime = Map EventMask RectWithBorders
-> Map EventMask RectWithBorders -> Map EventMask RectWithBorders
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map EventMask RectWithBorders
wrsChanged Map EventMask RectWithBorders
wrsCreated
            ([(EventMask, Rectangle)], Maybe (BorderResize EventMask))
-> X ([(EventMask, Rectangle)], Maybe (BorderResize EventMask))
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map EventMask RectWithBorders
-> [EventMask] -> [(EventMask, Rectangle)]
compileWrs Map EventMask RectWithBorders
wrsThisTime [EventMask]
correctOrder, BorderResize EventMask -> Maybe (BorderResize EventMask)
forall a. a -> Maybe a
Just (BorderResize EventMask -> Maybe (BorderResize EventMask))
-> BorderResize EventMask -> Maybe (BorderResize EventMask)
forall a b. (a -> b) -> a -> b
$ EventType
-> Map EventMask RectWithBorders -> BorderResize EventMask
forall a.
EventType -> Map EventMask RectWithBorders -> BorderResize a
BR EventType
borderSize Map EventMask 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 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
rCurrent
                    then (Maybe a
forall a. Maybe a
Nothing, (a, b)
entry)
                    else (a -> Maybe a
forall a. a -> Maybe a
Just a
rCurrent, (a, b)
entry)

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

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

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

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

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

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

handleStillThere :: Dimension -> M.Map Window (Maybe Rectangle, RectWithBorders) -> M.Map Window RectWithBorders
handleStillThere :: EventType
-> Map EventMask (Maybe Rectangle, RectWithBorders)
-> Map EventMask RectWithBorders
handleStillThere EventType
borderSize = ((Maybe Rectangle, RectWithBorders) -> RectWithBorders)
-> Map EventMask (Maybe Rectangle, RectWithBorders)
-> Map EventMask RectWithBorders
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 = (BorderInfo -> BorderBlueprint -> BorderInfo)
-> [BorderInfo] -> [BorderBlueprint] -> [BorderInfo]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (((BorderInfo, BorderBlueprint) -> BorderInfo)
-> BorderInfo -> BorderBlueprint -> BorderInfo
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 = r }

createBorderLookupTable :: M.Map Window RectWithBorders -> [(Window, (BorderType, Window, Rectangle))]
createBorderLookupTable :: Map EventMask RectWithBorders
-> [(EventMask, (BorderType, EventMask, Rectangle))]
createBorderLookupTable Map EventMask RectWithBorders
wrsLastTime = ((EventMask, RectWithBorders)
 -> [(EventMask, (BorderType, EventMask, Rectangle))])
-> [(EventMask, RectWithBorders)]
-> [(EventMask, (BorderType, EventMask, Rectangle))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (EventMask, RectWithBorders)
-> [(EventMask, (BorderType, EventMask, Rectangle))]
processSingleEntry (Map EventMask RectWithBorders -> [(EventMask, RectWithBorders)]
forall k a. Map k a -> [(k, a)]
M.toList Map EventMask RectWithBorders
wrsLastTime)
    where
        processSingleEntry :: (Window, RectWithBorders) -> [(Window, (BorderType, Window, Rectangle))]
        processSingleEntry :: (EventMask, RectWithBorders)
-> [(EventMask, (BorderType, EventMask, Rectangle))]
processSingleEntry (EventMask
w, (Rectangle
r, [BorderInfo]
borderInfos)) = [BorderInfo]
-> (BorderInfo -> (EventMask, (BorderType, EventMask, Rectangle)))
-> [(EventMask, (BorderType, EventMask, Rectangle))]
forall a b. [a] -> (a -> b) -> [b]
for [BorderInfo]
borderInfos ((BorderInfo -> (EventMask, (BorderType, EventMask, Rectangle)))
 -> [(EventMask, (BorderType, EventMask, Rectangle))])
-> (BorderInfo -> (EventMask, (BorderType, EventMask, Rectangle)))
-> [(EventMask, (BorderType, EventMask, Rectangle))]
forall a b. (a -> b) -> a -> b
$ \BorderInfo
bi -> (BorderInfo -> EventMask
bWin BorderInfo
bi, (BorderInfo -> BorderType
bType BorderInfo
bi, EventMask
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 Position -> Position -> Position
forall a. Num a => a -> a -> a
+ EventType -> Position
forall a b. (Integral a, Num b) => a -> b
fi EventType
wh Position -> Position -> Position
forall a. Num a => a -> a -> a
- EventType -> Position
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 Position -> Position -> Position
forall a. Num a => a -> a -> a
+ EventType -> Position
forall a b. (Integral a, Num b) => a -> b
fi EventType
ht Position -> Position -> Position
forall a. Num a => a -> a -> a
- EventType -> Position
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 :: [(EventMask, (BorderType, EventMask, Rectangle))] -> Event -> X ()
handleResize [(EventMask, (BorderType, EventMask, Rectangle))]
borders 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 (BorderType, EventMask, Rectangle)
edge <- EventMask
-> [(EventMask, (BorderType, EventMask, Rectangle))]
-> Maybe (BorderType, EventMask, Rectangle)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup EventMask
ew [(EventMask, (BorderType, EventMask, Rectangle))]
borders =
    case (BorderType, EventMask, Rectangle)
edge of
        (BorderType
RightSideBorder, EventMask
hostWin, Rectangle Position
hx Position
hy EventType
_ EventType
hht) ->
            (Position -> Position -> X ()) -> X () -> X ()
mouseDrag (\Position
x Position
_ -> do
                            let nwh :: EventType
nwh = EventType -> EventType -> EventType
forall a. Ord a => a -> a -> a
max EventType
1 (EventType -> EventType) -> EventType -> EventType
forall a b. (a -> b) -> a -> b
$ Position -> EventType
forall a b. (Integral a, Num b) => a -> b
fi (Position
x Position -> Position -> Position
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
                            EventMask -> X ()
focus EventMask
hostWin
                            Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Position
x Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
hx Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
> Position
0) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ WindowArrangerMsg -> X ()
forall a. Message a => a -> X ()
sendMessage (Rectangle -> WindowArrangerMsg
SetGeometry Rectangle
rect)) (EventMask -> X ()
focus EventMask
hostWin)
        (BorderType
LeftSideBorder, EventMask
hostWin, Rectangle Position
hx Position
hy EventType
hwh EventType
hht) ->
            (Position -> Position -> X ()) -> X () -> X ()
mouseDrag (\Position
x Position
_ -> do
                            let nx :: Position
nx = Position -> Position -> Position
forall a. Ord a => a -> a -> a
max Position
0 (Position -> Position) -> Position -> Position
forall a b. (a -> b) -> a -> b
$ Position -> Position -> Position
forall a. Ord a => a -> a -> a
min (Position
hx Position -> Position -> Position
forall a. Num a => a -> a -> a
+ EventType -> Position
forall a b. (Integral a, Num b) => a -> b
fi EventType
hwh) Position
x
                                nwh :: EventType
nwh = EventType -> EventType -> EventType
forall a. Ord a => a -> a -> a
max EventType
1 (EventType -> EventType) -> EventType -> EventType
forall a b. (a -> b) -> a -> b
$ EventType
hwh EventType -> EventType -> EventType
forall a. Num a => a -> a -> a
+ Position -> EventType
forall a b. (Integral a, Num b) => a -> b
fi (Position
hx Position -> Position -> Position
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
                            EventMask -> X ()
focus EventMask
hostWin
                            Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Position
x Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
< Position
hx Position -> Position -> Position
forall a. Num a => a -> a -> a
+ EventType -> Position
forall a b. (Integral a, Num b) => a -> b
fi EventType
hwh) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ WindowArrangerMsg -> X ()
forall a. Message a => a -> X ()
sendMessage (Rectangle -> WindowArrangerMsg
SetGeometry Rectangle
rect)) (EventMask -> X ()
focus EventMask
hostWin)
        (BorderType
TopSideBorder, EventMask
hostWin, Rectangle Position
hx Position
hy EventType
hwh EventType
hht) ->
            (Position -> Position -> X ()) -> X () -> X ()
mouseDrag (\Position
_ Position
y -> do
                            let ny :: Position
ny = Position -> Position -> Position
forall a. Ord a => a -> a -> a
max Position
0 (Position -> Position) -> Position -> Position
forall a b. (a -> b) -> a -> b
$ Position -> Position -> Position
forall a. Ord a => a -> a -> a
min (Position
hy Position -> Position -> Position
forall a. Num a => a -> a -> a
+ EventType -> Position
forall a b. (Integral a, Num b) => a -> b
fi EventType
hht) Position
y
                                nht :: EventType
nht = EventType -> EventType -> EventType
forall a. Ord a => a -> a -> a
max EventType
1 (EventType -> EventType) -> EventType -> EventType
forall a b. (a -> b) -> a -> b
$ EventType
hht EventType -> EventType -> EventType
forall a. Num a => a -> a -> a
+ Position -> EventType
forall a b. (Integral a, Num b) => a -> b
fi (Position
hy Position -> Position -> Position
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
                            EventMask -> X ()
focus EventMask
hostWin
                            Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Position
y Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
< Position
hy Position -> Position -> Position
forall a. Num a => a -> a -> a
+ EventType -> Position
forall a b. (Integral a, Num b) => a -> b
fi EventType
hht) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ WindowArrangerMsg -> X ()
forall a. Message a => a -> X ()
sendMessage (Rectangle -> WindowArrangerMsg
SetGeometry Rectangle
rect)) (EventMask -> X ()
focus EventMask
hostWin)
        (BorderType
BottomSideBorder, EventMask
hostWin, Rectangle Position
hx Position
hy EventType
hwh EventType
_) ->
            (Position -> Position -> X ()) -> X () -> X ()
mouseDrag (\Position
_ Position
y -> do
                            let nht :: EventType
nht = EventType -> EventType -> EventType
forall a. Ord a => a -> a -> a
max EventType
1 (EventType -> EventType) -> EventType -> EventType
forall a b. (a -> b) -> a -> b
$ Position -> EventType
forall a b. (Integral a, Num b) => a -> b
fi (Position
y Position -> Position -> Position
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
                            EventMask -> X ()
focus EventMask
hostWin
                            Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Position
y Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
hy Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
> Position
0) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ WindowArrangerMsg -> X ()
forall a. Message a => a -> X ()
sendMessage (Rectangle -> WindowArrangerMsg
SetGeometry Rectangle
rect)) (EventMask -> X ()
focus EventMask
hostWin)
handleResize [(EventMask, (BorderType, EventMask, Rectangle))]
_ Event
_ = () -> X ()
forall a. a -> X a
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
    EventMask
borderWin <- Glyph -> Rectangle -> X EventMask
createInputWindow Glyph
borderCursor Rectangle
borderRect
    BorderInfo -> X BorderInfo
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return BI { bWin :: EventMask
bWin = EventMask
borderWin, bRect :: Rectangle
bRect = Rectangle
borderRect, bType :: BorderType
bType = BorderType
borderType }

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

for :: [a] -> (a -> b) -> [b]
for :: forall a b. [a] -> (a -> b) -> [b]
for = ((a -> b) -> [a] -> [b]) -> [a] -> (a -> b) -> [b]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> b) -> [a] -> [b]
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 = (a -> [(a, b)]) -> [a] -> [(a, b)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([(a, b)] -> a -> [(a, b)]
forall {a} {b}. Eq a => [(a, b)] -> a -> [(a, b)]
pickElem [(a, b)]
wrs) [a]
order
        rest :: [(a, b)]
rest = ((a, b) -> Bool) -> [(a, b)] -> [(a, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
w, b
_) -> a
w a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
order) [(a, b)]
wrs
    in [(a, b)]
ordered [(a, b)] -> [(a, b)] -> [(a, b)]
forall a. [a] -> [a] -> [a]
++ [(a, b)]
rest
    where
        pickElem :: [(a, b)] -> a -> [(a, b)]
pickElem [(a, b)]
list a
e = case a -> [(a, b)] -> Maybe b
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 -> []