From b55e8f7575e34c65b735a4bceb14dde66a7ef9b7 Mon Sep 17 00:00:00 2001
From: Jens Nolte <jens@nightmarestudio.de>
Date: Mon, 3 Feb 2020 04:36:44 +0100
Subject: [PATCH] Change theming from Pango to 'ThemedBlockOutput'
---
src/QBar/BlockOutput.hs | 10 ++-
src/QBar/Pango.hs | 41 ++++++++++++
src/QBar/Server.hs | 12 ++--
src/QBar/Theme.hs | 141 +++++++++++++++++++++-------------------
4 files changed, 127 insertions(+), 77 deletions(-)
create mode 100644 src/QBar/Pango.hs
diff --git a/src/QBar/BlockOutput.hs b/src/QBar/BlockOutput.hs
index cce0087..9e0207a 100644
--- a/src/QBar/BlockOutput.hs
+++ b/src/QBar/BlockOutput.hs
@@ -28,12 +28,10 @@ instance Monoid BlockText where
data BlockTextSegment = BlockTextSegment {
active :: Bool,
importance :: Importance,
- text :: T.Text
+ segmentText :: T.Text
}
deriving (Eq, Show)
-type PangoText = T.Text
-
type Importance = Float
$(deriveJSON defaultOptions ''BlockOutput)
@@ -135,16 +133,16 @@ rawText :: BlockText -> T.Text
rawText (BlockText b) = foldMap rawTextFromSegment b
where
rawTextFromSegment :: BlockTextSegment -> T.Text
- rawTextFromSegment BlockTextSegment{text} = text
+ rawTextFromSegment BlockTextSegment{segmentText} = segmentText
printedLength :: BlockText -> Int64
printedLength (BlockText b) = sum . map segmentLength $ b
where
segmentLength :: BlockTextSegment -> Int64
- segmentLength BlockTextSegment { text } = T.length text
+ segmentLength BlockTextSegment { segmentText } = T.length segmentText
mkText :: Bool -> Importance -> T.Text -> BlockText
-mkText active importance text = BlockText [BlockTextSegment { text = pangoFriendly text, active, importance }]
+mkText active importance segmentText = BlockText [BlockTextSegment { segmentText = pangoFriendly segmentText, active, importance }]
where
pangoFriendly :: T.Text -> T.Text
pangoFriendly = T.replace "<" "<" . T.replace ">" ">" . T.replace "&" "&"
diff --git a/src/QBar/Pango.hs b/src/QBar/Pango.hs
new file mode 100644
index 0000000..c9cd4b3
--- /dev/null
+++ b/src/QBar/Pango.hs
@@ -0,0 +1,41 @@
+module QBar.Pango (PangoText, renderPango) where
+
+import QBar.Theme
+
+import Data.Colour.RGBSpace
+import qualified Data.Text.Lazy as T
+import Numeric (showHex)
+
+type PangoText = Text
+
+renderPango :: ThemedBlockText -> PangoText
+renderPango (ThemedBlockText segments) = foldMap renderSegment segments
+ where
+ renderSegment :: ThemedBlockTextSegment -> PangoText
+ renderSegment ThemedBlockTextSegment{themedSegmentText, color, backgroundColor} = coloredText backgroundColor color themedSegmentText
+
+
+coloredText :: Maybe Color -> Color -> Text -> PangoText
+coloredText Nothing foreground text = "<span color='" <> pangoColor foreground <> "'>" <> text <> "</span>"
+coloredText (Just background) foreground text = "<span color='" <> pangoColor foreground <> "' background='" <> pangoColor background <> "'>" <> text <> "</span>"
+
+pangoColor :: Color -> Text
+pangoColor = pangoColor'
+ where
+ pangoColor' :: Color -> Text
+ pangoColor' (ColorRGB rgb) = pangoRGB rgb
+ pangoColor' (ColorRGBA rgb a) = pangoRGB rgb <> hexColorComponent a
+
+ pangoRGB :: RGB Double -> Text
+ pangoRGB (RGB r g b) =
+ let r' = hexColorComponent r
+ g' = hexColorComponent g
+ b' = hexColorComponent b
+ in "#" <> r' <> g' <> b'
+ hexColorComponent :: Double -> Text
+ hexColorComponent val = paddedHexComponent $ T.pack $ showHex (max 0 $ min 255 (truncate (val * 255) :: Int)) ""
+ paddedHexComponent :: Text -> Text
+ paddedHexComponent hex =
+ let len = 2 - T.length hex
+ padding = if len == 1 then "0" else ""
+ in padding <> hex
diff --git a/src/QBar/Server.hs b/src/QBar/Server.hs
index fcccd91..9024c10 100644
--- a/src/QBar/Server.hs
+++ b/src/QBar/Server.hs
@@ -7,6 +7,7 @@ import QBar.Core
import QBar.Cli
import QBar.ControlSocket
import QBar.Host
+import QBar.Pango
import QBar.Theme
import Control.Monad (forever, when, unless, forM_)
@@ -21,7 +22,6 @@ import Data.Maybe (fromMaybe)
import qualified Data.Text.Lazy as T
import Pipes
import System.IO (stdin, stdout, stderr, hFlush)
-import Control.Lens hiding (each, (.=))
renderIndicator :: CachedBlock
-- Using 'cachedBlock' is a hack to actually get the block to update on every bar update (by doing this it will not get a cache later in the pipeline).
@@ -70,9 +70,13 @@ swayBarOutput MainOptions{verbose} = do
swayBarOutput'
encodeOutput :: [BlockOutput] -> BS.ByteString
- encodeOutput bs = encode $ zipWith encodeBlock bs $ defaultTheme bs
- encodeBlock :: BlockOutput -> (T.Text, Maybe T.Text) -> RenderBlock
- encodeBlock b (fullText', shortText') = RenderBlock fullText' shortText' (b ^. blockName)
+ encodeOutput bs = encode $ map encodeBlock $ defaultTheme bs
+ encodeBlock :: ThemedBlockOutput -> RenderBlock
+ encodeBlock ThemedBlockOutput{_fullText, _shortText, _blockName} = RenderBlock {
+ renderBlockFullText = renderPango _fullText,
+ renderBlockShortText = renderPango <$> _shortText,
+ renderBlockName = _blockName
+ }
-- |A producer that reads swaybar/i3bar-input events from stdin and emits them as 'BlockEvent's.
swayBarInput :: MainOptions -> Producer BlockEvent BarIO ()
diff --git a/src/QBar/Theme.hs b/src/QBar/Theme.hs
index 44c9c8a..e890636 100644
--- a/src/QBar/Theme.hs
+++ b/src/QBar/Theme.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DuplicateRecordFields #-}
module QBar.Theme where
import QBar.BlockOutput
@@ -7,35 +8,61 @@ 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 Data.Time.Clock.POSIX (getPOSIXTime)
+import Pipes
data Color = ColorRGB (RGB Double) | ColorRGBA (RGB Double) Double
-
-
-type Theme = [BlockOutput] -> [(PangoText, Maybe PangoText)]
+ deriving (Eq, Show)
+
+data ThemedBlockOutput = ThemedBlockOutput {
+ _fullText :: ThemedBlockText,
+ _shortText :: Maybe ThemedBlockText,
+ _blockName :: Maybe T.Text
+ }
+ deriving (Eq, Show)
+
+newtype ThemedBlockText = ThemedBlockText [ThemedBlockTextSegment]
+ deriving (Eq, Show)
+instance Semigroup ThemedBlockText where
+ (ThemedBlockText a) <> (ThemedBlockText b) = ThemedBlockText (a <> b)
+instance Monoid ThemedBlockText where
+ mempty = ThemedBlockText []
+
+data ThemedBlockTextSegment = ThemedBlockTextSegment {
+ themedSegmentText :: T.Text,
+ color :: Color,
+ backgroundColor :: Maybe Color
+ }
+ deriving (Eq, Show)
+
+
+type Theme = [BlockOutput] -> [ThemedBlockOutput]
type SimplifiedTheme = Bool -> Importance -> (Color, Maybe Color)
-type AnimatedTheme = Double -> Theme
+type AnimatedTheme = Pipe [BlockOutput] [ThemedBlockOutput] IO ()
mkTheme :: SimplifiedTheme -> Theme
mkTheme theming' = map themeBlock
where
- themeBlock :: BlockOutput -> (PangoText, Maybe PangoText)
- themeBlock block = (fullText', shortText')
+ themeBlock :: BlockOutput -> ThemedBlockOutput
+ themeBlock block@BlockOutput{_blockName} = ThemedBlockOutput{_fullText = fullText', _shortText = shortText', _blockName}
where
theming :: SimplifiedTheme
theming
| block ^. invalid = invalidSimplifiedTheme
| otherwise = theming'
- fullText' :: PangoText
+ fullText' :: ThemedBlockText
fullText' = themeBlockText theming $ block ^. fullText
- shortText' :: Maybe PangoText
+ shortText' :: Maybe ThemedBlockText
shortText' = themeBlockText theming <$> block ^. shortText
- themeBlockText :: SimplifiedTheme -> BlockText -> PangoText
- themeBlockText theming (BlockText b) = foldMap (themeSegment theming) b
- themeSegment :: SimplifiedTheme -> BlockTextSegment -> PangoText
- themeSegment theming BlockTextSegment {active, importance, text} = (coloredText' $ theming active importance) text
+ themeBlockText :: SimplifiedTheme -> BlockText -> ThemedBlockText
+ themeBlockText theming (BlockText b) = ThemedBlockText $ themeSegment theming <$> b
+ themeSegment :: SimplifiedTheme -> BlockTextSegment -> ThemedBlockTextSegment
+ themeSegment theming BlockTextSegment {active, importance, segmentText} = mkThemedSegment (theming active importance) segmentText
+
+mkThemedSegment :: (Color, Maybe Color) -> Text -> ThemedBlockTextSegment
+mkThemedSegment (color, backgroundColor) text = ThemedBlockTextSegment{themedSegmentText=text, color, backgroundColor}
invalidColor :: Color
@@ -65,58 +92,38 @@ defaultTheme = mkTheme defaultTheme'
| otherwise = (ColorRGB (RGB (0x96 / 255) (0x98 / 255) (0x96 / 255)), Nothing)
-rainbowTheme :: Double -> Theme
-rainbowTheme time blocks = reverse $ evalState (mapM rainbowBlock $ reverse blocks) 0
+rainbowTheme :: AnimatedTheme
+rainbowTheme = do
+ time <- liftIO $ fromRational . toRational <$> getPOSIXTime
+ yield =<< rainbowTheme' time <$> await
where
- rainbowBlock :: BlockOutput -> State Integer (PangoText, Maybe PangoText)
- rainbowBlock block = do
- let text = rawText $ block ^. fullText
- let chars = T.unpack . T.reverse $ text
- coloredChars <- mapM rainbowChar chars
- let rainbowText = T.concat . reverse $ coloredChars
- return (rainbowText, Nothing)
- 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
+ rainbowTheme' :: Double -> Theme
+ rainbowTheme' time blocks = reverse $ evalState (mapM rainbowBlock $ reverse blocks) 0
+ where
+ rainbowBlock :: BlockOutput -> State Integer ThemedBlockOutput
+ rainbowBlock block@BlockOutput{_blockName} = do
+ let text = rawText $ block ^. fullText
+ let chars = T.unpack . T.reverse $ text
+ coloredChars <- mapM rainbowChar chars
+ let rainbowText = reverse $ coloredChars
+ return $ ThemedBlockOutput {
+ _blockName,
+ _fullText = ThemedBlockText rainbowText,
+ _shortText = Nothing
+ }
+ rainbowChar :: Char -> State Integer ThemedBlockTextSegment
+ rainbowChar char = do
+ color <- nextRainbowColor
+ return $ mkThemedSegment (color, Nothing) $ 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
+
--
GitLab