{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
module XMonad.Layout.DragPane (
dragPane
, DragPane, DragType (..)
) where
import XMonad
import Data.Unique
import qualified XMonad.StackSet as W
import XMonad.Util.Invisible
import XMonad.Util.XUtils
halfHandleWidth :: Integral a => a
halfHandleWidth :: forall a. Integral a => a
halfHandleWidth = a
1
handleColor :: String
handleColor :: String
handleColor = String
"#000000"
dragPane :: DragType -> Double -> Double -> DragPane a
dragPane :: forall a. DragType -> Double -> Double -> DragPane a
dragPane = forall a.
Invisible Maybe (Window, Rectangle, Int)
-> DragType -> Double -> Double -> DragPane a
DragPane (forall (m :: * -> *) a. m a -> Invisible m a
I forall a. Maybe a
Nothing)
data DragPane a =
DragPane (Invisible Maybe (Window,Rectangle,Int)) DragType Double Double
deriving ( Int -> DragPane a -> ShowS
forall a. Int -> DragPane a -> ShowS
forall a. [DragPane a] -> ShowS
forall a. DragPane a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DragPane a] -> ShowS
$cshowList :: forall a. [DragPane a] -> ShowS
show :: DragPane a -> String
$cshow :: forall a. DragPane a -> String
showsPrec :: Int -> DragPane a -> ShowS
$cshowsPrec :: forall a. Int -> DragPane a -> ShowS
Show, ReadPrec [DragPane a]
ReadPrec (DragPane a)
ReadS [DragPane a]
forall a. ReadPrec [DragPane a]
forall a. ReadPrec (DragPane a)
forall a. Int -> ReadS (DragPane a)
forall a. ReadS [DragPane a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DragPane a]
$creadListPrec :: forall a. ReadPrec [DragPane a]
readPrec :: ReadPrec (DragPane a)
$creadPrec :: forall a. ReadPrec (DragPane a)
readList :: ReadS [DragPane a]
$creadList :: forall a. ReadS [DragPane a]
readsPrec :: Int -> ReadS (DragPane a)
$creadsPrec :: forall a. Int -> ReadS (DragPane a)
Read )
data DragType = Horizontal | Vertical deriving ( Int -> DragType -> ShowS
[DragType] -> ShowS
DragType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DragType] -> ShowS
$cshowList :: [DragType] -> ShowS
show :: DragType -> String
$cshow :: DragType -> String
showsPrec :: Int -> DragType -> ShowS
$cshowsPrec :: Int -> DragType -> ShowS
Show, ReadPrec [DragType]
ReadPrec DragType
Int -> ReadS DragType
ReadS [DragType]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DragType]
$creadListPrec :: ReadPrec [DragType]
readPrec :: ReadPrec DragType
$creadPrec :: ReadPrec DragType
readList :: ReadS [DragType]
$creadList :: ReadS [DragType]
readsPrec :: Int -> ReadS DragType
$creadsPrec :: Int -> ReadS DragType
Read )
instance LayoutClass DragPane a where
doLayout :: DragPane a
-> Rectangle -> Stack a -> X ([(a, Rectangle)], Maybe (DragPane a))
doLayout d :: DragPane a
d@(DragPane Invisible Maybe (Window, Rectangle, Int)
_ DragType
Vertical Double
_ Double
_) = forall a.
(Rectangle -> Rectangle)
-> DragPane a
-> Rectangle
-> Stack a
-> X ([(a, Rectangle)], Maybe (DragPane a))
doLay forall a. a -> a
id DragPane a
d
doLayout d :: DragPane a
d@(DragPane Invisible Maybe (Window, Rectangle, Int)
_ DragType
Horizontal Double
_ Double
_) = forall a.
(Rectangle -> Rectangle)
-> DragPane a
-> Rectangle
-> Stack a
-> X ([(a, Rectangle)], Maybe (DragPane a))
doLay Rectangle -> Rectangle
mirrorRect DragPane a
d
handleMessage :: DragPane a -> SomeMessage -> X (Maybe (DragPane a))
handleMessage = forall a. DragPane a -> SomeMessage -> X (Maybe (DragPane a))
handleMess
data SetFrac = SetFrac Int Double deriving ( Int -> SetFrac -> ShowS
[SetFrac] -> ShowS
SetFrac -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SetFrac] -> ShowS
$cshowList :: [SetFrac] -> ShowS
show :: SetFrac -> String
$cshow :: SetFrac -> String
showsPrec :: Int -> SetFrac -> ShowS
$cshowsPrec :: Int -> SetFrac -> ShowS
Show, ReadPrec [SetFrac]
ReadPrec SetFrac
Int -> ReadS SetFrac
ReadS [SetFrac]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SetFrac]
$creadListPrec :: ReadPrec [SetFrac]
readPrec :: ReadPrec SetFrac
$creadPrec :: ReadPrec SetFrac
readList :: ReadS [SetFrac]
$creadList :: ReadS [SetFrac]
readsPrec :: Int -> ReadS SetFrac
$creadsPrec :: Int -> ReadS SetFrac
Read, SetFrac -> SetFrac -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SetFrac -> SetFrac -> Bool
$c/= :: SetFrac -> SetFrac -> Bool
== :: SetFrac -> SetFrac -> Bool
$c== :: SetFrac -> SetFrac -> Bool
Eq)
instance Message SetFrac
handleMess :: DragPane a -> SomeMessage -> X (Maybe (DragPane a))
handleMess :: forall a. DragPane a -> SomeMessage -> X (Maybe (DragPane a))
handleMess d :: DragPane a
d@(DragPane mb :: Invisible Maybe (Window, Rectangle, Int)
mb@(I (Just (Window
win,Rectangle
_,Int
ident))) DragType
ty Double
delta Double
split) SomeMessage
x
| Just Event
e <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
x :: Maybe Event = do forall a. DragPane a -> Event -> X ()
handleEvent DragPane a
d Event
e
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
x = do Window -> X ()
hideWindow Window
win
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall a.
Invisible Maybe (Window, Rectangle, Int)
-> DragType -> Double -> Double -> DragPane a
DragPane Invisible Maybe (Window, Rectangle, Int)
mb DragType
ty Double
delta Double
split)
| Just LayoutMessages
ReleaseResources <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
x = do Window -> X ()
deleteWindow Window
win
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall a.
Invisible Maybe (Window, Rectangle, Int)
-> DragType -> Double -> Double -> DragPane a
DragPane (forall (m :: * -> *) a. m a -> Invisible m a
I forall a. Maybe a
Nothing) DragType
ty Double
delta Double
split)
| Just Resize
Shrink <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
x = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall a.
Invisible Maybe (Window, Rectangle, Int)
-> DragType -> Double -> Double -> DragPane a
DragPane Invisible Maybe (Window, Rectangle, Int)
mb DragType
ty Double
delta (Double
split forall a. Num a => a -> a -> a
- Double
delta))
| Just Resize
Expand <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
x = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall a.
Invisible Maybe (Window, Rectangle, Int)
-> DragType -> Double -> Double -> DragPane a
DragPane Invisible Maybe (Window, Rectangle, Int)
mb DragType
ty Double
delta (Double
split forall a. Num a => a -> a -> a
+ Double
delta))
| Just (SetFrac Int
ident' Double
frac) <- forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
x, Int
ident' forall a. Eq a => a -> a -> Bool
== Int
ident =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall a.
Invisible Maybe (Window, Rectangle, Int)
-> DragType -> Double -> Double -> DragPane a
DragPane Invisible Maybe (Window, Rectangle, Int)
mb DragType
ty Double
delta Double
frac)
handleMess DragPane a
_ SomeMessage
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
handleEvent :: DragPane a -> Event -> X ()
handleEvent :: forall a. DragPane a -> Event -> X ()
handleEvent (DragPane (I (Just (Window
win,Rectangle
r,Int
ident))) DragType
ty Double
_ Double
_)
ButtonEvent{ev_window :: Event -> Window
ev_window = Window
thisw, ev_subwindow :: Event -> Window
ev_subwindow = Window
thisbw, ev_event_type :: Event -> EventType
ev_event_type = EventType
t }
| EventType
t forall a. Eq a => a -> a -> Bool
== EventType
buttonPress Bool -> Bool -> Bool
&& Window
thisw forall a. Eq a => a -> a -> Bool
== Window
win Bool -> Bool -> Bool
|| Window
thisbw forall a. Eq a => a -> a -> Bool
== Window
win =
(Position -> Position -> X ()) -> X () -> X ()
mouseDrag (\Position
ex Position
ey -> do
let frac :: Double
frac = case DragType
ty of
DragType
Vertical -> (forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
ex forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rectangle -> Position
rect_x Rectangle
r))forall a. Fractional a => a -> a -> a
/forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rectangle -> EventType
rect_width Rectangle
r)
DragType
Horizontal -> (forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
ey forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rectangle -> Position
rect_x Rectangle
r))forall a. Fractional a => a -> a -> a
/forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rectangle -> EventType
rect_width Rectangle
r)
forall a. Message a => a -> X ()
sendMessage (Int -> Double -> SetFrac
SetFrac Int
ident Double
frac))
(forall (m :: * -> *) a. Monad m => a -> m a
return ())
handleEvent DragPane a
_ Event
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
doLay :: (Rectangle -> Rectangle) -> DragPane a -> Rectangle -> W.Stack a -> X ([(a, Rectangle)], Maybe (DragPane a))
doLay :: forall a.
(Rectangle -> Rectangle)
-> DragPane a
-> Rectangle
-> Stack a
-> X ([(a, Rectangle)], Maybe (DragPane a))
doLay Rectangle -> Rectangle
mirror (DragPane Invisible Maybe (Window, Rectangle, Int)
mw DragType
ty Double
delta Double
split) Rectangle
r Stack a
s = do
let r' :: Rectangle
r' = Rectangle -> Rectangle
mirror Rectangle
r
(Rectangle
left', Rectangle
right') = forall r. RealFrac r => r -> Rectangle -> (Rectangle, Rectangle)
splitHorizontallyBy Double
split Rectangle
r'
left :: Rectangle
left = case Rectangle
left' of Rectangle Position
x Position
y EventType
w EventType
h ->
Rectangle -> Rectangle
mirror forall a b. (a -> b) -> a -> b
$ Position -> Position -> EventType -> EventType -> Rectangle
Rectangle Position
x Position
y (EventType
wforall a. Num a => a -> a -> a
-forall a. Integral a => a
halfHandleWidth) EventType
h
right :: Rectangle
right = case Rectangle
right' of
Rectangle Position
x Position
y EventType
w EventType
h ->
Rectangle -> Rectangle
mirror forall a b. (a -> b) -> a -> b
$ Position -> Position -> EventType -> EventType -> Rectangle
Rectangle (Position
xforall a. Num a => a -> a -> a
+forall a. Integral a => a
halfHandleWidth) Position
y (EventType
wforall a. Num a => a -> a -> a
-forall a. Integral a => a
halfHandleWidth) EventType
h
handr :: Rectangle
handr = case Rectangle
left' of
Rectangle Position
x Position
y EventType
w EventType
h ->
Rectangle -> Rectangle
mirror forall a b. (a -> b) -> a -> b
$ Position -> Position -> EventType -> EventType -> Rectangle
Rectangle (Position
x forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral EventType
w forall a. Num a => a -> a -> a
- forall a. Integral a => a
halfHandleWidth) Position
y (EventType
2forall a. Num a => a -> a -> a
*forall a. Integral a => a
halfHandleWidth) EventType
h
wrs :: [(a, Rectangle)]
wrs = case forall a. [a] -> [a]
reverse (forall a. Stack a -> [a]
W.up Stack a
s) of
(a
master:[a]
_) -> [(a
master,Rectangle
left),(forall a. Stack a -> a
W.focus Stack a
s,Rectangle
right)]
[] -> case forall a. Stack a -> [a]
W.down Stack a
s of
(a
next:[a]
_) -> [(forall a. Stack a -> a
W.focus Stack a
s,Rectangle
left),(a
next,Rectangle
right)]
[] -> [(forall a. Stack a -> a
W.focus Stack a
s, Rectangle
r)]
if forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, Rectangle)]
wrs forall a. Ord a => a -> a -> Bool
> Int
1
then case Invisible Maybe (Window, Rectangle, Int)
mw of
I (Just (Window
w,Rectangle
_,Int
ident)) -> do
Window
w' <- Window -> X ()
deleteWindow Window
w forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Rectangle -> X Window
newDragWin Rectangle
handr
forall (m :: * -> *) a. Monad m => a -> m a
return ([(a, Rectangle)]
wrs, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a.
Invisible Maybe (Window, Rectangle, Int)
-> DragType -> Double -> Double -> DragPane a
DragPane (forall (m :: * -> *) a. m a -> Invisible m a
I forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Window
w',Rectangle
r',Int
ident)) DragType
ty Double
delta Double
split)
I Maybe (Window, Rectangle, Int)
Nothing -> do
Window
w <- Rectangle -> X Window
newDragWin Rectangle
handr
Unique
i <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io IO Unique
newUnique
forall (m :: * -> *) a. Monad m => a -> m a
return ([(a, Rectangle)]
wrs, forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a.
Invisible Maybe (Window, Rectangle, Int)
-> DragType -> Double -> Double -> DragPane a
DragPane (forall (m :: * -> *) a. m a -> Invisible m a
I forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Window
w,Rectangle
r',Unique -> Int
hashUnique Unique
i)) DragType
ty Double
delta Double
split)
else forall (m :: * -> *) a. Monad m => a -> m a
return ([(a, Rectangle)]
wrs, forall a. Maybe a
Nothing)
newDragWin :: Rectangle -> X Window
newDragWin :: Rectangle -> X Window
newDragWin Rectangle
r = do
let mask :: Maybe Window
mask = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Window
exposureMask forall a. Bits a => a -> a -> a
.|. Window
buttonPressMask
Window
w <- Rectangle -> Maybe Window -> String -> Bool -> X Window
createNewWindow Rectangle
r Maybe Window
mask String
handleColor Bool
False
Window -> X ()
showWindow Window
w
Display
d <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO ()
lowerWindow Display
d Window
w
forall (m :: * -> *) a. Monad m => a -> m a
return Window
w