Tabbed now uses Decoration

darcs-hash:20080125152311-32816-a9956f4fe81156bb37370082fd18c04e47496844.gz

1 files changed, 80 insertions, 183 deletions

diff --git a/XMonad/Layout/Tabbed.hs b/XMonad/Layout/Tabbed.hs
index db4ec05..3581793 100644
--- a/XMonad/Layout/Tabbed.hs
+++ b/XMonad/Layout/Tabbed.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonad.Layout.Tabbed
@@ -11,29 +12,32 @@
 --
 -- A tabbed layout for the Xmonad Window Manager
 --
+-- This module has functions and types that conflict with those used
+-- in Decoration.hs. These functions and types are deprecated and will
+-- be removed.
+--
+-- PLEASE: do not use 'tabbed'. Use 'tabDeco' instead.
+--
 -----------------------------------------------------------------------------
 
-module XMonad.Layout.Tabbed (
-                             -- * Usage:
-                             -- $usage
-                             tabbed
-                            , shrinkText, CustomShrink(CustomShrink)
-                            , TConf (..), defaultTConf
-                            , Shrinker(..)
-                            ) where
+module XMonad.Layout.Tabbed
+    ( -- * Usage:
+      -- $usage
+      tabbed
+    , tabDeco
+    , TConf (..), defaultTConf
+    , TabbedDecoration (..), defaultTabbedConfig
+    , shrinkText, CustomShrink(CustomShrink)
+    , Shrinker(..)
+    ) where
 
 import Data.Maybe
 import Data.List
 
 import XMonad
-import qualified XMonad.StackSet as W
-
-import XMonad.Util.NamedWindows
-import XMonad.Util.Invisible
-import XMonad.Util.XUtils
-import XMonad.Util.Font
-
-import XMonad.Hooks.UrgencyHook
+import qualified XMonad.StackSet as S
+import XMonad.Layout.Decoration
+import XMonad.Layout.Simplest
 
 -- $usage
 -- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
@@ -42,7 +46,7 @@ import XMonad.Hooks.UrgencyHook
 --
 -- Then edit your @layoutHook@ by adding the Tabbed layout:
 --
--- > myLayouts = tabbed shrinkText defaultTConf ||| Full ||| etc..
+-- > myLayouts = tabDeco shrinkText defaultTabbedConfig ||| Full ||| etc..
 -- > main = xmonad defaultConfig { layoutHook = myLayouts }
 --
 -- For more detailed instructions on editing the layoutHook see:
@@ -51,16 +55,56 @@ import XMonad.Hooks.UrgencyHook
 --
 -- You can also edit the default configuration options.
 --
--- > myTabConfig = defaultTConf { inactiveBorderColor = "#FF0000"
--- >                            , activeTextColor = "#00FF00"}
+-- > myTabConfig = defaultTabbedConfig { inactiveBorderColor = "#FF0000"
+-- >                                   , activeTextColor = "#00FF00"}
 --
 -- and
 --
