From f1663d49f123e66078d66403681a90e30d862e8d Mon Sep 17 00:00:00 2001
From: Jens Nolte <jens@nightmarestudio.de>
Date: Tue, 28 Jan 2020 18:43:40 +0100
Subject: [PATCH] Move BlockOutput from QBar.Core to QBar.BlockOutput
---
src/QBar/BlockOutput.hs | 37 ++++++++++++++++++++++++++++++++
src/QBar/Blocks/Battery.hs | 3 ++-
src/QBar/Blocks/Date.hs | 5 +++--
src/QBar/ControlSocket.hs | 8 +++----
src/QBar/Core.hs | 43 ++++++++------------------------------
src/QBar/DefaultConfig.hs | 1 +
src/QBar/Filter.hs | 2 +-
src/QBar/Server.hs | 5 +++--
src/QBar/Themes.hs | 3 +--
9 files changed, 61 insertions(+), 46 deletions(-)
create mode 100644 src/QBar/BlockOutput.hs
diff --git a/src/QBar/BlockOutput.hs b/src/QBar/BlockOutput.hs
new file mode 100644
index 0000000..d20ac35
--- /dev/null
+++ b/src/QBar/BlockOutput.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module QBar.BlockOutput where
+
+import QBar.BlockText
+
+import Control.Lens
+import Data.Aeson.TH
+import qualified Data.Text.Lazy as T
+
+data BlockOutput = BlockOutput
+ { _fullText :: BlockText
+ , _shortText :: Maybe BlockText
+ , _blockName :: Maybe T.Text
+ , _invalid :: Bool
+ }
+$(deriveJSON defaultOptions ''BlockOutput)
+makeLenses ''BlockOutput
+
+
+mkBlockOutput :: BlockText -> BlockOutput
+mkBlockOutput text = BlockOutput
+ { _fullText = text
+ , _shortText = Nothing
+ , _blockName = Nothing
+ , _invalid = False
+ }
+
+mkErrorOutput :: T.Text -> BlockOutput
+mkErrorOutput = mkBlockOutput . importantText criticalImportant
+
+emptyBlock :: BlockOutput
+emptyBlock = mkBlockOutput mempty
+
+addIcon :: T.Text -> BlockOutput -> BlockOutput
+addIcon icon = over fullText $ (<>) . normalText $ icon <> " "
+
diff --git a/src/QBar/Blocks/Battery.hs b/src/QBar/Blocks/Battery.hs
index 7dcd5ec..7c0ece8 100644
--- a/src/QBar/Blocks/Battery.hs
+++ b/src/QBar/Blocks/Battery.hs
@@ -5,6 +5,7 @@ module QBar.Blocks.Battery where
import QBar.Core hiding (name)
+import QBar.BlockOutput
import QBar.BlockText
import Pipes
@@ -86,7 +87,7 @@ batteryBlock = do
updateBatteryBlock :: Bool -> [BatteryState] -> Block ()
updateBatteryBlock _ [] = yield Nothing
-updateBatteryBlock isPlugged bs = updateBlock $ (shortText.~shortText') $ createBlock fullText'
+updateBatteryBlock isPlugged bs = updateBlock $ (shortText.~shortText') $ mkBlockOutput fullText'
where
fullText' :: BlockText
fullText' = normalText (batteryIcon <> " ") <> overallPercentage <> optionalEachBattery <> optionalOverallEstimate
diff --git a/src/QBar/Blocks/Date.hs b/src/QBar/Blocks/Date.hs
index d47cd72..bfbff2a 100644
--- a/src/QBar/Blocks/Date.hs
+++ b/src/QBar/Blocks/Date.hs
@@ -1,8 +1,9 @@
module QBar.Blocks.Date where
+import QBar.BlockOutput
+import QBar.BlockText
import QBar.Core
import QBar.Time
-import QBar.BlockText
import qualified Data.Text.Lazy as T
import Data.Time.Format
@@ -24,4 +25,4 @@ dateBlockOutput = do
let date = T.pack (formatTime defaultTimeLocale "%a %F" zonedTime)
let time = T.pack (formatTime defaultTimeLocale "%R" zonedTime)
let text = normalText ("📅\xFE0E " <> date <> " ") <> activeText time
- return $ blockName ?~ "date" $ createBlock text
+ return $ blockName ?~ "date" $ mkBlockOutput text
diff --git a/src/QBar/ControlSocket.hs b/src/QBar/ControlSocket.hs
index e64fc63..1c1b7a6 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.BlockOutput
import QBar.BlockText
import Control.Exception (handle)
@@ -17,6 +18,8 @@ import Control.Concurrent.Async
import Control.Concurrent.STM.TChan (TChan, writeTChan)
import Data.Aeson.TH
import Data.ByteString (ByteString)
+import System.FilePath ((</>))
+import System.IO
import Data.Either (either)
import Data.Maybe (maybe)
import Data.Text.Lazy (Text, pack)
@@ -30,9 +33,6 @@ import Pipes.Aeson.Unchecked (encode)
import Pipes.Network.TCP (fromSocket, toSocket)
import System.Directory (removeFile, doesFileExist)
import System.Environment (getEnv)
-import System.FilePath ((</>))
-import System.IO
-
type CommandChan = TChan Command
data Command = SetFilter Filter
@@ -128,5 +128,5 @@ handleBlockStream producer = do
where
handleParsedBlock :: Producer ByteString IO () -> String -> PushBlock
handleParsedBlock leftovers update = do
- updateBlock $ createBlock . normalText $ TL.pack update
+ updateBlock $ mkBlockOutput . normalText $ TL.pack update
handleBlockStream leftovers
diff --git a/src/QBar/Core.hs b/src/QBar/Core.hs
index 359daf0..5404966 100644
--- a/src/QBar/Core.hs
+++ b/src/QBar/Core.hs
@@ -3,16 +3,18 @@
module QBar.Core where
+import QBar.BlockOutput
import QBar.BlockText
-import Control.Exception (IOException)
-import Control.Monad (forever)
-import Control.Monad.Reader (ReaderT, runReaderT, ask)
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
import Control.Concurrent.Event as Event
import Control.Concurrent.MVar
import Control.Concurrent.STM.TChan (TChan, writeTChan)
+import Control.Exception (IOException)
+import Control.Lens
+import Control.Monad (forever)
+import Control.Monad.Reader (ReaderT, runReaderT, ask)
import Data.Aeson.TH
import qualified Data.ByteString.Lazy.Char8 as C8
import Data.Int (Int64)
@@ -28,7 +30,6 @@ import System.Exit
import System.IO
import System.Process.Typed (Process, shell, setStdin, setStdout,
getStdout, closed, createPipe, readProcessStdout, startProcess, stopProcess)
-import Control.Lens
data BlockEvent = Click {
@@ -37,14 +38,6 @@ data BlockEvent = Click {
} deriving Show
$(deriveJSON defaultOptions ''BlockEvent)
-data BlockOutput = BlockOutput
- { _fullText :: BlockText
- , _shortText :: Maybe BlockText
- , _blockName :: Maybe T.Text
- , _invalid :: Bool
- }
-$(deriveJSON defaultOptions ''BlockOutput)
-
data PushMode = PushMode
data PullMode = PullMode
@@ -84,7 +77,6 @@ data Bar = Bar {
requestBarUpdate :: IO (),
newBlockChan :: TChan CachedBlock
}
-makeLenses ''BlockOutput
instance IsBlock PushBlock where
toCachedBlock = cachePushBlock
@@ -114,23 +106,6 @@ runBarIO bar action = runReaderT (runSafeT action) bar
askBar :: BarIO Bar
askBar = lift ask
-createBlock :: BlockText -> BlockOutput
-createBlock text = BlockOutput
- { _fullText = text
- , _shortText = Nothing
- , _blockName = Nothing
- , _invalid = False
- }
-
-createErrorBlock :: T.Text -> BlockOutput
-createErrorBlock = createBlock . importantText criticalImportant
-
-emptyBlock :: BlockOutput
-emptyBlock = createBlock mempty
-
-addIcon :: T.Text -> BlockOutput -> BlockOutput
-addIcon icon = over fullText $ (<>) . normalText $ icon <> " "
-
modify :: (BlockOutput -> BlockOutput)
-> Pipe BlockState BlockState BarIO r
modify x = PP.map (over (_Just . _1) x)
@@ -252,9 +227,9 @@ blockScript path = forever $ updateBlock =<< (lift blockScriptAction)
(text:short:_) -> shortText ?~ pangoText short $ createScriptBlock text
(text:_) -> createScriptBlock text
[] -> createScriptBlock "-"
- (ExitFailure nr) -> return $ createErrorBlock $ "[" <> T.pack (show nr) <> "]"
+ (ExitFailure nr) -> return $ mkErrorOutput $ "[" <> T.pack (show nr) <> "]"
createScriptBlock :: T.Text -> BlockOutput
- createScriptBlock text = blockName ?~ T.pack path $ createBlock . pangoText $ text
+ createScriptBlock text = blockName ?~ T.pack path $ mkBlockOutput . pangoText $ text
startPersistentBlockScript :: FilePath -> PushBlock
-- The outer catchP only catches errors that occur during process creation
@@ -262,7 +237,7 @@ startPersistentBlockScript path = catchP startScriptProcess handleError
where
handleError :: IOException -> PushBlock
handleError e = do
- updateBlock . createErrorBlock $ "[" <> T.pack (show e) <> "]"
+ updateBlock . mkErrorOutput $ "[" <> T.pack (show e) <> "]"
exitBlock
handleErrorWithProcess :: (Process i o e) -> IOException -> PushBlock
handleErrorWithProcess process e = do
@@ -278,7 +253,7 @@ startPersistentBlockScript path = catchP startScriptProcess handleError
blockFromHandle :: Handle -> PushBlock
blockFromHandle handle = forever $ do
line <- liftIO $ TIO.hGetLine handle
- updateBlock $ createBlock . pangoText $ line
+ updateBlock $ mkBlockOutput . pangoText $ line
lift updateBar
addBlock :: IsBlock a => a -> BarIO ()
diff --git a/src/QBar/DefaultConfig.hs b/src/QBar/DefaultConfig.hs
index a004be8..5c0d613 100644
--- a/src/QBar/DefaultConfig.hs
+++ b/src/QBar/DefaultConfig.hs
@@ -1,6 +1,7 @@
module QBar.DefaultConfig where
import QBar.Blocks
+import QBar.BlockOutput
import QBar.Core
import Pipes
diff --git a/src/QBar/Filter.hs b/src/QBar/Filter.hs
index 6992617..eef1b64 100644
--- a/src/QBar/Filter.hs
+++ b/src/QBar/Filter.hs
@@ -2,7 +2,7 @@
module QBar.Filter where
-import QBar.Core
+import QBar.BlockOutput
import QBar.BlockText
import Control.Monad.State.Lazy (State, evalState, get, put)
diff --git a/src/QBar/Server.hs b/src/QBar/Server.hs
index ad918d4..f466972 100644
--- a/src/QBar/Server.hs
+++ b/src/QBar/Server.hs
@@ -1,6 +1,7 @@
module QBar.Server where
import QBar.Blocks
+import QBar.BlockOutput
import QBar.BlockText
import QBar.Core
import QBar.Cli
@@ -36,7 +37,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 (mkBlockState . createBlock . normalText) ["/", "-", "\\", "|"]
+renderIndicator = forever $ each $ map (mkBlockState . mkBlockOutput . normalText) ["/", "-", "\\", "|"]
runBlock :: CachedBlock -> BarIO (Maybe (BlockState, CachedBlock))
runBlock producer = do
@@ -183,7 +184,7 @@ renderInitialBlocks options handle blockFilter = do
date <- dateBlockOutput
let initialBlocks = [mkBlockState date]
-- Attach spinner indicator when verbose flag is set
- let initialBlocks' = if indicator options then initialBlocks <> [mkBlockState $ createBlock . normalText $ "*"] else initialBlocks
+ let initialBlocks' = if indicator options then initialBlocks <> [mkBlockState $ mkBlockOutput . normalText $ "*"] else initialBlocks
-- Render initial time block so the bar is not empty after startup
renderLine options handle blockFilter initialBlocks' ""
diff --git a/src/QBar/Themes.hs b/src/QBar/Themes.hs
index 09728fc..16cfdc2 100644
--- a/src/QBar/Themes.hs
+++ b/src/QBar/Themes.hs
@@ -1,8 +1,7 @@
module QBar.Themes where
-
+import QBar.BlockOutput
import QBar.BlockText
-import QBar.Core
import qualified Data.Text.Lazy as T
--
GitLab