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

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.DecorationEx.TextEngine
-- Description :  Text-based window decoration engine
-- 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
--
-- Window decoration engine, that uses text fragments (like @"[X]"@) to indicate
-- widgets (window buttons).
-----------------------------------------------------------------------------

module XMonad.Layout.DecorationEx.TextEngine (
    textDecoration,
    TextDecoration (..)
  ) where 

import XMonad
import XMonad.Prelude
import XMonad.Layout.LayoutModifier
import XMonad.Util.Font

import XMonad.Layout.DecorationEx.LayoutModifier
import XMonad.Layout.DecorationEx.Common
import XMonad.Layout.DecorationEx.Engine
import XMonad.Layout.DecorationEx.Geometry
import XMonad.Layout.DecorationEx.Widgets

-- | Decoration engine data type
data TextDecoration widget a = TextDecoration
  deriving (Int -> TextDecoration widget a -> ShowS
[TextDecoration widget a] -> ShowS
TextDecoration widget a -> String
(Int -> TextDecoration widget a -> ShowS)
-> (TextDecoration widget a -> String)
-> ([TextDecoration widget a] -> ShowS)
-> Show (TextDecoration widget a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall widget a. Int -> TextDecoration widget a -> ShowS
forall widget a. [TextDecoration widget a] -> ShowS
forall widget a. TextDecoration widget a -> String
$cshowsPrec :: forall widget a. Int -> TextDecoration widget a -> ShowS
showsPrec :: Int -> TextDecoration widget a -> ShowS
$cshow :: forall widget a. TextDecoration widget a -> String
show :: TextDecoration widget a -> String
$cshowList :: forall widget a. [TextDecoration widget a] -> ShowS
showList :: [TextDecoration widget a] -> ShowS
Show, ReadPrec [TextDecoration widget a]
ReadPrec (TextDecoration widget a)
Int -> ReadS (TextDecoration widget a)
ReadS [TextDecoration widget a]
(Int -> ReadS (TextDecoration widget a))
-> ReadS [TextDecoration widget a]
-> ReadPrec (TextDecoration widget a)
-> ReadPrec [TextDecoration widget a]
-> Read (TextDecoration widget a)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall widget a. ReadPrec [TextDecoration widget a]
forall widget a. ReadPrec (TextDecoration widget a)
forall widget a. Int -> ReadS (TextDecoration widget a)
forall widget a. ReadS [TextDecoration widget a]
$creadsPrec :: forall widget a. Int -> ReadS (TextDecoration widget a)
readsPrec :: Int -> ReadS (TextDecoration widget a)
$creadList :: forall widget a. ReadS [TextDecoration widget a]
readList :: ReadS [TextDecoration widget a]
$creadPrec :: forall widget a. ReadPrec (TextDecoration widget a)
readPrec :: ReadPrec (TextDecoration widget a)
$creadListPrec :: forall widget a. ReadPrec [TextDecoration widget a]
readListPrec :: ReadPrec [TextDecoration widget a]
Read)

instance (TextWidget widget, ClickHandler (GenericTheme SimpleStyle) widget)
  => DecorationEngine TextDecoration widget Window where
  type Theme TextDecoration = GenericTheme SimpleStyle
  type DecorationPaintingContext TextDecoration = XPaintingContext
  type DecorationEngineState TextDecoration = XMonadFont

  describeEngine :: TextDecoration widget Window -> String
describeEngine TextDecoration widget Window
_ = String
"TextDecoration"

  calcWidgetPlace :: TextDecoration widget Window
-> DrawData TextDecoration widget -> widget -> X WidgetPlace
calcWidgetPlace = TextDecoration widget Window
-> DrawData TextDecoration widget -> widget -> X WidgetPlace
forall widget (engine :: * -> * -> *).
(TextWidget widget, DecorationEngineState engine ~ XMonadFont,
 DecorationEngine engine widget Window) =>
engine widget Window
-> DrawData engine widget -> widget -> X WidgetPlace
calcTextWidgetPlace

  paintWidget :: forall shrinker.
Shrinker shrinker =>
TextDecoration widget Window
-> DecorationPaintingContext TextDecoration
-> WidgetPlace
-> shrinker
-> DrawData TextDecoration widget
-> widget
-> Bool
-> X ()
paintWidget = TextDecoration widget Window
-> DecorationPaintingContext TextDecoration
-> WidgetPlace
-> shrinker
-> DrawData TextDecoration widget
-> widget
-> Bool
-> X ()
forall widget (engine :: * -> * -> *) shrinker.
(TextWidget widget, Style (Theme engine widget) ~ SimpleStyle,
 DecorationPaintingContext engine ~ XPaintingContext,
 DecorationEngineState engine ~ XMonadFont, Shrinker shrinker,
 DecorationEngine engine widget Window) =>
engine widget Window
-> DecorationPaintingContext engine
-> WidgetPlace
-> shrinker
-> DrawData engine widget
-> widget
-> Bool
-> X ()
paintTextWidget

  paintDecoration :: forall shrinker.
Shrinker shrinker =>
TextDecoration widget Window
-> Window
-> Dimension
-> Dimension
-> shrinker
-> DrawData TextDecoration widget
-> Bool
-> X ()
paintDecoration = TextDecoration widget Window
-> Window
-> Dimension
-> Dimension
-> shrinker
-> DrawData TextDecoration widget
-> Bool
-> X ()
forall (engine :: * -> * -> *) shrinker widget.
(DecorationEngine engine widget Window,
 DecorationPaintingContext engine ~ XPaintingContext,
 Shrinker shrinker, Style (Theme engine widget) ~ SimpleStyle) =>
engine widget Window
-> Window
-> Dimension
-> Dimension
-> shrinker
-> DrawData engine widget
-> Bool
-> X ()
paintDecorationSimple

  initializeState :: forall (geom :: * -> *).
TextDecoration widget Window
-> geom Window
-> Theme TextDecoration widget
-> X (DecorationEngineState TextDecoration)
initializeState TextDecoration widget Window
_ geom Window
_ Theme TextDecoration widget
theme = String -> X XMonadFont
initXMF (GenericTheme SimpleStyle widget -> String
forall theme. ThemeAttributes theme => theme -> String
themeFontName GenericTheme SimpleStyle widget
Theme TextDecoration widget
theme)
  releaseStateResources :: TextDecoration widget Window
-> DecorationEngineState TextDecoration -> X ()
releaseStateResources TextDecoration widget Window
_ = XMonadFont -> X ()
DecorationEngineState TextDecoration -> X ()
releaseXMF

-- | Implementation of @paintWidget@ for decoration engines based on @TextDecoration@.
paintTextWidget :: (TextWidget widget,
                    Style (Theme engine widget) ~ SimpleStyle,
                    DecorationPaintingContext engine ~ XPaintingContext,
                    DecorationEngineState engine ~ XMonadFont,
                    Shrinker shrinker,
                    DecorationEngine engine widget Window)
                => engine widget Window
                -> DecorationPaintingContext engine
                -> WidgetPlace
                -> shrinker
                -> DrawData engine widget
                -> widget
                -> Bool
                -> X ()
paintTextWidget :: forall widget (engine :: * -> * -> *) shrinker.
(TextWidget widget, Style (Theme engine widget) ~ SimpleStyle,
 DecorationPaintingContext engine ~ XPaintingContext,
 DecorationEngineState engine ~ XMonadFont, Shrinker shrinker,
 DecorationEngine engine widget Window) =>
engine widget Window
-> DecorationPaintingContext engine
-> WidgetPlace
-> shrinker
-> DrawData engine widget
-> widget
-> Bool
-> X ()
paintTextWidget engine widget Window
engine (Display
dpy, Window
pixmap, GC
gc) WidgetPlace
place shrinker
shrinker DrawData engine widget
dd widget
widget Bool
_ = do
    let style :: Style (Theme engine widget)
style = DrawData engine widget -> Style (Theme engine widget)
forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Style (Theme engine widget)
ddStyle DrawData engine widget
dd
        rect :: Rectangle
rect = WidgetPlace -> Rectangle
wpRectangle WidgetPlace
place
        x :: Position
x = Rectangle -> Position
rect_x Rectangle
rect
        y :: Position
y = WidgetPlace -> Position
wpTextYPosition WidgetPlace
place
    str <- DrawData engine widget -> widget -> X String
forall widget (engine :: * -> * -> *).
TextWidget widget =>
DrawData engine widget -> widget -> X String
forall (engine :: * -> * -> *).
DrawData engine widget -> widget -> X String
widgetString DrawData engine widget
dd widget
widget
    str' <- if isShrinkable widget
              then getShrinkedWindowName engine shrinker (ddEngineState dd) str (rect_width rect) (rect_height rect)
              else return str
    printStringXMF dpy pixmap (ddEngineState dd) gc (sTextColor style) (sTextBgColor style) x y str'

-- | Implementation of @calcWidgetPlace@ for decoration engines based on @TextDecoration@.
calcTextWidgetPlace :: (TextWidget widget,
                        DecorationEngineState engine ~ XMonadFont,
                        DecorationEngine engine widget Window)
                    => engine widget Window
                    -> DrawData engine widget
                    -> widget
                    -> X WidgetPlace
calcTextWidgetPlace :: forall widget (engine :: * -> * -> *).
(TextWidget widget, DecorationEngineState engine ~ XMonadFont,
 DecorationEngine engine widget Window) =>
engine widget Window
-> DrawData engine widget -> widget -> X WidgetPlace
calcTextWidgetPlace engine widget Window
_ DrawData engine widget
dd widget
widget = do
    str <- DrawData engine widget -> widget -> X String
forall widget (engine :: * -> * -> *).
TextWidget widget =>
DrawData engine widget -> widget -> X String
forall (engine :: * -> * -> *).
DrawData engine widget -> widget -> X String
widgetString DrawData engine widget
dd widget
widget
    let h = Rectangle -> Dimension
rect_height (DrawData engine widget -> Rectangle
forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Rectangle
ddDecoRect DrawData engine widget
dd)
        font = DrawData engine widget -> DecorationEngineState engine
forall (engine :: * -> * -> *) widget.
DrawData engine widget -> DecorationEngineState engine
ddEngineState DrawData engine widget
dd
    withDisplay $ \Display
dpy -> do
      width <- Int -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (Int -> Dimension) -> X Int -> X Dimension
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Display -> XMonadFont -> String -> X Int
forall (m :: * -> *).
MonadIO m =>
Display -> XMonadFont -> String -> m Int
textWidthXMF Display
dpy (DrawData engine widget -> DecorationEngineState engine
forall (engine :: * -> * -> *) widget.
DrawData engine widget -> DecorationEngineState engine
ddEngineState DrawData engine widget
dd) String
str
      (a, d) <- textExtentsXMF font str
      let height = Position
a Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
d
          y = Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi (Dimension -> Position) -> Dimension -> Position
forall a b. (a -> b) -> a -> b
$ (Dimension
h Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Position
height) Dimension -> Dimension -> Dimension
forall a. Integral a => a -> a -> a
`div` Dimension
2
          y0 = Position
y Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position -> Position
forall a b. (Integral a, Num b) => a -> b
fi Position
a
          rect = Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
0 Position
y Dimension
width (Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Position
height)
      return $ WidgetPlace y0 rect

-- | Add decoration to existing layout. Widgets are indicated by text fragments, like @"[+]"@.
-- Geometry is simple: a horizontal panel at the top of each window, going for the full width
-- of the window.
textDecoration :: (Shrinker shrinker)
               => shrinker                -- ^ String shrinker, for example @shrinkText@
               -> Theme TextDecoration StandardWidget  -- ^ Decoration theme (font, colors, widgets, etc)
               -> l Window                -- ^ Layout to be decorated
             -> ModifiedLayout (DecorationEx TextDecoration StandardWidget DefaultGeometry shrinker) l Window
textDecoration :: forall shrinker (l :: * -> *).
Shrinker shrinker =>
shrinker
-> Theme TextDecoration StandardWidget
-> l Window
-> ModifiedLayout
     (DecorationEx
        TextDecoration StandardWidget DefaultGeometry shrinker)
     l
     Window
textDecoration shrinker
shrinker Theme TextDecoration StandardWidget
theme = shrinker
-> Theme TextDecoration StandardWidget
-> TextDecoration StandardWidget Window
-> DefaultGeometry Window
-> l Window
-> ModifiedLayout
     (DecorationEx
        TextDecoration StandardWidget DefaultGeometry shrinker)
     l
     Window
forall (engine :: * -> * -> *) widget a (geom :: * -> *) shrinker
       (l :: * -> *).
(DecorationEngine engine widget a, DecorationGeometry geom a,
 Shrinker shrinker) =>
shrinker
-> Theme engine widget
-> engine widget a
-> geom a
-> l a
-> ModifiedLayout (DecorationEx engine widget geom shrinker) l a
decorationEx shrinker
shrinker Theme TextDecoration StandardWidget
theme TextDecoration StandardWidget Window
forall widget a. TextDecoration widget a
TextDecoration DefaultGeometry Window
forall a. Default a => a
def