{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module XMonad.Layout.DecorationEx.Common (
WindowDecoration (..)
, WindowCommand (..)
, DecorationWidget (..)
, WidgetPlace (..)
, WidgetLayout (..)
, HasWidgets (..)
, ClickHandler (..)
, ThemeAttributes (..)
, XPaintingContext
, BoxBorders (..)
, BorderColors
, ThemeStyleType (..)
, SimpleStyle (..)
, GenericTheme (..)
, ThemeEx
, widgetLayout
, windowStyleType
, genericWindowStyle
, themeEx
, borderColor
, shadowBorder
) where
import qualified Data.Map as M
import Data.Bits (testBit)
import XMonad
import qualified XMonad.StackSet as W
import XMonad.Hooks.UrgencyHook
import qualified XMonad.Layout.Decoration as D
data WindowDecoration = WindowDecoration {
WindowDecoration -> Window
wdOrigWindow :: !Window
, WindowDecoration -> Rectangle
wdOrigWinRect :: !Rectangle
, WindowDecoration -> Maybe Window
wdDecoWindow :: !(Maybe Window)
, WindowDecoration -> Maybe Rectangle
wdDecoRect :: !(Maybe Rectangle)
, WindowDecoration -> [WidgetPlace]
wdWidgets :: ![WidgetPlace]
}
class (Read cmd, Show cmd) => WindowCommand cmd where
executeWindowCommand :: cmd -> Window -> X Bool
isCommandChecked :: cmd -> Window -> X Bool
class (WindowCommand (WidgetCommand widget), Read widget, Show widget)
=> DecorationWidget widget where
type WidgetCommand widget
widgetCommand :: widget -> Int -> WidgetCommand widget
isShrinkable :: widget -> Bool
data WidgetLayout a = WidgetLayout {
forall a. WidgetLayout a -> [a]
wlLeft :: ![a]
, forall a. WidgetLayout a -> [a]
wlCenter :: ![a]
, forall a. WidgetLayout a -> [a]
wlRight :: ![a]
}
data WidgetPlace = WidgetPlace {
WidgetPlace -> Position
wpTextYPosition :: !Position
, WidgetPlace -> Rectangle
wpRectangle :: !Rectangle
}
deriving (Int -> WidgetPlace -> ShowS
[WidgetPlace] -> ShowS
WidgetPlace -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WidgetPlace] -> ShowS
$cshowList :: [WidgetPlace] -> ShowS
show :: WidgetPlace -> String
$cshow :: WidgetPlace -> String
showsPrec :: Int -> WidgetPlace -> ShowS
$cshowsPrec :: Int -> WidgetPlace -> ShowS
Show)
data BoxBorders a = BoxBorders {
forall a. BoxBorders a -> a
bxTop :: !a
, forall a. BoxBorders a -> a
bxRight :: !a
, forall a. BoxBorders a -> a
bxBottom :: !a
, forall a. BoxBorders a -> a
bxLeft :: !a
} deriving (BoxBorders a -> BoxBorders a -> Bool
forall a. Eq a => BoxBorders a -> BoxBorders a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BoxBorders a -> BoxBorders a -> Bool
$c/= :: forall a. Eq a => BoxBorders a -> BoxBorders a -> Bool
== :: BoxBorders a -> BoxBorders a -> Bool
$c== :: forall a. Eq a => BoxBorders a -> BoxBorders a -> Bool
Eq, ReadPrec [BoxBorders a]
ReadPrec (BoxBorders a)
ReadS [BoxBorders a]
forall a. Read a => ReadPrec [BoxBorders a]
forall a. Read a => ReadPrec (BoxBorders a)
forall a. Read a => Int -> ReadS (BoxBorders a)
forall a. Read a => ReadS [BoxBorders a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BoxBorders a]
$creadListPrec :: forall a. Read a => ReadPrec [BoxBorders a]
readPrec :: ReadPrec (BoxBorders a)
$creadPrec :: forall a. Read a => ReadPrec (BoxBorders a)
readList :: ReadS [BoxBorders a]
$creadList :: forall a. Read a => ReadS [BoxBorders a]
readsPrec :: Int -> ReadS (BoxBorders a)
$creadsPrec :: forall a. Read a => Int -> ReadS (BoxBorders a)
Read, Int -> BoxBorders a -> ShowS
forall a. Show a => Int -> BoxBorders a -> ShowS
forall a. Show a => [BoxBorders a] -> ShowS
forall a. Show a => BoxBorders a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BoxBorders a] -> ShowS
$cshowList :: forall a. Show a => [BoxBorders a] -> ShowS
show :: BoxBorders a -> String
$cshow :: forall a. Show a => BoxBorders a -> String
showsPrec :: Int -> BoxBorders a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> BoxBorders a -> ShowS
Show)
type BorderColors = BoxBorders String
data SimpleStyle = SimpleStyle {
SimpleStyle -> String
sBgColor :: !String
, SimpleStyle -> String
sTextColor :: !String
, SimpleStyle -> String
sTextBgColor :: !String
, SimpleStyle -> Dimension
sDecoBorderWidth :: !Dimension
, SimpleStyle -> BorderColors
sDecorationBorders :: !BorderColors
}
deriving (Int -> SimpleStyle -> ShowS
[SimpleStyle] -> ShowS
SimpleStyle -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SimpleStyle] -> ShowS
$cshowList :: [SimpleStyle] -> ShowS
show :: SimpleStyle -> String
$cshow :: SimpleStyle -> String
showsPrec :: Int -> SimpleStyle -> ShowS
$cshowsPrec :: Int -> SimpleStyle -> ShowS
Show, ReadPrec [SimpleStyle]
ReadPrec SimpleStyle
Int -> ReadS SimpleStyle
ReadS [SimpleStyle]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SimpleStyle]
$creadListPrec :: ReadPrec [SimpleStyle]
readPrec :: ReadPrec SimpleStyle
$creadPrec :: ReadPrec SimpleStyle
readList :: ReadS [SimpleStyle]
$creadList :: ReadS [SimpleStyle]
readsPrec :: Int -> ReadS SimpleStyle
$creadsPrec :: Int -> ReadS SimpleStyle
Read)
class HasWidgets theme widget where
themeWidgets :: theme widget -> WidgetLayout widget
class ClickHandler theme widget where
onDecorationClick :: theme widget
-> Int
-> Maybe (WidgetCommand widget)
isDraggingEnabled :: theme widget
-> Int
-> Bool
class (Read theme, Show theme) => ThemeAttributes theme where
type Style theme
selectWindowStyle :: theme -> Window -> X (Style theme)
widgetsPadding :: theme -> BoxBorders Dimension
defaultBgColor :: theme -> String
themeFontName :: theme -> String
data GenericTheme style widget = GenericTheme {
forall style widget. GenericTheme style widget -> style
exActive :: !style
, forall style widget. GenericTheme style widget -> style
exInactive :: !style
, forall style widget. GenericTheme style widget -> style
exUrgent :: !style
, forall style widget.
GenericTheme style widget -> BoxBorders Dimension
exPadding :: !(BoxBorders Dimension)
, forall style widget. GenericTheme style widget -> String
exFontName :: !String
, forall style widget.
GenericTheme style widget -> Map Int (WidgetCommand widget)
exOnDecoClick :: !(M.Map Int (WidgetCommand widget))
, forall style widget. GenericTheme style widget -> [Int]
exDragWindowButtons :: ![Int]
, forall style widget. GenericTheme style widget -> [widget]
exWidgetsLeft :: ![widget]
, forall style widget. GenericTheme style widget -> [widget]
exWidgetsCenter :: ![widget]
, forall style widget. GenericTheme style widget -> [widget]
exWidgetsRight :: ![widget]
}
deriving instance (Show widget, Show (WidgetCommand widget), Show style) => Show (GenericTheme style widget)
deriving instance (Read widget, Read (WidgetCommand widget), Read style) => Read (GenericTheme style widget)
type ThemeEx widget = GenericTheme SimpleStyle widget
instance HasWidgets (GenericTheme style) widget where
themeWidgets :: GenericTheme style widget -> WidgetLayout widget
themeWidgets GenericTheme style widget
theme = forall a. [a] -> [a] -> [a] -> WidgetLayout a
WidgetLayout (forall style widget. GenericTheme style widget -> [widget]
exWidgetsLeft GenericTheme style widget
theme) (forall style widget. GenericTheme style widget -> [widget]
exWidgetsCenter GenericTheme style widget
theme) (forall style widget. GenericTheme style widget -> [widget]
exWidgetsRight GenericTheme style widget
theme)
data ThemeStyleType = ActiveWindow | UrgentWindow | InactiveWindow
deriving (ThemeStyleType -> ThemeStyleType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ThemeStyleType -> ThemeStyleType -> Bool
$c/= :: ThemeStyleType -> ThemeStyleType -> Bool
== :: ThemeStyleType -> ThemeStyleType -> Bool
$c== :: ThemeStyleType -> ThemeStyleType -> Bool
Eq, Int -> ThemeStyleType -> ShowS
[ThemeStyleType] -> ShowS
ThemeStyleType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ThemeStyleType] -> ShowS
$cshowList :: [ThemeStyleType] -> ShowS
show :: ThemeStyleType -> String
$cshow :: ThemeStyleType -> String
showsPrec :: Int -> ThemeStyleType -> ShowS
$cshowsPrec :: Int -> ThemeStyleType -> ShowS
Show, ReadPrec [ThemeStyleType]
ReadPrec ThemeStyleType
Int -> ReadS ThemeStyleType
ReadS [ThemeStyleType]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [ThemeStyleType]
$creadListPrec :: ReadPrec [ThemeStyleType]
readPrec :: ReadPrec ThemeStyleType
$creadPrec :: ReadPrec ThemeStyleType
readList :: ReadS [ThemeStyleType]
$creadList :: ReadS [ThemeStyleType]
readsPrec :: Int -> ReadS ThemeStyleType
$creadsPrec :: Int -> ReadS ThemeStyleType
Read)
widgetLayout :: WidgetLayout widget -> [widget]
widgetLayout :: forall a. WidgetLayout a -> [a]
widgetLayout WidgetLayout widget
ws = forall a. WidgetLayout a -> [a]
wlLeft WidgetLayout widget
ws forall a. [a] -> [a] -> [a]
++ forall a. WidgetLayout a -> [a]
wlCenter WidgetLayout widget
ws forall a. [a] -> [a] -> [a]
++ forall a. WidgetLayout a -> [a]
wlRight WidgetLayout widget
ws
type XPaintingContext = (Display, Pixmap, GC)
instance (Show widget, Read widget, Read (WidgetCommand widget), Show (WidgetCommand widget))
=> ThemeAttributes (ThemeEx widget) where
type Style (ThemeEx widget) = SimpleStyle
selectWindowStyle :: ThemeEx widget -> Window -> X (Style (ThemeEx widget))
selectWindowStyle ThemeEx widget
theme Window
w = forall style widget. Window -> GenericTheme style widget -> X style
genericWindowStyle Window
w ThemeEx widget
theme
defaultBgColor :: ThemeEx widget -> String
defaultBgColor ThemeEx widget
t = SimpleStyle -> String
sBgColor forall a b. (a -> b) -> a -> b
$ forall style widget. GenericTheme style widget -> style
exInactive ThemeEx widget
t
widgetsPadding :: ThemeEx widget -> BoxBorders Dimension
widgetsPadding = forall style widget.
GenericTheme style widget -> BoxBorders Dimension
exPadding
themeFontName :: ThemeEx widget -> String
themeFontName = forall style widget. GenericTheme style widget -> String
exFontName
instance ClickHandler (GenericTheme SimpleStyle) widget where
onDecorationClick :: GenericTheme SimpleStyle widget
-> Int -> Maybe (WidgetCommand widget)
onDecorationClick GenericTheme SimpleStyle widget
theme Int
button = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
button (forall style widget.
GenericTheme style widget -> Map Int (WidgetCommand widget)
exOnDecoClick GenericTheme SimpleStyle widget
theme)
isDraggingEnabled :: GenericTheme SimpleStyle widget -> Int -> Bool
isDraggingEnabled GenericTheme SimpleStyle widget
theme Int
button = Int
button forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall style widget. GenericTheme style widget -> [Int]
exDragWindowButtons GenericTheme SimpleStyle widget
theme
genericWindowStyle :: Window -> GenericTheme style widget -> X style
genericWindowStyle :: forall style widget. Window -> GenericTheme style widget -> X style
genericWindowStyle Window
win GenericTheme style widget
theme = do
ThemeStyleType
styleType <- Window -> X ThemeStyleType
windowStyleType Window
win
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case ThemeStyleType
styleType of
ThemeStyleType
ActiveWindow -> forall style widget. GenericTheme style widget -> style
exActive GenericTheme style widget
theme
ThemeStyleType
InactiveWindow -> forall style widget. GenericTheme style widget -> style
exInactive GenericTheme style widget
theme
ThemeStyleType
UrgentWindow -> forall style widget. GenericTheme style widget -> style
exUrgent GenericTheme style widget
theme
windowStyleType :: Window -> X ThemeStyleType
windowStyleType :: Window -> X ThemeStyleType
windowStyleType Window
win = do
Maybe Window
mbFocused <- forall i l a s sd. StackSet i l a s sd -> Maybe a
W.peek forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> WindowSet
windowset
Bool
isWmStateUrgent <- (Window
win forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> X [Window]
readUrgents
Bool
isUrgencyBitSet <- forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
WMHints
hints <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO WMHints
getWMHints Display
dpy Window
win
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ WMHints -> CLong
wmh_flags WMHints
hints forall a. Bits a => a -> Int -> Bool
`testBit` Int
urgencyHintBit
if Bool
isWmStateUrgent Bool -> Bool -> Bool
|| Bool
isUrgencyBitSet
then forall (m :: * -> *) a. Monad m => a -> m a
return ThemeStyleType
UrgentWindow
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
case Maybe Window
mbFocused of
Maybe Window
Nothing -> ThemeStyleType
InactiveWindow
Just Window
focused
| Window
focused forall a. Eq a => a -> a -> Bool
== Window
win -> ThemeStyleType
ActiveWindow
| Bool
otherwise -> ThemeStyleType
InactiveWindow
themeEx :: Default (WidgetCommand widget) => D.Theme -> ThemeEx widget
themeEx :: forall widget.
Default (WidgetCommand widget) =>
Theme -> ThemeEx widget
themeEx Theme
t =
GenericTheme {
exActive :: SimpleStyle
exActive = String
-> String -> String -> Dimension -> BorderColors -> SimpleStyle
SimpleStyle (Theme -> String
D.activeColor Theme
t) (Theme -> String
D.activeTextColor Theme
t) (Theme -> String
D.activeColor Theme
t) (Theme -> Dimension
D.activeBorderWidth Theme
t) (String -> BorderColors
borderColor forall a b. (a -> b) -> a -> b
$ Theme -> String
D.activeColor Theme
t)
, exInactive :: SimpleStyle
exInactive = String
-> String -> String -> Dimension -> BorderColors -> SimpleStyle
SimpleStyle (Theme -> String
D.inactiveColor Theme
t) (Theme -> String
D.inactiveTextColor Theme
t) (Theme -> String
D.inactiveColor Theme
t) (Theme -> Dimension
D.inactiveBorderWidth Theme
t) (String -> BorderColors
borderColor forall a b. (a -> b) -> a -> b
$ Theme -> String
D.inactiveColor Theme
t)
, exUrgent :: SimpleStyle
exUrgent = String
-> String -> String -> Dimension -> BorderColors -> SimpleStyle
SimpleStyle (Theme -> String
D.urgentColor Theme
t) (Theme -> String
D.urgentTextColor Theme
t) (Theme -> String
D.urgentColor Theme
t) (Theme -> Dimension
D.urgentBorderWidth Theme
t) (String -> BorderColors
borderColor forall a b. (a -> b) -> a -> b
$ Theme -> String
D.urgentColor Theme
t)
, exPadding :: BoxBorders Dimension
exPadding = forall a. a -> a -> a -> a -> BoxBorders a
BoxBorders Dimension
0 Dimension
4 Dimension
0 Dimension
4
, exFontName :: String
exFontName = Theme -> String
D.fontName Theme
t
, exOnDecoClick :: Map Int (WidgetCommand widget)
exOnDecoClick = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Int
1, forall a. Default a => a
def)]
, exDragWindowButtons :: [Int]
exDragWindowButtons = [Int
1]
, exWidgetsLeft :: [widget]
exWidgetsLeft = []
, exWidgetsCenter :: [widget]
exWidgetsCenter = []
, exWidgetsRight :: [widget]
exWidgetsRight = []
}
instance Default (WidgetCommand widget) => Default (ThemeEx widget) where
def :: ThemeEx widget
def = forall widget.
Default (WidgetCommand widget) =>
Theme -> ThemeEx widget
themeEx (forall a. Default a => a
def :: D.Theme)
borderColor :: String -> BorderColors
borderColor :: String -> BorderColors
borderColor String
c = forall a. a -> a -> a -> a -> BoxBorders a
BoxBorders String
c String
c String
c String
c
shadowBorder :: String -> String -> BorderColors
shadowBorder :: String -> String -> BorderColors
shadowBorder String
highlight String
shadow = forall a. a -> a -> a -> a -> BoxBorders a
BoxBorders String
highlight String
shadow String
shadow String
highlight