Add support for window borders

4 files changed, 62 insertions, 19 deletions

diff --git a/XMonad/Config.hs b/XMonad/Config.hs
index 1a2c378..7524368 100644
--- a/XMonad/Config.hs
+++ b/XMonad/Config.hs
@@ -27,11 +27,11 @@ module XMonad.Config (defaultConfig, Default(..)) where
 --
 import XMonad.Core as XMonad hiding
     (workspaces,manageHook,keys,logHook,startupHook,mouseBindings
-    ,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor,focusFollowsMouse
+    ,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor,defaultBorderWidth,focusFollowsMouse
     ,handleEventHook,clickJustFocuses,rootMask,clientMask)
 import qualified XMonad.Core as XMonad
     (workspaces,manageHook,keys,logHook,startupHook,mouseBindings
-    ,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor,focusFollowsMouse
+    ,layoutHook,modMask,terminal,normalBorderColor,focusedBorderColor,defaultBorderWidth,focusFollowsMouse
     ,handleEventHook,clickJustFocuses,rootMask,clientMask)
 
 import XMonad.Layout
@@ -71,6 +71,9 @@ normalBorderColor, focusedBorderColor :: String
 normalBorderColor  = "gray" -- "#dddddd"
 focusedBorderColor = "red"  -- "#ff0000" don't use hex, not <24 bit safe
 
+defaultBorderWidth :: BorderWidth
+defaultBorderWidth = BorderWidth 1 1 1 1
+
 ------------------------------------------------------------------------
 -- Window rules
 
@@ -242,6 +245,7 @@ instance (a ~ Choose Tall (Choose (Mirror Tall) Full)) => Default (XConfig a) wh
     , XMonad.terminal           = terminal
     , XMonad.normalBorderColor  = normalBorderColor
     , XMonad.focusedBorderColor = focusedBorderColor
+    , XMonad.defaultBorderWidth = defaultBorderWidth
     , XMonad.modMask            = defaultModMask
     , XMonad.keys               = keys
     , XMonad.logHook            = logHook
diff --git a/XMonad/Core.hs b/XMonad/Core.hs
index 4171060..483bc28 100644
--- a/XMonad/Core.hs
+++ b/XMonad/Core.hs
@@ -17,7 +17,7 @@
 -----------------------------------------------------------------------------
 
 module XMonad.Core (
-    X, WindowSet, WindowSpace, WorkspaceId, WindowState(..),
+    X, WindowSet, WindowSpace, WorkspaceId, BorderWidth(..), WindowState(..),
     ScreenId(..), ScreenDetail(..), XState(..),
     XConf(..), XConfig(..), LayoutClass(..),
     Layout(..), readsLayout, Typeable, Message,
@@ -35,9 +35,11 @@ import Prelude hiding ( catch )
 import Codec.Binary.UTF8.String (encodeString)
 import Control.Exception.Extensible (catch, fromException, try, bracket, throw, finally, SomeException(..))
 import Control.Applicative
+import Control.Arrow ((&&&))
 import Control.Monad.State
 import Control.Monad.Reader
 import Data.Default
+import Data.Function (on)
 import System.FilePath
 import System.IO
 import System.Info
@@ -58,11 +60,22 @@ import Data.Monoid
 import qualified Data.Map as M
 
 
+data BorderWidth = BorderWidth
+    { bwTop    :: !Dimension
+    , bwRight  :: !Dimension
+    , bwBottom :: !Dimension
+    , bwLeft   :: !Dimension
+    } deriving Show
+
 data WindowState = WindowState
     { wsMapped       :: !Bool
     , wsWaitingUnmap :: !Int         -- ^ the number of expected UnmapEvents
     , wsFrame        :: !Window
-    } deriving (Show, Eq)
+    , wsBorderWidth  :: !BorderWidth
+    } deriving Show
+
+instance Eq WindowState where
+  (==) = (==) `on` (wsMapped &&& wsWaitingUnmap &&& wsFrame)
 
 
 -- | XState, the (mutable) window manager state.
