xmonad-config/lib/XMonad/Internal/Theme.hs

--------------------------------------------------------------------------------
-- Theme for XMonad and Xmobar

module XMonad.Internal.Theme
  ( baseColor
  , bgColor
  , fgColor
  , bordersColor
  , warningColor
  , errorColor
  , selectedFgColor
  , selectedBgColor
  , selectedBordersColor
  , backdropBaseColor
  , backdropFgColor
  , backdropTextColor
  , blend'
  , darken'
  , Slant (..)
  , Weight (..)
  , FontData (..)
  , FontBuilder
  , buildFont
  , fallbackFont
  , defFontFamily
  , defFontData
  , tabbedTheme
  , promptTheme
  )
where

import Data.Colour
import Data.Colour.SRGB
import RIO
import qualified RIO.Text as T
import qualified XMonad.Layout.Decoration as D
import qualified XMonad.Prompt as P

--------------------------------------------------------------------------------
-- Colors - vocabulary roughly based on GTK themes

baseColor :: T.Text
baseColor = "#f7f7f7"

bgColor :: T.Text
bgColor = "#d6d6d6"

fgColor :: T.Text
fgColor = "#2c2c2c"

bordersColor :: T.Text
bordersColor = darken' 0.3 bgColor

warningColor :: T.Text
warningColor = "#ffca28"

errorColor :: T.Text
errorColor = "#e53935"

selectedFgColor :: T.Text
selectedFgColor = "#ffffff"

selectedBgColor :: T.Text
selectedBgColor = "#4a79c7"

selectedBordersColor :: T.Text
selectedBordersColor = "#4a79c7"

backdropBaseColor :: T.Text
backdropBaseColor = baseColor

backdropTextColor :: T.Text
backdropTextColor = blend' 0.95 fgColor backdropBaseColor

backdropFgColor :: T.Text
backdropFgColor = blend' 0.75 fgColor bgColor

--------------------------------------------------------------------------------
-- Color functions

blend' :: Float -> T.Text -> T.Text -> T.Text
blend' wt c0 c1 = sRGB24showT $ blend wt (sRGB24readT c0) (sRGB24readT c1)

darken' :: Float -> T.Text -> T.Text
darken' wt = sRGB24showT . darken wt . sRGB24readT

sRGB24readT :: (RealFrac a, Floating a) => T.Text -> Colour a
sRGB24readT = sRGB24read . T.unpack

sRGB24showT :: (RealFrac a, Floating a) => Colour a -> T.Text
sRGB24showT = T.pack . sRGB24show

--------------------------------------------------------------------------------
-- Fonts

data Slant
  = Roman
  | Italic
  | Oblique
  deriving (Eq, Show)

data Weight
  = Light
  | Medium
  | Demibold
  | Bold
  | Black
  deriving (Eq, Show)

data FontData = FontData
  { weight :: Maybe Weight
  , slant :: Maybe Slant
  , size :: Maybe Int
  , pixelsize :: Maybe Int
  , antialias :: Maybe Bool
  }

type FontBuilder = FontData -> T.Text

buildFont :: Maybe T.Text -> FontData -> T.Text
buildFont Nothing _ = "fixed"
buildFont
  (Just fam)
  FontData
    { weight = w
    , slant = l
    , size = s
    , pixelsize = p
    , antialias = a
    } =
    T.intercalate ":" $ ["xft", fam] ++ elems
    where
      elems =
        [ T.concat [k, "=", v]
        | (k, Just v) <-
            [ ("weight", showLower w)
            , ("slant", showLower l)
            , ("size", showLower s)
            , ("pixelsize", showLower p)
            , ("antialias", showLower a)
            ]
        ]
      showLower :: Show a => Maybe a -> Maybe T.Text
      showLower = fmap (T.toLower . T.pack . show)

fallbackFont :: FontBuilder
fallbackFont = buildFont Nothing

--------------------------------------------------------------------------------
-- Default font and data

defFontData :: FontData
defFontData =
  FontData
    { size = Just 10
    , antialias = Just True
    , weight = Nothing
    , slant = Nothing
    , pixelsize = Nothing
    }

defFontFamily :: T.Text
defFontFamily = "DejaVu Sans"

-- defFontDep :: IODependency FontBuilder
-- defFontDep = fontDependency "DejaVu Sans"

-- defFontTree :: IOTree FontBuilder
-- defFontTree = fontTree "DejaVu Sans"

--------------------------------------------------------------------------------
-- Complete themes

tabbedTheme :: FontBuilder -> D.Theme
tabbedTheme fb =
  D.def
    { D.fontName = T.unpack $ fb $ defFontData {weight = Just Bold}
    , D.activeTextColor = T.unpack fgColor
    , D.activeColor = T.unpack bgColor
    , D.activeBorderColor = T.unpack bgColor
    , D.inactiveTextColor = T.unpack backdropTextColor
    , D.inactiveColor = T.unpack backdropFgColor
    , D.inactiveBorderColor = T.unpack backdropFgColor
    , D.urgentTextColor = T.unpack $ darken' 0.5 errorColor
    , D.urgentColor = T.unpack errorColor
    , D.urgentBorderColor = T.unpack errorColor
    , -- this is in a newer version
      -- , D.activeBorderWidth     = 0
      -- , D.inactiveBorderWidth   = 0
      -- , D.urgentBorderWidth     = 0

      D.decoHeight = 20
    , D.windowTitleAddons = []
    , D.windowTitleIcons = []
    }

promptTheme :: FontBuilder -> P.XPConfig
promptTheme fb =
  P.def
    { P.font = T.unpack $ fb $ defFontData {size = Just 12}
    , P.bgColor = T.unpack bgColor
    , P.fgColor = T.unpack fgColor
    , P.fgHLight = T.unpack selectedFgColor
    , P.bgHLight = T.unpack selectedBgColor
    , P.borderColor = T.unpack bordersColor
    , P.promptBorderWidth = 1
    , P.height = 35
    , P.position = P.CenteredAt 0.5 0.5
    , P.historySize = 0
    }