{-# LANGUAGE MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.MouseResize
-- Description :  A layout modifier to resize windows with the mouse.
-- Copyright   :  (c) 2007 Andrea Rossato
-- License     :  BSD-style (see xmonad/LICENSE)
--
-- Maintainer  :  andrea.rossato@unibz.it
-- Stability   :  unstable
-- Portability :  unportable
--
-- A layout modifier to resize windows with the mouse by grabbing the
-- window's lower right corner.
--
-- This module must be used together with "XMonad.Layout.WindowArranger".
-----------------------------------------------------------------------------

module XMonad.Actions.MouseResize
    ( -- * Usage:
      -- $usage
      mouseResize
    , MouseResize (..)
    ) where

import XMonad
import XMonad.Layout.Decoration

import XMonad.Layout.WindowArranger
import XMonad.Util.XUtils

-- $usage
-- Usually this module is used to create layouts, but you can also use
-- it to resize windows in any layout, together with the
-- "XMonad.Layout.WindowArranger". For usage example see
-- "XMonad.Layout.SimpleFloat" or "XMonad.Layout.DecorationMadness".
--
-- You can use this module with the following in your
-- @~\/.xmonad\/xmonad.hs@:
--
-- > import XMonad.Actions.MouseResize
-- > import XMonad.Layout.WindowArranger
--
-- Then edit your @layoutHook@ by modifying a given layout:
--
-- > myLayout = mouseResize $ windowArrange $ layoutHook def
--
-- and then:
--
-- > main = xmonad def { layoutHook = myLayout }
--
-- For more detailed instructions on editing the layoutHook see:
--
-- "XMonad.Doc.Extending#Editing_the_layout_hook"

mouseResize :: l a -> ModifiedLayout MouseResize l a
mouseResize :: forall (l :: * -> *) a. l a -> ModifiedLayout MouseResize l a
mouseResize = MouseResize a -> l a -> ModifiedLayout MouseResize l a
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout ([((a, Rectangle), Maybe a)] -> MouseResize a
forall a. [((a, Rectangle), Maybe a)] -> MouseResize a
MR [])

newtype MouseResize a = MR [((a,Rectangle),Maybe a)]
instance Show (MouseResize a) where show :: MouseResize a -> String
show        MouseResize a
_ = String
""
instance Read (MouseResize a) where readsPrec :: Int -> ReadS (MouseResize a)
readsPrec Int
_ String
s = [([((a, Rectangle), Maybe a)] -> MouseResize a
forall a. [((a, Rectangle), Maybe a)] -> MouseResize a
MR [], String
s)]

instance LayoutModifier MouseResize Window where
    redoLayout :: MouseResize Window
-> Rectangle
-> Maybe (Stack Window)
-> [(Window, Rectangle)]
-> X ([(Window, Rectangle)], Maybe (MouseResize Window))
redoLayout MouseResize Window
_       Rectangle
_ Maybe (Stack Window)
Nothing  [(Window, Rectangle)]
wrs = ([(Window, Rectangle)], Maybe (MouseResize Window))
-> X ([(Window, Rectangle)], Maybe (MouseResize Window))
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Window, Rectangle)]
wrs, Maybe (MouseResize Window)
forall a. Maybe a
Nothing)
    redoLayout (MR [((Window, Rectangle), Maybe Window)]
st) Rectangle
_ (Just Stack Window
s) [(Window, Rectangle)]
wrs
        | [] <- [((Window, Rectangle), Maybe Window)]
st  = X [((Window, Rectangle), Maybe Window)]
initState    X [((Window, Rectangle), Maybe Window)]
-> ([((Window, Rectangle), Maybe Window)]
    -> X ([(Window, Rectangle)], Maybe (MouseResize Window)))
-> X ([(Window, Rectangle)], Maybe (MouseResize Window))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[((Window, Rectangle), Maybe Window)]
nst -> ([(Window, Rectangle)], Maybe (MouseResize Window))
-> X ([(Window, Rectangle)], Maybe (MouseResize Window))
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Window, Rectangle)]
wrs, MouseResize Window -> Maybe (MouseResize Window)
forall a. a -> Maybe a
Just (MouseResize Window -> Maybe (MouseResize Window))
-> MouseResize Window -> Maybe (MouseResize Window)
forall a b. (a -> b) -> a -> b
$ [((Window, Rectangle), Maybe Window)] -> MouseResize Window
forall a. [((a, Rectangle), Maybe a)] -> MouseResize a
MR [((Window, Rectangle), Maybe Window)]
nst)
        | Bool