@@ -101,6 +114,7 @@ data XConf = XConf
 data XConfig l = XConfig
     { normalBorderColor  :: !String              -- ^ Non focused windows border color. Default: \"#dddddd\"
     , focusedBorderColor :: !String              -- ^ Focused windows border color. Default: \"#ff0000\"
+    , defaultBorderWidth :: !BorderWidth
     , terminal           :: !String              -- ^ The preferred terminal application. Default: \"xterm\"
     , layoutHook         :: !(l Window)          -- ^ The available layouts
     , manageHook         :: !ManageHook          -- ^ The action to run when a new window is opened
@@ -218,20 +232,25 @@ isRoot w = (w==) <$> asks theRoot
 getAtom :: String -> X Atom
 getAtom str = withDisplay $ \dpy -> io $ internAtom dpy str False
 
-emptyWindowState :: WindowState
-emptyWindowState = WindowState False 0 0
+emptyWindowState :: X WindowState
+emptyWindowState = asks (defaultBorderWidth . config) >>= return . WindowState False 0 0
 
 getWindowState :: Window -> X WindowState
-getWindowState w = gets $ M.findWithDefault emptyWindowState w . windowState
+getWindowState w = do
+  ws <- gets $ (M.lookup w) . windowState
+  case ws of
+    Just s  -> return s
+    Nothing -> emptyWindowState
 
 getsWindowState :: (WindowState -> a) -> Window -> X a
 getsWindowState f w = f <$> getWindowState w
 
 setWindowState :: Window -> WindowState -> X ()
-setWindowState w ws = modify $ \s -> s { windowState = f (windowState s) }
-  where
-    f | ws == emptyWindowState = M.delete w
-      | otherwise              = M.insert w ws
+setWindowState w ws = do
+  emptyState <- emptyWindowState
+  let  f | ws == emptyState = M.delete w
+         | otherwise        = M.insert w ws
+  modify $ \s -> s { windowState = f (windowState s) }
 
 modifyWindowState :: (WindowState -> WindowState) -> Window -> X ()
 modifyWindowState f w = getWindowState w >>= return . f >>= setWindowState w
diff --git a/XMonad/Main.hsc b/XMonad/Main.hsc
index b5a2bf2..d09e024 100644
--- a/XMonad/Main.hsc
+++ b/XMonad/Main.hsc
@@ -215,7 +215,7 @@ handle (DestroyWindowEvent {ev_window = w}) = do
 handle (UnmapEvent {ev_window = w, ev_send_event = synthetic}) = whenX (isClient w) $ do
     e <- getsWindowState wsWaitingUnmap w
     if (synthetic || e == 0)
-        then unmanage w
+        then unmanage w >> hideParent w
         else modifyWindowState (\ws -> ws { wsWaitingUnmap = (wsWaitingUnmap ws) - 1 }) w
 
 -- set keyboard mapping
@@ -326,6 +326,11 @@ reparent w = withDisplay $ \dpy -> do
       reparentWindow dpy w frame 0 0
     modifyWindowState (\ws -> ws { wsFrame = frame }) w
 
+hideParent :: Window -> X ()
+hideParent w = withDisplay $ \dpy -> do
+  frame <- getsWindowState wsFrame w
+  when (frame /= 0) $ io $ unmapWindow dpy frame
+
 unparent :: Window -> X ()
 unparent w = withDisplay $ \dpy -> do
   trace $ "unparent: " ++ show w
diff --git a/XMonad/Operations.hs b/XMonad/Operations.hs
index a88ce06..ad6f8b1 100644
--- a/XMonad/Operations.hs
+++ b/XMonad/Operations.hs
@@ -29,6 +29,7 @@ import Data.Ratio
 import qualified Data.Map as M
 
 import Control.Applicative
+import Control.Arrow ((&&&))
 import Control.Monad.Reader
 import Control.Monad.State
 import qualified Control.Exception.Extensible as C
@@ -91,10 +92,11 @@ windows f = do
     let oldvisible = concatMap (W.integrate' . W.stack . W.screenWorkspace) $ W.screens old
         newwindows = W.allWindows ws \\ W.allWindows old
         ws = f old
-    XConf { display = d } <- ask
+    XConf { display = d , normalBorder = nbc, focusedBorder = fbc } <- ask
 
     mapM_ setInitialProperties newwindows
 
+    whenJust (W.peek old) $ \otherw -> setFrameBackground d otherw nbc
     modify (\s -> s { windowset = ws })
 
     -- notify non visibility
@@ -127,6 +129,8 @@ windows f = do
 
     mapM_ (uncurry tileWindow) rects
 
+    whenJust (W.peek ws) $ \w -> setFrameBackground d w fbc
+
     mapM_ reveal visible
     setTopFocus
 
@@ -142,6 +146,13 @@ windows f = do
     isMouseFocused <- asks mouseFocused
     unless isMouseFocused $ clearEvents enterWindowMask
     asks (logHook . config) >>= userCodeDef ()
+  where
+    setFrameBackground :: Display -> Window -> Pixel -> X ()
+    setFrameBackground d w p = do
+      frame <- getsWindowState wsFrame w
+      io $ 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
@@ -178,15 +189,20 @@ reveal w = withDisplay $ \d -> do
     setWMState w normalState
     io $ mapWindow d w
     whenX (isClient w) $ do
-      frame <- getsWindowState wsFrame w
+      (frame, bw) <- getsWindowState (wsFrame &&& wsBorderWidth) w
       io $ do
         mapWindow d frame
         (_, x, y, width, height, _, _) <- getGeometry d frame
-        moveResizeWindow d w 0 0 width height
+        let least1 n = max 1 n
+            x' = x + (fi $ bwLeft bw)
+            y' = y + (fi $ bwTop bw)
+            width' = least1 (width - bwLeft bw - bwRight bw)
+            height' = least1 (height - bwTop bw - bwBottom bw)
+        moveResizeWindow d w (fi $ bwLeft bw) (fi $ bwTop bw) width' height'
         -- send absolute ConfigureNotify
         allocaXEvent $ \event -> do
           setEventType event configureNotify
-          setConfigureEvent event w w (fi x) (fi y) (fi width) (fi height) 0 0 False
+          setConfigureEvent event w w (fi x') (fi y') (fi width') (fi height') 0 0 False
           sendEvent d w False structureNotifyMask event
       modifyWindowState (\ws -> ws { wsMapped = True }) w
   where
@@ -221,10 +237,9 @@ clearEvents mask = withDisplay $ \d -> io $ do
 -- rectangle, including its border.
 tileWindow :: Window -> Rectangle -> X ()
 tileWindow w r = withDisplay $ \d -> do
-    let bw = 0
     -- give all windows at least 1x1 pixels
-    let least x | x <= bw*2  = 1
-                | otherwise  = x - bw*2
+    let least x | x <= 0  = 1
+                | otherwise  = x
     frame <- getsWindowState wsFrame w
     io $ moveResizeWindow d frame (rect_x r) (rect_y r) (least $ rect_width r) (least $ rect_height r)