Add layout modifier for floating layer support

9 files changed, 128 insertions, 64 deletions

diff --git a/MetaTile/Config.hs b/MetaTile/Config.hs
index 71706d8..b553bd4 100644
--- a/MetaTile/Config.hs
+++ b/MetaTile/Config.hs
@@ -20,7 +20,7 @@
 --
 ------------------------------------------------------------------------
 
-module MetaTile.Config (defaultConfig, Default(..)) where
+module MetaTile.Config (Default(..)) where
 
 --
 -- Useful imports
@@ -34,7 +34,10 @@ import qualified MetaTile.Core as MetaTile
     ,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor,defaultBorderWidth,focusFollowsMouse
     ,handleEventHook,clickJustFocuses,rootMask,frameMask,clientMask)
 
+import Prelude hiding (Floating)
 import MetaTile.Layout
+import MetaTile.Layout.Floating
+import MetaTile.Layout.LayoutModifier
 import MetaTile.Operations
 import qualified MetaTile.StackSet as W
 import Data.Bits ((.|.))
@@ -128,7 +131,7 @@ startupHook = return ()
 
 -- | The available layouts.  Note that each layout is separated by |||, which
 -- denotes layout choice.
-layout = tiled ||| Mirror tiled ||| Full
+layout = floating $ tiled ||| Mirror tiled ||| Full
   where
      -- default tiling algorithm partitions the screen into two panes
      tiled   = Tall nmaster delta ratio
@@ -209,6 +212,9 @@ keys conf@(XConfig {MetaTile.modMask = modMask}) = M.fromList $
     , ((modMask,               xK_h     ), sendMessage Shrink) -- %! Shrink the master area
     , ((modMask,               xK_l     ), sendMessage Expand) -- %! Expand the master area
 
+    -- floating layer support
+    , ((modMask,               xK_t     ), withFocused sink) -- %! Push window back into tiling
+
     -- increase or decrease number of windows in the master area
     , ((modMask              , xK_comma ), sendMessage (IncMasterN 1)) -- %! Increment the number of windows in the master area
     , ((modMask              , xK_period), sendMessage (IncMasterN (-1))) -- %! Deincrement the number of windows in the master area
@@ -237,12 +243,16 @@ keys conf@(XConfig {MetaTile.modMask = modMask}) = M.fromList $
 -- | Mouse bindings: default actions bound to mouse events
 mouseBindings :: XConfig Layout -> M.Map (KeyMask, Button) (Window -> X ())
 mouseBindings (XConfig {MetaTile.modMask = modMask}) = M.fromList
