Change theming from Pango to 'ThemedBlockOutput'

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 "<" "&lt;" . T.replace ">" "&gt;" . T.replace "&" "&amp;"

src/QBar/Pango.hs

+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

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 ()

src/QBar/Theme.hs

+{-# 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
+