--- > mylayout = tabbed shrinkText myTabConfig ||| Full ||| etc..
-
-tabbed :: Shrinker s => s -> TConf -> Tabbed s a
-tabbed s t = Tabbed (I Nothing) s t
-
+-- > mylayout = tabDeco shrinkText myTabConfig ||| Full ||| etc..
+
+-- | Create a tabbed layout with a shrinker and a tabbed configuration.
+tabDeco :: (Eq a, Shrinker s) => s -> DeConfig TabbedDecoration a
+        -> ModifiedLayout (Decoration TabbedDecoration s) Simplest  a
+tabDeco s c = decoration s c Simplest
+
+-- | This function is deprecated and will be removed before 0.7!!
+tabbed :: (Eq a, Shrinker s) => s -> TConf
+       -> ModifiedLayout (Decoration TabbedDecoration s) Simplest a
+tabbed s c = decoration s (toNewConf c) Simplest
+
+defaultTabbedConfig :: Eq a => DeConfig TabbedDecoration a
+defaultTabbedConfig = mkDefaultDeConfig $ Tabbed
+
+data TabbedDecoration a = Tabbed deriving (Read, Show)
+
+instance Eq a => DecorationStyle TabbedDecoration a where
+    describeDeco  _ = "Tabbed"
+    decorateFirst _ = False
+    pureDecoration _ _ ht (Rectangle x y wh _) s wrs (w,_) = Just $ Rectangle nx y nwh (fi ht)
+        where nwh = wh `div` max 1 (fi $ length wrs)
+              nx  = case w `elemIndex` (S.integrate s) of
+                      Just i  -> x + (fi nwh * fi i)
+                      Nothing -> x
+
+-- Backward compatibility stuff
+-- DEPRECATED!!
+toNewConf :: Eq a => TConf -> DeConfig TabbedDecoration a
+toNewConf oc =
+    nc { XMonad.Layout.Decoration.activeColor         = XMonad.Layout.Tabbed.activeColor         oc
+       , XMonad.Layout.Decoration.inactiveColor       = XMonad.Layout.Tabbed.inactiveColor       oc
+       , XMonad.Layout.Decoration.urgentColor         = XMonad.Layout.Tabbed.urgentColor         oc
+       , XMonad.Layout.Decoration.activeBorderColor   = XMonad.Layout.Tabbed.activeBorderColor   oc
+       , XMonad.Layout.Decoration.inactiveBorderColor = XMonad.Layout.Tabbed.inactiveBorderColor oc
+       , XMonad.Layout.Decoration.urgentBorderColor   = XMonad.Layout.Tabbed.urgentBorderColor   oc
+       , XMonad.Layout.Decoration.activeTextColor     = XMonad.Layout.Tabbed.activeTextColor     oc
+       , XMonad.Layout.Decoration.inactiveTextColor   = XMonad.Layout.Tabbed.inactiveTextColor   oc
+       , XMonad.Layout.Decoration.urgentTextColor     = XMonad.Layout.Tabbed.urgentTextColor     oc
+       , XMonad.Layout.Decoration.fontName            = XMonad.Layout.Tabbed.fontName            oc
+       , XMonad.Layout.Decoration.decoHeight     = fi $ XMonad.Layout.Tabbed.tabSize             oc
+       }
+    where nc = mkDefaultDeConfig $ Tabbed
+
+-- | This datatype is deprecated and will be removed before 0.7!!
 data TConf =
     TConf { activeColor         :: String
           , inactiveColor       :: String
@@ -75,166 +119,19 @@ data TConf =
           , tabSize             :: Int
           } deriving (Show, Read)
 
+-- | This function is deprecated and will be removed before 0.7!!
 defaultTConf :: TConf
 defaultTConf =
