aboutsummaryrefslogtreecommitdiffstats
path: root/Tabbed.hs
blob: c91ef12a5716590ad1f4499745302475e69a49a4 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonadContrib.Tabbed
-- Copyright   :  (c) David Roundy
-- License     :  BSD-style (see xmonad/LICENSE)
-- 
-- Maintainer  :  email@address.com
-- Stability   :  unstable
-- Portability :  unportable
--
-- A tabbed layout for the Xmonad Window Manager 
--
-----------------------------------------------------------------------------

module XMonadContrib.Tabbed ( 
                             -- * Usage:
                             -- $usage
                              tabbed
                            , Shrinker, shrinkText
                            , TConf (..), defaultTConf
                            ) where

import Control.Monad.State ( gets )

import Graphics.X11.Xlib
import XMonad
import XMonadContrib.Decoration
import Operations ( focus, initColor )
import qualified StackSet as W

import XMonadContrib.NamedWindows
import XMonadContrib.SimpleStacking ( simpleStacking )
import XMonadContrib.LayoutHelpers ( idModify )

-- $usage
-- You can use this module with the following in your configuration file:
--
-- > import XMonadContrib.Tabbed
--
-- > defaultLayouts :: [Layout Window]
-- > defaultLayouts = [ tabbed shrinkText defaultTConf
-- >                  , ... ]
--
-- You can also edit the default configuration options.
--
-- > myconfig = defaultTConf { inactiveBolderColor = "#FF0000"
-- >                         , activeTextColor = "#00FF00"}
--
-- and
--
-- > defaultLayouts = [ tabbed shrinkText myconfig
-- >                  , ... ]

-- %import XMonadContrib.Tabbed
-- %layout , tabbed shrinkText defaultTConf

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
          }

tabbed :: Shrinker -> TConf -> Layout Window
tabbed s t = simpleStacking $ tabbed' s t

tabbed' :: Shrinker -> TConf -> Layout Window
tabbed' shrinkT config =  Layout { doLayout = dolay shrinkT config, modifyLayout = idModify }

dolay :: Shrinker -> TConf
      -> Rectangle -> W.Stack Window -> X ([(Window, Rectangle)], Maybe (Layout Window))
dolay _ _ sc (W.Stack w [] []) = return ([(w,sc)], Nothing)
dolay shr conf sc@(Rectangle x y wid _) s = withDisplay $ \dpy ->
    do ac   <- io $ initColor dpy $ activeColor conf
       ic <- io $ initColor dpy $ inactiveColor conf
       abc <- io $ initColor dpy $ activeBorderColor conf
       ibc <- io $ initColor dpy $ inactiveBorderColor conf
       atc <- io $ initColor dpy $ activeTextColor conf 
       itc <- io $ initColor dpy $ inactiveTextColor conf
       let ws = W.integrate s
           ts = gentabs conf x y wid (length ws)
           tws = zip ts ws
           focusColor w incol actcol = (maybe incol (\focusw -> if focusw == w 
                                                                then actcol else incol) . W.peek) 
                                       `fmap` gets windowset
           make_tabs [] l = return l
           make_tabs (tw':tws') l = do bc <- focusColor (snd tw') ibc abc
                                       l' <- maketab tw' bc l
                                       make_tabs tws' l'
           maketab (t,ow) bg = newDecoration ow t 1 bg ac
                                (fontName conf) (drawtab t ow) (focus ow)
           drawtab r@(Rectangle _ _ wt ht) ow d w' gc fn =
               do nw <- getName ow
                  (fc,tc) <- focusColor ow (ic,itc) (ac,atc)
                  io $ setForeground d gc fc
                  io $ fillRectangles d w' gc [Rectangle 0 0 wt ht]
                  io $ setForeground d gc tc
                  centerText d w' gc fn r (show nw)
           centerText d w' gc fontst (Rectangle _ _ wt ht) name =
               do let (_,asc,_,_) = textExtents fontst name
                      name' = shrinkWhile shr (\n -> textWidth fontst n >
                                                     fromIntegral wt - fromIntegral (ht `div` 2)) name
                      width = textWidth fontst name'
                  io $ drawString d w' gc
                         (fromIntegral (wt `div` 2) - fromIntegral (width `div` 2))
                         ((fromIntegral ht + fromIntegral asc) `div` 2) name'
       l' <- make_tabs tws $ tabbed shr conf
       return (map (\w -> (w,shrink conf sc)) ws, Just l')

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)

shrink :: TConf -> Rectangle -> Rectangle
shrink c (Rectangle x y w h) = Rectangle x (y + fromIntegral (tabSize c)) w (h - fromIntegral (tabSize c))

gentabs :: TConf -> Position -> Position -> Dimension -> Int -> [Rectangle]
gentabs _ _ _ _ 0 = []
gentabs c x y w num = Rectangle x y (wid - 2) (fromIntegral (tabSize c) - 2)
                      : gentabs c (x + fromIntegral wid) y (w - wid) (num - 1)
                          where wid = w `div` (fromIntegral num)