{-# 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
    , 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\/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
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]
(Int -> ReadS BorderType)
-> ReadS [BorderType]
-> ReadPrec BorderType
-> ReadPrec [BorderType]
-> Read 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
(BorderType -> BorderType -> Bool)
-> (BorderType -> BorderType -> Bool) -> Eq BorderType
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
(Int -> BorderInfo -> ShowS)
-> (BorderInfo -> String)
-> ([BorderInfo] -> ShowS)
-> Show BorderInfo
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]
(Int -> ReadS BorderInfo)
-> ReadS [BorderInfo]
-> ReadPrec BorderInfo
-> ReadPrec [BorderInfo]
-> Read 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])

newtype BorderResize a = BR (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
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)
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
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)

brBorderSize :: Dimension
brBorderSize :: EventType
brBorderSize = EventType
2

borderResize :: l a -> ModifiedLayout BorderResize l a
borderResize :: forall (l :: * -> *) a. l a -> ModifiedLayout BorderResize l a
borderResize = BorderResize a -> l a -> ModifiedLayout BorderResize l a
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (Map Window RectWithBorders -> BorderResize a
forall a. Map Window RectWithBorders -> BorderResize a
BR Map Window RectWithBorders
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 = ([(Window, Rectangle)], Maybe (BorderResize Window))
-> X ([(Window, Rectangle)], Maybe (BorderResize Window))
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Window, Rectangle)]
wrs, Maybe (BorderResize Window)
forall a. Maybe a
Nothing)
    redoLayout (BR Map Window RectWithBorders
wrsLastTime) Rectangle
_ Maybe (Stack Window)
_ [(Window, Rectangle)]
wrs = do
            let correctOrder :: [Window]
correctOrder = ((Window, Rectangle) -> Window)
-> [(Window, Rectangle)] -> [Window]
forall a b. (a -> b) -> [a] -> [b]
map (Window, Rectangle) -> Window
forall a b. (a, b) -> a
fst [(Window, Rectangle)]
wrs
                wrsCurrent :: Map Window Rectangle
wrsCurrent = [(Window, Rectangle)] -> Map Window Rectangle
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Window, Rectangle)]
wrs
                wrsGone :: Map Window RectWithBorders
wrsGone = Map Window RectWithBorders
-> Map Window Rectangle -> Map Window RectWithBorders
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 = Map Window Rectangle
-> Map Window RectWithBorders -> Map Window Rectangle
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 = (RectWithBorders
 -> Rectangle -> (Maybe Rectangle, RectWithBorders))
