ENH move theming to own module

bin/xmobar.hs

@@ -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"
+  font = barFont
-  , additionalFonts =
+  , additionalFonts = [ iconFont, blockFont ]
-    [ "xft:FontAwesome:pixelsize=13:antialias=true:hinting=true"
-    , "xft:Symbola:size=13:bold:antialias=true"
-    ]
   , textOffset = 16
   , textOffsets = [ 16, 17 ]
-  , bgColor = bgColor0
+  , bgColor = T.bgColor
-  , fgColor = fgColor0
+  , 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", T.fgColor
-        , "-C", fgColor0
+        , "-C", T.fgColor
         ]
 
       , Run $ Battery [ "--template", "<acstatus><left>"
                     , "--Low", "10"
                     , "--High", "80"
                     , "--low", "red"
-                    , "--normal", fgColor0
+                    , "--normal", T.fgColor
-                    , "--high", fgColor0
+                    , "--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
       ]

bin/xmonad.hs

@@ -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"]
 

lib/Theme.hs

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

my-xmonad.cabal

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