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

{-# LANGUAGE OverloadedStrings #-}

--------------------------------------------------------------------------------
-- | 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 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
  }