summaryrefslogtreecommitdiffstats
path: root/MetaTile/Layout
diff options
context:
space:
mode:
Diffstat (limited to 'MetaTile/Layout')
-rw-r--r--MetaTile/Layout/Floating.hs105
-rw-r--r--MetaTile/Layout/LayoutModifier.hs2
2 files changed, 106 insertions, 1 deletions
diff --git a/MetaTile/Layout/Floating.hs b/MetaTile/Layout/Floating.hs
new file mode 100644
index 0000000..48abc7f
--- /dev/null
+++ b/MetaTile/Layout/Floating.hs
@@ -0,0 +1,105 @@
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveDataTypeable #-}
+
+module MetaTile.Layout.Floating (
+ Floating, floating,
+ float, sink, mouseMoveWindow, mouseResizeWindow
+ ) where
+
+import Prelude hiding (Floating)
+
+import MetaTile.Core
+import MetaTile.Layout.LayoutModifier
+import MetaTile.Operations
+import qualified MetaTile.StackSet as W
+import qualified MetaTile.Util.ExtensibleState as XS
+
+import Control.Arrow ((&&&), first)
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.Functor
+import qualified Data.Map as M
+import Data.Maybe
+import Graphics.X11.Xlib
+import Graphics.X11.Xlib.Extras
+
+
+data FloatingStorage = FloatingStorage {
+ floatingWindows :: M.Map Window Rectangle
+ } deriving (Show, Read, Typeable)
+
+instance ExtensionClass FloatingStorage where
+ initialValue = FloatingStorage M.empty
+ extensionType = PersistentExtension
+
+
+data Floating a = Floating deriving (Show, Read)
+
+instance LayoutModifier Floating Window where
+ modifyLayout _ (w@W.Workspace { W.stack = stack }) r = do
+ bw <- asks (defaultBorderWidth . config)
+ ws <- gets windowset
+ FloatingStorage { floatingWindows = fw } <- XS.get
+ let fw' = M.filterWithKey (\k _ -> k `W.member` ws) fw
+ tiled = stack >>= W.filter (`M.notMember` fw')
+ fwLayout = [(a, ar, bw) | (a, ar) <- catMaybes . map (maybeSecond . (id &&& flip M.lookup fw')) $ W.integrate' stack]
+ XS.put $ FloatingStorage fw'
+ first (fwLayout ++) <$> runBorderLayout (w { W.stack = tiled }) r
+ where
+ maybeSecond :: (a, Maybe b) -> Maybe (a, b)
+ maybeSecond (a, Just b) = Just (a, b)
+ maybeSecond (_, Nothing) = Nothing
+
+floating :: l Window -> ModifiedLayout Floating l Window
+floating = ModifiedLayout Floating
+
+
+------------------------------------------------------------------------
+-- | Floating layer support
+
+-- | Given a window, find the screen it is located on, and compute
+-- the geometry of that window wrt. that screen.
+floatLocation :: Window -> X (ScreenId, Rectangle)
+floatLocation w = withDisplay $ \d -> do
+ ws <- gets windowset
+ frame <- getsWindowState wsFrame w
+ wa <- io $ getWindowAttributes d frame
+ sc <- fromMaybe (W.current ws) <$> pointScreen (fi $ wa_x wa) (fi $ wa_y wa)
+ let sr = screenRect . W.screenDetail $ sc
+ rr = Rectangle ((fi $ wa_x wa) - (fi $ rect_x sr)) ((fi $ wa_y wa) - (fi $ rect_y sr)) (fi $ wa_width wa) (fi $ wa_height wa)
+ return (W.screen sc, rr)
+ where fi x = fromIntegral x
+
+-- | Make a tiled window floating, using its suggested rectangle
+float :: Window -> X ()
+float w = do
+ (_, r) <- floatLocation w
+ XS.modify $ \(FloatingStorage fw) -> FloatingStorage (M.insert w r fw)
+ refresh
+
+-- | Make a tiled window floating, using its suggested rectangle
+sink :: Window -> X ()
+sink w = do
+ XS.modify $ \(FloatingStorage fw) -> FloatingStorage (M.delete w fw)
+ refresh
+
+
+-- | XXX comment me
+mouseMoveWindow :: Window -> X ()
+mouseMoveWindow w = whenX (isClient w) $ withDisplay $ \d -> do
+ frame <- getsWindowState wsFrame w
+ io $ raiseWindow d frame
+ wa <- io $ getWindowAttributes d frame
+ (_, _, _, ox', oy', _, _, _) <- io $ queryPointer d frame
+ let ox = fromIntegral ox'
+ oy = fromIntegral oy'
+ mouseDrag (\ex ey -> (io $ moveWindow d frame (fromIntegral (fromIntegral (wa_x wa) + (ex - ox))) (fromIntegral (fromIntegral (wa_y wa) + (ey - oy)))) >> reveal w) (float w)
+
+-- | XXX comment me
+mouseResizeWindow :: Window -> X ()
+mouseResizeWindow w = whenX (isClient w) $ withDisplay $ \d -> do
+ frame <- getsWindowState wsFrame w
+ io $ raiseWindow d frame
+ wa <- io $ getWindowAttributes d frame
+ sh <- io $ getWMNormalHints d w
+ io $ warpPointer d none frame 0 0 0 0 (fromIntegral (wa_width wa)) (fromIntegral (wa_height wa))
+ mouseDrag (\ex ey -> (io $ resizeWindow d frame `uncurry` applySizeHintsContents sh (ex - fromIntegral (wa_x wa), ey - fromIntegral (wa_y wa))) >> reveal w) (float w)
diff --git a/MetaTile/Layout/LayoutModifier.hs b/MetaTile/Layout/LayoutModifier.hs
index 5d97467..7b66586 100644
--- a/MetaTile/Layout/LayoutModifier.hs
+++ b/MetaTile/Layout/LayoutModifier.hs
@@ -31,7 +31,7 @@ module MetaTile.Layout.LayoutModifier (
import Control.Monad
-import MetaTile
+import MetaTile.Core
import MetaTile.StackSet ( Stack, Workspace (..) )
-- $usage