+    -- mod-button1 %! Set the window to floating mode and move by dragging
+    [ ((modMask, button1), \w -> focus w >> mouseMoveWindow w)
     -- mod-button2 %! Raise the window to the top of the stack
-    [ ((modMask, button2), windows . (W.shiftMaster .) . W.focusWindow)
+    , ((modMask, button2), windows . (W.shiftMaster .) . W.focusWindow)
+    -- mod-button3 %! Set the window to floating mode and resize by dragging
+    , ((modMask, button3), \w -> focus w >> mouseResizeWindow w)
     -- you may also bind events to the mouse scroll wheel (button4 and button5)
     ]
 
-instance (a ~ Choose Tall (Choose (Mirror Tall) Full)) => Default (XConfig a) where
+instance (a ~ ModifiedLayout Floating (Choose Tall (Choose (Mirror Tall) Full))) => Default (XConfig a) where
   def = XConfig
     { MetaTile.workspaces         = workspaces
     , MetaTile.layoutHook         = layout
@@ -264,11 +274,6 @@ instance (a ~ Choose Tall (Choose (Mirror Tall) Full)) => Default (XConfig a) wh
     , MetaTile.rootMask           = rootMask
     }
 
--- | The default set of configuration values itself
-{-# DEPRECATED defaultConfig "Use def (from Data.Default, and re-exported by MetaTile and MetaTile.Config) instead." #-}
-defaultConfig :: XConfig (Choose Tall (Choose (Mirror Tall) Full))
-defaultConfig = def
-
 -- | Finally, a copy of the default bindings in simple textual tabular format.
 help :: String
 help = unlines ["The default modifier key is 'alt'. Default keybindings:",
diff --git a/MetaTile/Core.hs b/MetaTile/Core.hs
index 79611fd..3d84ea3 100644
--- a/MetaTile/Core.hs
+++ b/MetaTile/Core.hs
@@ -22,7 +22,7 @@ module MetaTile.Core (
     XConf(..), XConfig(..), LayoutClass(..),
     Layout(..), readsLayout, Typeable, Message,
     SomeMessage(..), fromMessage, LayoutMessages(..),
-    StateExtension(..), ExtensionClass(..),
+    StateExtension(..), ExtensionClass(..), Window, Rectangle(..),
     runX, catchX, userCode, userCodeDef, io, catchIO, installSignalHandlers, uninstallSignalHandlers,
     withDisplay, withWindowSet, isRoot, runOnWorkspaces,
     getWindowState, getsWindowState, setWindowState, modifyWindowState,
diff --git a/MetaTile/Layout.hs b/MetaTile/Layout.hs
index 93b9408..ad65f32 100644
--- a/MetaTile/Layout.hs
+++ b/MetaTile/Layout.hs
@@ -26,7 +26,6 @@ module MetaTile.Layout (
 
 import MetaTile.Core
 
-import Graphics.X11 (Rectangle(..))
 import qualified MetaTile.StackSet as W
 import Control.Arrow ((***), second)
 import Control.Monad
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
diff --git a/MetaTile/Main.hsc b/MetaTile/Main.hsc
index 426e78f..92692a3 100644
--- a/MetaTile/Main.hsc
+++ b/MetaTile/Main.hsc
@@ -24,6 +24,7 @@ import Control.Monad.Reader
 import Control.Monad.State
 import Data.Maybe (fromMaybe)
 import Data.Monoid (getAll)
+import Data.Traversable (traverse)
 
 import Foreign.C
 import Foreign.Ptr
@@ -252,8 +253,10 @@ handle e@(ButtonEvent {ev_window = w,ev_event_type = t,ev_button = b })
     isr <- isRoot w
     m <- cleanMask $ ev_state e
     mact <- asks (M.lookup (m, b) . buttonActions)
+    trace $ show (ev_subwindow e)
+    getsFrameState fsWindow (ev_subwindow e) >>= trace . show
     case mact of
-        Just act | isr -> act $ ev_subwindow e
+        Just act | isr -> getsFrameState fsWindow (ev_subwindow e) >>= traverse act >> return ()
         _              -> do
             focus w
             ctf <- asks (clickJustFocuses . config)
diff --git a/MetaTile/ManageHook.hs b/MetaTile/ManageHook.hs
index c7140c4..8dad704 100644
--- a/MetaTile/ManageHook.hs
+++ b/MetaTile/ManageHook.hs
@@ -20,7 +20,7 @@ module MetaTile.ManageHook where
 
 import MetaTile.Core
 import Graphics.X11.Xlib.Extras
-import Graphics.X11.Xlib (Display, Window, internAtom, wM_NAME)
+import Graphics.X11.Xlib (Display, internAtom, wM_NAME)
 import Control.Exception.Extensible (bracket, SomeException(..))
 import Control.Monad.Reader
 import Data.Maybe
diff --git a/MetaTile/Operations.hs b/MetaTile/Operations.hs
index b45403f..4edf67b 100644
--- a/MetaTile/Operations.hs
+++ b/MetaTile/Operations.hs
@@ -25,7 +25,6 @@ import Data.Maybe
 import Data.Monoid          (Endo(..))
 import Data.List            (nub, (\\), find)
 import Data.Bits            ((.|.), (.&.), complement, testBit)
-import Data.Ratio
 import qualified Data.Map as M
 
 import Control.Applicative
@@ -160,12 +159,6 @@ windows f = do
         setWindowBackground d frame p
         clearWindow d frame
 
--- | Produce the actual rectangle from a screen and a ratio on that screen.
-scaleRationalRect :: Rectangle -> W.RationalRect -> Rectangle
-scaleRationalRect (Rectangle sx sy sw sh) (W.RationalRect rx ry rw rh)
- = Rectangle (sx + scale sw rx) (sy + scale sh ry) (scale sw rw) (scale sh rh)
- where scale s r = floor (toRational s * r)
-
 -- | setWMState.  set the WM_STATE property
 setWMState :: Window -> Int -> X ()
 setWMState w v = withDisplay $ \dpy -> do
@@ -255,6 +248,7 @@ tileWindow w r bw = withDisplay $ \d -> do
     modifyFrameState (\fs -> fs {fsBorderWidth = bw}) frame
     io $ moveResizeWindow d frame (rect_x r) (rect_y r) (least $ rect_width r) (least $ rect_height r)
 
+
 -- ---------------------------------------------------------------------
 
 -- | Returns 'True' if the first rectangle is contained within, but not equal
@@ -453,22 +447,6 @@ restart prog resume = do
 
 -- | Given a window, find the screen it is located on, and compute
 -- the geometry of that window wrt. that screen.
-floatLocation :: Window -> X (ScreenId, W.RationalRect)
-floatLocation w = withDisplay $ \d -> do
-    ws <- gets windowset
-    wa <- io $ getWindowAttributes d w
-    let bw = (fromIntegral . wa_border_width) wa
-    sc <- fromMaybe (W.current ws) <$> pointScreen (fi $ wa_x wa) (fi $ wa_y wa)
-
-    let sr = screenRect . W.screenDetail $ sc
-        rr = W.RationalRect ((fi (wa_x wa) - fi (rect_x sr)) % fi (rect_width sr))
-                            ((fi (wa_y wa) - fi (rect_y sr)) % fi (rect_height sr))
-                            (fi (wa_width  wa + bw*2) % fi (rect_width sr))
-                            (fi (wa_height wa + bw*2) % fi (rect_height sr))
-
-    return (W.screen sc, rr)
-  where fi x = fromIntegral x
-
 -- | Given a point, determine the screen (if any) that contains it.
 pointScreen :: Position -> Position
             -> X (Maybe (W.Screen WorkspaceId (Layout Window) Window ScreenId ScreenDetail))
@@ -483,17 +461,6 @@ pointWithin x y r = x >= rect_x r &&
                     y >= rect_y r &&
                     y <  rect_y r + fromIntegral (rect_height r)
 
--- | Make a tiled window floating, using its suggested rectangle
-{-float :: Window -> X ()
-float w = do
-    (sc, rr) <- floatLocation w
-    windows $ \ws -> W.float w rr . fromMaybe ws $ do
-        i  <- W.findTag w ws
-        guard $ i `elem` concatMap (map W.tag . W.screenWorkspaces) (W.screens ws)
-        f  <- W.peek ws
-        sw <- W.lookupWorkspace sc ws
-        return (W.focusWindow f . W.shiftWin sw w $ ws)-}
-
 -- ---------------------------------------------------------------------
 -- Mouse handling
 
diff --git a/MetaTile/StackSet.hs b/MetaTile/StackSet.hs
index 907840c..d37f7c8 100644
--- a/MetaTile/StackSet.hs
+++ b/MetaTile/StackSet.hs
@@ -24,7 +24,7 @@ module MetaTile.StackSet (
         -- ** Master and Focus
         -- $focus
 
-        StackSet(..), Workspace(..), Screen(..), Stack(..), RationalRect(..),
+        StackSet(..), Workspace(..), Screen(..), Stack(..),
         -- *  Construction
         -- $construction
         new, view, greedyView,
@@ -148,10 +148,6 @@ data Screen i l a sid sd = Screen { screenWorkspace :: !(Workspace i l a)
 data Workspace i l a = Workspace  { tag :: !i, layout :: l, stack :: Maybe (Stack a) }
     deriving (Show, Read, Eq)
 
--- | A structure for window geometries
-data RationalRect = RationalRect Rational Rational Rational Rational
-    deriving (Show, Read, Eq)
-
 -- |
 -- A stack is a cursor onto a window list.
 -- The data structure tracks focus by construction, and
@@ -481,17 +477,6 @@ delete w s = mapWorkspace removeFromWorkspace s
     where removeFromWorkspace ws = ws { stack = stack ws >>= filter (/=w) }
 
 ------------------------------------------------------------------------
-
--- | Given a window, and its preferred rectangle, set it as floating
--- A floating window should already be managed by the 'StackSet'.
---float :: Ord a => a -> RationalRect -> StackSet i l a s sd -> StackSet i l a s sd
---float w r s = s { floating = M.insert w r (floating s) }
-
--- | Clear the floating status of a window
---sink :: Ord a => a -> StackSet i l a s sd -> StackSet i l a s sd
---sink w s = s { floating = M.delete w (floating s) }
-
-------------------------------------------------------------------------
 -- $settingMW
 
 -- | /O(s)/. Set the master window to the focused window.