-    TConf { activeColor         = "#999999"
-          , inactiveColor       = "#666666"
-          , urgentColor         = "#FFFF00"
-          , activeBorderColor   = "#FFFFFF"
-          , inactiveBorderColor = "#BBBBBB"
-          , urgentBorderColor   = "##00FF00"
-          , activeTextColor     = "#FFFFFF"
-          , inactiveTextColor   = "#BFBFBF"
-          , urgentTextColor     = "#FF0000"
-          , fontName            = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
-          , tabSize             = 20
+    TConf { XMonad.Layout.Tabbed.activeColor         = "#999999"
+          , XMonad.Layout.Tabbed.inactiveColor       = "#666666"
+          , XMonad.Layout.Tabbed.urgentColor         = "#FFFF00"
+          , XMonad.Layout.Tabbed.activeBorderColor   = "#FFFFFF"
+          , XMonad.Layout.Tabbed.inactiveBorderColor = "#BBBBBB"
+          , XMonad.Layout.Tabbed.urgentBorderColor   = "##00FF00"
+          , XMonad.Layout.Tabbed.activeTextColor     = "#FFFFFF"
+          , XMonad.Layout.Tabbed.inactiveTextColor   = "#BFBFBF"
+          , XMonad.Layout.Tabbed.urgentTextColor     = "#FF0000"
+          , XMonad.Layout.Tabbed.fontName            = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
+          , XMonad.Layout.Tabbed.tabSize             = 20
           }
 
-data TabState =
-    TabState { tabsWindows :: [(Window,Window)]
-             , scr         :: Rectangle
-             , font        :: XMonadFont
-             }
-
-data Tabbed s a =
-    Tabbed (Invisible Maybe TabState) s TConf
-    deriving (Show, Read)
-
-instance Shrinker s => LayoutClass (Tabbed s) Window where
-    doLayout (Tabbed ist ishr conf) = doLay ist ishr conf
-    handleMessage                   = handleMess
-    description _                   = "Tabbed"
-
-doLay :: Shrinker s => Invisible Maybe TabState -> s -> TConf
-      -> Rectangle -> W.Stack Window -> X ([(Window, Rectangle)], Maybe (Tabbed s 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 c 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 c 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 c sc ws
-                                   return (ts {scr = sc, tabsWindows = zip tws ws})
-  mapM_ showWindow $ map fst $ tabsWindows st
-  mapM_ (updateTab ishr c (font st) width) $ tabsWindows st
-  return ([(w,shrink c sc)], Just (Tabbed (I (Just st)) ishr c))
-
-handleMess :: Shrinker s => Tabbed s Window -> SomeMessage -> X (Maybe (Tabbed s 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
-                                                  releaseXMF (font st)
-                                                  return $ Just $ Tabbed (I Nothing) ishr conf
-handleMess _ _  = return Nothing
-
-handleEvent :: Shrinker s => s -> TConf -> TabState -> Event -> X ()
--- button press
-handleEvent ishr conf (TabState    {tabsWindows = tws,   scr          = screen, font          = 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)
-
-handleEvent ishr conf (TabState {tabsWindows = tws,   scr           = screen, font = fs})
-                      (AnyEvent {ev_window   = thisw, ev_event_type = t                })
--- expose
-    | thisw `elem` (map fst tws) && t == expose         = do
-  updateTab ishr conf fs width (thisw, fromJust $ lookup thisw tws)
-    where
-      width = rect_width screen`div` fromIntegral (length tws)
-
--- propertyNotify
-handleEvent ishr conf (TabState      {tabsWindows = tws, scr = screen, font = 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, font = 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  <- initXMF (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) True
-  io $ restackWindows d $ w : [ow]
-  ws <- createTabs c (Rectangle (x + fromIntegral wid) y (wh - wid) ht) ows
-  return (w:ws)
-
-updateTab :: Shrinker s => s -> TConf -> XMonadFont -> Dimension -> (Window,Window) -> X ()
-updateTab ishr c fs wh (tabw,ow) = do
-  nw <- getName ow
-  ur <- readUrgents
-  let ht                   = fromIntegral $ tabSize c :: Dimension
-      focusColor win ic ac uc = (maybe ic (\focusw -> case () of
-                                                       _ | focusw == win -> ac
-                                                         | win `elem` ur -> uc
-                                                         | otherwise     -> ic) . W.peek)
-                                `fmap` gets windowset
-  (bc',borderc',tc') <- focusColor ow
-                           (inactiveColor c, inactiveBorderColor c, inactiveTextColor c)
-                           (activeColor   c, activeBorderColor   c, activeTextColor   c)
-                           (urgentColor   c, urgentBorderColor   c, urgentTextColor   c)
-  dpy <- asks display
-  let s = shrinkIt ishr
-  name <- shrinkWhile s (\n -> do
-                                size <- io $ textWidthXMF dpy fs n
-                                return $ size > 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))
-
-shrinkWhile :: (String -> [String]) -> (String -> X Bool) -> String -> X 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
-
-data CustomShrink = CustomShrink
-instance Show CustomShrink where show _ = ""
-instance Read CustomShrink where readsPrec _ s = [(CustomShrink,s)]
-
-class (Read s, Show s) => Shrinker s where
-    shrinkIt :: s -> String -> [String]
-
-data DefaultShrinker = DefaultShrinker
-instance Show DefaultShrinker where show _ = ""
-instance Read DefaultShrinker where readsPrec _ s = [(DefaultShrinker,s)]
-instance Shrinker DefaultShrinker where
-    shrinkIt _ "" = [""]
-    shrinkIt s cs = cs : shrinkIt s (init cs)
-
-shrinkText :: DefaultShrinker
-shrinkText = DefaultShrinker