{-# 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
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
showList :: [TextDecoration widget a] -> ShowS
$cshowList :: forall widget a. [TextDecoration widget a] -> ShowS
show :: TextDecoration widget a -> String
$cshow :: forall widget a. TextDecoration widget a -> String
showsPrec :: Int -> TextDecoration widget a -> ShowS
$cshowsPrec :: forall widget a. Int -> TextDecoration widget a -> ShowS
Show, ReadPrec [TextDecoration widget a]
ReadPrec (TextDecoration widget a)
ReadS [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]
readListPrec :: ReadPrec [TextDecoration widget a]
$creadListPrec :: forall widget a. ReadPrec [TextDecoration widget a]
readPrec :: ReadPrec (TextDecoration widget a)
$creadPrec :: forall widget a. ReadPrec (TextDecoration widget a)
readList :: ReadS [TextDecoration widget a]
$creadList :: forall widget a. ReadS [TextDecoration widget a]
readsPrec :: Int -> ReadS (TextDecoration widget a)
$creadsPrec :: forall widget a. Int -> ReadS (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 = 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 = 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 = 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 (forall theme. ThemeAttributes theme => theme -> String
themeFontName Theme TextDecoration widget
theme)
  releaseStateResources :: TextDecoration widget Window
-> DecorationEngineState TextDecoration -> X ()
releaseStateResources TextDecoration widget Window
_ = XMonadFont -> 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 = 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
    String
str <- forall widget (engine :: * -> * -> *).
TextWidget widget =>
DrawData engine widget -> widget -> X String
widgetString DrawData engine widget
dd widget
widget
    String
str' <- if forall widget. DecorationWidget widget => widget -> Bool
isShrinkable widget
widget
              then forall (engine :: * -> * -> *) widget a shrinker.
(DecorationEngine engine widget a, Shrinker shrinker) =>
engine widget a
-> shrinker
-> DecorationEngineState engine
-> String
-> Dimension
-> Dimension
-> X String
getShrinkedWindowName engine widget Window
engine shrinker
shrinker (forall (engine :: * -> * -> *) widget.
DrawData engine widget -> DecorationEngineState engine
ddEngineState DrawData engine widget
dd) String
str (Rectangle -> Dimension
rect_width Rectangle
rect) (Rectangle -> Dimension
rect_height Rectangle
rect)
              else forall (m :: * -> *) a. Monad m => a -> m a
return String
str
    forall (m :: * -> *).
(Functor m, MonadIO m) =>
Display
-> Window
-> XMonadFont
-> GC
-> String
-> String
-> Position
-> Position
-> String
-> m ()
printStringXMF Display
dpy Window
pixmap (forall (engine :: * -> * -> *) widget.
DrawData engine widget -> DecorationEngineState engine
ddEngineState DrawData engine widget
dd) GC
gc (SimpleStyle -> String
sTextColor Style (Theme engine widget)
style) (SimpleStyle -> String
sTextBgColor Style (Theme engine widget)
style) Position
x Position
y String
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
    String
str <- forall widget (engine :: * -> * -> *).
TextWidget widget =>
DrawData engine widget -> widget -> X String
widgetString DrawData engine widget
dd widget
widget
    let h :: Dimension
h = Rectangle -> Dimension
rect_height (forall (engine :: * -> * -> *) widget.
DrawData engine widget -> Rectangle
ddDecoRect DrawData engine widget
dd)
        font :: DecorationEngineState engine
font = forall (engine :: * -> * -> *) widget.
DrawData engine widget -> DecorationEngineState engine
ddEngineState DrawData engine widget
dd
    forall a. (Display -> X a) -> X a
withDisplay forall a b. (a -> b) -> a -> b
$ \Display
dpy -> do
      Dimension
width <- forall a b. (Integral a, Num b) => a -> b
fi forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
Display -> XMonadFont -> String -> m Int
textWidthXMF Display
dpy (forall (engine :: * -> * -> *) widget.
DrawData engine widget -> DecorationEngineState engine
ddEngineState DrawData engine widget
dd) String
str
      (Position
a, Position
d) <- forall (m :: * -> *).
MonadIO m =>
XMonadFont -> String -> m (Position, Position)
textExtentsXMF DecorationEngineState engine
font String
str
      let height :: Position
height = Position
a forall a. Num a => a -> a -> a
+ Position
d
          y :: Position
y = forall a b. (Integral a, Num b) => a -> b
fi forall a b. (a -> b) -> a -> b
$ (Dimension
h forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fi Position
height) forall a. Integral a => a -> a -> a
`div` Dimension
2
          y0 :: Position
y0 = Position
y forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi Position
a
          rect :: Rectangle
rect = Position -> Position -> Dimension -> Dimension -> Rectangle
Rectangle Position
0 Position
y Dimension
width (forall a b. (Integral a, Num b) => a -> b
fi Position
height)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Position -> Rectangle -> WidgetPlace
WidgetPlace Position
y0 Rectangle
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 = 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 forall widget a. TextDecoration widget a
TextDecoration forall a. Default a => a
def