ENH move theming to own module

This commit is contained in:
Nathan Dwarshuis 2020-03-16 13:50:08 -04:00
parent 6c385c27cb
commit 7787006621
4 changed files with 188 additions and 107 deletions

View File

@ -1,27 +1,17 @@
import Xmobar.Screensaver
import qualified Theme as T
import Data.List
import Xmobar
import XMonad (getXMonadDir)
fgColor0 :: String
fgColor0 = "black"
fgColor1 :: String
fgColor1 = "#888888"
bgColor0 :: String
bgColor0 = "#eeeeee"
bdColor :: String
bdColor = "#cccccc"
wrapColor :: String -> String -> String
wrapColor c s = "<fc=" ++ c ++ ">" ++ s ++ "</fc>"
sep :: String
sep = wrapColor fgColor1 " : "
sep = wrapColor T.backdropFgColor " : "
myTemplate :: String
myTemplate = formatTemplate left right
@ -40,20 +30,38 @@ myTemplate = formatTemplate left right
, "%date%"
]
barFont :: String
barFont = T.fmtFontXFT T.font
{ T.family = "DejaVu Sans Mono"
, T.size = Just 11
, T.weight = Just T.Bold
}
iconFont :: String
iconFont = T.fmtFontXFT T.font
{ T.family = "FontAwesome"
, T.size = Nothing
, T.pixelsize = Just 13
}
blockFont :: String
blockFont = T.fmtFontXFT T.font
{ T.family = "Symbola"
, T.size = Just 13
, T.weight = Just T.Bold
}
config :: String -> Config
config confDir = defaultConfig {
font = "xft:DejaVu Sans Mono:size=11:bold:antialias=true"
, additionalFonts =
[ "xft:FontAwesome:pixelsize=13:antialias=true:hinting=true"
, "xft:Symbola:size=13:bold:antialias=true"
]
font = barFont
, additionalFonts = [ iconFont, blockFont ]
, textOffset = 16
, textOffsets = [ 16, 17 ]
, bgColor = bgColor0
, fgColor = fgColor0
, bgColor = T.bgColor
, fgColor = T.fgColor
, position = BottomSize C 100 24
, border = NoBorder
, borderColor = bdColor
, borderColor = T.bordersColor
, sepChar = "%"
, alignSep = "}{"
@ -73,16 +81,16 @@ config confDir = defaultConfig {
, "--"
, "-O", "<fn=1>\xf028</fn>"
, "-o", "<fn=1>\xf026 </fn>"
, "-c", fgColor0
, "-C", fgColor0
, "-c", T.fgColor
, "-C", T.fgColor
]
, Run $ Battery [ "--template", "<acstatus><left>"
, "--Low", "10"
, "--High", "80"
, "--low", "red"
, "--normal", fgColor0
, "--high", fgColor0
, "--normal", T.fgColor
, "--high", T.fgColor
, "--"
, "-P"
, "-o" , "<fn=1>\xf0e7</fn>"
@ -103,9 +111,9 @@ config confDir = defaultConfig {
, Run $ Locks
[ "-N", "<fn=2>\x1f13d</fn>"
, "-n", wrapColor fgColor1 "<fn=2>\x1f13d</fn>"
, "-n", wrapColor T.backdropFgColor "<fn=2>\x1f13d</fn>"
, "-C", "<fn=2>\x1f132</fn>"
, "-c", wrapColor fgColor1 "<fn=2>\x1f132</fn>"
, "-c", wrapColor T.backdropFgColor "<fn=2>\x1f132</fn>"
, "-s", ""
, "-S", ""
, "-d", "<fn=2> </fn>"
@ -113,7 +121,7 @@ config confDir = defaultConfig {
, Run $ Date "%Y-%m-%d %H:%M" "date" 10
, Run $ Screensaver ("<fn=1>\xf254</fn>", fgColor0, fgColor1) 10
, Run $ Screensaver ("<fn=1>\xf254</fn>", T.fgColor, T.fgColor) 10
, Run UnsafeStdinReader
]

View File

@ -5,6 +5,7 @@ module Main (main) where
import ACPI
import SendXMsg
import Theme
import Control.Monad (mapM_, forM_, void, when)
@ -97,29 +98,6 @@ spawnPipe' x = io $ do
closeFd rd
return (p, h)
myTopBarTheme = def
{ fontName = myFont
, inactiveBorderColor = "#999999"
, inactiveColor = "#999999"
, inactiveTextColor = "#999999"
, activeBorderColor = "#d6d6d6"
, activeColor = "#d6d6d6"
, activeTextColor = "#d6d6d6"
-- , urgentBorderColor = red
-- , urgentTextColor = yellow
, decoHeight = 20
}
myTabbedTheme = def
{ fontName = myFont
, activeColor = "#d6d6d6"
, activeTextColor = "black"
, activeBorderColor = "#d6d6d6"
, inactiveColor = "#999999"
, inactiveTextColor = "#333333"
, inactiveBorderColor = "#999999"
}
myWorkspaces = map show [1..10 :: Int]
myVMWorkspace = "VM"
@ -129,7 +107,7 @@ myLayouts = onWorkspace myVMWorkspace (noBorders Full)
-- $ onWorkspace myGimpWorkspace gimpLayout
$ tall ||| single ||| full
where
addTopBar = noFrillsDeco shrinkText myTopBarTheme
addTopBar = noFrillsDeco shrinkText tabbedTheme
tall = named "Tall"
$ avoidStruts
$ addTopBar
@ -139,7 +117,7 @@ myLayouts = onWorkspace myVMWorkspace (noBorders Full)
-- $ addTopBar
$ avoidStruts
$ noBorders
$ tabbedAlways shrinkText myTabbedTheme
$ tabbedAlways shrinkText tabbedTheme
full = named "Full"
$ noBorders Full
-- gimpLayout = named "Gimp Layout"
@ -230,7 +208,7 @@ myEventHook ClientMessageEvent { ev_message_type = t, ev_data = d }
let acpiTag = readMaybe tag :: Maybe ACPIEvent
forM_ acpiTag $ \case
Power -> myPowerPrompt
Sleep -> confirmPrompt myPromptTheme "suspend?" runSuspend
Sleep -> confirmPrompt promptTheme "suspend?" runSuspend
LidClose -> do
status <- io isDischarging
forM_ status $ \s -> runScreenLock >> when s runSuspend
@ -248,57 +226,6 @@ removeEmptyWorkspaceByTag' tag = do
-- this will be enough to make it disappear.
removeEmptyWorkspaceByTag tag
-- themes
myFont = "xft:DejaVu Sans:size=11:autohint=false"
-- base00 = "#657b83"
-- base01 = "#586e75"
-- base02 = "#073642"
-- base03 = "#002b36"
-- base0 = "#839496"
-- base1 = "#93a1a1"
-- base2 = "#eee8d5"
-- base3 = "#fdf6e3"
-- yellow = "#b58900"
-- orange = "#cb4b16"
-- red = "#dc322f"
-- magenta = "#d33682"
-- violet = "#6c71c4"
-- blue = "#268bd2"
-- cyan = "#2aa198"
-- green = "#859900"
-- gap = 10
-- topbar = 10
-- border = 0
-- prompt = 20
-- status = 20
-- active = blue
-- activeWarn = red
-- inactive = base02
-- focusColor = blue
-- unfocusColor = base02
myPromptTheme = def
{ font = myFont
, bgColor = "#eeeeee"
, fgColor = "#282828"
, fgHLight = "white"
, bgHLight = "#268bd2"
, borderColor = "white"
, promptBorderWidth = 0
, height = 30
, position = CenteredAt 0.5 0.5
}
-- hotPromptTheme = myPromptTheme
-- { bgColor = red
-- , fgColor = base3
-- , position = Top
-- }
-- TODO is there a better way to get the prompt to say what I want?
data PowerPrompt = PowerPrompt
@ -326,7 +253,7 @@ myPowerPrompt = mkXPrompt PowerPrompt conf comps
. (`lookup` commands)
where
comps = mkComplFunFromList' (map fst commands)
conf = myPromptTheme
conf = promptTheme
commands =
[ ("poweroff", runPowerOff)
, ("suspend", runScreenLock >> runSuspend)
@ -335,7 +262,7 @@ myPowerPrompt = mkXPrompt PowerPrompt conf comps
]
myQuitPrompt :: X ()
myQuitPrompt = confirmPrompt myPromptTheme "quit?" $ io exitSuccess
myQuitPrompt = confirmPrompt promptTheme "quit?" $ io exitSuccess
-- shell commands
@ -508,9 +435,11 @@ runVolumeUp = void (raiseVolume 2)
runVolumeMute :: X ()
runVolumeMute = void toggleMute
-- TODO write this in haskell
runToggleBluetooth :: X ()
runToggleBluetooth = spawn "togglebt"
-- TODO write these in haskell
runIncBacklight :: X ()
runIncBacklight = spawnCmd "adj_backlight" ["up"]

141
lib/Theme.hs Normal file
View File

@ -0,0 +1,141 @@
{-# LANGUAGE LambdaCase #-}
module Theme where
import Data.Char
import Data.Colour
import Data.Colour.SRGB
import Data.List
import qualified XMonad.Layout.Decoration as D
import qualified XMonad.Prompt as P
-- Colors
baseColor :: String
baseColor = "#f7f7f7"
bgColor :: String
bgColor = "#d6d6d6"
fgColor :: String
fgColor = "#000000"
bordersColor :: String
bordersColor = darken' 0.85 bgColor
warningColor :: String
warningColor = "#ffca28"
errorColor :: String
errorColor = "#e53935"
selectedFgColor :: String
selectedFgColor = "#ffffff"
selectedBgColor :: String
selectedBgColor = "#3399ff"
backdropBaseColor :: String
backdropBaseColor = baseColor
backdropTextColor :: String
backdropTextColor = blend' 0.95 fgColor backdropBaseColor
backdropFgColor :: String
backdropFgColor = blend' 0.75 fgColor bgColor
-- Color functions
blend' :: Float -> String -> String -> String
blend' wt c0 c1 = sRGB24show $ blend wt (sRGB24read c0) (sRGB24read c1)
darken' :: Float -> String -> String
darken' wt = sRGB24show . darken wt . sRGB24read
-- Fonts
data Slant = Roman | Italic | Oblique deriving (Eq, Show)
data Weight = Light | Medium | Demibold | Bold | Black deriving (Eq, Show)
data ThemeFont = ThemeFont
{ family :: String
, weight :: Maybe Weight
, slant :: Maybe Slant
, size :: Maybe Int
, pixelsize :: Maybe Int
, antialias :: Maybe Bool
}
fmtFontXFT :: ThemeFont -> String
fmtFontXFT ThemeFont
-- TODO there should be a better way to do this...
{ family = f
, weight = w
, slant = l
, size = s
, pixelsize = i
, antialias = a
} = "xft:" ++ intercalate ":" (filter (not . null) elems)
where
elems = [ f
, fmt "weight" w
, fmt "slant" l
, fmt "size" s
, fmt "pixelsize" i
, fmt "antialias" a]
fmt :: Show a => String -> Maybe a -> String
fmt e = \case
Just d -> e ++ "=" ++ map toLower (show d)
Nothing -> ""
font = ThemeFont
{ family = "DejaVu Sans"
, size = Just 11
, antialias = Just True
, weight = Nothing
, slant = Nothing
, pixelsize = Nothing
}
-- Complete themes
tabbedTheme = D.def
{ D.fontName = fmtFontXFT font
, D.activeTextColor = fgColor
, D.activeColor = bgColor
, D.activeBorderColor = bgColor
, D.inactiveTextColor = backdropTextColor
, D.inactiveColor = backdropFgColor
, D.inactiveBorderColor = backdropFgColor
, D.urgentTextColor = darken' 0.5 errorColor
, D.urgentColor = errorColor
, D.urgentBorderColor = errorColor
-- this is in a newer version
-- , D.activeBorderWidth = 0
-- , D.inactiveBorderWidth = 0
-- , D.urgentBorderWidth = 0
, D.decoHeight = 20
, D.windowTitleAddons = []
, D.windowTitleIcons = []
}
promptTheme = P.def
{ P.font = fmtFontXFT font
, P.bgColor = bgColor
, P.fgColor = fgColor
, P.fgHLight = selectedFgColor
, P.bgHLight = selectedBgColor
, P.borderColor = bordersColor
, P.promptBorderWidth = 1
, P.height = 30
, P.position = P.CenteredAt 0.5 0.5
}

View File

@ -7,9 +7,12 @@ library
hs-source-dirs: lib
exposed-modules: SendXMsg
, ACPI
, Theme
, Xmobar.Screensaver
build-depends: base
, X11 >= 1.9.1
, colour >= 2.3.5
, xmonad-contrib >= 0.13
, xmobar
ghc-options: -Wall -Werror -fno-warn-missing-signatures
default-language: Haskell2010