Volume indicator

src/Bar.hs

 {-# LANGUAGE DeriveGeneric, OverloadedStrings #-}
 
-module Bar (StatusLine (StatusLine), Block (), textBlock, toUnderline, toWarning) where
+module Bar (StatusLine (StatusLine), Block (), emptyBlock, textBlock, toBold, toUnderline, toWarning) where
 
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Aeson (FromJSON, ToJSON)
 import GHC.Generics
 
-
 newtype StatusLine = StatusLine [Block] deriving (Show, Generic)
 
 data Block = Block {
@@ -43,10 +42,14 @@ textBlock text = emptyBlock {full_text = text}
 toWarning :: Block -> Block
 toWarning block = block {background = Just "#a2620280"}
 
+toBold :: Block -> Block
+toBold block = block {full_text = T.concat ["<b>", full_text block, "</b>"], markup = Just "pango"}
+
 -- | Turns a block into an underlined one with the given color in the format "#rrggbb".
 toUnderline :: Text -> Block -> Block
 toUnderline color block = block {full_text = T.concat ["<span underline=\"single\" underline_color=\"", color, "\">", full_text block, "</span>"], markup = Just "pango"}
 
+-- Generic instances
 instance FromJSON StatusLine
 instance ToJSON StatusLine
 instance FromJSON Block

src/Block.hs

@@ -13,7 +13,7 @@ import qualified Data.Text as T
 import Data.Maybe
 
 datetime :: IO Block
-datetime = textBlock . (Icon.calendar <>) . ("\8239" <>) <$> Data.datetime
+datetime = textBlock . (Icon.calendar <>) . (" " <>) <$> Data.datetime
 
 displayBrightness :: IO Block
 displayBrightness = do
@@ -33,9 +33,22 @@ wifi :: IO Block
 wifi = do
     signal <- Data.wifi
     return $ textBlock $ if isJust signal
-        then (fromJust $ Icon.pickByPercentage Icon.wifi (fromJust signal)) <> " " <> T.pack (show $ fromJust signal) <> "\8239%"
+        then fromJust (Icon.pickByPercentage Icon.wifi (fromJust signal)) <> " " <> T.pack (show $ fromJust signal) <> "\8239%"
         else Icon.wifiNoConnection <> " 0\8239%"
 
+hostname :: IO Block
+hostname = do
+    name <- Data.hostname
+    return $ toBold . textBlock $ name
+
+volume :: IO Block
+volume = do
+    volumeLevel <- Data.volumeLevel
+    volumeMuted <- Data.volumeMuted
+    let icon = if volumeMuted
+        then Icon.volumeMuted
+        else fromMaybe "?" $ Icon.pickByPercentage Icon.volume volumeLevel
+    return $ textBlock $ icon <> " " <> T.pack (show volumeLevel) <> "\8239%"
 
 iff :: (a -> Bool) -> (a -> a) -> a -> a
 iff p f input

src/Data.hs

-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, LambdaCase #-}
 
 -- | Functions for reading the system status data.
 module Data where
@@ -6,6 +6,7 @@ module Data where
 import System.IO
 import Control.Concurrent
 import System.Process
+import System.Exit
 import Data.Time
 import Data.Time.Clock.System
 import Data.Char
@@ -24,9 +25,25 @@ displayBrightness :: IO Int
 displayBrightness = round . read <$> readCreateProcess (shell "light -G") ""
 
 datetime :: IO Text
-datetime = T.pack . formatTime defaultTimeLocale "%Y-%m-%d\8239%H:%M" <$> (utcToLocalZonedTime =<< (systemToUTCTime <$> getSystemTime))
+datetime = T.pack . formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" <$> (utcToLocalZonedTime =<< (systemToUTCTime <$> getSystemTime))
 
+-- | Gets the current wifi connection strength in percent. Returns Nothing if not currently connected.
+-- | Uses nmcli, so it only works if NetworkManager is being used.
 wifi :: IO (Maybe Int)
 wifi = do
     output <- readCreateProcess (shell "nmcli -t -f in-use,signal d wifi") ""
-    return $ read <$> fromMaybe "0" <$> stripPrefix "*:" <$> find ("*:" `isPrefixOf`) (lines output)
+    return $ read . fromMaybe "0" . stripPrefix "*:" <$> find ("*:" `isPrefixOf`) (lines output)
+
+hostname :: IO Text
+hostname = T.strip . T.pack <$> readCreateProcess (shell "hostname") ""
+
+volumeLevel :: IO Int
+volumeLevel = do
+    (_, out, _) <- readCreateProcessWithExitCode (shell "pamixer --get-volume") ""
+    return $ read out
+
+volumeMuted :: IO Bool
+volumeMuted = readCreateProcessWithExitCode (shell "pamixer --get-mute") "" >>= \case
+    (ExitSuccess, "true\n", _) -> return True
+    (ExitFailure _, "false\n", _) -> return False
+    _ -> return False

src/Icon.hs

 {-# LANGUAGE OverloadedStrings #-}
 
+-- | Icons for the status bar.
 module Icon where
 
 import Data.Text (Text)
 
+-- | Picks an element from a list by a percentage value.
+-- | For example: pickByPercentage [1,2,3] 50 ~> 2
 pickByPercentage :: [a] -> Int -> Maybe a
 pickByPercentage [] _ = Nothing
 pickByPercentage xs percent
@@ -28,6 +31,9 @@ batteryCharging = "\62851"  -- nf-mdi-battery-charging
 volume :: [Text]
 volume = ["\64126", "\64127", "\64125"]  -- nf-md-volume_low, nf-md-volume_medium, nf-md-volume_high
 
+volumeMuted :: Text
+volumeMuted = "\64128"  -- nf-mdi-volume_mute
+
 wifi :: [Text]
 wifi = ["\64168"]
 

src/Main.hs

 {-# LANGUAGE OverloadedStrings #-}
 
+-- TODO: Refactor this horrible, HORRIBLE module.
 module Main (main) where
 
 import System.IO
@@ -10,6 +11,7 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Char
 import Data.List
+import Data.Foldable
 import System.Process
 import Bar
 import Data
@@ -23,21 +25,31 @@ main :: IO ()
 main = do
     putStrLn "{\"version\": 1}\n[[]"
     hFlush stdout
-    putStatusLines
+    initial <- toStatusLine $ fst <$> blocks
+    putStatusLines initial $ snd <$> blocks
 
-putStatusLines :: IO ()
-putStatusLines = do
+putStatusLines :: StatusLine -> [Int] -> IO ()
+putStatusLines statusLine countdowns = do
     putChar ','
-    st <- status
-    B.putStr (encode st)
+    B.putStr (encode statusLine)
     putChar '\n'
     hFlush stdout
-    threadDelay $ delay * 1000000
-    putStatusLines
+    threadDelay $ delay * 900000
+    let (actions, newCountdowns) = unzip $ updateActions statusLine blocks countdowns
+    next <- toStatusLine actions
+    putStatusLines next newCountdowns
 
-status :: IO StatusLine
-status = (\a b c d -> StatusLine [a, b, c, d]) <$> Block.wifi <*> Block.displayBrightness <*> Block.battery <*> Block.datetime
+updateActions :: StatusLine -> [(IO Block, Int)] -> [Int] -> [(IO Block, Int)]
+updateActions (StatusLine (b:bs)) ((d, mt):ds) (t:ts)
+    | t <= 1 = (d, mt) : updateActions (StatusLine bs) ds ts
+    | otherwise = (return b, t - 1) : updateActions (StatusLine bs) ds ts
+updateActions (StatusLine []) [] [] = []
+
+toStatusLine :: [IO Block] -> IO StatusLine
+toStatusLine blockIOs = StatusLine <$> foldrM f [] blockIOs where
+    f :: IO Block -> [Block] -> IO [Block]
+    f bio bs = (:bs) <$> bio
 
 -- List of activated status blocks and their checking interval in seconds.
 blocks :: [(IO Block, Int)]
-blocks = [(Block.wifi, 10), (Block.datetime, 5), (Block.displayBrightness, 1), (Block.battery, 10)]
+blocks = [(Block.wifi, 10), (Block.datetime, 3), (Block.displayBrightness, 1), (Block.volume, 3), (Block.battery, 10), (Block.hostname, 60)]