module XMonad.Layout.Decoration
(
decoration
, Theme (..), defaultTheme
, Decoration
, DecorationMsg (..)
, DecorationStyle (..)
, DecorationState (..)
, DefaultDecoration (..)
, isInStack, isVisible, isInvisible, isWithin, fi, lookFor
, module XMonad.Layout.LayoutModifier
, module XMonad.Layout.DecorationUtils
) where
import Data.Maybe
import Data.List
import XMonad
import qualified XMonad.StackSet as W
import XMonad.Hooks.UrgencyHook
import XMonad.Layout.DecorationUtils
import XMonad.Layout.LayoutModifier
import XMonad.Layout.WindowArranger (WindowArrangerMsg (..), diff, listFromList)
import XMonad.Layout.Minimize
import XMonad.Layout.Maximize
import XMonad.Util.NamedWindows (getName)
import XMonad.Util.Invisible
import XMonad.Util.XUtils
import XMonad.Util.Font
import XMonad.PositionStore
import XMonad.Hooks.ManageDocks
import XMonad.Actions.WindowMenu
import Control.Applicative((<$>))
import Foreign.C.Types(CInt)
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
}
minimizeButtonOffset :: Int
minimizeButtonOffset = 48
maximizeButtonOffset :: Int
maximizeButtonOffset = 25
closeButtonOffset :: Int
closeButtonOffset = 10
buttonSize :: Int
buttonSize = 10
data DecoClickAction = WindowMenu | MinimizeButton | MaximizeButton | CloseButton | Dragging
deriving (Show)
data DecorationMsg = SetTheme Theme deriving ( Typeable )
instance Message DecorationMsg
data DecorationState =
DS { decos :: [(OrigWin,DecoWin)]
, decoFont :: XMonadFont
}
type DecoWin = (Maybe Window, Maybe Rectangle)
type OrigWin = (Window,Rectangle)
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
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 = handleMouseFocusDrag ds s e
decorationWhileDraggingHook :: ds a -> CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X ()
decorationWhileDraggingHook _ ex ey (mainw, r) x y = handleDraggingInProgress ex ey (mainw, r) x y
decorationAfterDraggingHook :: ds a -> (Window, Rectangle) -> Window -> X ()
decorationAfterDraggingHook ds (mainw, r) decoWin = focus mainw
>> handleScreenCrossing mainw decoWin
>>= decorationAfterDraggingHookAddon ds (mainw, r)
decorationAfterDraggingHookAddon :: ds a -> (Window, Rectangle) -> Bool -> X ()
decorationAfterDraggingHookAddon _ _ _ = return ()
pureDecoration :: ds a -> Dimension -> Dimension -> Rectangle
-> W.Stack a -> [(a,Rectangle)] -> (a,Rectangle) -> Maybe Rectangle
pureDecoration _ _ ht _ s _ (w,Rectangle x y wh ht') = if isInStack s w && (ht < ht')
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 wrs wr = return $ pureDecoration ds w h r s wrs wr
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 (I (Just s)) sh t ds) _ Nothing _ = do
releaseResources s
return ([], Just $ Decoration (I Nothing) sh t ds)
redoLayout _ _ Nothing _ = return ([], Nothing)
redoLayout (Decoration st sh t ds) sc (Just stack) wrs
| 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)
let ndwrs = zip toAdd $ repeat (Nothing,Nothing)
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 )
check_dwr dwr = case dwr of
(Nothing, Just dr) -> do dw <- createDecoWindow t dr
return (Just dw, Just dr)
_ -> return dwr
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)
dwr <- check_dwr (find_dw i d, dr)
dwrs <- resync d xs
return $ ((w,r),dwr) : dwrs
Nothing -> resync d xs
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 (decoFont 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 = 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
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
, Just i <- w `elemIndex` (map (fst . fst) dwrs) = updateDeco sh t fs (dwrs !! i)
| ExposeEvent {ev_window = w} <- e
, Just i <- w `elemIndex` (catMaybes $ map (fst . snd) dwrs) = updateDeco sh t fs (dwrs !! i)
handleEvent _ _ _ _ = return ()
handleMouseFocusDrag :: (DecorationStyle ds a) => ds a -> DecorationState -> Event -> X ()
handleMouseFocusDrag ds (DS dwrs _) ButtonEvent { ev_window = ew
, ev_event_type = et
, ev_x_root = ex
, ev_y_root = ey }
| et == buttonPress
, Just ((mainw,r), (_, decoRectM)) <- lookFor ew dwrs = do
let Just (Rectangle dx _ dwh _) = decoRectM
distFromRight = fi dwh (ex fi dx)
distFromLeft = ex fi dx
action = if (fi distFromLeft <= 3 * buttonSize)
then WindowMenu
else if (fi distFromRight >= closeButtonOffset &&
fi distFromRight <= closeButtonOffset + buttonSize)
then CloseButton
else if (fi distFromRight >= maximizeButtonOffset &&
fi distFromRight <= maximizeButtonOffset + (2 * buttonSize))
then MaximizeButton
else if (fi distFromRight >= minimizeButtonOffset &&
fi distFromRight <= minimizeButtonOffset + buttonSize)
then MinimizeButton
else Dragging
case action of
WindowMenu -> focus mainw >> windowMenu
CloseButton -> focus mainw >> kill
MinimizeButton -> focus mainw >> sendMessage (MinimizeWin mainw)
MaximizeButton -> focus mainw >> sendMessage (maximizeRestore mainw)
Dragging -> mouseDrag (\x y -> focus mainw
>> decorationWhileDraggingHook ds ex ey (mainw, r) x y)
(decorationAfterDraggingHook ds (mainw, r) ew)
handleMouseFocusDrag _ _ _ = return ()
handleDraggingInProgress :: CInt -> CInt -> (Window, Rectangle) -> Position -> Position -> X ()
handleDraggingInProgress ex ey (_, r) 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
handleScreenCrossing :: Window -> Window -> X Bool
handleScreenCrossing w decoWin = withDisplay $ \d -> do
root <- asks theRoot
(_, _, _, px, py, _, _, _) <- io $ queryPointer d root
ws <- gets windowset
sc <- fromMaybe (W.current ws) <$> pointScreen (fi px) (fi py)
maybeWksp <- screenWorkspace $ W.screen sc
let targetWksp = maybeWksp >>= \wksp ->
W.findTag w ws >>= \currentWksp ->
if (currentWksp /= wksp)
then Just wksp
else Nothing
case targetWksp of
Just wksp -> do
windows $ \ws' -> W.view wksp ws'
(_, _, selWin, _, _, _, _, _) <- io $ queryPointer d root
let oldScreenRect = screenRect . W.screenDetail $ W.current ws
newScreenRect = screenRect . W.screenDetail $ sc
oldScreenRect' <- fmap ($ oldScreenRect) (calcGap [U,D,L,R])
newScreenRect' <- fmap ($ newScreenRect) (calcGap [U,D,L,R])
wa <- io $ getWindowAttributes d decoWin
modifyPosStore (\ps ->
posStoreMove ps w (fi $ wa_x wa) (fi $ wa_y wa)
oldScreenRect' newScreenRect')
windows $ \ws' -> W.shiftWin wksp w . W.focusWindow selWin $ ws'
return True
Nothing -> return False
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 (decoFont 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 dw <- createDecoWindow t dr
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 []
createDecoWindow :: Theme -> Rectangle -> X Window
createDecoWindow t r = let mask = Just (exposureMask .|. buttonPressMask) in
createNewWindow r mask (inactiveColor t) True
showDecos :: [DecoWin] -> X ()
showDecos = showWindows . catMaybes . map fst
hideDecos :: [DecoWin] -> X ()
hideDecos = hideWindows . catMaybes . map fst
deleteDecos :: [DecoWin] -> X ()
deleteDecos = deleteWindows . catMaybes . map fst
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)
let (als, strs) = ([AlignLeft, AlignCenter, AlignRightOffset minimizeButtonOffset,
AlignRightOffset maximizeButtonOffset, AlignRightOffset closeButtonOffset]
,[" (M)" , name , "_" ,
"[]" , "X"])
paintAndWrite dw fs wh ht 1 bc borderc tc bc als strs
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