diff --git a/package.yaml b/package.yaml
index 2083e409abc62373d23fd690db4e095885eaa994..24c033f065c884f386af724cdc7e291f6e06f9ec 100644
--- a/package.yaml
+++ b/package.yaml
@@ -29,6 +29,7 @@ dependencies:
- concurrent-extra
- directory
- filepath
+- lens
- mtl
- network
- optparse-applicative
diff --git a/src/QBar/BlockOutput.hs b/src/QBar/BlockOutput.hs
deleted file mode 100644
index 23cc2508624ae2b5f59583c6f1c92963c4d464c2..0000000000000000000000000000000000000000
--- a/src/QBar/BlockOutput.hs
+++ /dev/null
@@ -1,39 +0,0 @@
-module BlockOutput where
-
-import qualified Data.Text.Lazy as T
-
-newtype BlockText = BlockText [BlockTextSegment]
-instance Semigroup BlockText where
- (BlockText a) <> (BlockText b) = BlockText (a <> b)
-instance Monoid BlockText where
- mempty = BlockText []
-
-data BlockTextSegment = BlockTextSegment {
- active :: Bool,
- importance :: Importance,
- text :: T.Text
- }
- | PangoTextSegment T.Text
-
-type Importance = Float
-
-mkText :: Bool -> Importance -> T.Text -> BlockText
-mkText active importance text = BlockText [BlockTextSegment { text, active, importance }]
-
-activeImportantText :: Importance -> T.Text -> BlockText
-activeImportantText = mkText True
-
-importantText :: Importance -> T.Text -> BlockText
-importantText = mkText False
-
-activeText :: T.Text -> BlockText
-activeText = mkText True 0
-
-normalText :: T.Text -> BlockText
-normalText = mkText False 0
-
-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)
diff --git a/src/QBar/BlockText.hs b/src/QBar/BlockText.hs
new file mode 100644
index 0000000000000000000000000000000000000000..7f5f1c63d68dbcbca49b33c86b72c511260593b2
--- /dev/null
+++ b/src/QBar/BlockText.hs
@@ -0,0 +1,122 @@
+module QBar.BlockText where
+
+import qualified Data.Text.Lazy as T
+import Data.Int (Int64)
+import QBar.Pango
+
+newtype BlockText = BlockText [BlockTextSegment]
+ deriving (Show)
+instance Semigroup BlockText where
+ (BlockText a) <> (BlockText b) = BlockText (a <> b)
+instance Monoid BlockText where
+ mempty = BlockText []
+
+data BlockTextSegment = BlockTextSegment {
+ active :: Bool,
+ importance :: Importance,
+ text :: T.Text
+ }
+ | PangoTextSegment T.Text
+ deriving (Show)
+
+type Importance = Float
+
+normalImportant :: Importance
+normalImportant = 0
+warnImportant :: Importance
+warnImportant = 1
+errorImportant :: Importance
+errorImportant = 2
+criticalImportant :: Importance
+criticalImportant = 3
+
+isCritical :: Importance -> Bool
+isCritical i
+ | i >= criticalImportant = True
+ | otherwise = False
+isError :: Importance -> Bool
+isError i
+ | isCritical i = False
+ | i >= errorImportant = True
+ | otherwise = False
+isWarning :: Importance -> Bool
+isWarning i
+ | isCritical i = False
+ | isError i = False
+ | i >= warnImportant = True
+ | otherwise = False
+isNormal :: Importance -> Bool
+isNormal i
+ | isCritical i = False
+ | isError i = False
+ | isWarning i = False
+ | otherwise = True
+
+removePango :: BlockText -> T.Text
+removePango (BlockText b) = foldr ((<>) . removePangoFromSegment) "" b
+ where
+ removePangoFromSegment :: BlockTextSegment -> T.Text
+ removePangoFromSegment BlockTextSegment { active=_active, importance=_importance, text } = text
+ removePangoFromSegment (PangoTextSegment text) =
+ case parsePango text of
+ Left _ -> text
+ Right parsed -> removeFormatting parsed
+
+printedLength :: BlockText -> Int64
+printedLength (BlockText b) = foldr ((+) . printedLength') 0 b
+ where
+ printedLength' :: BlockTextSegment -> Int64
+ printedLength' BlockTextSegment { text, active=_, importance=_ } = T.length text
+ printedLength' (PangoTextSegment _) = 0
+
+mkText :: Bool -> Importance -> T.Text -> BlockText
+mkText active importance text = BlockText [BlockTextSegment { text = pangoFriendly text, active, importance }]
+ where
+ pangoFriendly :: T.Text -> T.Text
+ pangoFriendly = T.replace "<" "<" . T.replace ">" ">" . T.replace "&" "&"
+
+activeImportantText :: Importance -> T.Text -> BlockText
+activeImportantText = mkText True
+
+importantText :: Importance -> T.Text -> BlockText
+importantText = mkText False
+
+activeText :: T.Text -> BlockText
+activeText = mkText True normalImportant
+
+normalText :: T.Text -> BlockText
+normalText = mkText False normalImportant
+
+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
diff --git a/src/QBar/Blocks.hs b/src/QBar/Blocks.hs
index 2a953f7eee2cb369da254c36bba6774b336903f9..794ecdb8388059ee0bbacfef7bcadb94c373d1d1 100644
--- a/src/QBar/Blocks.hs
+++ b/src/QBar/Blocks.hs
@@ -4,12 +4,15 @@ module QBar.Blocks where
import QBar.Core
import QBar.Time
+import QBar.BlockText
import qualified Data.Text.Lazy as T
import Data.Time.Format
import Data.Time.LocalTime
import Pipes
+import Control.Lens
+
dateBlock :: PushBlock
dateBlock = do
yield =<< liftIO dateBlockOutput
@@ -21,5 +24,5 @@ dateBlockOutput = do
zonedTime <- getZonedTime
let date = T.pack (formatTime defaultTimeLocale "%a %F" zonedTime)
let time = T.pack (formatTime defaultTimeLocale "%R" zonedTime)
- let text = (T.pack "📅 ") <> date <> " " <> (coloredText activeColor time)
- return $ setBlockName "date" $ pangoMarkup $ createBlock text
+ let text = normalText ("📅 " <> date <> " ") <> activeText time
+ return $ blockName ?~ "date" $ createBlock text
diff --git a/src/QBar/ControlSocket.hs b/src/QBar/ControlSocket.hs
index a0411368b02adf4ac43169f7694a5913858ef00e..eb1f20d4fd2b68386e1d3b1b49c9a7ccba34ac08 100644
--- a/src/QBar/ControlSocket.hs
+++ b/src/QBar/ControlSocket.hs
@@ -7,6 +7,7 @@ import QBar.Cli (MainOptions(..))
import QBar.Core
-- TODO: remove dependency?
import QBar.Filter
+import QBar.BlockText
import Control.Monad (forever, void, when)
import Control.Monad.STM (atomically)
@@ -112,5 +113,5 @@ handleBlockStream producer = do
where
handleParsedBlock :: Producer ByteString IO () -> String -> PushBlock
handleParsedBlock leftovers update = do
- yield $ createBlock $ TL.pack update
- handleBlockStream leftovers
\ No newline at end of file
+ yield $ createBlock . normalText $ TL.pack update
+ handleBlockStream leftovers
diff --git a/src/QBar/Core.hs b/src/QBar/Core.hs
index 9b25be1396d685676600c677cf73a042065311a6..7615b4d0eae4a9527c66f2616a7bab0f31898059 100644
--- a/src/QBar/Core.hs
+++ b/src/QBar/Core.hs
@@ -3,7 +3,7 @@
module QBar.Core where
-import QBar.Pango
+import QBar.BlockText
import Control.Exception (catch, finally, IOException)
import Control.Monad (forever)
@@ -15,21 +15,19 @@ import Control.Concurrent.MVar
import Control.Concurrent.STM.TChan (TChan, writeTChan)
import Data.Aeson.TH
import qualified Data.ByteString.Lazy.Char8 as C8
-import qualified Data.HashMap.Lazy as HM
import Data.Int (Int64)
-import Data.Maybe (fromMaybe, catMaybes)
+import Data.Maybe (catMaybes)
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Encoding as E
import qualified Data.Text.Lazy.IO as TIO
-import Numeric (showHex)
import Pipes
import Pipes.Concurrent
import qualified Pipes.Prelude as PP
import System.Exit
import System.IO
import System.Process.Typed (shell, withProcessWait, setStdin, setStdout, getStdout, closed, createPipe, readProcessStdout)
+import Control.Lens
-import Data.Colour.RGBSpace
data Click = Click {
name :: T.Text,
@@ -37,12 +35,14 @@ data Click = Click {
} deriving Show
$(deriveJSON defaultOptions ''Click)
-data BlockOutput = BlockOutput {
- values :: HM.HashMap T.Text T.Text,
- clickAction :: Maybe (Click -> BarIO ())
-}
-instance Show BlockOutput where
- show BlockOutput{values} = show values
+data BlockOutput = BlockOutput
+ { _fullText :: BlockText
+ , _shortText :: Maybe BlockText
+ , _blockName :: Maybe T.Text
+ , _clickAction :: Maybe (Click -> BarIO ())
+ , _invalid :: Bool
+ }
+
data PushMode = PushMode
data PullMode = PullMode
@@ -60,10 +60,6 @@ type CachedBlock = Block CachedMode
class IsBlock a where
toCachedBlock :: a -> CachedBlock
-instance IsBlock PushBlock where
- toCachedBlock = cachePushBlock
-instance IsBlock CachedBlock where
- toCachedBlock = id
class IsBlockMode a where
exitBlock :: Block a
@@ -81,90 +77,34 @@ data Bar = Bar {
requestBarUpdate :: IO (),
newBlockChan :: TChan CachedBlock
}
+makeLenses ''BlockOutput
+
+instance IsBlock PushBlock where
+ toCachedBlock = cachePushBlock
+instance IsBlock CachedBlock where
+ toCachedBlock = id
data BarUpdateChannel = BarUpdateChannel (IO ())
type BarUpdateEvent = Event.Event
-defaultColor :: T.Text
-defaultColor = "#969896"
-
-activeColor :: T.Text
-activeColor = "#ffffff"
-
-updatingColor :: T.Text
---updatingColor = "#444444"
-updatingColor = "#96989677"
-
-createBlock :: T.Text -> BlockOutput
-createBlock text = setColor defaultColor $ BlockOutput {
- values = HM.singleton "full_text" text,
- clickAction = Nothing
-}
+createBlock :: BlockText -> BlockOutput
+createBlock text = BlockOutput
+ { _fullText = text
+ , _shortText = Nothing
+ , _blockName = Nothing
+ , _clickAction = Nothing
+ , _invalid = False
+ }
createErrorBlock :: T.Text -> BlockOutput
-createErrorBlock = setColor "ff0000" . createBlock
-
-setValue :: T.Text -> T.Text -> BlockOutput -> BlockOutput
-setValue key val block = block {
- values = HM.insert key val (values block)
-}
-
-getValue :: T.Text -> BlockOutput -> Maybe T.Text
-getValue key block = HM.lookup key (values block)
-
-adjustValue :: (T.Text -> T.Text) -> T.Text -> BlockOutput -> BlockOutput
-adjustValue f k block = block {
- values = HM.adjust f k (values block)
-}
+createErrorBlock = createBlock . importantText criticalImportant
emptyBlock :: BlockOutput
-emptyBlock = createBlock ""
-
-shortText :: T.Text -> BlockOutput -> BlockOutput
-shortText = setValue "short_text"
-
-fullText :: T.Text -> BlockOutput -> BlockOutput
-fullText = setValue "full_text"
-
-getFullText :: BlockOutput -> T.Text
-getFullText = fromMaybe "" . getValue "full_text"
-
-setColor :: T.Text -> BlockOutput -> BlockOutput
-setColor = setValue "color"
-
-setBlockName :: T.Text -> BlockOutput -> BlockOutput
-setBlockName = setValue "name"
-
-getBlockName :: BlockOutput -> Maybe T.Text
-getBlockName = getValue "name"
-
-pangoMarkup :: BlockOutput -> BlockOutput
-pangoMarkup = setValue "markup" "pango"
-
-adjustText :: (T.Text -> T.Text) -> BlockOutput -> BlockOutput
-adjustText f = adjustValue f "full_text" . adjustValue f "short_text"
-
-coloredText :: T.Text -> T.Text -> T.Text
-coloredText color text = "<span color='" <> color <> "'>" <> text <> "</span>"
+emptyBlock = createBlock mempty
addIcon :: T.Text -> BlockOutput -> BlockOutput
-addIcon icon block = prefixIcon "full_text" $ prefixIcon "short_text" block
- where
- prefixIcon = adjustValue ((icon <> " ") <>)
-
-removePango :: BlockOutput -> BlockOutput
-removePango block
- | getValue "markup" block == Just "pango" = adjustText removePangoFromText $ block {
- values = HM.delete "markup" (values block)
- }
- | otherwise = block
- where
- removePangoFromText :: T.Text -> T.Text
- removePangoFromText text =
- case parsePango text of
- Left _ -> text
- Right parsed -> removeFormatting parsed
+addIcon icon = over fullText $ (<>) . normalText $ icon <> " "
modify :: (BlockOutput -> BlockOutput) -> Pipe BlockOutput BlockOutput BarIO r
modify = PP.map
@@ -175,16 +115,19 @@ autoPadding = autoPadding' 0 0
autoPadding' :: Int64 -> Int64 -> Pipe BlockOutput BlockOutput BarIO r
autoPadding' fullLength shortLength = do
block <- await
- let values' = (values block)
- let fullLength' = T.length $ HM.lookupDefault "" "full_text" values'
- let shortLength' = T.length $ HM.lookupDefault "" "short_text" values'
- let values'' = HM.adjust (<> (T.take (fullLength - fullLength') $ T.repeat ' ')) "full_text" values'
- let values''' = HM.adjust (<> (T.take (shortLength - shortLength') $ T.repeat ' ')) "short_text" values''
- yield block { values = values''' }
- autoPadding' (max fullLength fullLength') (max shortLength shortLength')
+ let fullLength' = max fullLength . printedLength $ block^.fullText
+ let shortLength' = max shortLength . printedLength $ block^.shortText._Just -- TODO: ???
+ yield $ padFullText fullLength' . padShortText shortLength' $ block
+ autoPadding' fullLength' shortLength'
+ padString :: Int64 -> BlockText
+ padString len = normalText . T.take len . T.repeat $ ' '
+ padFullText :: Int64 -> BlockOutput -> BlockOutput
+ padFullText len = over fullText $ \s -> padString (len - printedLength s) <> s
+ padShortText :: Int64 -> BlockOutput -> BlockOutput
+ padShortText len = over (shortText._Just) $ \s -> padString (len - printedLength s) <> s
cacheFromInput :: Input BlockOutput -> CachedBlock
-cacheFromInput input = const CachedMode <$> fromInput input
+cacheFromInput input = CachedMode <$ fromInput input
-- | Create a shared interval. Takes a BarUpdateChannel to signal bar updates and an interval (in seconds).Data.Maybe
-- Returns an IO action that can be used to attach blocks to the shared interval and an async that contains a reference to the scheduler thread.
@@ -223,7 +166,7 @@ sharedInterval seconds = do
Left _ -> return (exitBlock, False)
Right (blockOutput, blockProducer') -> do
success <- atomically $ send output blockOutput {
- clickAction = Just (updateClickHandler blockOutput)
+ _clickAction = Just (updateClickHandler blockOutput)
}
if success
-- Store new BlockProducer back into MVar
@@ -234,8 +177,8 @@ sharedInterval seconds = do
updateClickHandler :: BlockOutput -> Click -> BarIO ()
updateClickHandler block _ = do
-- Give user feedback that the block is updating
- let outdatedBlock = setColor updatingColor $ removePango block
- liftIO $ void $ atomically $ send output $ outdatedBlock
+ let outdatedBlock = block & invalid.~True
+ liftIO $ void $ atomically $ send output outdatedBlock
-- Notify bar about changed block state to display the feedback
updateBar
-- Run a normal block update to update the block to the new value
@@ -262,7 +205,7 @@ sharedInterval seconds = do
cacheFromInput input
blockScript :: FilePath -> PullBlock
-blockScript path = forever $ yield =<< (lift $ blockScriptAction)
+blockScript path = forever $ yield =<< (lift blockScriptAction)
where
blockScriptAction :: BarIO BlockOutput
blockScriptAction = do
@@ -271,33 +214,36 @@ blockScript path = forever $ yield =<< (lift $ blockScriptAction)
(exitCode, output) <- liftIO $ readProcessStdout $ shell path
case exitCode of
ExitSuccess -> return $ case map E.decodeUtf8 (C8.lines output) of
- (text:short:color:_) -> setColor color $ shortText short $ createScriptBlock text
- (text:short:_) -> shortText short $ createScriptBlock text
+ -- TODO: Fix this, but how?
+ -- PangoSegments cannot have external formatting, so either allow that here,
+ -- or duplicate the function into ango and nonPango variants.
+ -- (text:short:color:_) -> setColor color $ shortText short $ createScriptBlock text
+ (text:short:_) -> shortText ?~ pangoText short $ createScriptBlock text
(text:_) -> createScriptBlock text
[] -> createScriptBlock "-"
- (ExitFailure nr) -> return $ createErrorBlock $ "[" <> (T.pack $ show nr) <> "]"
+ (ExitFailure nr) -> return $ createErrorBlock $ "[" <> T.pack (show nr) <> "]"
createScriptBlock :: T.Text -> BlockOutput
- createScriptBlock text = pangoMarkup $ setBlockName (T.pack path) $ createBlock text
+ createScriptBlock text = blockName ?~ T.pack path $ createBlock . pangoText $ text
startPersistentBlockScript :: FilePath -> CachedBlock
-- This is only using 'CachedBlock' because the code was already written and tested
-- This could probably be massively simplified by using the new 'pushBlock'
startPersistentBlockScript path = do
- bar <- lift $ ask
+ bar <- lift ask
do
- (output, input, seal) <- liftIO $ spawn' $ latest $ emptyBlock
- initialDataEvent <- liftIO $ Event.new
+ (output, input, seal) <- liftIO $ spawn' $ latest emptyBlock
+ initialDataEvent <- liftIO Event.new
task <- liftIO $ async $ do
let processConfig = setStdin closed $ setStdout createPipe $ shell path
finally (
catch (
withProcessWait processConfig $ \ process -> do
let handle = getStdout process
- runEffect $ (fromHandle bar handle) >-> signalFirstBlock initialDataEvent >-> toOutput output
+ runEffect $ fromHandle bar handle >-> signalFirstBlock initialDataEvent >-> toOutput output
)
( \ e ->
-- output error
- runEffect $ (yield $ createErrorBlock $ "[" <> (T.pack $ show (e :: IOException)) <> "]") >-> signalFirstBlock initialDataEvent >-> toOutput output
+ runEffect $ yield (createErrorBlock $ "[" <> T.pack (show (e :: IOException)) <> "]") >-> signalFirstBlock initialDataEvent >-> toOutput output
)
)
(atomically seal)
@@ -315,23 +261,9 @@ startPersistentBlockScript path = do
fromHandle :: Bar -> Handle -> Producer BlockOutput IO ()
fromHandle bar handle = forever $ do
line <- lift $ TIO.hGetLine handle
- yield $ pangoMarkup $ createBlock line
+ yield $ createBlock . pangoText $ line
lift $ updateBar' bar
-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
-
addBlock :: IsBlock a => a -> BarIO ()
addBlock block = do
@@ -370,7 +302,7 @@ cachePushBlock pushBlock = lift (next pushBlock) >>= either (const exitBlock) wi
-- The void is discarding the boolean result that indicates if the mailbox is sealed
-- This is ok because a cached block is never sealed from the receiving side
liftIO $ atomically $ void $ send output $ Just blockOutput
- lift $ updateBar
+ lift updateBar
terminateOnMaybe :: Producer (Maybe BlockOutput) BarIO () -> Producer BlockOutput BarIO CachedMode
terminateOnMaybe p = do
eitherMaybeValue <- lift $ next p
diff --git a/src/QBar/DefaultConfig.hs b/src/QBar/DefaultConfig.hs
index aeaee53898b518cbbc32de95c45c2c125625345b..b429901ad5e603e705b94af11c4a111b34f3c172 100644
--- a/src/QBar/DefaultConfig.hs
+++ b/src/QBar/DefaultConfig.hs
@@ -5,6 +5,8 @@ import QBar.Core
import Pipes
+import Control.Lens
+
blockLocation :: String -> FilePath
blockLocation name = "~/.config/qbar/blocks/" <> name
@@ -15,7 +17,7 @@ generateDefaultBarConfig = do
let todo = systemInfoInterval (blockScript $ blockLocation "todo")
let wifi = systemInfoInterval (blockScript $ blockLocation "wifi2 wlan") >-> modify (addIcon "📡")
let networkEnvironment = systemInfoInterval (blockScript $ blockLocation "network-environment")
- let cpu = systemInfoInterval (blockScript $ blockLocation "cpu_usage") >-> modify (setBlockName "cpu" . addIcon "💻") >-> autoPadding
+ let cpu = systemInfoInterval (blockScript $ blockLocation "cpu_usage") >-> modify ((blockName?~"cpu") . addIcon "💻") >-> autoPadding
let ram = systemInfoInterval (blockScript $ blockLocation "memory") >-> modify (addIcon "ðŸ") >-> autoPadding
let temperature = systemInfoInterval (blockScript $ blockLocation "temperature") >-> autoPadding
let volumeBlock = startPersistentBlockScript $ blockLocation "volume-pulseaudio -S -F3"
@@ -29,4 +31,4 @@ generateDefaultBarConfig = do
addBlock cpu
addBlock networkEnvironment
addBlock wifi
- addBlock todo
\ No newline at end of file
+ addBlock todo
diff --git a/src/QBar/Filter.hs b/src/QBar/Filter.hs
index c848475c36fbaa73cf02fca2ae489fb0dbe4bc77..699261728a0f23d8e8a1f1fa4366699bcd11e87d 100644
--- a/src/QBar/Filter.hs
+++ b/src/QBar/Filter.hs
@@ -3,11 +3,17 @@
module QBar.Filter where
import QBar.Core
+import QBar.BlockText
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
@@ -34,17 +40,36 @@ 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 cleanBlock = removePango block
- let text = getFullText cleanBlock
+ let text = removePango $ block^.fullText
let chars = T.unpack . T.reverse $ text
coloredChars <- mapM rainbowChar chars
let rainbowText = T.concat . reverse $ coloredChars
- return $ pangoMarkup $ fullText rainbowText $ cleanBlock
+ return $ fullText .~ pangoText rainbowText $ block
rainbowChar :: Char -> State Integer T.Text
rainbowChar char = do
color <- nextRainbowColor
@@ -56,6 +81,7 @@ rainbow time blocks = reverse $ evalState (mapM rainbowBlock $ reverse blocks) 0
put $ index + 1
return $ rainbowColor (fromInteger index + time * 10)
+
rainbowColor :: Double -> T.Text
rainbowColor position =
let hue' = position * 3
diff --git a/src/QBar/Server.hs b/src/QBar/Server.hs
index 9a282a9fc3822fc1ca45fa6b1e6cea25dbccab9b..12c663646312530f0e5825c109ad32d9d6679f2a 100644
--- a/src/QBar/Server.hs
+++ b/src/QBar/Server.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
-
module QBar.Server where
import QBar.Blocks
@@ -7,6 +5,8 @@ import QBar.Core
import QBar.Cli
import QBar.ControlSocket
import QBar.Filter
+import QBar.BlockText
+import QBar.Themes
import Control.Monad (forever, when, unless)
import Control.Monad.Reader (runReaderT, ask)
@@ -15,18 +15,19 @@ import Control.Concurrent (threadDelay, forkFinally)
import Control.Concurrent.Async
import Control.Concurrent.Event as Event
import Control.Concurrent.STM.TChan (TChan, newTChanIO, readTChan, tryReadTChan)
-import Data.Aeson (encode, decode)
+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 (isJust, fromJust, catMaybes, mapMaybe)
+import Data.Maybe (catMaybes, mapMaybe, fromMaybe)
import qualified Data.Text.Lazy as T
import Data.Time.Clock.POSIX
import Pipes
import System.IO (stdin, stdout, stderr, hFlush, hPutStrLn)
import System.Posix.Signals
+import Control.Lens hiding (each, (.=))
data Handle = Handle {
handleActionList :: IORef [(T.Text, Click -> BarIO ())],
@@ -35,7 +36,7 @@ data Handle = Handle {
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).
-renderIndicator = forever $ each $ map createBlock ["/", "-", "\\", "|"]
+renderIndicator = forever $ each $ map (createBlock . normalText) ["/", "-", "\\", "|"]
runBlock :: CachedBlock -> BarIO (Maybe (BlockOutput, CachedBlock))
runBlock producer = do
@@ -47,6 +48,19 @@ runBlock producer = do
runBlocks :: [CachedBlock] -> BarIO ([BlockOutput], [CachedBlock])
runBlocks block = unzip . catMaybes <$> mapM runBlock block
+data RenderBlock = RenderBlock T.Text (Maybe T.Text) (Maybe T.Text)
+ deriving(Show)
+instance ToJSON RenderBlock where
+ toJSON (RenderBlock fullText' shortText' blockName') = object $
+ fullText'' <> shortText'' <> blockName'' <> pango''
+ where
+ fullText'' = [ "full_text" .= fullText' ]
+ shortText'' = fromMaybe (\s -> ["short_text".=s]) mempty shortText'
+ blockName'' = fromMaybe (\s -> ["block_name".=s]) mempty blockName'
+ pango'' = [ "markup" .= ("pango" :: T.Text) ]
+
+
+
renderLoop :: MainOptions -> Handle -> BarUpdateEvent -> BS.ByteString -> TChan CachedBlock -> BarIO ()
renderLoop options handle@Handle{handleActiveFilter} barUpdateEvent previousBarOutput newBlockChan = renderLoop' previousBarOutput []
where
@@ -82,7 +96,8 @@ renderLine :: MainOptions -> Handle -> Filter -> [BlockOutput] -> BS.ByteString
renderLine MainOptions{verbose} Handle{handleActionList} blockFilter blocks previousEncodedOutput = do
time <- fromRational . toRational <$> getPOSIXTime
let filteredBlocks = applyFilter blockFilter time blocks
- let encodedOutput = encode $ map values filteredBlocks
+ -- let encodedOutput = encode $ map values filteredBlocks
+ let encodedOutput = encodeOutput filteredBlocks
let changed = previousEncodedOutput /= encodedOutput
when changed $ do
hPut stdout encodedOutput
@@ -101,15 +116,19 @@ renderLine MainOptions{verbose} Handle{handleActionList} blockFilter blocks prev
return encodedOutput
where
+ theme :: Theme
+ theme = defaultTheme
+ encodeOutput :: [BlockOutput] -> BS.ByteString
+ encodeOutput bs = encode $ zipWith encodeBlock bs $ theme bs
+ encodeBlock :: BlockOutput -> (T.Text, Maybe T.Text) -> RenderBlock
+ encodeBlock b (fullText', shortText') = RenderBlock fullText' shortText' (b^.blockName)
clickActionList :: [(T.Text, Click -> BarIO ())]
clickActionList = mapMaybe getClickAction blocks
getClickAction :: BlockOutput -> Maybe (T.Text, Click -> BarIO ())
- getClickAction block = if hasBlockName && hasClickAction then Just (fromJust maybeBlockName, fromJust maybeClickAction) else Nothing
- where
- maybeBlockName = getBlockName block
- hasBlockName = isJust maybeBlockName
- maybeClickAction = clickAction block
- hasClickAction = isJust maybeClickAction
+ getClickAction block = do
+ blockName' <- block^.blockName
+ clickAction' <- block^.clickAction
+ return (blockName', clickAction')
createBarUpdateChannel :: IO (IO (), BarUpdateEvent)
createBarUpdateChannel = do
@@ -162,7 +181,7 @@ renderInitialBlocks options handle blockFilter = do
date <- dateBlockOutput
let initialBlocks = [date]
-- Attach spinner indicator when verbose flag is set
- let initialBlocks' = if indicator options then initialBlocks <> [createBlock "*"] else initialBlocks
+ let initialBlocks' = if indicator options then initialBlocks <> [createBlock . normalText $ "*"] else initialBlocks
-- Render initial time block so the bar is not empty after startup
renderLine options handle blockFilter initialBlocks' ""
@@ -234,4 +253,4 @@ runQBar barConfiguration options@MainOptions{barCommand} = runCommand barCommand
where
runCommand BarServer = runBarConfiguration barConfiguration options
runCommand NoFilter = sendIpc options $ SetFilter $ StaticFilter None
- runCommand RainbowFilter = sendIpc options $ SetFilter $ AnimatedFilter Rainbow
\ No newline at end of file
+ runCommand RainbowFilter = sendIpc options $ SetFilter $ AnimatedFilter Rainbow
diff --git a/src/QBar/Themes.hs b/src/QBar/Themes.hs
new file mode 100644
index 0000000000000000000000000000000000000000..09728fc5da5477028749abeb20b436bc2ec2db15
--- /dev/null
+++ b/src/QBar/Themes.hs
@@ -0,0 +1,65 @@
+module QBar.Themes where
+
+
+import QBar.BlockText
+import QBar.Core
+
+import qualified Data.Text.Lazy as T
+
+import Control.Lens
+
+
+type Theme = [BlockOutput] -> [(T.Text, Maybe T.Text)]
+type SimplifiedTheme = Bool -> Importance -> (Color, Maybe Color)
+type AnimatedTheme = Double -> Theme
+
+
+mkTheme :: SimplifiedTheme -> Theme
+mkTheme theming' = map themeBlock
+ where
+ themeBlock :: BlockOutput -> (T.Text, Maybe T.Text)
+ themeBlock block = (fullText', shortText')
+ where
+ theming :: SimplifiedTheme
+ theming
+ | block^.invalid = invalidSimplifiedTheme
+ | otherwise = theming'
+ fullText' :: T.Text
+ fullText' = themeBlockText theming $ block^.fullText
+ shortText' :: Maybe T.Text
+ shortText' = themeBlockText theming <$> block^.shortText
+ 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 _ (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)
+
+
+invalidSimplifiedTheme :: SimplifiedTheme
+invalidSimplifiedTheme _ _ = (invalidColor, Nothing)
+
+
+invalidTheme :: Theme
+invalidTheme = mkTheme invalidSimplifiedTheme
+
+
+defaultTheme :: Theme
+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)