{-# 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.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
-- <https://xmonad.org/TUTORIAL.html#customizing-xmonad the tutorial> and
-- "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 = forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (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 = [(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 = forall (m :: * -> *) a. Monad m => a -> m a
return ([(Window, Rectangle)]
wrs, 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    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[((Window, Rectangle), Maybe Window)]
nst -> forall (m :: * -> *) a. Monad m => a -> m a
return ([(Window, Rectangle)]
wrs, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. [((a, Rectangle), Maybe a)] -> MouseResize a
MR [((Window, Rectangle), Maybe Window)]
nst)
        | Bool
otherwise = X [((Window, Rectangle), Maybe Window)]
processState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[((Window, Rectangle), Maybe Window)]
nst -> forall (m :: * -> *) a. Monad m => a -> m a
return ([(Window, Rectangle)]
wrs, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. [((a, Rectangle), Maybe a)] -> MouseResize a
MR [((Window, Rectangle), Maybe Window)]
nst)
        where
          wrs' :: [((Window, Rectangle), Maybe Rectangle)]
wrs'         = forall {a}.
[Rectangle]
-> [(a, Rectangle)] -> [((a, Rectangle), Maybe Rectangle)]
wrs_to_state [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => Stack a -> a -> Bool
isInStack Stack Window
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ [(Window, Rectangle)]
wrs
          initState :: X [((Window, Rectangle), Maybe Window)]
initState    = 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 = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe Window -> X ()
deleteInputWin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [((Window, Rectangle), Maybe Window)]
st forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 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
- Position
5) (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
- 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),forall a. a -> Maybe a
Just Rectangle
ir) forall a. a -> [a] -> [a]
: [Rectangle]
-> [(a, Rectangle)] -> [((a, Rectangle), Maybe Rectangle)]
wrs_to_state (Rectangle
rforall a. a -> [a] -> [a]
:Rectangle
irforall a. a -> [a] -> [a]
:[Rectangle]
rs) [(a, Rectangle)]
xs
              | Bool
otherwise         = ((a
w,Rectangle
r),forall a. Maybe a
Nothing) forall a. a -> [a] -> [a]
: [Rectangle]
-> [(a, Rectangle)] -> [((a, Rectangle), Maybe Rectangle)]
wrs_to_state (Rectangle
rforall 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 <- 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 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
Hide             <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = X ()
releaseResources 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. [((a, Rectangle), Maybe a)] -> MouseResize a
MR [])
        | Just LayoutMessages
ReleaseResources <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = X ()
releaseResources 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. [((a, Rectangle), Maybe a)] -> MouseResize a
MR [])
        where releaseResources :: X ()
releaseResources = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Maybe Window -> X ()
deleteInputWin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [((Window, Rectangle), Maybe Window)]
s
    handleMess MouseResize Window
_ SomeMessage
_ = forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a. Eq a => a -> a -> Bool
== EventType
buttonPress
    , Just (Window
w,Rectangle Position
wx Position
wy EventType
_ EventType
_) <- 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
                                                                (forall a. Ord a => a -> a -> a
max EventType
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fi forall a b. (a -> b) -> a -> b
$ Position
x forall a. Num a => a -> a -> a
- Position
wx)
                                                                (forall a. Ord a => a -> a -> a
max EventType
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fi forall a b. (a -> b) -> a -> b
$ Position
y forall a. Num a => a -> a -> a
- Position
wy)
                                                     forall a. Message a => a -> X ()
sendMessage (Rectangle -> WindowArrangerMsg
SetGeometry Rectangle
rect)) (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 forall a. Eq a => a -> a -> Bool
== t
w'   = 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
_ []     = forall a. Maybe a
Nothing
handleResize [((Window, Rectangle), Maybe Window)]
_ Event
_ = 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  -> forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
d -> do
                  Window
tw <- Display -> Rectangle -> X Window
mkInputWindow Display
d Rectangle
tr
                  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
tw (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
xC_bottom_right_corner
                  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
tw 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
tw
                  forall (m :: * -> *) a. Monad m => a -> m a
return ((Window
w,Rectangle
r), forall a. a -> Maybe a
Just Window
tw)
    Maybe Rectangle
Nothing ->    forall (m :: * -> *) a. Monad m => a -> m a
return ((Window
w,Rectangle
r), forall a. Maybe a
Nothing)

deleteInputWin :: Maybe Window -> X ()
deleteInputWin :: Maybe Window -> X ()
deleteInputWin = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (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 <- 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