otherwise = X [((Window, Rectangle), Maybe Window)]
processState X [((Window, Rectangle), Maybe Window)]
-> ([((Window, Rectangle), Maybe Window)]
    -> X ([(Window, Rectangle)], Maybe (MouseResize Window)))
-> X ([(Window, Rectangle)], Maybe (MouseResize Window))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[((Window, Rectangle), Maybe Window)]
nst -> ([(Window, Rectangle)], Maybe (MouseResize Window))
-> X ([(Window, Rectangle)], Maybe (MouseResize Window))
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Window, Rectangle)]
wrs, MouseResize Window -> Maybe (MouseResize Window)
forall a. a -> Maybe a
Just (MouseResize Window -> Maybe (MouseResize Window))
-> MouseResize Window -> Maybe (MouseResize Window)
forall a b. (a -> b) -> a -> b
$ [((Window, Rectangle), Maybe Window)] -> MouseResize Window
forall a. [((a, Rectangle), Maybe a)] -> MouseResize a
MR [((Window, Rectangle), Maybe Window)]
nst)
        where
          wrs' :: [((Window, Rectangle), Maybe Rectangle)]
wrs'         = [Rectangle]
-> [(Window, Rectangle)]
-> [((Window, Rectangle), Maybe Rectangle)]
forall {a}.
[Rectangle]
-> [(a, Rectangle)] -> [((a, Rectangle), Maybe Rectangle)]
wrs_to_state [] ([(Window, Rectangle)] -> [((Window, Rectangle), Maybe Rectangle)])
-> ([(Window, Rectangle)] -> [(Window, Rectangle)])
-> [(Window, Rectangle)]
-> [((Window, Rectangle), Maybe Rectangle)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Window, Rectangle) -> Bool)
-> [(Window, Rectangle)] -> [(Window, Rectangle)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Stack Window -> Window -> Bool
forall a. Eq a => Stack a -> a -> Bool
isInStack Stack Window
s (Window -> Bool)
-> ((Window, Rectangle) -> Window) -> (Window, Rectangle) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Window, Rectangle) -> Window
forall a b. (a, b) -> a
fst) ([(Window, Rectangle)] -> [((Window, Rectangle), Maybe Rectangle)])
-> [(Window, Rectangle)]
-> [((Window, Rectangle), Maybe Rectangle)]
forall a b. (a -> b) -> a -> b
$ [(Window, Rectangle)]
wrs
          initState :: X [((Window, Rectangle), Maybe Window)]
initState    = (((Window, Rectangle), Maybe Rectangle)
 -> X ((Window, Rectangle), Maybe Window))
-> [((Window, Rectangle), Maybe Rectangle)]
-> X [((Window, Rectangle), Maybe Window)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Window, Rectangle), Maybe Rectangle)
-> X ((Window, Rectangle), Maybe Window)
createInputWindow [((Window, Rectangle), Maybe Rectangle)]
wrs'
          processState :: X [((Window, Rectangle), Maybe Window)]
processState = (((Window, Rectangle), Maybe Window) -> X ())
-> [((Window, Rectangle), Maybe Window)] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe Window -> X ()
deleteInputWin (Maybe Window -> X ())
-> (((Window, Rectangle), Maybe Window) -> Maybe Window)
-> ((Window, Rectangle), Maybe Window)
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Window, Rectangle), Maybe Window) -> Maybe Window
forall a b. (a, b) -> b
snd) [((Window, Rectangle), Maybe Window)]
st X ()
-> X [((Window, Rectangle), Maybe Window)]
-> X [((Window, Rectangle), Maybe Window)]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (((Window, Rectangle), Maybe Rectangle)
 -> X ((Window, Rectangle), Maybe Window))
-> [((Window, Rectangle), Maybe Rectangle)]
-> X [((Window, Rectangle), Maybe Window)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Window, Rectangle), Maybe Rectangle)
-> X ((Window, Rectangle), Maybe Window)
createInputWindow [((Window, Rectangle), Maybe Rectangle)]
wrs'

          inputRectangle :: Rectangle -> Rectangle
inputRectangle (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
- Position
5) (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
- Position
5) EventType
10 EventType
10

          wrs_to_state :: [Rectangle]
-> [(a, Rectangle)] -> [((a, Rectangle), Maybe Rectangle)]
wrs_to_state [Rectangle]
rs ((a
w,Rectangle
r):[(a, Rectangle)]
xs)
              | Rectangle