-> Map Window RectWithBorders
-> Map Window Rectangle
-> Map Window (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 Window RectWithBorders
wrsLastTime Map Window Rectangle
wrsCurrent
            Map Window RectWithBorders -> X ()
handleGone Map Window RectWithBorders
wrsGone
            Map Window RectWithBorders
wrsCreated <- Map Window Rectangle -> X (Map Window RectWithBorders)
handleAppeared Map Window Rectangle
wrsAppeared
            let wrsChanged :: Map Window RectWithBorders
wrsChanged = Map Window (Maybe Rectangle, RectWithBorders)
-> Map Window RectWithBorders
handleStillThere Map Window (Maybe Rectangle, RectWithBorders)
wrsStillThere
                wrsThisTime :: Map Window RectWithBorders
wrsThisTime = Map Window RectWithBorders
-> Map Window RectWithBorders -> Map Window RectWithBorders
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map Window RectWithBorders
wrsChanged Map Window RectWithBorders
wrsCreated
            ([(Window, Rectangle)], Maybe (BorderResize Window))
-> X ([(Window, Rectangle)], Maybe (BorderResize Window))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Window RectWithBorders -> [Window] -> [(Window, Rectangle)]
compileWrs Map Window RectWithBorders
wrsThisTime [Window]
correctOrder, BorderResize Window -> Maybe (BorderResize Window)
forall a. a -> Maybe a
Just (BorderResize Window -> Maybe (BorderResize Window))
-> BorderResize Window -> Maybe (BorderResize Window)
forall a b. (a -> b) -> a -> b
$ Map Window RectWithBorders -> BorderResize Window
forall a. Map Window RectWithBorders -> BorderResize a
BR 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 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 Window
-> SomeMessage -> X (Maybe (BorderResize Window))
handleMess (BR Map Window RectWithBorders
wrsLastTime) SomeMessage
m
        | Just Event
e <- SomeMessage -> Maybe Event
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 X ()
-> X (Maybe (BorderResize Window))
-> X (Maybe (BorderResize Window))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (BorderResize Window) -> X (Maybe (BorderResize Window))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (BorderResize Window)
forall a. Maybe a
Nothing
        | Just LayoutMessages
_ <- SomeMessage -> Maybe LayoutMessages
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m :: Maybe LayoutMessages =
            Map Window RectWithBorders -> X ()
handleGone Map Window RectWithBorders
wrsLastTime X ()
-> X (Maybe (BorderResize Window))
-> X (Maybe (BorderResize Window))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (BorderResize Window) -> X (Maybe (BorderResize Window))
forall (m :: * -> *) a. Monad m => a -> m a
return (BorderResize Window -> Maybe (BorderResize Window)
forall a. a -> Maybe a
Just (BorderResize Window -> Maybe (BorderResize Window))
-> BorderResize Window -> Maybe (BorderResize Window)
forall a b. (a -> b) -> a -> b
$ Map Window RectWithBorders -> BorderResize Window
forall a. Map Window RectWithBorders -> BorderResize a
BR Map Window RectWithBorders
forall k a. Map k a
M.empty)
    handleMess BorderResize Window
_ SomeMessage
_ = Maybe (BorderResize Window) -> X (Maybe (BorderResize Window))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (BorderResize Window)
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 = [(Window, RectWithBorders)]
-> [Window] -> [(Window, RectWithBorders)]
forall a b. Eq a => [(a, b)] -> [a] -> [(a, b)]
reorder (Map Window RectWithBorders -> [(Window, RectWithBorders)]
forall k a. Map k a -> [(k, a)]
M.toList Map Window RectWithBorders
wrsThisTime) [Window]
correctOrder
                                      in ((Window, RectWithBorders) -> [(Window, Rectangle)])
-> [(Window, RectWithBorders)] -> [(Window, Rectangle)]
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 = [BorderInfo]
-> (BorderInfo -> (Window, Rectangle)) -> [(Window, Rectangle)]
forall a b. [a] -> (a -> b) -> [b]
for [BorderInfo]
borderInfos ((BorderInfo -> (Window, Rectangle)) -> [(Window, Rectangle)])
-> (BorderInfo -> (Window, Rectangle)) -> [(Window, Rectangle)]
forall a b. (a -> b) -> a -> b
$ \BorderInfo
bi -> (BorderInfo -> Window
bWin BorderInfo
bi, BorderInfo -> Rectangle
bRect BorderInfo
bi)
    in [(Window, Rectangle)]
borderWrs [(Window, Rectangle)]
-> [(Window, Rectangle)] -> [(Window, Rectangle)]
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 = (Window -> X ()) -> [Window] -> X ()
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 = (BorderInfo -> Window) -> [BorderInfo] -> [Window]
forall a b. (a -> b) -> [a] -> [b]
map BorderInfo -> Window
bWin ([BorderInfo] -> [Window])
-> (Map Window RectWithBorders -> [BorderInfo])
-> Map Window RectWithBorders
-> [Window]
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 Window RectWithBorders -> [RectWithBorders])
-> Map Window RectWithBorders
-> [BorderInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Window RectWithBorders -> [RectWithBorders]
forall k a. Map k a -> [a]
M.elems (Map Window RectWithBorders -> [Window])
-> Map Window RectWithBorders -> [Window]
forall a b. (a -> b) -> a -> b
$ Map Window RectWithBorders
wrsGone

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

handleSingleAppeared :: (Window, Rectangle) -> X (Window, RectWithBorders)
handleSingleAppeared :: (Window, Rectangle) -> X (Window, RectWithBorders)
handleSingleAppeared (Window
w, Rectangle
r) = do
    let borderBlueprints :: [BorderBlueprint]
borderBlueprints = Rectangle -> [BorderBlueprint]
prepareBorders 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)
mapM BorderBlueprint -> X BorderInfo
createBorder [BorderBlueprint]
borderBlueprints
    (Window, RectWithBorders) -> X (Window, RectWithBorders)
forall (m :: * -> *) a. Monad m => a -> m a
return (Window
w, (Rectangle
r, [BorderInfo]
borderInfos))

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

handleSingleStillThere :: (Maybe Rectangle, RectWithBorders) -> RectWithBorders
handleSingleStillThere :: (Maybe Rectangle, RectWithBorders) -> RectWithBorders
handleSingleStillThere (Maybe Rectangle
Nothing, RectWithBorders
entry) = RectWithBorders
entry
handleSingleStillThere (Just Rectangle
rCurrent, (Rectangle
_, [BorderInfo]
borderInfos)) = (Rectangle
rCurrent, [BorderInfo]
updatedBorderInfos)
    where
        changedBorderBlueprints :: [BorderBlueprint]
