path: root/XMonad/Layout/Decoration.hs

{-# OPTIONS_GHC -fglasgow-exts #-} -- for deriving Typeable
{-# 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
    , DefaultDecoration (..)
    , DecorationStyle (..)
    , DecorationMsg (..)
    , Theme (..), defaultTheme
    , shrinkText, CustomShrink ( CustomShrink )
    , Shrinker (..), DefaultShrinker
    , module XMonad.Layout.LayoutModifier
    , isInStack, isVisible, isInvisible, isWithin, fi
    ) where

import Control.Monad (when)
import Data.Maybe
import Data.List

import XMonad
import qualified XMonad.StackSet as W
import XMonad.Hooks.UrgencyHook
import XMonad.Layout.LayoutModifier
import XMonad.Layout.WindowArranger (WindowArrangerMsg (..), diff, listFromList)
import XMonad.Util.NamedWindows (getName)
import XMonad.Util.Invisible
import XMonad.Util.XUtils
import XMonad.Util.Font

-- $usage
-- For usage examples you can see "XMonad.Layout.SimpleDecoration",
-- "XMonad.Layout.Tabbed", "XMonad.Layout.DwmStyle",

decoration :: (DecorationStyle ds a, Shrinker s) => s -> Theme -> ds a
           -> l a -> ModifiedLayout (Decoration ds s) l a
decoration s t ds = ModifiedLayout (Decoration (I Nothing) s t ds)

data Theme =
    Theme { activeColor         :: String
          , inactiveColor       :: String
          , urgentColor         :: String
          , activeBorderColor   :: String
          , inactiveBorderColor :: String
          , urgentBorderColor   :: String
          , activeTextColor     :: String
          , inactiveTextColor   :: String
          , urgentTextColor     :: String
          , fontName            :: String
          , decoWidth           :: Dimension
          , decoHeight          :: Dimension
          } deriving (Show, Read)

defaultTheme :: Theme
defaultTheme =
    Theme { 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
          }

data DecorationMsg = SetTheme Theme deriving ( Typeable )
instance Message DecorationMsg

type DecoWin = (Maybe 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 Theme (ds a)
    deriving (Show, Read)

class (Read (ds a), Show (ds a), Eq 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)

    decorationEventHook :: ds a -> DecorationState -> Event -> X ()
    decorationEventHook ds s e = do decorationMouseFocusHook  ds s e
                                    decorationMouseDragHook   ds s e

    decorationMouseFocusHook :: ds a -> DecorationState -> Event -> X ()
    decorationMouseFocusHook _ s e = handleMouseFocusDrag False s e

    decorationMouseDragHook :: ds a -> DecorationState -> Event -> X ()
    decorationMouseDragHook _ s e = handleMouseFocusDrag True s e

    pureDecoration :: ds a -> Dimension -> Dimension -> Rectangle
                   -> W.Stack a -> [(a,Rectangle)] -> (a,Rectangle) -> Maybe Rectangle
    pureDecoration _ _ ht _ s _ (w,Rectangle x y wh _) = if isInStack s w
                                                         then Just $ Rectangle x y wh ht
                                                         else Nothing

    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 DefaultDecoration a = DefaultDecoration deriving ( Read, Show )
instance Eq a => DecorationStyle DefaultDecoration a

instance (DecorationStyle ds Window, Shrinker s) => LayoutModifier (Decoration ds s) Window where
    redoLayout (Decoration st sh t ds) sc stack wrs
        | decorate_first   = do whenIJust st releaseResources
                                return (wrs, Just $ Decoration (I Nothing) sh t ds)
        | I Nothing  <- st = initState t ds sc stack 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
                                deleteDecos (map snd toDel)
                                ndwrs  <- createDecos t ds sc stack wrs toAdd
                                ndecos <- resync (ndwrs ++ del_dwrs d dwrs) wrs
                                processState (s {decos = ndecos })
        | otherwise        = return (wrs, Nothing)

        where
          ws        = map fst wrs
          get_w     = fst . fst
          get_ws    = map get_w
          del_dwrs  = listFromList get_w notElem
          find_dw i = fst . snd . flip (!!) i
          todel   d = filter (flip elem d . get_w)
          toadd   a = filter (flip elem a . fst  )

          decorate_first = length wrs == 1 && (not . decorateFirst $ ds)

          resync _         [] = return []
          resync d ((w,r):xs) = case  w `elemIndex` get_ws d of
                                  Just i  -> do dr   <- decorate ds (decoWidth t) (decoHeight t) sc stack wrs (w,r)
                                                dwrs <- resync d xs
                                                return $ ((w,r),(find_dw i d, dr)) : dwrs
                                  Nothing -> resync d xs

          -- We drop any windows that are *precisely* stacked underneath
          -- another window: these must be intended to be tabbed!
          remove_stacked rs ((w,r):xs)
              | r `elem` rs   = remove_stacked rs xs
              | otherwise     = (w,r) : remove_stacked (r:rs) xs
          remove_stacked _ [] = []

          insert_dwr ((w,r),(Just dw,Just dr)) xs = (dw,dr):(w, shrink ds dr r):xs
          insert_dwr (x    ,(     _ ,     _ )) xs = x:xs

          dwrs_to_wrs    = remove_stacked [] . foldr insert_dwr []

          processState s = do let ndwrs = decos s
                              showDecos (map snd ndwrs)
                              updateDecos sh t (font s) ndwrs
                              return (dwrs_to_wrs ndwrs, Just (Decoration (I (Just (s {decos = ndwrs}))) sh t ds))

    handleMess (Decoration (I (Just s@(DS {decos = dwrs}))) sh t ds) m
        | Just e <- fromMessage m :: Maybe Event = do decorationEventHook ds s e
                                                      handleEvent sh t s e
                                                      return Nothing
        | Just Hide             <- fromMessage m = do hideDecos (map snd dwrs)
                                                      return Nothing
        | Just (SetTheme nt)    <- fromMessage m = do releaseResources s
                                                      return $ Just $ Decoration (I Nothing) sh nt ds
        | Just ReleaseResources <- fromMessage m = do releaseResources s
                                                      return $ Just $ Decoration (I Nothing) sh t  ds
    handleMess _ _ = return Nothing

    emptyLayoutMod (Decoration (I (Just s)) sh t ds) _ _ = do
        releaseResources s
        return ([], Just $ Decoration (I Nothing) sh t ds)
    emptyLayoutMod _ _ _  = return ([], Nothing)

    modifierDescription (Decoration _ _ _ ds) = describeDeco ds

handleEvent :: Shrinker s => s -> Theme -> DecorationState -> Event -> X ()
handleEvent sh t (DS dwrs fs) e
    | PropertyEvent {ev_window = w} <- e
    , w `elem`             (map (fst . fst) dwrs) = updateDecos sh t fs dwrs
    | ExposeEvent   {ev_window = w} <- e
    , w `elem` (catMaybes $ map (fst . snd) dwrs) = updateDecos sh t fs dwrs
handleEvent _ _ _ _ = return ()

handleMouseFocusDrag :: Bool -> DecorationState -> Event -> X ()
handleMouseFocusDrag b (DS dwrs _) ButtonEvent { ev_window     = ew
                                               , ev_event_type = et
                                               , ev_x_root     = ex
                                               , ev_y_root     = ey }
    | et == buttonPress
    , Just ((mainw,r),_) <- lookFor ew dwrs = do
                              focus mainw
                              when b $ mouseDrag (\x y -> do
                                                    let rect = Rectangle (x - (fi ex - rect_x r))
                                                                         (y - (fi ey - rect_y r))
                                                                         (rect_width  r)
                                                                         (rect_height r)
                                                    sendMessage (SetGeometry rect)) (return ())
handleMouseFocusDrag _ _ _ = return ()

lookFor :: Window -> [(OrigWin,DecoWin)] -> Maybe (OrigWin,(Window,Maybe Rectangle))
lookFor w ((wr,(Just dw,dr)):dwrs) | w == dw = Just (wr,(dw,dr))
                                   | otherwise = lookFor w dwrs
lookFor w ((_, (Nothing, _)):dwrs) = lookFor w dwrs
lookFor _ [] = Nothing

initState :: DecorationStyle ds Window => Theme -> ds Window -> Rectangle
          -> W.Stack Window -> [(Window,Rectangle)] -> X DecorationState
initState t ds sc s wrs = do
  fs   <- initXMF (fontName t)
  dwrs <- createDecos t ds sc s wrs wrs
  return $ DS dwrs fs

releaseResources :: DecorationState -> X ()
releaseResources s = do
  deleteDecos (map snd $ decos s)
  releaseXMF  (font s)

createDecos :: DecorationStyle ds Window => Theme -> ds Window -> Rectangle -> W.Stack Window
            -> [(Window,Rectangle)] -> [(Window,Rectangle)] -> X [(OrigWin,DecoWin)]
createDecos t ds sc s wrs ((w,r):xs) = do
  deco <- decorate ds (decoWidth t) (decoHeight t) sc s wrs (w,r)
  case deco of
    Just dr -> do let mask = Just (exposureMask .|. buttonPressMask)
                  dw   <- createNewWindow dr mask (inactiveColor t) True
                  dwrs <- createDecos t ds sc s wrs xs
                  return $ ((w,r), (Just dw, Just dr)) : dwrs
    Nothing -> do dwrs <- createDecos t ds sc s wrs xs
                  return $ ((w,r), (Nothing, Nothing)) : dwrs
createDecos _ _ _ _ _ [] = return []

showDecos :: [DecoWin] -> X ()
showDecos (m:mwrs)
    | (Just w,_) <- m = showWindow w >> showDecos mwrs
    | otherwise       = showDecos mwrs
showDecos       []    = return ()

hideDecos :: [DecoWin] -> X ()
hideDecos (m:mwrs)
    | (Just w,_) <- m = hideWindow w >> hideDecos mwrs
    | otherwise       = hideDecos mwrs
hideDecos       []    = return ()

deleteDecos :: [DecoWin] -> X ()
deleteDecos (m:mwrs)
    | (Just w,_) <- m = deleteWindow w >> deleteDecos mwrs
    | otherwise       = deleteDecos mwrs
deleteDecos       []  = return ()

updateDecos :: Shrinker s => s -> Theme -> XMonadFont -> [(OrigWin,DecoWin)] -> X ()
updateDecos s t f = mapM_ $ updateDeco s t f

updateDeco :: Shrinker s => s -> Theme -> XMonadFont -> (OrigWin,DecoWin) -> X ()
updateDeco sh t fs ((w,_),(Just 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 t, inactiveBorderColor t, inactiveTextColor t)
                                  (activeColor   t, activeBorderColor   t, activeTextColor   t)
                                  (urgentColor   t, urgentBorderColor   t, urgentTextColor   t)
  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 _ _ _ (_,(Just w,Nothing)) = hideWindow w
updateDeco _ _ _ _ = return ()

isInStack :: Eq a => W.Stack a -> a -> Bool
isInStack s = flip elem (W.integrate s)

isVisible :: Rectangle -> [Rectangle] -> Bool
isVisible r = and . foldr f []
    where f x xs = if r `isWithin` x then False : xs else True : xs

isInvisible :: Rectangle -> [Rectangle] -> Bool
isInvisible r = not . isVisible r

isWithin :: Rectangle -> Rectangle -> Bool
isWithin (Rectangle x y w h) (Rectangle rx ry rw rh)
    | x >= rx, x <= rx + fi rw
    , y >= ry, y <= ry + fi rh
    , x + fi w <= rx + fi rw
    , y + fi h <= ry + fi rh = True
    | otherwise              = False

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