Add '<span>'-support to tag parser

src/QBar/BlockOutput.hs

@@ -3,7 +3,10 @@
 
 module QBar.BlockOutput where
 
+import QBar.Color
+
 import Control.Lens
+import Data.Aeson
 import Data.Aeson.TH
 import Data.Int (Int64)
 import qualified Data.Text.Lazy as T
@@ -30,10 +33,16 @@ data BlockTextSegment = BlockTextSegment {
     importance :: Importance,
     segmentText :: T.Text
   }
+  | StyledBlockTextSegment {
+    segmentText :: T.Text,
+    color :: Maybe Color,
+    backgroundColor :: Maybe Color
+  }
   deriving (Eq, Show)
 
 type Importance = Float
 
+
 $(deriveJSON defaultOptions ''BlockOutput)
 makeLenses ''BlockOutput
 $(deriveJSON defaultOptions ''BlockTextSegment)
@@ -142,12 +151,14 @@ rawText (BlockText b) = foldMap rawTextFromSegment b
   where
     rawTextFromSegment :: BlockTextSegment -> T.Text
     rawTextFromSegment BlockTextSegment{segmentText} = segmentText
+    rawTextFromSegment StyledBlockTextSegment{segmentText} = segmentText
 
 printedLength :: BlockText -> Int64
 printedLength (BlockText b) = sum . map segmentLength $ b
   where
     segmentLength :: BlockTextSegment -> Int64
     segmentLength BlockTextSegment { segmentText } = T.length segmentText
+    segmentLength StyledBlockTextSegment { segmentText } = T.length segmentText
 
 mkText :: Bool -> Importance -> T.Text -> BlockText
 mkText active importance segmentText = BlockText [BlockTextSegment { segmentText = pangoFriendly segmentText, active, importance }]
@@ -168,4 +179,7 @@ normalText :: T.Text -> BlockText
 normalText = mkText False normalImportant
 
 surroundWith :: (T.Text -> BlockText) -> T.Text -> T.Text -> BlockText -> BlockText
-surroundWith format left right middle = format left <> middle <> format right
\ No newline at end of file
+surroundWith format left right middle = format left <> middle <> format right
+
+mkStyledText :: Maybe Color -> Maybe Color -> Text -> BlockText
+mkStyledText color backgroundColor text = BlockText $ [StyledBlockTextSegment { segmentText=text, color, backgroundColor }]

src/QBar/Color.hs

+module QBar.Color where
+
+import Data.Aeson
+import Data.Bits ((.|.), shiftL)
+import Data.Char (ord)
+import Data.Attoparsec.Text.Lazy as A
+import Data.Colour.RGBSpace
+import qualified Data.Text.Lazy as T
+import Numeric (showHex)
+
+data Color = ColorRGB (RGB Double) | ColorRGBA (RGB Double) Double
+  deriving (Eq, Show)
+instance FromJSON Color where
+  parseJSON = withText "Color" $ either fail pure . parseOnly (colorParser <* endOfInput)
+instance ToJSON Color where
+  toJSON = String . T.toStrict . hexColorText
+
+hexColorText :: Color -> Text
+hexColorText = hexColor'
+  where
+    hexColor' :: Color -> Text
+    hexColor' (ColorRGB rgb) = pangoRGB rgb
+    hexColor' (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
+
+
+colorParser :: Parser Color
+colorParser = do
+  void $ char '#'
+  rgb <- RGB <$> doubleFromHex2 <*> doubleFromHex2 <*> doubleFromHex2
+  option (ColorRGB rgb) (ColorRGBA rgb <$> doubleFromHex2)
+  where
+    doubleFromHex2 :: Parser Double
+    doubleFromHex2 = (/ 256) . fromIntegral <$> hexadecimal'' 2
+
+    -- |Variant of 'Data.Attoparsec.Text.hexadecimal' that parses a fixed amount of digits.
+    hexadecimal'' :: Int -> Parser Int
+    hexadecimal'' digits = foldl step 0 <$> count digits (satisfy isHexDigit)
+      where
+        isHexDigit c = (c >= '0' && c <= '9') ||
+                      (c >= 'a' && c <= 'f') ||
+                      (c >= 'A' && c <= 'F')
+        step a c | w >= 48 && w <= 57  = (a `shiftL` 4) .|. fromIntegral (w - 48)
+                | w >= 97             = (a `shiftL` 4) .|. fromIntegral (w - 87)
+                | otherwise           = (a `shiftL` 4) .|. fromIntegral (w - 55)
+          where w = ord c
+

src/QBar/Pango.hs

