aboutsummaryrefslogtreecommitdiffstats
path: root/XMonad/Actions
diff options
context:
space:
mode:
authorClemens Fruhwirth <clemens@endorphin.org>2008-11-07 12:51:14 +0100
committerClemens Fruhwirth <clemens@endorphin.org>2008-11-07 12:51:14 +0100
commit237f39aad4c22026f581f7e80b121b3b54eafb83 (patch)
tree5cecc3319ec6ea93f6776800ae9416eedfd9fdd9 /XMonad/Actions
parent4d2d2104601e4deb942ae9d5dc1b90ec0ff9f591 (diff)
downloadXMonadContrib-237f39aad4c22026f581f7e80b121b3b54eafb83.tar.gz
XMonadContrib-237f39aad4c22026f581f7e80b121b3b54eafb83.tar.xz
XMonadContrib-237f39aad4c22026f581f7e80b121b3b54eafb83.zip
Initial version of GridSelect.hs with a lot room for improvement/cleanups
darcs-hash:20081107115114-ed0c4-000ce76dd7160a7b5157a1bef463b213f8062705.gz
Diffstat (limited to 'XMonad/Actions')
-rw-r--r--XMonad/Actions/GridSelect.hs246
1 files changed, 246 insertions, 0 deletions
diff --git a/XMonad/Actions/GridSelect.hs b/XMonad/Actions/GridSelect.hs
new file mode 100644
index 0000000..c73aaae
--- /dev/null
+++ b/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"