From b4565c530add8622bfe09a8d0d98f9dae1a6c805 Mon Sep 17 00:00:00 2001
From: Jens Nolte <jens@nightmarestudio.de>
Date: Sat, 1 Feb 2020 04:27:18 +0100
Subject: [PATCH] Unify color types
---
src/QBar/BlockOutput.hs | 35 ++-------------
src/QBar/Cli.hs | 6 +--
src/QBar/ControlSocket.hs | 4 +-
src/QBar/Filter.hs | 88 --------------------------------------
src/QBar/Server.hs | 19 +++------
src/QBar/Themes.hs | 89 +++++++++++++++++++++++++++++++++------
6 files changed, 88 insertions(+), 153 deletions(-)
delete mode 100644 src/QBar/Filter.hs
diff --git a/src/QBar/BlockOutput.hs b/src/QBar/BlockOutput.hs
index 1b20587..5869ae4 100644
--- a/src/QBar/BlockOutput.hs
+++ b/src/QBar/BlockOutput.hs
@@ -11,7 +11,6 @@ import Data.Int (Int64)
import qualified Data.Text.Lazy as T
-
data BlockOutput = BlockOutput
{ _fullText :: BlockText
, _shortText :: Maybe BlockText
@@ -38,9 +37,11 @@ data BlockTextSegment = BlockTextSegment {
importance :: Importance,
text :: T.Text
}
- | PangoTextSegment T.Text
+ | PangoTextSegment PangoText
deriving (Eq, Show)
+type PangoText = T.Text
+
type Importance = Float
$(deriveJSON defaultOptions ''BlockOutput)
@@ -171,32 +172,4 @@ pangoText :: T.Text -> BlockText
pangoText pango = BlockText [PangoTextSegment pango]
surroundWith :: (T.Text -> BlockText) -> T.Text -> T.Text -> BlockText -> BlockText
-surroundWith format left right middle = format left <> middle <> format right
-
-data Color = ColorRGB Float Float Float | ColorRGBA Float Float Float Float
-colorToHex :: Color -> T.Text
-colorToHex = colorToHex'
- where
- colorToHex' :: Color -> T.Text
- colorToHex' (ColorRGB r g b) = "#" <> (toDualHex . floor) (r * 255) <> (toDualHex . floor) (g * 255) <> (toDualHex . floor) (b * 255)
- colorToHex' (ColorRGBA r g b a) = "#" <> (toDualHex . floor) (r * 255) <> (toDualHex . floor) (g * 255) <> (toDualHex . floor) (b * 255) <> (toDualHex . floor) (a * 255)
- toHex :: Int -> T.Text
- toHex 0 = "0"
- toHex 1 = "1"
- toHex 2 = "2"
- toHex 3 = "3"
- toHex 4 = "4"
- toHex 5 = "5"
- toHex 6 = "6"
- toHex 7 = "7"
- toHex 8 = "8"
- toHex 9 = "9"
- toHex 10 = "A"
- toHex 11 = "B"
- toHex 12 = "C"
- toHex 13 = "D"
- toHex 14 = "E"
- toHex 15 = "F"
- toHex x = toHex $ mod x 16
- toDualHex :: Int -> T.Text
- toDualHex x = toHex (div x 16) <> toHex x
+surroundWith format left right middle = format left <> middle <> format right
\ No newline at end of file
diff --git a/src/QBar/Cli.hs b/src/QBar/Cli.hs
index 512e0e5..75fdfed 100644
--- a/src/QBar/Cli.hs
+++ b/src/QBar/Cli.hs
@@ -5,13 +5,13 @@ module QBar.Cli where
import qualified Data.Text as T
import Options.Applicative
-data BarCommand = BarServer | NoFilter | RainbowFilter
+data BarCommand = BarServer | DefaultTheme | RainbowTheme
barCommandParser :: Parser BarCommand
barCommandParser = hsubparser
( command "server" (info (pure BarServer) (progDesc "Start a new qbar server. Should be called by swaybar, i3bar or or another i3bar-protocol compatible host process.")) <>
- command "default" (info (pure NoFilter) (progDesc "Send a message to a running qbar server.")) <>
- command "rainbow" (info (pure RainbowFilter) (progDesc "Send a message to a running qbar server."))
+ command "default" (info (pure DefaultTheme) (progDesc "Send a message to a running qbar server.")) <>
+ command "rainbow" (info (pure RainbowTheme) (progDesc "Send a message to a running qbar server."))
)
data MainOptions = MainOptions {
diff --git a/src/QBar/ControlSocket.hs b/src/QBar/ControlSocket.hs
index 195a8f1..6dde25c 100644
--- a/src/QBar/ControlSocket.hs
+++ b/src/QBar/ControlSocket.hs
@@ -5,8 +5,6 @@ module QBar.ControlSocket where
import QBar.Cli (MainOptions(..))
import QBar.Core
--- TODO: remove dependency?
-import QBar.Filter
import QBar.BlockOutput
import Control.Exception (handle)
@@ -35,7 +33,7 @@ import System.Environment (getEnv)
type CommandChan = TChan Command
-data Command = SetFilter Filter
+data Command = SetTheme T.Text
| Block
deriving Show
diff --git a/src/QBar/Filter.hs b/src/QBar/Filter.hs
deleted file mode 100644
index 125d9af..0000000
--- a/src/QBar/Filter.hs
+++ /dev/null
@@ -1,88 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-
-module QBar.Filter where
-
-import QBar.BlockOutput
-
-import Control.Monad.State.Lazy (State, evalState, get, put)
-import Data.Aeson.TH
-import Data.Colour.RGBSpace.HSV (hsv)
-import qualified Data.Text.Lazy as T
-import Control.Lens hiding (index)
-
-import Numeric (showHex)
-import Data.Colour.RGBSpace
-
-
-data Filter = StaticFilter StaticFilter
- | AnimatedFilter AnimatedFilter
- deriving Show
-
-data StaticFilter = None
- deriving Show
-
-data AnimatedFilter = Rainbow
- deriving Show
-
-$(deriveJSON defaultOptions ''Filter)
-$(deriveJSON defaultOptions ''StaticFilter)
-$(deriveJSON defaultOptions ''AnimatedFilter)
-
-isAnimatedFilter :: Filter -> Bool
-isAnimatedFilter (AnimatedFilter _) = True
-isAnimatedFilter _ = False
-
-applyFilter :: Filter -> Double -> [BlockOutput] -> [BlockOutput]
-applyFilter (StaticFilter None) = static id
-applyFilter (AnimatedFilter Rainbow) = rainbow
-
-static :: a -> Double -> a
-static fn _ = fn
-
-
-coloredText :: T.Text -> T.Text -> T.Text
-coloredText color text = "<span color='" <> color <> "'>" <> text <> "</span>"
-
-
-pangoColor :: RGB Double -> T.Text
-pangoColor (RGB r g b) =
- let r' = hexColorComponent r
- g' = hexColorComponent g
- b' = hexColorComponent b
- in "#" <> r' <> g' <> b'
- where
- hexColorComponent :: Double -> T.Text
- hexColorComponent val = paddedHexComponent $ T.pack $ showHex (max 0 $ min 255 (truncate (val * 255) :: Int)) ""
- paddedHexComponent hex =
- let len = 2 - T.length hex
- padding = if len == 1 then "0" else ""
- in padding <> hex
-
-
-rainbow :: Double -> [BlockOutput] -> [BlockOutput]
-rainbow time blocks = reverse $ evalState (mapM rainbowBlock $ reverse blocks) 0
- where
- rainbowBlock :: BlockOutput -> State Integer BlockOutput
- rainbowBlock block = do
- let text = removePango $ block^.fullText
- let chars = T.unpack . T.reverse $ text
- coloredChars <- mapM rainbowChar chars
- let rainbowText = T.concat . reverse $ coloredChars
- return $ fullText .~ pangoText rainbowText $ block
- rainbowChar :: Char -> State Integer T.Text
- rainbowChar char = do
- color <- nextRainbowColor
- return $ coloredText color $ T.singleton char
- nextRainbowColor :: State Integer T.Text
- -- nextRainbowColor = state $ \index -> (rainbowColor (fromInteger index), index + 1)
- nextRainbowColor = do
- index <- get
- put $ index + 1
- return $ rainbowColor (fromInteger index + time * 10)
-
-
-rainbowColor :: Double -> T.Text
-rainbowColor position =
- let hue' = position * 3
- color = hsv hue' 0.8 1.0
- in pangoColor color
diff --git a/src/QBar/Server.hs b/src/QBar/Server.hs
index e17590a..86a19ef 100644
--- a/src/QBar/Server.hs
+++ b/src/QBar/Server.hs
@@ -6,20 +6,17 @@ import QBar.BlockOutput
import QBar.Core
import QBar.Cli
import QBar.ControlSocket
-import QBar.Filter
import QBar.Host
import QBar.Themes
import Control.Monad (forever, when, unless, forM_)
-import Control.Monad.STM (atomically)
import Control.Concurrent.Async
-import Control.Concurrent.STM.TChan (newTChanIO, readTChan)
+import Control.Concurrent.STM.TChan (newTChanIO)
import Data.Aeson (encode, decode, ToJSON, toJSON, object, (.=))
import Data.ByteString.Lazy (hPut)
import qualified Data.ByteString.Char8 as BSSC8
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as C8
-import Data.IORef
import Data.Maybe (fromMaybe)
import qualified Data.Text.Lazy as T
import Pipes
@@ -105,10 +102,6 @@ runBarServer defaultBarConfig options = runBarHost barServer (swayBarInput optio
where
barServer :: Consumer [BlockOutput] BarIO ()
barServer = do
- -- Create IORef to contain the active filter
- let initialBlockFilter = StaticFilter None
- activeFilter <- liftIO $ newIORef initialBlockFilter
-
-- Load blocks
lift $ do
when (indicator options) $ addBlock renderIndicator
@@ -123,10 +116,8 @@ runBarServer defaultBarConfig options = runBarHost barServer (swayBarInput optio
-- Update bar on control socket messages
socketUpdateAsync <- liftIO $ async $ forever $ do
- command <- atomically $ readTChan commandChan
- case command of
- SetFilter blockFilter -> atomicWriteIORef activeFilter blockFilter
- Block -> error "TODO"
+ -- command <- atomically $ readTChan commandChan
+ void $ error "TODO"
updateBar' bar
liftIO $ link socketUpdateAsync
@@ -140,5 +131,5 @@ runQBar :: BarIO () -> MainOptions -> IO ()
runQBar barConfiguration options@MainOptions{barCommand} = runCommand barCommand
where
runCommand BarServer = runBarServer barConfiguration options
- runCommand NoFilter = sendIpc options $ SetFilter $ StaticFilter None
- runCommand RainbowFilter = sendIpc options $ SetFilter $ AnimatedFilter Rainbow
+ runCommand DefaultTheme = sendIpc options $ SetTheme "default"
+ runCommand RainbowTheme = sendIpc options $ SetTheme "rainbow"
diff --git a/src/QBar/Themes.hs b/src/QBar/Themes.hs
index 63531f9..7e48b69 100644
--- a/src/QBar/Themes.hs
+++ b/src/QBar/Themes.hs
@@ -2,9 +2,16 @@ module QBar.Themes where
import QBar.BlockOutput
+import Control.Lens ((^.), (.~))
+import Control.Monad.State.Lazy (State, evalState, get, put)
+import Data.Colour.RGBSpace
+import Data.Colour.RGBSpace.HSV (hsv)
import qualified Data.Text.Lazy as T
+import Numeric (showHex)
-import Control.Lens
+
+
+data Color = ColorRGB (RGB Double) | ColorRGBA (RGB Double) Double
type Theme = [BlockOutput] -> [(T.Text, Maybe T.Text)]
@@ -29,15 +36,12 @@ mkTheme theming' = map themeBlock
themeBlockText :: SimplifiedTheme -> BlockText -> T.Text
themeBlockText theming (BlockText b) = foldr ((<>) . themeSegment theming) "" b
themeSegment :: SimplifiedTheme -> BlockTextSegment -> T.Text
- themeSegment theming BlockTextSegment {active, importance, text} = (applyTheme $ theming active importance) text
+ themeSegment theming BlockTextSegment {active, importance, text} = (coloredText' $ theming active importance) text
themeSegment _ (PangoTextSegment text) = text
- applyTheme :: (Color, Maybe Color) -> T.Text -> T.Text
- applyTheme (fc, Just bc) s = "<span color='" <> colorToHex fc <> "' background='" <> colorToHex bc <> "'>" <> s <> "</span>"
- applyTheme (fc, Nothing) s = "<span color='" <> colorToHex fc <> "'>" <> s <> "</span>"
invalidColor :: Color
-invalidColor = ColorRGBA (0x96 / 255) (0x98 / 255) (0x96 / 255) (0x77 / 255)
+invalidColor = ColorRGBA (RGB (0x96 / 255) (0x98 / 255) (0x96 / 255)) (0x77 / 255)
invalidSimplifiedTheme :: SimplifiedTheme
@@ -53,11 +57,68 @@ defaultTheme = mkTheme defaultTheme'
where
defaultTheme' :: SimplifiedTheme
defaultTheme' active importance
- | isCritical importance, active = (ColorRGB 0 0 0, Just $ ColorRGB 1 0 0)
- | isCritical importance = (ColorRGB 0.8 0.15 0.15, Nothing)
- | isError importance, active = (ColorRGB 1 0.3 0, Nothing)
- | isError importance = (ColorRGB 0.7 0.35 0.2, Nothing)
- | isWarning importance,active = (ColorRGB 1 0.9 0, Nothing)
- | isWarning importance = (ColorRGB 0.6 0.6 0, Nothing)
- | otherwise, active = (ColorRGB 1 1 1, Nothing)
- | otherwise = (ColorRGB (0x96 / 255) (0x98 / 255) (0x96 / 255), Nothing)
+ | isCritical importance, active = (ColorRGB (RGB 0 0 0), Just $ ColorRGB (RGB 1 0 0))
+ | isCritical importance = (ColorRGB (RGB 0.8 0.15 0.15), Nothing)
+ | isError importance, active = (ColorRGB (RGB 1 0.3 0), Nothing)
+ | isError importance = (ColorRGB (RGB 0.7 0.35 0.2), Nothing)
+ | isWarning importance,active = (ColorRGB (RGB 1 0.9 0), Nothing)
+ | isWarning importance = (ColorRGB (RGB 0.6 0.6 0), Nothing)
+ | otherwise, active = (ColorRGB (RGB 1 1 1), Nothing)
+ | otherwise = (ColorRGB (RGB (0x96 / 255) (0x98 / 255) (0x96 / 255)), Nothing)
+
+
+rainbowTheme :: Double -> [BlockOutput] -> [BlockOutput]
+rainbowTheme time blocks = reverse $ evalState (mapM rainbowBlock $ reverse blocks) 0
+ where
+ rainbowBlock :: BlockOutput -> State Integer BlockOutput
+ rainbowBlock block = do
+ let text = removePango $ block ^. fullText
+ let chars = T.unpack . T.reverse $ text
+ coloredChars <- mapM rainbowChar chars
+ let rainbowText = T.concat . reverse $ coloredChars
+ return $ fullText .~ pangoText rainbowText $ block
+ rainbowChar :: Char -> State Integer T.Text
+ rainbowChar char = do
+ color <- nextRainbowColor
+ return $ coloredText color $ T.singleton char
+ nextRainbowColor :: State Integer Color
+ -- nextRainbowColor = state $ \index -> (rainbowColor (fromInteger index), index + 1)
+ nextRainbowColor = do
+ index <- get
+ put $ index + 1
+ return $ rainbowColor (fromInteger index + time * 10)
+ rainbowColor :: Double -> Color
+ rainbowColor position =
+ let hue' = position * 3
+ color = hsv hue' 0.8 1.0
+ in ColorRGB color
+
+
+coloredText :: Color -> T.Text -> PangoText
+coloredText color text = "<span color='" <> pangoColor color <> "'>" <> text <> "</span>"
+
+coloredText' :: (Color, Maybe Color) -> T.Text -> PangoText
+coloredText' (foreground, Nothing) text = "<span color='" <> pangoColor foreground <> "'>" <> text <> "</span>"
+coloredText' (foreground, Just background) text = "<span color='" <> pangoColor foreground <> "' background='" <> pangoColor background <> "'>" <> text <> "</span>"
+
+
+pangoColor :: Color -> T.Text
+pangoColor = pangoColor'
+ where
+ pangoColor' :: Color -> T.Text
+ pangoColor' (ColorRGB rgb) = pangoRGB rgb
+ pangoColor' (ColorRGBA rgb a) = pangoRGB rgb <> hexColorComponent a
+
+ pangoRGB :: RGB Double -> T.Text
+ pangoRGB (RGB r g b) =
+ let r' = hexColorComponent r
+ g' = hexColorComponent g
+ b' = hexColorComponent b
+ in "#" <> r' <> g' <> b'
+ hexColorComponent :: Double -> T.Text
+ hexColorComponent val = paddedHexComponent $ T.pack $ showHex (max 0 $ min 255 (truncate (val * 255) :: Int)) ""
+ paddedHexComponent :: T.Text -> T.Text
+ paddedHexComponent hex =
+ let len = 2 - T.length hex
+ padding = if len == 1 then "0" else ""
+ in padding <> hex
--
GitLab