+{-# LANGUAGE DuplicateRecordFields #-}
+
 module QBar.Pango (PangoText, renderPango) where
 
+import QBar.Color
 import QBar.Theme
 
-import Data.Colour.RGBSpace
-import qualified Data.Text.Lazy as T
-import Numeric (showHex)
-
 type PangoText = Text
 
 renderPango :: ThemedBlockText -> PangoText
@@ -20,22 +19,4 @@ coloredText Nothing foreground text = "<span color='" <> pangoColor foreground <
 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
+pangoColor = hexColorText

src/QBar/TagParser.hs

 module QBar.TagParser where
 
 import QBar.BlockOutput
+import QBar.Color
 
+import Control.Applicative ((<|>))
 import Control.Monad (void)
-import Data.Functor (($>))
+import Data.Attoparsec.Text.Lazy as A
 import Data.Either (either)
+import Data.Functor (($>))
+import Data.Maybe (catMaybes)
 import qualified Data.Text as TS
 import qualified Data.Text.Lazy as T
-import Data.Attoparsec.Text.Lazy as A
 
 type TagState = (Bool, Importance)
 
@@ -18,7 +21,7 @@ tagParser = parser (False, normalImportant)
     parser (active, importance) = mconcat <$> many' singleElementParser
       where
         singleElementParser :: Parser BlockText
-        singleElementParser = choice [textParser, activeTagParser, importanceTagParser]
+        singleElementParser = choice [textParser, activeTagParser, importanceTagParser, spanParser]
 
         textParser :: Parser BlockText
         textParser = mkText active importance . T.fromStrict <$> A.takeWhile1 (notInClass "<>")
@@ -46,6 +49,40 @@ tagParser = parser (False, normalImportant)
             ("critical", criticalImportant)
           ]
 
+    spanParser :: Parser BlockText
+    spanParser = do
+      void $ string "<span"
+      (colors, backgrounds) <- unzip <$> (many' $ colorAttribute <|> backgroundAttribute)
+      let color = listToMaybe . catMaybes $ colors
+      let background = listToMaybe . catMaybes $ backgrounds
+      void $ char '>'
+      content <- T.fromStrict <$> A.takeWhile1 (notInClass "<>")
+      void $ string $ "</span>"
+      return $ mkStyledText color background content
+      where
+        colorAttributeParser :: Text -> Parser Color
+        colorAttributeParser attribute = do
+          space >> skipSpace
+          void $ string $ T.toStrict attribute
+          skipSpace
+          void $ char '='
+          skipSpace
+          value <- (
+              char '\'' *> colorParser <* char '\''
+              <|> char '"' *> colorParser <* char '"'
+            )
+          return value
+
+        colorAttribute :: Parser (Maybe Color, Maybe Color)
+        colorAttribute = do
+          color <- colorAttributeParser "color"
+          pure (Just color, Nothing)
+        backgroundAttribute :: Parser (Maybe Color, Maybe Color)
+        backgroundAttribute = do
+          background <- colorAttributeParser "background"
+          pure (Nothing, Just background)
+
+
 
 parseTags :: T.Text -> Either String BlockText
 parseTags text = parseOnly (tagParser <* endOfInput) (T.toStrict text)

src/QBar/Theme.hs

@@ -4,20 +4,20 @@
 module QBar.Theme where
 
 import QBar.BlockOutput
+import QBar.Color
 
+import Control.Applicative ((<|>))
 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.HashMap.Lazy as HM
+import Data.Maybe (fromMaybe)
 import qualified Data.Text.Lazy as T
 import Data.Time.Clock.POSIX (getPOSIXTime)
 import Pipes
 
 
-data Color = ColorRGB (RGB Double) | ColorRGBA (RGB Double) Double
-  deriving (Eq, Show)
-
 data ThemedBlockOutput = ThemedBlockOutput {
     _fullText :: ThemedBlockText,
     _shortText :: Maybe ThemedBlockText,
@@ -87,6 +87,13 @@ mkTheme theming' = StaticTheme $ map themeBlock
     themeBlockText theming (BlockText b) = ThemedBlockText $ themeSegment theming <$> b
     themeSegment :: SimplifiedTheme -> BlockTextSegment -> ThemedBlockTextSegment
     themeSegment theming BlockTextSegment {active, importance, segmentText} = mkThemedSegment (theming active importance) segmentText
+    themeSegment theming StyledBlockTextSegment {color, backgroundColor, segmentText} = mkThemedSegment (themedColor, themedBackgroundColor) segmentText
+      where
+        themedColor :: Color
+        themedColor = fromMaybe normalThemedColor color
+        themedBackgroundColor :: Maybe Color
+        themedBackgroundColor = backgroundColor <|> normalThemedBackground
+        (normalThemedColor, normalThemedBackground) = theming False normalImportant
 
 mkThemedBlockOutput :: (Color, Maybe Color) -> Text -> ThemedBlockOutput
 mkThemedBlockOutput color text = ThemedBlockOutput {