From 18f7a794cfc90bd7b57e3fb65a8711e6735b12b7 Mon Sep 17 00:00:00 2001
From: Jens Nolte <jens@nightmarestudio.de>
Date: Thu, 20 Feb 2020 22:36:11 +0100
Subject: [PATCH] Add '<span>'-support to tag parser
---
src/QBar/BlockOutput.hs | 16 ++++++++++-
src/QBar/Color.hs | 60 +++++++++++++++++++++++++++++++++++++++++
src/QBar/Pango.hs | 27 +++----------------
src/QBar/TagParser.hs | 43 ++++++++++++++++++++++++++---
src/QBar/Theme.hs | 13 ++++++---
5 files changed, 129 insertions(+), 30 deletions(-)
create mode 100644 src/QBar/Color.hs
diff --git a/src/QBar/BlockOutput.hs b/src/QBar/BlockOutput.hs
index a9654a8..1604fe7 100644
--- a/src/QBar/BlockOutput.hs
+++ b/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 }]
diff --git a/src/QBar/Color.hs b/src/QBar/Color.hs
new file mode 100644
index 0000000..41e7ef0
--- /dev/null
+++ b/src/QBar/Color.hs
@@ -0,0 +1,60 @@
+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
+
diff --git a/src/QBar/Pango.hs b/src/QBar/Pango.hs
index c9cd4b3..4d51470 100644
--- a/src/QBar/Pango.hs
+++ b/src/QBar/Pango.hs
@@ -1,11 +1,10 @@
+{-# 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
diff --git a/src/QBar/TagParser.hs b/src/QBar/TagParser.hs
index a731aea..b02ca58 100644
--- a/src/QBar/TagParser.hs
+++ b/src/QBar/TagParser.hs
@@ -1,13 +1,16 @@
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)
diff --git a/src/QBar/Theme.hs b/src/QBar/Theme.hs
index 36b9867..2e48356 100644
--- a/src/QBar/Theme.hs
+++ b/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 {
--
GitLab