Add a GSCONFIG class to overload defaultGSConfig.

Ignore-this: 220a13bf1ee145b18f28c66e32c79266

This uses -XOverlappingInstances to provide a fallback instance which uses the
focusedBorderColor and normalBorderColor, but that part is optional.

User's configs should use -XNoMonomorphismRestriction if they want to avoid
writing a type signature for myGSConfig.

Also, type variables become ambiguous in expressions like:

> myGSConfig

darcs-hash:20091003193804-1499c-ae124fc732c4bc956ace090b57681f2463441990.gz

2 files changed, 31 insertions, 22 deletions

diff --git a/XMonad/Actions/GridSelect.hs b/XMonad/Actions/GridSelect.hs
index 4ca34bc..ff2d4ae 100644
--- a/XMonad/Actions/GridSelect.hs
+++ b/XMonad/Actions/GridSelect.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables, GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances, OverlappingInstances #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonad.Actions.GridSelect
@@ -20,10 +20,9 @@ module XMonad.Actions.GridSelect (
 
     -- * Configuration
     GSConfig(..),
+    GSCONFIG(defaultGSConfig),
     NavigateMap,
     TwoDPosition,
-    defaultGSConfig,
-    defaultGSSpawnConfig,
     buildDefaultGSConfig,
 
     -- * Variations on 'gridselect'
@@ -75,7 +74,7 @@ import Data.Word (Word8)
 -- the user select from it. E.g. to spawn an application from a given list, you
 -- can use the following:
 --
--- >   , ((modMask x, xK_s), spawnSelected defaultGSSpawnConfig ["xterm","gmplayer","gvim"])
+-- >   , ((modMask x, xK_s), spawnSelected defaultGSConfig ["xterm","gmplayer","gvim"])
 
 -- $screenshots
 --
@@ -98,6 +97,31 @@ data GSConfig a = GSConfig {
       gs_originFractY :: Double
 }
 
+class GSCONFIG a where
+    defaultGSConfig :: GSConfig a -- ^ A basic configuration for 'gridselect'.
+                                  -- To configure your own colorizer, use
+                                  -- 'buildDefaultGSConfig', otherwise the
+                                  -- default colorizer with the correct type
+                                  -- will be used.
+                                  --
+                                  -- That is 'fromClassName' if
+                                  -- you are selecting a 'Window', or
+                                  -- 'defaultColorizer' if you are selecting a
+                                  -- 'String'. The catch-all instance @GSCONFIG
+                                  -- a@ uses the 'focusedBorderColor' and
+                                  -- 'normalBorderColor' colors.
+
+instance GSCONFIG Window where
+    defaultGSConfig = buildDefaultGSConfig fromClassName
+
+instance GSCONFIG String where
+    defaultGSConfig = buildDefaultGSConfig defaultColorizer
+
+instance GSCONFIG a where
+    defaultGSConfig = buildDefaultGSConfig $ \_ isFg -> do
+        let getColor = if isFg then focusedBorderColor else normalBorderColor
+        asks $ flip (,) "black" . getColor . config
+
 type NavigateMap = M.Map (KeyMask,KeySym) (TwoDPosition -> TwoDPosition)
 
 type TwoDPosition = (Integer, Integer)
@@ -334,9 +358,8 @@ gridselect gsconfig elmap =
     font <- initXMF (gs_font gsconfig)
     let screenWidth = toInteger $ rect_width s;
         screenHeight = toInteger $ rect_height s;
-    selectedElement <- if (status == grabSuccess) then
-                          do
-                            let restriction ss cs = ((fromInteger ss)/(fromInteger $ cs gsconfig)-1)/2
+    selectedElement <- if (status == grabSuccess) then do
+                            let restriction ss cs = (fromInteger ss/fromInteger (cs gsconfig)-1)/2 :: Double
                                 restrictX = floor $ restriction screenWidth gs_cellwidth
                                 restrictY = floor $ restriction screenHeight gs_cellheight
                                 originPosX = floor $ ((gs_originFractX gsconfig) - (1/2)) * 2 * fromIntegral restrictX
@@ -386,10 +409,6 @@ decorateName' :: Window -> X String
 decorateName' w = do
   fmap show $ getName w
 
--- | The default 'GSConfig' to use when selecting windows.
-defaultGSConfig :: GSConfig Window
-defaultGSConfig = buildDefaultGSConfig fromClassName
-
 -- | Builds a default gs config from a colorizer function.
 buildDefaultGSConfig :: (a -> Bool -> X (String,String)) -> GSConfig a
 buildDefaultGSConfig col = GSConfig 50 130 10 col "xft:Sans-8" defaultGSNav (1/2) (1/2)
@@ -420,9 +439,6 @@ bringSelected = withSelectedWindow $ \w -> do
 goToSelected :: GSConfig Window -> X ()
 goToSelected = withSelectedWindow $ windows . W.focusWindow
 
-defaultGSSpawnConfig :: GSConfig String
-defaultGSSpawnConfig = buildDefaultGSConfig defaultColorizer
-
 -- | Select an application to spawn from a given list
 spawnSelected :: GSConfig String -> [String] -> X ()
 spawnSelected conf lst = gridselect conf (zip lst lst) >>= flip whenJust spawn
diff --git a/XMonad/Actions/WindowMenu.hs b/XMonad/Actions/WindowMenu.hs
index 0401424..9d30823 100644
--- a/XMonad/Actions/WindowMenu.hs
+++ b/XMonad/Actions/WindowMenu.hs
@@ -41,21 +41,14 @@ import XMonad.Util.XUtils (fi)
 --
 -- >    , ((modMask x,               xK_o ), windowMenu)
 
-simpleColorizer :: (Monad m) => t -> t -> t1 -> Bool -> m (t, [Char])
-simpleColorizer nBC _ _ False  = return (nBC, "black")
-simpleColorizer _ fBC _ True  = return (fBC, "black")
-
 windowMenu :: X ()
 windowMenu = withFocused $ \w -> do
-    nBC <- asks (normalBorderColor . config)
-    fBC <- asks (focusedBorderColor . config)
     tags <- asks (workspaces . config)
     Rectangle x y wh ht <- getSize w
     Rectangle sx sy swh sht <- gets $ screenRect . W.screenDetail . W.current . windowset
     let originFractX = (fi x - fi sx + fi wh / 2) / fi swh
         originFractY = (fi y - fi sy + fi ht / 2) / fi sht
-        colorizer = simpleColorizer nBC fBC
-        gsConfig = (buildDefaultGSConfig colorizer)
+        gsConfig = defaultGSConfig
                     { gs_originFractX = originFractX
                     , gs_originFractY = originFractY }
         actions = [ ("Cancel menu", return ())