{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, PatternGuards #-}
module XMonad.Layout.BorderResize
(
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
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
, 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
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)
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
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 -> []