diff --git a/src/QBar/Blocks.hs b/src/QBar/Blocks.hs index cf199409e48f4f8450b07a08cb7e17201491ad70..973768338ad0e8a0225f30261bf8e3865bf8b27b 100644 --- a/src/QBar/Blocks.hs +++ b/src/QBar/Blocks.hs @@ -11,7 +11,7 @@ import Data.Time.LocalTime import Pipes import Pipes.Concurrent -dateBlock :: IO Block +dateBlock :: IO BlockOutput dateBlock = do zonedTime <- getZonedTime let date = T.pack (formatTime defaultTimeLocale "%a %F" zonedTime) @@ -27,7 +27,7 @@ dateBlockProducer barUpdateChannel = do lift $ void $ forkIO $ update output fromInput input where - update :: Output Block -> IO () + update :: Output BlockOutput -> IO () update output = do sleepUntil =<< nextMinute block <- dateBlock diff --git a/src/QBar/Core.hs b/src/QBar/Core.hs index 6998dd28c6017a0abac73e7f32a4c4553a6c257c..713bb03acbcf8b23a7901d5a5c954fa3692b5e56 100644 --- a/src/QBar/Core.hs +++ b/src/QBar/Core.hs @@ -29,12 +29,12 @@ import System.Process.Typed (shell, withProcessWait, setStdin, setStdout, getStd import Data.Colour.RGBSpace -data Block = Block { +data BlockOutput = BlockOutput { values :: HM.HashMap T.Text T.Text, clickAction :: Maybe (Click -> IO ()) } -instance Show Block where - show Block{values} = show values +instance Show BlockOutput where + show BlockOutput{values} = show values data Click = Click { name :: T.Text, @@ -42,7 +42,7 @@ data Click = Click { } deriving Show $(deriveJSON defaultOptions ''Click) -type BlockProducer = Producer Block IO () +type BlockProducer = Producer BlockOutput IO () data BarUpdateChannel = BarUpdateChannel (IO ()) type BarUpdateEvent = Event.Event @@ -57,64 +57,64 @@ updatingColor :: T.Text --updatingColor = "#444444" updatingColor = "#96989677" -createBlock :: T.Text -> Block -createBlock text = setColor defaultColor $ Block { +createBlock :: T.Text -> BlockOutput +createBlock text = setColor defaultColor $ BlockOutput { values = HM.singleton "full_text" text, clickAction = Nothing } -createErrorBlock :: T.Text -> Block +createErrorBlock :: T.Text -> BlockOutput createErrorBlock = setColor "ff0000" . createBlock -setValue :: T.Text -> T.Text -> Block -> Block +setValue :: T.Text -> T.Text -> BlockOutput -> BlockOutput setValue key val block = block { values = HM.insert key val (values block) } -getValue :: T.Text -> Block -> Maybe T.Text +getValue :: T.Text -> BlockOutput -> Maybe T.Text getValue key block = HM.lookup key (values block) -adjustValue :: (T.Text -> T.Text) -> T.Text -> Block -> Block +adjustValue :: (T.Text -> T.Text) -> T.Text -> BlockOutput -> BlockOutput adjustValue f k block = block { values = HM.adjust f k (values block) } -emptyBlock :: Block +emptyBlock :: BlockOutput emptyBlock = createBlock "" -shortText :: T.Text -> Block -> Block +shortText :: T.Text -> BlockOutput -> BlockOutput shortText = setValue "short_text" -fullText :: T.Text -> Block -> Block +fullText :: T.Text -> BlockOutput -> BlockOutput fullText = setValue "full_text" -getFullText :: Block -> T.Text +getFullText :: BlockOutput -> T.Text getFullText = fromMaybe "" . getValue "full_text" -setColor :: T.Text -> Block -> Block +setColor :: T.Text -> BlockOutput -> BlockOutput setColor = setValue "color" -setBlockName :: T.Text -> Block -> Block +setBlockName :: T.Text -> BlockOutput -> BlockOutput setBlockName = setValue "name" -getBlockName :: Block -> Maybe T.Text +getBlockName :: BlockOutput -> Maybe T.Text getBlockName = getValue "name" -pangoMarkup :: Block -> Block +pangoMarkup :: BlockOutput -> BlockOutput pangoMarkup = setValue "markup" "pango" -adjustText :: (T.Text -> T.Text) -> Block -> Block +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>" -addIcon :: T.Text -> Block -> Block +addIcon :: T.Text -> BlockOutput -> BlockOutput addIcon icon block = prefixIcon "full_text" $ prefixIcon "short_text" block where prefixIcon = adjustValue ((icon <> " ") <>) -removePango :: Block -> Block +removePango :: BlockOutput -> BlockOutput removePango block | getValue "markup" block == Just "pango" = adjustText removePangoFromText $ block { values = HM.delete "markup" (values block) @@ -127,13 +127,13 @@ removePango block Left _ -> text Right parsed -> removeFormatting parsed -modify :: (Block -> Block) -> Pipe Block Block IO () +modify :: (BlockOutput -> BlockOutput) -> Pipe BlockOutput BlockOutput IO () modify = PP.map -autoPadding :: Pipe Block Block IO () +autoPadding :: Pipe BlockOutput BlockOutput IO () autoPadding = autoPadding' 0 0 where - autoPadding' :: Int64 -> Int64 -> Pipe Block Block IO () + autoPadding' :: Int64 -> Int64 -> Pipe BlockOutput BlockOutput IO () autoPadding' fullLength shortLength = do block <- await let values' = (values block) @@ -146,9 +146,9 @@ autoPadding = autoPadding' 0 0 -- | 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. -sharedInterval :: BarUpdateChannel -> Int -> IO (IO Block -> BlockProducer, Async ()) +sharedInterval :: BarUpdateChannel -> Int -> IO (IO BlockOutput -> BlockProducer, Async ()) sharedInterval barUpdateChannel seconds = do - clientsMVar <- newMVar ([] :: [(IO Block, Output Block)]) + clientsMVar <- newMVar ([] :: [(IO BlockOutput, Output BlockOutput)]) task <- async $ forever $ do threadDelay $ seconds * 1000000 @@ -160,18 +160,18 @@ sharedInterval barUpdateChannel seconds = do return (addClient clientsMVar, task) where - runAndFilterClient :: (IO Block, Output Block) -> IO (Maybe (IO Block, Output Block)) + runAndFilterClient :: (IO BlockOutput, Output BlockOutput) -> IO (Maybe (IO BlockOutput, Output BlockOutput)) runAndFilterClient client = do result <- runClient client return $ if result then Just client else Nothing - runClient :: (IO Block, Output Block) -> IO Bool + runClient :: (IO BlockOutput, Output BlockOutput) -> IO Bool runClient (blockAction, output) = do result <- blockAction atomically $ send output result { clickAction = Just (updateClickHandler result) } where - updateClickHandler :: Block -> Click -> IO () + updateClickHandler :: BlockOutput -> Click -> IO () updateClickHandler block _ = do -- Give user feedback that the block is updating let outdatedBlock = setColor updatingColor $ removePango block @@ -182,7 +182,7 @@ sharedInterval barUpdateChannel seconds = do void $ runClient (blockAction, output) -- Notify bar about changed block state, this is usually done by the shared interval handler updateBar barUpdateChannel - addClient :: MVar [(IO Block, Output Block)] -> IO Block -> BlockProducer + addClient :: MVar [(IO BlockOutput, Output BlockOutput)] -> IO BlockOutput -> BlockProducer addClient clientsMVar blockAction = do -- Spawn the mailbox that preserves the latest block (output, input) <- lift $ spawn $ latest emptyBlock @@ -196,7 +196,7 @@ sharedInterval barUpdateChannel seconds = do -- Return a block producer from the mailbox fromInput input -blockScript :: FilePath -> IO Block +blockScript :: FilePath -> IO BlockOutput blockScript path = do -- The exit code is used for i3blocks signaling but ignored here (=not implemented) -- I am trying to replace i3blocks scripts with native haskell blocks, so I do not need it @@ -209,10 +209,10 @@ blockScript path = do [] -> createScriptBlock "-" (ExitFailure nr) -> return $ createErrorBlock $ "[" <> (T.pack $ show nr) <> "]" where - createScriptBlock :: T.Text -> Block + createScriptBlock :: T.Text -> BlockOutput createScriptBlock text = pangoMarkup $ setBlockName (T.pack path) $ createBlock text -startPersistentBlockScript :: BarUpdateChannel -> FilePath -> Producer Block IO () +startPersistentBlockScript :: BarUpdateChannel -> FilePath -> Producer BlockOutput IO () startPersistentBlockScript barUpdateChannel path = do (output, input, seal) <- lift $ spawn' $ latest $ emptyBlock initialDataEvent <- lift $ Event.new @@ -234,14 +234,14 @@ startPersistentBlockScript barUpdateChannel path = do lift $ Event.wait initialDataEvent fromInput input where - signalFirstBlock :: Event.Event -> Pipe Block Block IO () + signalFirstBlock :: Event.Event -> Pipe BlockOutput BlockOutput IO () signalFirstBlock event = do -- Await first block await >>= yield lift $ Event.set event -- Replace with cat cat - fromHandle :: Handle -> Producer Block IO () + fromHandle :: Handle -> Producer BlockOutput IO () fromHandle handle = forever $ do line <- lift $ TIO.hGetLine handle yield $ pangoMarkup $ createBlock line diff --git a/src/QBar/Filter.hs b/src/QBar/Filter.hs index 1651626a53d6b6cb473ac3b99127824078932e84..c848475c36fbaa73cf02fca2ae489fb0dbe4bc77 100644 --- a/src/QBar/Filter.hs +++ b/src/QBar/Filter.hs @@ -27,17 +27,17 @@ isAnimatedFilter :: Filter -> Bool isAnimatedFilter (AnimatedFilter _) = True isAnimatedFilter _ = False -applyFilter :: Filter -> Double -> [Block] -> [Block] +applyFilter :: Filter -> Double -> [BlockOutput] -> [BlockOutput] applyFilter (StaticFilter None) = static id applyFilter (AnimatedFilter Rainbow) = rainbow static :: a -> Double -> a static fn _ = fn -rainbow :: Double -> [Block] -> [Block] +rainbow :: Double -> [BlockOutput] -> [BlockOutput] rainbow time blocks = reverse $ evalState (mapM rainbowBlock $ reverse blocks) 0 where - rainbowBlock :: Block -> State Integer Block + rainbowBlock :: BlockOutput -> State Integer BlockOutput rainbowBlock block = do let cleanBlock = removePango block let text = getFullText cleanBlock diff --git a/src/QBar/Server.hs b/src/QBar/Server.hs index 35d3e910efa26f7e8af8ed84a15e59c3cef59381..efc1ce6cce277a3bac1f7b613ecda9f578f53b5d 100644 --- a/src/QBar/Server.hs +++ b/src/QBar/Server.hs @@ -35,14 +35,14 @@ data Handle = Handle { renderIndicator :: BlockProducer renderIndicator = forever $ each $ map createBlock ["/", "-", "\\", "|"] -runBlock :: BlockProducer -> IO (Maybe (Block, BlockProducer)) +runBlock :: BlockProducer -> IO (Maybe (BlockOutput, BlockProducer)) runBlock producer = do next' <- next producer return $ case next' of Left _ -> Nothing Right (block, newProducer) -> Just (block, newProducer) -runBlocks :: [BlockProducer] -> IO ([Block], [BlockProducer]) +runBlocks :: [BlockProducer] -> IO ([BlockOutput], [BlockProducer]) runBlocks blockProducers = unzip . catMaybes <$> mapM runBlock blockProducers renderLoop :: MainOptions -> Handle -> BarUpdateEvent -> BS.ByteString -> TChan BlockProducer -> IO () @@ -76,7 +76,7 @@ renderLoop options handle@Handle{handleActiveFilter} barUpdateEvent previousBarO renderLoop' currentBarOutput blockProducers'' -renderLine :: MainOptions -> Handle -> Filter -> [Block] -> BS.ByteString -> IO BS.ByteString +renderLine :: MainOptions -> Handle -> Filter -> [BlockOutput] -> BS.ByteString -> IO BS.ByteString renderLine MainOptions{verbose} Handle{handleActionList} blockFilter blocks previousEncodedOutput = do time <- fromRational . toRational <$> getPOSIXTime let filteredBlocks = applyFilter blockFilter time blocks @@ -101,7 +101,7 @@ renderLine MainOptions{verbose} Handle{handleActionList} blockFilter blocks prev where clickActionList :: [(T.Text, Click -> IO ())] clickActionList = mapMaybe getClickAction blocks - getClickAction :: Block -> Maybe (T.Text, Click -> IO ()) + getClickAction :: BlockOutput -> Maybe (T.Text, Click -> IO ()) getClickAction block = if hasBlockName && hasClickAction then Just (fromJust maybeBlockName, fromJust maybeClickAction) else Nothing where maybeBlockName = getBlockName block