Add Decoration, a layout modifier and a class for easily writing decorated layouts

darcs-hash:20080125151726-32816-bc0b6fc3e33a601e2973c08efa71da35f7f0f7ef.gz

1 files changed, 252 insertions, 0 deletions

diff --git a/XMonad/Layout/Decoration.hs b/XMonad/Layout/Decoration.hs
new file mode 100644
index 0000000..02954e4
--- /dev/null
+++ b/XMonad/Layout/Decoration.hs
@@ -0,0 +1,252 @@
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonad.Layout.Decoration
+-- Copyright   :  (c) 2007 Andrea Rossato
+-- License     :  BSD-style (see xmonad/LICENSE)
+--
+-- Maintainer  :  andrea.rossato@unibz.it
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- A layout modifier and a class for easily creating decorated
+-- layouts.
+-----------------------------------------------------------------------------
+
+module XMonad.Layout.Decoration
+    ( -- * Usage:
+      -- $usage
+      decoration
+    , Decoration
+    , DecorationStyle (..)
+    , shrinkText, CustomShrink(CustomShrink)
+    , mkDefaultDeConfig
+    , DeConfig (..), defaultDeConfig
+    , Shrinker(..)
+    , module XMonad.Layout.LayoutModifier
+    , fi
+    ) where
+
+import Data.Maybe
+import Data.List
+
+import XMonad
+import qualified XMonad.StackSet as W
+
+import XMonad.Layout.LayoutModifier
+import XMonad.Layout.WindowArranger
+
+import XMonad.Util.NamedWindows
+import XMonad.Util.Invisible
+import XMonad.Util.XUtils
+import XMonad.Util.Font
+
+import XMonad.Hooks.UrgencyHook
+
+-- $usage
+-- For usage examples you can see "XMonad.Layout.SimpleDecoration",
+-- "XMonad.Layout.Tabbed", "XMonad.Layout.DwmStyle",
+
+decoration :: (DecorationStyle ds a, Shrinker s) => s -> DeConfig ds a
+           -> l a -> ModifiedLayout (Decoration ds s) l a
+decoration s c = ModifiedLayout (Decoration (I Nothing) s c)
+
+data DeConfig ds a =
+    DeConfig { activeColor         :: String
+             , inactiveColor       :: String
+             , urgentColor         :: String
+             , activeBorderColor   :: String
+             , inactiveBorderColor :: String
+             , urgentBorderColor   :: String
+             , activeTextColor     :: String
+             , inactiveTextColor   :: String
+             , urgentTextColor     :: String
+             , fontName            :: String
+             , decoWidth           :: Dimension
+             , decoHeight          :: Dimension
+             , style               :: ds a
+             } deriving (Show, Read)
+
+mkDefaultDeConfig :: DecorationStyle ds a => ds a -> DeConfig ds a
+mkDefaultDeConfig ds =
+    DeConfig { activeColor         = "#999999"
+             , inactiveColor       = "#666666"
+             , urgentColor         = "#FFFF00"
+             , activeBorderColor   = "#FFFFFF"
+             , inactiveBorderColor = "#BBBBBB"
+             , urgentBorderColor   = "##00FF00"
+             , activeTextColor     = "#FFFFFF"
+             , inactiveTextColor   = "#BFBFBF"
+             , urgentTextColor     = "#FF0000"
+             , fontName            = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
+             , decoWidth           = 200
+             , decoHeight          = 20
+             , style               = ds
+             }
+
+type DecoWin = (Window,Maybe Rectangle)
+type OrigWin = (Window,Rectangle)
+data DecorationState =
+    DS { decos  :: [(OrigWin,DecoWin)]
+       , font   :: XMonadFont
+       }
+
+data Decoration ds s a =
+    Decoration (Invisible Maybe DecorationState) s (DeConfig ds a)
+    deriving (Show, Read)
+
+class (Read (ds a), Show (ds a)) => DecorationStyle ds a where
+    describeDeco :: ds a -> String
+    describeDeco ds = show ds
+
+    decorateFirst :: ds a -> Bool
+    decorateFirst _ = True
+
+    shrink :: ds a -> Rectangle -> Rectangle -> Rectangle
+    shrink _ (Rectangle _ _ _ dh) (Rectangle x y w h) = Rectangle x (y + fi dh) w (h - dh)
+
+    pureDecoration :: ds a -> Dimension -> Dimension -> Rectangle
+                   -> W.Stack a -> [(a,Rectangle)] -> (a,Rectangle) -> Maybe Rectangle
+    pureDecoration _ _ h _ _ _ (_,Rectangle x y w _) = Just $ Rectangle x y w h
+
+    decorate :: ds a -> Dimension -> Dimension -> Rectangle
+             -> W.Stack a -> [(a,Rectangle)] -> (a,Rectangle) -> X (Maybe Rectangle)
+    decorate ds w h r s ars ar = return $ pureDecoration ds w h r s ars ar
+
+data DefaultStyle a = DefaultStyle deriving (Read, Show)
+instance DecorationStyle DefaultStyle a
+
+defaultDeConfig :: DeConfig DefaultStyle a
+defaultDeConfig = mkDefaultDeConfig DefaultStyle
+
+instance (DecorationStyle ds Window, Shrinker s) => LayoutModifier (Decoration ds s) Window where
+    redoLayout (Decoration st sh c) sc stack wrs
+        | decorate_first   = do whenIJust st $ \s -> deleteWindows (getDWs $ decos s)
+                                return (wrs, Just $ Decoration (I Nothing) sh c)
+        | I Nothing  <- st = initState c wrs >>= processState
+        | I (Just s) <- st = do let dwrs  = decos s
+                                    (d,a) = curry diff (get_ws dwrs) ws
+                                    toDel = todel d dwrs
+                                    toAdd = toadd a wrs
+                                deleteWindows (getDWs toDel)
+                                ndwrs <- createDecos c toAdd
+                                processState (s {decos = ndwrs ++ del_dwrs d dwrs })
+        | otherwise        = return (wrs, Nothing)
+
+        where
+          ws        = map fst wrs
+          del_dwrs  = listFromList get_w notElem
+          get_ws    = map get_w
+          get_w     = fst . fst
+          find_dw i = fst . snd . flip (!!) i
+          todel   d = filter (flip elem d . get_w)
+          toadd   a = filter (flip elem a . fst  )
+
+          insert_dwr ((w,r),(dw,Just dr)) xs = (dw,dr):(w, shrink (style c) dr r):xs
+          insert_dwr (x    ,(_ ,Nothing)) xs = x:xs
+
+          resync _         [] = return []
+          resync d ((w,r):xs) = case  w `elemIndex` get_ws d of
+                                  Just i  -> do dr   <- decorate (style c) (decoWidth c) (decoHeight c) sc stack wrs (w,r)
+                                                dwrs <- resync d xs
+                                                return $ ((w,r),(find_dw i d, dr)) : dwrs
+                                  Nothing -> resync d xs
+
+          decorate_first = length wrs == 1 && (not . decorateFirst . style $ c)
+          processState s = do ndwrs <- resync (decos s) wrs
+                              showWindows (getDWs ndwrs)
+                              updateDecos sh c (font s) ndwrs
+                              return (foldr insert_dwr [] ndwrs, Just (Decoration (I (Just (s {decos = ndwrs}))) sh c))
+
+
+    handleMess (Decoration (I (Just s@(DS {decos = dwrs}))) sh c) m
+        | Just e <- fromMessage m :: Maybe Event = handleEvent sh c s e >> return Nothing
+        | Just Hide             <- fromMessage m = hideWindows      dws >> return Nothing
+        | Just ReleaseResources <- fromMessage m = do deleteWindows dws
+                                                      releaseXMF (font s)
+                                                      return $ Just $ Decoration (I Nothing) sh c
+        where dws = getDWs dwrs
+
+    handleMess _ _ = return Nothing
+
+    emptyLayoutMod (Decoration (I (Just (DS dwrs _))) _ _) _ _ = deleteWindows (getDWs dwrs) >> return ([], Nothing)
+    emptyLayoutMod _ _ _  = return ([], Nothing)
+
+    modifierDescription (Decoration _ _ c) = describeDeco $ style c
+
+handleEvent :: (DecorationStyle ds a, Shrinker s) => s -> DeConfig ds a -> DecorationState-> Event -> X ()
+handleEvent sh c (DS dwrs fs) e
+    | PropertyEvent {ev_window = w} <- e, w `elem` (map (fst . fst) dwrs) = updateDecos sh c fs dwrs
+    | ExposeEvent   {ev_window = w} <- e, w `elem` (map (fst . snd) dwrs) = updateDecos sh c fs dwrs
+handleEvent _ _ _ _ = return ()
+
+
+getDWs :: [(OrigWin,DecoWin)] -> [Window]
+getDWs = map (fst . snd)
+
+initState ::  DecorationStyle ds a => DeConfig ds a -> [(Window,Rectangle)] -> X DecorationState
+initState conf wrs = do
+  fs   <- initXMF (fontName conf)
+  dwrs <- createDecos conf wrs
+  return $ DS dwrs fs
+
+createDecos :: DecorationStyle ds a => DeConfig ds a -> [(Window,Rectangle)] -> X [(OrigWin,DecoWin)]
+createDecos _ [] = return []
+createDecos c (wr:wrs) = do
+  let rect = Rectangle 0 0 1 1
+      mask = Just (exposureMask .|. buttonPressMask)
+  dw  <- createNewWindow rect mask (inactiveColor c) True
+  dwrs <- createDecos c wrs
+  return ((wr,(dw,Nothing)):dwrs)
+
+updateDecos :: (DecorationStyle ds a, Shrinker s) => s -> DeConfig ds a -> XMonadFont -> [(OrigWin, DecoWin)] -> X ()
+updateDecos s c f = mapM_ $ updateDeco s c f
+
+updateDeco :: (DecorationStyle ds a, Shrinker s) => s -> DeConfig ds a -> XMonadFont -> (OrigWin, DecoWin) -> X ()
+updateDeco sh c fs ((w,_),(dw,Just (Rectangle _ _ wh ht))) = do
+  nw  <- getName w
+  ur  <- readUrgents
+  dpy <- asks display
+  let 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 w
+                           (inactiveColor c, inactiveBorderColor c, inactiveTextColor c)
+                           (activeColor   c, activeBorderColor   c, activeTextColor   c)
+                           (urgentColor   c, urgentBorderColor   c, urgentTextColor   c)
+  let s  = shrinkIt sh
+  name <- shrinkWhile s (\n -> do
+                                size <- io $ textWidthXMF dpy fs n
+                                return $ size > fromIntegral wh - fromIntegral (ht `div` 2)) (show nw)
+  paintAndWrite dw fs wh ht 1 bc' borderc' tc' bc' AlignCenter name
+updateDeco _ _ _ (_,(w,Nothing)) = hideWindow w
+
+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