Initial version of GridSelect.hs with a lot room for improvement/cleanups

XMonad/Actions/GridSelect.hs

@@ -0,0 +1,246 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Actions.GridSelect
+-- Copyright   :  Clemens Fruhwirth <clemens@endorphin.org>
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  Clemens Fruhwirth <clemens@endorphin.org>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- GridSelect displays a 2D grid of windows to navigate with cursor
+-- keys and to select with return.
+--
+-----------------------------------------------------------------------------
+
+module XMonad.Actions.GridSelect where
+import Data.Maybe
+import Data.Bits
+import Control.Monad.State
+import Control.Arrow
+import Data.List as L
+import XMonad
+import XMonad.Util.Font
+import XMonad.Prompt (mkUnmanagedWindow)
+import XMonad.StackSet as W
+import XMonad.Layout.Decoration
+import XMonad.Util.NamedWindows
+import Text.Printf
+
+data GSConfig = GSConfig {
+      gs_cellheight :: Integer,
+      gs_cellwidth :: Integer,
+      gs_cellpadding :: Integer,
+      gs_colorizer :: Window -> Bool -> X (String, String),
+      gs_font :: String
+}
+
+type TwoDPosition = (Integer, Integer)
+
+data TwoDState = TwoDState { td_curpos :: TwoDPosition,
+			     td_windowmap :: [(TwoDPosition,(String,Window))],
+			     td_gsconfig :: GSConfig,
+			     td_font :: XMonadFont,
+			     td_paneX :: Integer,
+			     td_paneY :: Integer }
+
+
+type TwoD a = StateT TwoDState X a
+
+diamondLayer :: (Enum b', Num b') => b' -> [(b', b')]
+-- FIXME remove nub
+diamondLayer n = let ul = [ (x,n-x) | x <- [0..n] ]
+	in nub $ ul ++ (map (negate *** id) ul) ++
+	   (map (negate *** negate) ul) ++
+           (map (id *** negate) ul)
+
+diamond :: (Enum a, Num a) => [(a, a)]
+diamond = concatMap diamondLayer [0..]
+
+
+-- FIXME this function returns a list an infinite list with finite
+-- elements, so going beyond the last proper element causes a never
+-- ending computation.
+
+diamondRestrict :: (Enum t, Num t, Ord t) => t -> t -> [(t, t)]
+diamondRestrict x y = L.filter f diamond
+    where f (x',y') = (x' <= x) &&
+		      (x' >= -x) &&
+		      (y' <= y) &&
+		      (y' >= -y)
+
+tupadd :: (Num t1, Num t) => (t, t1) -> (t, t1) -> (t, t1)
+tupadd (a,b) (c,d) = (a+c,b+d)
+tupmul :: (Num t1, Num t) => (t, t1) -> (t, t1) -> (t, t1)
+tupmul (a,b) (c,d) = (a*c,b*d)
+
+-- shrinkWhile should be exported  from Decoration.hs
+shrinkWhile :: Monad m => (String -> [String]) -> (String -> m Bool) -> String -> m String
+shrinkWhile sh p x = sw $ sh x
+    where sw [n] = return n
+          sw [] = return ""
+          sw (n:ns) = do
+                        cond <- p n
+                        if cond
+                          then sw ns
+                          else return n
+
+drawWinBox :: Display -> Window -> XMonadFont -> (String, String) -> Integer -> Integer -> String -> Integer -> Integer -> Integer -> X ()
+drawWinBox dpy win font (fg,bg) ch cw text x y cp = do
+  gc <- liftIO $ createGC dpy win
+  bordergc <- liftIO $ createGC dpy win
+  liftIO $ do
+    Just fgcolor <- initColor dpy fg
+    Just bgcolor <- initColor dpy bg
+    Just bordercolor <- initColor dpy borderColor
+    setForeground dpy gc fgcolor
+    setBackground dpy gc bgcolor
+    setForeground dpy bordergc bordercolor
+    fillRectangle dpy win gc (fromInteger x) (fromInteger y) (fromInteger cw) (fromInteger ch)
+    drawRectangle dpy win bordergc (fromInteger x) (fromInteger y) (fromInteger cw) (fromInteger ch)
+  stext <- shrinkWhile (shrinkIt shrinkText)
+	   (\n -> do size <- liftIO $ textWidthXMF dpy font n
+		     return $ size > (fromInteger (cw-(2*cp))))
+	   text
+  printStringXMF dpy win font gc bg fg (fromInteger (x+cp)) (fromInteger (y+(div ch 2))) stext
+  liftIO $ freeGC dpy gc
+  liftIO $ freeGC dpy bordergc
+
+updateWindows :: Display -> Window -> TwoD ()
+updateWindows dpy win = do
+    (TwoDState curpos windowList gsconfig font paneX paneY) <- get
+    let cellwidth = gs_cellwidth gsconfig
+	cellheight = gs_cellheight gsconfig
+	paneX' = div (paneX-cellwidth) 2
+        paneY' = div (paneY-cellheight) 2
+	updateWindow (pos@(x,y),(text, clientwindow)) = lift $ do
+	    colors <- (gs_colorizer gsconfig) clientwindow (pos == curpos)
+	    drawWinBox dpy win font
+		       colors
+		       (gs_cellheight gsconfig)
+		       (gs_cellwidth gsconfig) text
+						 (paneX'+x*cellwidth)
+						 (paneY'+y*cellheight)
+						 (gs_cellpadding gsconfig)
+    mapM updateWindow windowList
+    return ()
+
+eventLoop :: Display -> Window -> TwoD (Maybe Window)
+eventLoop d win = do
+  (keysym,string,event) <- liftIO $ allocaXEvent $ \e -> do
+			     nextEvent d e
+			     ev <- getEvent e
+			     (ks,s) <- if ev_event_type ev == keyPress
+				       then lookupString $ asKeyEvent e
+				       else return (Nothing, "")
+			     return (ks,s,ev)
+  handle d win (fromMaybe xK_VoidSymbol keysym,string) event
+
+handle :: Display
+       -> Window
+       -> (KeySym, String)
+       -> Event
+       -> StateT TwoDState X (Maybe Window)
+handle d win (ks,_) (KeyEvent {ev_event_type = t})
+    | t == keyPress && ks == xK_Escape = return Nothing
+    | t == keyPress && ks == xK_Left = diffAndRefresh (-1,0)
+    | t == keyPress && ks == xK_Right = diffAndRefresh (1,0)
+    | t == keyPress && ks == xK_Down = diffAndRefresh (0,1)
+    | t == keyPress && ks == xK_Up = diffAndRefresh (0,-1)
+    | t == keyPress && ks == xK_Return = do
+       (TwoDState pos win' _ _ _ _) <- get
+       return $ fmap (snd . snd) $ find ((== pos) . fst) win'
+  where diffAndRefresh diff = do
+	  (TwoDState pos windowlist gsconfig font paneX paneY) <- get
+	  put $ TwoDState (pos `tupadd` diff) windowlist gsconfig font paneX paneY
+	  updateWindows d win
+	  eventLoop d win
+
+handle d win _ _ = do
+  updateWindows d win
+  eventLoop d win
+
+-- FIXME probably move that into Utils?
+-- Conversion scheme as in http://en.wikipedia.org/wiki/HSV_color_space
+hsv2rgb :: Fractional a => (Integer,a,a) -> (a,a,a)
+hsv2rgb (h,s,v) =
+    let hi = (div h 60) `mod` 6 :: Integer
+	f = (((fromInteger h)/60) - (fromInteger hi)) :: Fractional a => a
+	q = v * (1-f)
+	p = v * (1-s)
+	t = v * (1-(1-f)*s)
+    in case hi of
+	 0 -> (v,t,p)
+	 1 -> (q,v,p)
+	 2 -> (p,v,t)
+	 3 -> (p,q,v)
+	 4 -> (t,p,v)
+	 5 -> (v,p,q)
+	 _ -> error "The world is ending. x mod a >= a."
+
+default_colorizer :: Window -> Bool -> X (String, String)
+default_colorizer w active = do
+    classname <- runQuery className w
+    let seed x = toInteger (sum $ map ((*x).fromEnum) classname) :: Integer
+        (r,g,b) = hsv2rgb ((seed 83) `mod` 360,
+			   (fromInteger ((seed 191) `mod` 1000))/2500+0.4,
+			   (fromInteger ((seed 121) `mod` 1000))/2500+0.4)
+    if active
+      then return ("#faff69", "black")
+      else return ("#" ++ concat (map (twodigitHex.(round :: Double -> Integer).(*256)) [r, g, b] ), "white")
+  where
+    twodigitHex :: Integer -> String
+    twodigitHex a = printf "%02x" a
+
+gridselect :: GSConfig -> X (Maybe Window)
+gridselect gsconfig =
+ withDisplay $ \dpy -> do
+    rootw <- liftIO $ rootWindow dpy (defaultScreen dpy)
+    s <- gets $ screenRect . W.screenDetail . W.current . windowset
+    windowList <- windowMap
+    win <- liftIO $ mkUnmanagedWindow dpy (defaultScreenOfDisplay dpy) rootw
+                    (rect_x s) (rect_y s) (rect_width s) (rect_height s)
+    liftIO $ mapWindow dpy win
+    liftIO $ selectInput dpy win (exposureMask .|. keyPressMask)
+    status <- io $ grabKeyboard dpy win True grabModeAsync grabModeAsync currentTime
+    font <- initXMF (gs_font gsconfig)
+    let screenWidth = toInteger $ rect_width s;
+	screenHeight = toInteger $ rect_height s;
+    selectedWindow <- if (status == grabSuccess) then
+			  do
+			    let restrictX = floor $ ((fromInteger screenWidth)/(fromInteger $ gs_cellwidth gsconfig)-1)/2 ;
+				restrictY = floor $ ((fromInteger screenHeight)/(fromInteger $ gs_cellheight gsconfig)-1)/2 ;
+			    selectedWindow <- evalStateT (do updateWindows dpy win; eventLoop dpy win)
+						   (TwoDState (0,0)
+						              (zipWith (,) (diamondRestrict restrictX restrictY) windowList)
+							      gsconfig
+							      font
+							      screenWidth
+							      screenHeight)
+			    return selectedWindow
+		      else
+			  return Nothing
+    liftIO $ do
+      unmapWindow dpy win
+      destroyWindow dpy win
+      sync dpy False
+    releaseXMF font
+    return selectedWindow
+
+
+windowMap :: X [(String,Window)]
+windowMap = do
+    ws <- gets windowset
+    wins <- mapM keyValuePair (W.allWindows ws)
+    return wins
+ where keyValuePair w = flip (,) w `fmap` decorateName' w
+
+decorateName' :: Window -> X String
+decorateName' w = do
+  fmap show $ getName w
+
+defaultGSConfig :: GSConfig
+defaultGSConfig = GSConfig 50 130 10 default_colorizer "xft:Sans-8"
+
+borderColor :: [Char]
+borderColor = "white"