From de4a3bd0edd52eb3d1418721eb4318aa6e64a64a Mon Sep 17 00:00:00 2001
From: Peter Jones <pjones@devalot.com>
Date: Tue, 7 Feb 2017 14:49:01 -0700
Subject: [PATCH] Use `setWindowBorderWithFallback' to support windows with
 RGBA color maps

This brings xmonad-contrib inline with xmonad in this regard.  Should
also be fix for #138
---
 XMonad/Hooks/UrgencyHook.hs       | 17 ++++++++---------
 XMonad/Layout/WindowNavigation.hs |  4 +++-
 XMonad/Util/Font.hs               | 16 ++++++++++++++++
 XMonad/Util/XUtils.hs             |  2 +-
 4 files changed, 28 insertions(+), 11 deletions(-)

diff --git a/XMonad/Hooks/UrgencyHook.hs b/XMonad/Hooks/UrgencyHook.hs
index afc5b169..f9360c51 100644
--- a/XMonad/Hooks/UrgencyHook.hs
+++ b/XMonad/Hooks/UrgencyHook.hs
@@ -339,7 +339,7 @@ getNetWMState :: Window -> X [CLong]
 getNetWMState w = do
     a_wmstate <- getAtom "_NET_WM_STATE"
     fromMaybe [] `fmap` getProp32 a_wmstate w
-   
+
 
 -- The Non-ICCCM Manifesto:
 -- Note: Some non-standard choices have been made in this implementation to
@@ -497,14 +497,14 @@ data BorderUrgencyHook = BorderUrgencyHook { urgencyBorderColor :: !String }
 
 instance UrgencyHook BorderUrgencyHook where
   urgencyHook BorderUrgencyHook { urgencyBorderColor = cs } w =
-    withDisplay $ \dpy -> io $ do
-      c' <- initColor dpy cs
+    withDisplay $ \dpy -> do
+      c' <- io (initColor dpy cs)
       case c' of
-        Just c -> setWindowBorder dpy w c
-        _      -> hPutStrLn stderr $ concat ["Warning: bad urgentBorderColor "
-                                            ,show cs
-                                            ," in BorderUrgencyHook"
-                                            ]
+        Just c -> setWindowBorderWithFallback dpy w cs c
+        _      -> io $ hPutStrLn stderr $ concat ["Warning: bad urgentBorderColor "
+                                                 ,show cs
+                                                 ," in BorderUrgencyHook"
+                                                 ]
 
 -- | Flashes when a window requests your attention and you can't see it.
 -- Defaults to a duration of five seconds, and no extra args to dzen.
@@ -543,4 +543,3 @@ filterUrgencyHook skips w = do
         Just tag -> when (tag `elem` skips)
                         $ adjustUrgents (delete w)
         _ -> return ()
-
diff --git a/XMonad/Layout/WindowNavigation.hs b/XMonad/Layout/WindowNavigation.hs
index 84e3aed6..94b153cd 100644
--- a/XMonad/Layout/WindowNavigation.hs
+++ b/XMonad/Layout/WindowNavigation.hs
@@ -195,7 +195,9 @@ navigable :: Direction2D -> Point -> [(Window, Rectangle)] -> [(Window, Rectangl
 navigable d pt = sortby d . filter (inr d pt . snd)
 
 sc :: Pixel -> Window -> X ()
-sc c win = withDisplay $ \dpy -> io $ setWindowBorder dpy win c
+sc c win = withDisplay $ \dpy -> do
+    colorName <- io (pixelToString dpy c)
+    setWindowBorderWithFallback dpy win colorName c
 
 center :: Rectangle -> Point
 center (Rectangle x y w h) = P (fromIntegral x + fromIntegral w/2)  (fromIntegral y + fromIntegral h/2)
diff --git a/XMonad/Util/Font.hs b/XMonad/Util/Font.hs
index 031a7060..0df98ffa 100644
--- a/XMonad/Util/Font.hs
+++ b/XMonad/Util/Font.hs
@@ -29,6 +29,7 @@ module XMonad.Util.Font
     , textExtentsXMF
     , printStringXMF
     , stringToPixel
+    , pixelToString
     , fi
     ) where
 
@@ -37,6 +38,8 @@ import Foreign
 import Control.Applicative
 import Control.Exception as E
 import Data.Maybe
+import Data.Bits (shiftR)
+import Text.Printf (printf)
 
 #ifdef XFT
 import Data.List
@@ -61,6 +64,19 @@ stringToPixel d s = fromMaybe fallBack <$> io getIt
     where getIt    = initColor d s
           fallBack = blackPixel d (defaultScreen d)
 
+-- | Convert a @Pixel@ into a @String@.
+pixelToString :: (MonadIO m) => Display -> Pixel -> m String
+pixelToString d p = do
+    let cm = defaultColormap d (defaultScreen d)
+    (Color _ r g b _) <- io (queryColor d cm $ Color p 0 0 0 0)
+    return ("#" ++ hex r ++ hex g ++ hex b)
+  where
+    -- NOTE: The @Color@ type has 16-bit values for red, green, and
+    -- blue, even though the actual type in X is only 8 bits wide.  It
+    -- seems that the upper and lower 8-bit sections of the @Word16@
+    -- values are the same.  So, we just discard the lower 8 bits.
+    hex = printf "%02x" . (`shiftR` 8)
+
 econst :: a -> IOException -> a
 econst = const
 
diff --git a/XMonad/Util/XUtils.hs b/XMonad/Util/XUtils.hs
index b7e0fec2..b12a6112 100644
--- a/XMonad/Util/XUtils.hs
+++ b/XMonad/Util/XUtils.hs
@@ -28,6 +28,7 @@ module XMonad.Util.XUtils
     , paintAndWrite
     , paintTextAndIcons
     , stringToPixel
+    , pixelToString
     , fi
     ) where
 
@@ -208,4 +209,3 @@ mkWindow d s rw x y w h p o = do
            set_background_pixel  attributes p
            createWindow d rw x y w h 0 (defaultDepthOfScreen s)
                         inputOutput visual attrmask attributes
-