ir Rectangle -> [Rectangle] -> Bool
`isVisible` [Rectangle]
rs = ((a
w,Rectangle
r),Rectangle -> Maybe Rectangle
forall a. a -> Maybe a
Just Rectangle
ir) ((a, Rectangle), Maybe Rectangle)
-> [((a, Rectangle), Maybe Rectangle)]
-> [((a, Rectangle), Maybe Rectangle)]
forall a. a -> [a] -> [a]
: [Rectangle]
-> [(a, Rectangle)] -> [((a, Rectangle), Maybe Rectangle)]
wrs_to_state (Rectangle
rRectangle -> [Rectangle] -> [Rectangle]
forall a. a -> [a] -> [a]
:Rectangle
irRectangle -> [Rectangle] -> [Rectangle]
forall a. a -> [a] -> [a]
:[Rectangle]
rs) [(a, Rectangle)]
xs
              | Bool
otherwise         = ((a
w,Rectangle
r),Maybe Rectangle
forall a. Maybe a
Nothing) ((a, Rectangle), Maybe Rectangle)
-> [((a, Rectangle), Maybe Rectangle)]
-> [((a, Rectangle), Maybe Rectangle)]
forall a. a -> [a] -> [a]
: [Rectangle]
-> [(a, Rectangle)] -> [((a, Rectangle), Maybe Rectangle)]
wrs_to_state (Rectangle
rRectangle -> [Rectangle] -> [Rectangle]
forall a. a -> [a] -> [a]
:   [Rectangle]
rs) [(a, Rectangle)]
xs
              where ir :: Rectangle
ir = Rectangle -> Rectangle
inputRectangle Rectangle
r
          wrs_to_state [Rectangle]
_ [] = []

    handleMess :: MouseResize Window -> SomeMessage -> X (Maybe (MouseResize Window))
handleMess (MR [((Window, Rectangle), Maybe Window)]
s) SomeMessage
m
        | Just Event
e <- SomeMessage -> Maybe Event
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m :: Maybe Event = [((Window, Rectangle), Maybe Window)] -> Event -> X ()
handleResize [((Window, Rectangle), Maybe Window)]
s Event
e X ()
-> X (Maybe (MouseResize Window)) -> X (Maybe (MouseResize Window))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (MouseResize Window) -> X (Maybe (MouseResize Window))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (MouseResize Window)
forall a. Maybe a
Nothing
        | Just LayoutMessages
Hide             <- SomeMessage -> Maybe LayoutMessages
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = X ()
releaseResources X ()
-> X (Maybe (MouseResize Window)) -> X (Maybe (MouseResize Window))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (MouseResize Window) -> X (Maybe (MouseResize Window))
forall (m :: * -> *) a. Monad m => a -> m a
return (MouseResize Window -> Maybe (MouseResize Window)
forall a. a -> Maybe a
Just (MouseResize Window -> Maybe (MouseResize Window))
-> MouseResize Window -> Maybe (MouseResize Window)
forall a b. (a -> b) -> a -> b
$ [((Window, Rectangle), Maybe Window)] -> MouseResize Window
forall a. [((a, Rectangle), Maybe a)] -> MouseResize a
MR [])
        | Just LayoutMessages
ReleaseResources <- SomeMessage -> Maybe LayoutMessages
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = X ()
releaseResources X ()
-> X (Maybe (MouseResize Window)) -> X (Maybe (MouseResize Window))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (MouseResize Window) -> X (Maybe (MouseResize Window))
forall (m :: * -> *) a. Monad m => a -> m a
return (MouseResize Window -> Maybe (MouseResize Window)
forall a. a -> Maybe a
Just (MouseResize Window -> Maybe (MouseResize Window))
-> MouseResize Window -> Maybe (MouseResize Window)
forall a b. (a -> b) -> a -> b
$ [((Window, Rectangle), Maybe Window)] -> MouseResize Window
forall a. [((a, Rectangle), Maybe a)] -> MouseResize a
MR [])
        where releaseResources :: X ()
releaseResources = (((Window, Rectangle), Maybe Window) -> X ())
-> [((Window, Rectangle), Maybe Window)] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe Window -> X ()
deleteInputWin (Maybe Window -> X ())
-> (((Window, Rectangle), Maybe Window) -> Maybe Window)
-> ((Window, Rectangle), Maybe Window)
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Window, Rectangle), Maybe Window) -> Maybe Window
forall a b. (a, b) -> b
snd) [((Window, Rectangle), Maybe Window)]
s
    handleMess MouseResize Window
