From 4866f2e367dfcf22a9591231ba40948826a1b438 Mon Sep 17 00:00:00 2001 From: Spencer Janssen Date: Thu, 1 Nov 2007 21:10:59 +0100 Subject: Hierarchify darcs-hash:20071101201059-a5988-fc1f1262bec1b69e13ba18ae7cefeafc8c4471d4.gz --- XMonad/Layout/Tabbed.hs | 214 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 214 insertions(+) create mode 100644 XMonad/Layout/Tabbed.hs (limited to 'XMonad/Layout/Tabbed.hs') diff --git a/XMonad/Layout/Tabbed.hs b/XMonad/Layout/Tabbed.hs new file mode 100644 index 0000000..92ef150 --- /dev/null +++ b/XMonad/Layout/Tabbed.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Layout.Tabbed +-- Copyright : (c) 2007 David Roundy, Andrea Rossato +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : droundy@darcs.net, andrea.rossato@unibz.it +-- Stability : unstable +-- Portability : unportable +-- +-- A tabbed layout for the Xmonad Window Manager +-- +----------------------------------------------------------------------------- + +module XMonad.Layout.Tabbed ( + -- * Usage: + -- $usage + tabbed + , shrinkText + , TConf (..), defaultTConf + ) where + +import Control.Monad.State ( gets ) +import Control.Monad.Reader +import Data.Maybe +import Data.Bits +import Data.List + +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +import XMonad +import XMonad.Operations +import qualified XMonad.StackSet as W + +import XMonad.Util.NamedWindows +import XMonad.Util.Invisible +import XMonad.Util.XUtils + +-- $usage +-- You can use this module with the following in your configuration file: +-- +-- > import XMonad.Layout.Tabbed +-- +-- > layouts :: [Layout Window] +-- > layouts = [ Layout tiled +-- > , Layout $ Mirror tiled +-- > , Layout Full +-- > +-- > -- Extension-provided layouts +-- > , Layout $ tabbed shrinkText defaultTConf +-- > ] +-- > +-- > , ... ] +-- +-- You can also edit the default configuration options. +-- +-- > myTabConfig = defaultTConf { inactiveBorderColor = "#FF0000" +-- > , activeTextColor = "#00FF00"} +-- +-- and +-- +-- > layouts = [ ... +-- > , Layout $ tabbed shrinkText myTabConfig ] + +-- %import XMonad.Layout.Tabbed +-- %layout , tabbed shrinkText defaultTConf + +tabbed :: Shrinker -> TConf -> Tabbed a +tabbed s t = Tabbed (I Nothing) (I (Just s)) t + +data TConf = + TConf { activeColor :: String + , inactiveColor :: String + , activeBorderColor :: String + , inactiveTextColor :: String + , inactiveBorderColor :: String + , activeTextColor :: String + , fontName :: String + , tabSize :: Int + } deriving (Show, Read) + +defaultTConf :: TConf +defaultTConf = + TConf { activeColor = "#999999" + , inactiveColor = "#666666" + , activeBorderColor = "#FFFFFF" + , inactiveBorderColor = "#BBBBBB" + , activeTextColor = "#FFFFFF" + , inactiveTextColor = "#BFBFBF" + , fontName = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + , tabSize = 20 + } + +data TabState = + TabState { tabsWindows :: [(Window,Window)] + , scr :: Rectangle + , fontS :: FontStruct -- FontSet + } + +data Tabbed a = + Tabbed (Invisible Maybe TabState) (Invisible Maybe Shrinker) TConf + deriving (Show, Read) + +instance LayoutClass Tabbed Window where + doLayout (Tabbed ist ishr conf) = doLay ist ishr conf + handleMessage = handleMess + description _ = "Tabbed" + +doLay :: Invisible Maybe TabState -> Invisible Maybe Shrinker -> TConf + -> Rectangle -> W.Stack Window -> X ([(Window, Rectangle)], Maybe (Tabbed Window)) +doLay ist ishr c sc (W.Stack w [] []) = do + whenIJust ist $ \st -> mapM_ deleteWindow (map fst $ tabsWindows st) + return ([(w,sc)], Just $ Tabbed (I Nothing) ishr c) +doLay ist ishr conf sc@(Rectangle _ _ wid _) s@(W.Stack w _ _) = do + let ws = W.integrate s + width = wid `div` fromIntegral (length ws) + -- initialize state + st <- case ist of + (I Nothing ) -> initState conf sc ws + (I (Just ts)) -> if map snd (tabsWindows ts) == ws && scr ts == sc + then return ts + else do mapM_ deleteWindow (map fst $ tabsWindows ts) + tws <- createTabs conf sc ws + return (ts {scr = sc, tabsWindows = zip tws ws}) + mapM_ showWindow $ map fst $ tabsWindows st + mapM_ (updateTab ishr conf (fontS st) width) $ tabsWindows st + return ([(w,shrink conf sc)], Just (Tabbed (I (Just st)) ishr conf)) + +handleMess :: Tabbed Window -> SomeMessage -> X (Maybe (Tabbed Window)) +handleMess (Tabbed (I (Just st@(TabState {tabsWindows = tws}))) ishr conf) m + | Just e <- fromMessage m :: Maybe Event = handleEvent ishr conf st e >> return Nothing + | Just Hide == fromMessage m = mapM_ hideWindow (map fst tws) >> return Nothing + | Just ReleaseResources == fromMessage m = do mapM_ deleteWindow $ map fst tws + releaseFont (fontS st) + return $ Just $ Tabbed (I Nothing) (I Nothing) conf +handleMess _ _ = return Nothing + +handleEvent :: Invisible Maybe Shrinker -> TConf -> TabState -> Event -> X () +-- button press +handleEvent ishr conf (TabState {tabsWindows = tws, scr = screen, fontS = fs }) + (ButtonEvent {ev_window = thisw, ev_subwindow = thisbw, ev_event_type = t }) + | t == buttonPress, tl <- map fst tws, thisw `elem` tl || thisbw `elem` tl = do + case lookup thisw tws of + Just x -> do focus x + updateTab ishr conf fs width (thisw, x) + Nothing -> return () + where width = rect_width screen `div` fromIntegral (length tws) +-- propertyNotify +handleEvent ishr conf (TabState {tabsWindows = tws, scr = screen, fontS = fs }) + (PropertyEvent {ev_window = thisw }) + | thisw `elem` (map snd tws) = do + let tabwin = (fst $ fromJust $ find ((== thisw) . snd) tws, thisw) + updateTab ishr conf fs width tabwin + where width = rect_width screen `div` fromIntegral (length tws) +-- expose +handleEvent ishr conf (TabState {tabsWindows = tws, scr = screen, fontS = fs }) + (ExposeEvent {ev_window = thisw }) + | thisw `elem` (map fst tws) = do + updateTab ishr conf fs width (thisw, fromJust $ lookup thisw tws) + where width = rect_width screen `div` fromIntegral (length tws) +handleEvent _ _ _ _ = return () + +initState :: TConf -> Rectangle -> [Window] -> X TabState +initState conf sc ws = do + fs <- initFont (fontName conf) + tws <- createTabs conf sc ws + return $ TabState (zip tws ws) sc fs + +createTabs :: TConf -> Rectangle -> [Window] -> X [Window] +createTabs _ _ [] = return [] +createTabs c (Rectangle x y wh ht) owl@(ow:ows) = do + let wid = wh `div` (fromIntegral $ length owl) + height = fromIntegral $ tabSize c + mask = Just (exposureMask .|. buttonPressMask) + d <- asks display + w <- createNewWindow (Rectangle x y wid height) mask (inactiveColor c) + io $ restackWindows d $ w : [ow] + ws <- createTabs c (Rectangle (x + fromIntegral wid) y (wh - wid) ht) ows + return (w:ws) + +updateTab :: Invisible Maybe Shrinker -> TConf -> FontStruct -> Dimension -> (Window,Window) -> X () +updateTab ishr c fs wh (tabw,ow) = do + nw <- getName ow + let ht = fromIntegral $ tabSize c :: Dimension + focusColor win ic ac = (maybe ic (\focusw -> if focusw == win + then ac else ic) . W.peek) + `fmap` gets windowset + (bc',borderc',tc') <- focusColor ow + (inactiveColor c, inactiveBorderColor c, inactiveTextColor c) + (activeColor c, activeBorderColor c, activeTextColor c) + let s = fromIMaybe shrinkText ishr + name = shrinkWhile s (\n -> textWidth fs n > + fromIntegral wh - fromIntegral (ht `div` 2)) (show nw) + paintAndWrite tabw fs wh ht 1 bc' borderc' tc' bc' AlignCenter name + +shrink :: TConf -> Rectangle -> Rectangle +shrink c (Rectangle x y w h) = + Rectangle x (y + fromIntegral (tabSize c)) w (h - fromIntegral (tabSize c)) + +type Shrinker = String -> [String] + +shrinkWhile :: Shrinker -> (String -> Bool) -> String -> String +shrinkWhile sh p x = sw $ sh x + where sw [n] = n + sw [] = "" + sw (n:ns) | p n = sw ns + | otherwise = n + +shrinkText :: Shrinker +shrinkText "" = [""] +shrinkText cs = cs : shrinkText (init cs) -- cgit v1.2.3