{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.DecorationEx.Common
-- Description :  Declaration of types used by DecorationEx module,
--                and commonly used utility functions.
-- Copyright   :  (c) 2007 Andrea Rossato, 2009 Jan Vornberger, 2023 Ilya Portnov
-- License     :  BSD-style (see xmonad/LICENSE)
--
-- Maintainer  :  portnov84@rambler.ru
-- Stability   :  unstable
-- Portability :  unportable
--
-- This module exposes a number of types which are used by other sub-modules
-- of "XMonad.Layout.DecorationEx" module.
-----------------------------------------------------------------------------

module XMonad.Layout.DecorationEx.Common (
    -- * Common types
    WindowDecoration (..)
  , WindowCommand (..)
  , DecorationWidget (..)
  , WidgetPlace (..)
  , WidgetLayout (..)
  , HasWidgets (..)
  , ClickHandler (..)
  , ThemeAttributes (..)
  , XPaintingContext
  , BoxBorders (..)
  , BorderColors
  , ThemeStyleType (..)
  , SimpleStyle (..)
  , GenericTheme (..)
  , ThemeEx 
  -- * Utilities
  , 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

-- | Information about decoration of one window
data WindowDecoration = WindowDecoration {
    WindowDecoration -> Window
wdOrigWindow :: !Window         -- ^ Original window (one being decorated)
  , WindowDecoration -> Rectangle
wdOrigWinRect :: !Rectangle     -- ^ Rectangle of original window
  , WindowDecoration -> Maybe Window
wdDecoWindow :: !(Maybe Window) -- ^ Decoration window, or Nothing if this window should not be decorated
  , WindowDecoration -> Maybe Rectangle
wdDecoRect :: !(Maybe Rectangle) -- ^ Rectangle for decoration window
  , WindowDecoration -> [WidgetPlace]
wdWidgets :: ![WidgetPlace]      -- ^ Places for widgets
  }

-- | Type class for window commands (such as maximize or close window)
class (Read cmd, Show cmd) => WindowCommand cmd where
  -- | Execute the command
  executeWindowCommand :: cmd -> Window -> X Bool

  -- | Is the command currently in `checked' state. 
  -- For example, for 'sticky' command, check if the
  -- window is currently sticky.
  isCommandChecked :: cmd -> Window -> X Bool

-- | Type class for decoration widgets
class (WindowCommand (WidgetCommand widget), Read widget, Show widget)
  => DecorationWidget widget where
  -- | Type of window commands which this type of widgets can execute
  type WidgetCommand widget

  -- | Get window command which is associated with this widget.
  widgetCommand :: widget -> Int -> WidgetCommand widget

  -- | Check if the widget is shrinkable, i.e. if it's width
  -- can be reduced if there is not enough place in the decoration.
  isShrinkable :: widget -> Bool

-- | Layout of widgets
data WidgetLayout a = WidgetLayout {
    forall a. WidgetLayout a -> [a]
wlLeft :: ![a]     -- ^ Widgets that should be aligned to the left side of decoration
  , forall a. WidgetLayout a -> [a]
wlCenter :: ![a]   -- ^ Widgets that should be in the center of decoration
  , forall a. WidgetLayout a -> [a]
wlRight :: ![a]    -- ^ Widgets taht should be aligned to the right side of decoration
  }

-- | Data type describing where the decoration widget (e.g. window button)
-- should be placed.
-- All coordinates are relative to decoration rectangle.
data WidgetPlace = WidgetPlace {
    WidgetPlace -> Position
wpTextYPosition :: !Position -- ^ Y position of text base line
                                 -- (for widgets like window title or text-based buttons)
  , WidgetPlace -> Rectangle
wpRectangle :: !Rectangle    -- ^ Rectangle where to place the widget
  }
  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)

-- | Generic data type which is used to
-- describe characteristics of rectangle borders.
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)

-- | Convinience data type describing colors of decoration rectangle borders.
type BorderColors = BoxBorders String

-- | Data type describing look of window decoration
-- in particular state (active or inactive)
data SimpleStyle = SimpleStyle {
    SimpleStyle -> String
sBgColor :: !String                 -- ^ Decoration background color
  , SimpleStyle -> String
sTextColor :: !String               -- ^ Text (foreground) color
  , SimpleStyle -> String
sTextBgColor :: !String             -- ^ Text background color
  , SimpleStyle -> Dimension
sDecoBorderWidth :: !Dimension      -- ^ Width of border of decoration rectangle. Set to 0 to disable the border.
  , SimpleStyle -> BorderColors
sDecorationBorders :: !BorderColors -- ^ Colors of borders of decoration rectangle.
  }
  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)

-- | Type class for themes, which claims that
-- the theme contains the list of widgets and their alignments.
class HasWidgets theme widget where
  themeWidgets :: theme widget -> WidgetLayout widget

-- | Type class for themes, which claims that
-- the theme can describe how the decoration should respond
-- to clicks on decoration itself (between widgets).
class ClickHandler theme widget where
  -- | This is called when the user clicks on the decoration rectangle
  -- (not on one of widgets).
  onDecorationClick :: theme widget
                    -> Int                          -- ^ Mouse button number
                    -> Maybe (WidgetCommand widget)

  -- | Determine if it is possible to drag window by it's decoration
  -- with mouse button.
  isDraggingEnabled :: theme widget
                    -> Int          -- ^ Mouse button number
                    -> Bool

-- | Type class for themes, which claims that the theme
-- is responsible for determining looks of decoration.
class (Read theme, Show theme) => ThemeAttributes theme where
  -- | Type which describes looks of decoration in one
  -- of window states (active, inactive, urgent, etc).
  type Style theme

  -- | Select style based on window state.
  selectWindowStyle :: theme -> Window -> X (Style theme)

  -- | Define padding between decoration rectangle and widgets.
  widgetsPadding :: theme -> BoxBorders Dimension
  
  -- | Initial background color of decoration rectangle.
  -- When decoration widget is created, it is initially filled
  -- with this color.
  defaultBgColor :: theme -> String

  -- | Font name defined in the theme.
  themeFontName :: theme -> String

-- | Generic Theme data type. This is used
-- by @TextEngine@ and can be used by other relatively
-- simple decoration engines.
data GenericTheme style widget = GenericTheme {
    forall style widget. GenericTheme style widget -> style
exActive :: !style                                  -- ^ Decoration style for active (focused) windows
  , forall style widget. GenericTheme style widget -> style
exInactive :: !style                                -- ^ Decoration style for inactive (unfocused) windows
  , forall style widget. GenericTheme style widget -> style
exUrgent :: !style                                  -- ^ Decoration style for urgent windows
  , forall style widget.
GenericTheme style widget -> BoxBorders Dimension
exPadding :: !(BoxBorders Dimension)                -- ^ Padding between decoration rectangle and widgets
  , forall style widget. GenericTheme style widget -> String
exFontName :: !String                               -- ^ Font name
  , forall style widget.
GenericTheme style widget -> Map Int (WidgetCommand widget)
exOnDecoClick :: !(M.Map Int (WidgetCommand widget)) -- ^ Correspondence between mouse button number and window command.
  , forall style widget. GenericTheme style widget -> [Int]
exDragWindowButtons :: ![Int]                       -- ^ For which mouse buttons dragging is enabled
  , forall style widget. GenericTheme style widget -> [widget]
exWidgetsLeft :: ![widget]                          -- ^ Widgets that should appear at the left of decoration rectangle (listed left to right)
  , forall style widget. GenericTheme style widget -> [widget]
exWidgetsCenter :: ![widget]                        -- ^ Widgets that should appear in the center of decoration rectangle (listed left to right)
  , forall style widget. GenericTheme style widget -> [widget]
exWidgetsRight :: ![widget]                         -- ^ Widgets that should appear at the right of decoration rectangle (listed left to right)
  }

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)

-- | Convience type for themes used by @TextDecoration@.
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)

-- | Supported states of windows (on which looks of decorations can depend).
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)

-- | Utility function to convert WidgetLayout to plain list of widgets.
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

-- | Painting context for decoration engines based on plain X11 calls.
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

-- | Generic utility function to select style from @GenericTheme@
-- based on current state of the window.
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

-- | Detect type of style to be used from current state of the window.
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

-- | Convert Theme type from "XMonad.Layout.Decoration" to 
-- theme type used by "XMonad.Layout.DecorationEx.TextEngine".
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