_ SomeMessage
_ = Maybe (MouseResize Window) -> X (Maybe (MouseResize Window))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (MouseResize Window)
forall a. Maybe a
Nothing

handleResize :: [((Window,Rectangle),Maybe Window)] -> Event -> X ()
handleResize :: [((Window, Rectangle), Maybe Window)] -> Event -> X ()
handleResize [((Window, Rectangle), Maybe Window)]
st 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 (Window
w,Rectangle Position
wx Position
wy EventType
_ EventType
_) <- Window
-> [((Window, Rectangle), Maybe Window)]
-> Maybe (Window, Rectangle)
forall {t} {a} {b}.
Eq t =>
t -> [((a, b), Maybe t)] -> Maybe (a, b)
getWin Window
ew [((Window, Rectangle), Maybe Window)]
st = do
                                        Window -> X ()
focus Window
w
                                        (Position -> Position -> X ()) -> X () -> X ()
mouseDrag (\Position
x Position
y -> do
                                                     let rect :: Rectangle
rect = Position -> Position -> EventType -> EventType -> Rectangle
Rectangle Position
wx Position
wy
                                                                (EventType -> EventType -> EventType
forall a. Ord a => a -> a -> a
max EventType
1 (EventType -> EventType)
-> (Position -> EventType) -> Position -> EventType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> EventType
forall a b. (Integral a, Num b) => a -> b
fi (Position -> EventType) -> Position -> EventType
forall a b. (a -> b) -> a -> b
$ Position
x Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
wx)
                                                                (EventType -> EventType -> EventType
forall a. Ord a => a -> a -> a
max EventType
1 (EventType -> EventType)
-> (Position -> EventType) -> Position -> EventType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> EventType
forall a b. (Integral a, Num b) => a -> b
fi (Position -> EventType) -> Position -> EventType
forall a b. (a -> b) -> a -> b
$ Position
y Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
wy)
                                                     WindowArrangerMsg -> X ()
forall a. Message a => a -> X ()
sendMessage (Rectangle -> WindowArrangerMsg
SetGeometry Rectangle
rect)) (() -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

      where
        getWin :: t -> [((a, b), Maybe t)] -> Maybe (a, b)
getWin t
w (((a
win,b
r),Maybe t
tw):[((a, b), Maybe t)]
xs)
            | Just t
w' <- Maybe t
tw
            , t
w t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
w'   = (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
win,b
r)
            | Bool
otherwise = t -> [((a, b), Maybe t)] -> Maybe (a, b)
getWin t
w [((a, b), Maybe t)]
xs
        getWin t
_ []     = Maybe (a, b)
forall a. Maybe a
Nothing
handleResize [((Window, Rectangle), Maybe Window)]
_ Event
_ = () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

createInputWindow :: ((Window,Rectangle), Maybe Rectangle) -> X ((Window,Rectangle),Maybe Window)
createInputWindow :: ((Window, Rectangle), Maybe Rectangle)
-> X ((Window, Rectangle), Maybe Window)
createInputWindow ((Window
w,Rectangle
r),Maybe Rectangle
mr) =
  case Maybe Rectangle
mr of
    Just Rectangle
tr  -> (Display -> X ((Window, Rectangle), Maybe Window))
-> X ((Window, Rectangle), Maybe Window)
forall a. (Display -> X a) -> X a
withDisplay ((Display -> X ((Window, Rectangle), Maybe Window))
 -> X ((Window, Rectangle), Maybe Window))
-> (Display -> X ((Window, Rectangle), Maybe Window))
-> X ((Window, Rectangle), Maybe Window)
forall a b. (a -> b) -> a -> b
$ \Display
d -> do
                  Window
tw <- Display -> Rectangle -> X Window
mkInputWindow Display
d Rectangle
tr
                  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
tw (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
xC_bottom_right_corner
                  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
tw 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
tw
                  ((Window, Rectangle), Maybe Window)
-> X ((Window, Rectangle), Maybe Window)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Window
w,Rectangle
r), Window -> Maybe Window
forall a. a -> Maybe a
Just Window
tw)
    Maybe Rectangle
Nothing ->    ((Window, Rectangle), Maybe Window)
-> X ((Window, Rectangle), Maybe Window)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Window
w,Rectangle
r), Maybe Window
forall a. Maybe a
Nothing)

deleteInputWin :: Maybe Window -> X ()
deleteInputWin :: Maybe Window -> X ()
deleteInputWin = X () -> (Window -> X ()) -> Maybe Window -> X ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Window -> X ()
deleteWindow

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