Add layout modifier for floating layer support

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