changedBorderBlueprints = Rectangle -> [BorderBlueprint]
prepareBorders 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 :: 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 = ((Window, RectWithBorders)
 -> [(Window, (BorderType, Window, Rectangle))])
-> [(Window, RectWithBorders)]
-> [(Window, (BorderType, Window, Rectangle))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Window, RectWithBorders)
-> [(Window, (BorderType, Window, Rectangle))]
processSingleEntry (Map Window RectWithBorders -> [(Window, RectWithBorders)]
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)) = [BorderInfo]
-> (BorderInfo -> (Window, (BorderType, Window, Rectangle)))
-> [(Window, (BorderType, Window, Rectangle))]
forall a b. [a] -> (a -> b) -> [b]
for [BorderInfo]
borderInfos ((BorderInfo -> (Window, (BorderType, Window, Rectangle)))
 -> [(Window, (BorderType, Window, Rectangle))])
-> (BorderInfo -> (Window, (BorderType, Window, Rectangle)))
-> [(Window, (BorderType, Window, Rectangle))]
forall a b. (a -> b) -> a -> b
$ \BorderInfo
bi -> (BorderInfo -> Window
bWin BorderInfo
bi, (BorderInfo -> BorderType
bType BorderInfo
bi, Window
w, Rectangle
r))

prepareBorders :: Rectangle -> [BorderBlueprint]
prepareBorders :: Rectangle -> [BorderBlueprint]
prepareBorders (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
brBorderSize) Position
y EventType
brBorderSize EventType
ht, Glyph
xC_right_side , BorderType
RightSideBorder),
     (Position -> Position -> EventType -> EventType -> Rectangle
Rectangle Position
x Position
y EventType
brBorderSize EventType
ht                            , Glyph
xC_left_side  , BorderType
LeftSideBorder),
     (Position -> Position -> EventType -> EventType -> Rectangle
Rectangle Position
x Position
y EventType
wh EventType
brBorderSize                            , 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
brBorderSize) EventType
wh EventType
brBorderSize, 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 EventType -> EventType -> Bool
forall a. Eq a => a -> a -> Bool
== EventType
buttonPress, Just (BorderType, Window, Rectangle)
edge <- Window
-> [(Window, (BorderType, Window, Rectangle))]
-> Maybe (BorderType, Window, Rectangle)
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 = 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
                            Window -> X ()
focus Window
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)) (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 = 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
                            Window -> X ()
focus Window
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)) (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 = 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
                            Window -> X ()
focus Window
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)) (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 = 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
                            Window -> X ()
focus Window
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)) (Window -> X ()
focus Window
hostWin)
handleResize [(Window, (BorderType, Window, Rectangle))]
_ Event
_ = () -> X ()
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
    BorderInfo -> X BorderInfo
forall (m :: * -> *) a. Monad m => a -> m a
return BI :: Window -> Rectangle -> BorderType -> BorderInfo
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 = (Display -> X Window) -> X Window
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X Window) -> X Window)
-> (Display -> X Window) -> X Window
forall a b. (a -> b) -> a -> b
$ \Display
d -> do
    Window
win <- Display -> Rectangle -> X Window
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 -> Window -> Window -> IO ()
selectInput Display
d Window
win (Window
exposureMask Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
buttonPressMask)
    Window
cursor <- IO Window -> X Window
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Window -> X Window) -> IO Window -> X Window
forall a b. (a -> b) -> a -> b
$ Display -> Glyph -> IO Window
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 -> Window -> Window -> IO ()
defineCursor Display
d Window
win Window
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 -> Window -> IO ()
freeCursor Display
d Window
cursor
    Window -> X ()
showWindow Window
win
    Window -> X Window
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 <- (XConf -> Window) -> X Window
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
  IO Window -> X Window
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Window -> X Window) -> IO Window -> X Window
forall a b. (a -> b) -> a -> b
$ (Ptr SetWindowAttributes -> IO Window) -> IO Window
forall a. (Ptr SetWindowAttributes -> IO a) -> IO a
allocaSetWindowAttributes ((Ptr SetWindowAttributes -> IO Window) -> IO Window)
-> (Ptr SetWindowAttributes -> IO Window) -> IO Window
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 = ((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 -> []