.gitignore

-.stack-work/
-stack.yaml.lock
-qbar.cabal
 *~
+.*.swp
+/result
+/result-*
+/dist-newstyle
 /TODO

ChangeLog.md

-# Changelog for qbar
-
-## Unreleased changes

README.md

@@ -6,31 +6,45 @@ qbar is a status command for [sway](https://swaywm.org/) and [i3](https://i3wm.o
 
 ### Compiling from Source
 
-Building qbar requires [stack](https://haskellstack.org/). To build it run:
+Building qbar requires nix. To build it run:
 ```
-stack build
+nix build
 ```
 
 You can also use the scripts in the `bin`-directory (all scripts will rebuild the project if required):
 ```
 # Launch as swaybar status command while redirecting stderr to shell
-./bin/run-sway
+./bin/run-sway default
+```
+
+## Configuration
+
+All configuration is currently done with command line arguments. The executable uses a command-style interface (e.g. `qbar theme rainbow`) which supports `--help` at every level of the tree. It also provides bash, zsh and fish tab completions.
 
-# Run the binary directly (mostly used to control the bar via rpc)
-./bin/run --help
+### Sway
 
-# Install the binary to ~/.local/bin
-./bin/install
+Use the following `status_command`:
+
+```
+qbar server swaybar default
 ```
 
-## Configuration
+You can specify a custom set of blocks:
+
+```
+qbar server swaybar date cpu network script ~/bin/my_script
+```
+
+### i3
+
+i3 runs the status command for every screen that shows a bar. To reuse the output of your primary display you can use mirror mode:
+
+```
+# Configure for primary display
+qbar server i3bar default
 
-Custom configuration is currently only possible from Haskell:
+# Configure for other displays
+qbar mirror i3bar
 ```
-myConfig :: BarIO ()
-myConfig = do
-  addBlock dateBlock
 
-main :: IO ()
-main = parseOptions >>= runQBar myConfig
-```
+Theming is not supported on mirrored servers.
\ No newline at end of file

Setup.hs

-import Distribution.Simple
-main = defaultMain

bin/install

-#!/usr/bin/env zsh
-
-set -e
-set -u
-
-readonly executable_name=qbar
-
-readonly local_bin=`stack path --local-bin`
-
-readonly executable_path=$local_bin/$executable_name
-
-stack install
-
-echo >&2
-if [[ -n "${LOCAL_ZSH_COMPLETION_PATH+set}" ]]
-then
-	if [[ -d "$LOCAL_ZSH_COMPLETION_PATH" ]]
-	then
-		ZSH_COMPLETION_SCRIPT_PATH=$LOCAL_ZSH_COMPLETION_PATH/_$executable_name
-		$executable_path --zsh-completion-script $executable_path > $ZSH_COMPLETION_SCRIPT_PATH
-		echo "Installed zsh completions for $executable_name to $ZSH_COMPLETION_SCRIPT_PATH" >&2
-  else
-		echo "Not installing completions, LOCAL_ZSH_COMPLETION_PATH is set but isn't a directory ($LOCAL_ZSH_COMPLETION_PATH)." >&2
-	fi
-else
-  echo "Not installing completions, set LOCAL_ZSH_COMPLETION_PATH to install them." >&2
-fi

bin/run

-#!/bin/sh
-
-set -e
-set -u
-
-readonly executable_name=qbar
-
-stack build && stack exec $executable_name -- "$@"

bin/run-sway

-#!/bin/sh
+#!/usr/bin/env bash
 
 set -e
 set -u
 set -o pipefail
 
-readonly executable_name=qbar
 readonly sway_bar_id=bar-0
 
 readonly default_bar_command="$(swaymsg -t get_bar_config "$sway_bar_id" | jq .status_command)"
 
+if [[ -z "$default_bar_command" ]]; then
+  echo "Cannot get the default bar command" >&2
+  exit 1
+fi
+
 stack build
 
 readonly temp_dir=$(mktemp -d)
@@ -17,7 +21,7 @@ mkfifo $stderr
 
 trap "swaymsg bar $sway_bar_id status_command '$default_bar_command'; rm -rf $temp_dir" EXIT INT HUP TERM
 
-swaymsg bar $sway_bar_id status_command "exec $(stack path --local-install-root)/bin/$executable_name server swaybar $* 2> $stderr"
+swaymsg bar $sway_bar_id status_command "exec nix run . -- server swaybar default $* 2> $stderr"
 
 # show output and run forever (use Ctrl-C to stop)
 cat $stderr

cabal.project

+packages: */*.cabal

flake.lock

+{
+  "nodes": {
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1681303793,
+        "narHash": "sha256-JEdQHsYuCfRL2PICHlOiH/2ue3DwoxUX7DJ6zZxZXFk=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "fe2ecaf706a5907b5e54d979fbde4924d84b65fc",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "ref": "nixos-unstable",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "quasar": {
+      "inputs": {
+        "nixpkgs": [
+          "nixpkgs"
+        ]
+      },
+      "locked": {
+        "lastModified": 1682474992,
+        "narHash": "sha256-tyN64/4weIGmlYMOOrVwFaBVyqvt8du9APhCO9vkV14=",
+        "owner": "queezle42",
+        "repo": "quasar",
+        "rev": "76faa881ae2e3a5575fba9f9e374931dbb8e6495",
+        "type": "github"
+      },
+      "original": {
+        "owner": "queezle42",
+        "repo": "quasar",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "nixpkgs": "nixpkgs",
+        "quasar": "quasar"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

flake.nix

+{
+  inputs = {
+    nixpkgs.url = github:NixOS/nixpkgs/nixos-unstable;
+    quasar.url = github:queezle42/quasar;
+    quasar.inputs.nixpkgs.follows = "nixpkgs";
+  };
+
+  outputs = { self, nixpkgs, quasar }:
+  with nixpkgs.lib;
+  let
+    systems = platforms.unix;
+    forAllSystems = genAttrs systems;
+    getHaskellPackages = pkgs: pattern: pipe pkgs.haskell.packages [
+      attrNames
+      (filter (x: !isNull (strings.match pattern x)))
+      (sort (x: y: x>y))
+      (map (x: pkgs.haskell.packages.${x}))
+      head
+    ];
+  in {
+    packages = forAllSystems (system:
+      let
+        pkgs = import nixpkgs {
+          inherit system;
+          overlays = [
+            self.overlays.default
+            quasar.overlays.default
+          ];
+        };
+        haskellPackages = getHaskellPackages pkgs "ghc94.";
+        results = {
+          qbar = haskellPackages.qbar;
+        };
+      in results // {
+        default = pkgs.linkFarm "qbar-all" (results // mapAttrs' (k: v: nameValuePair "${k}-doc" (v.doc or pkgs.emptyDirectory)) results);
+      }
+    );
+
+    apps = forAllSystems (system: {
+      default = {
+        type = "app";
+        program = "${self.packages.${system}.qbar}/bin/qbar";
+      };
+    });
+
+    overlays.default = final: prev: {
+      haskell = prev.haskell // {
+        packageOverrides = hfinal: hprev: prev.haskell.packageOverrides hfinal hprev // {
+          qbar = hfinal.generateOptparseApplicativeCompletions ["qbar"]
+            (hfinal.callCabal2nix "qbar" ./qbar {});
+        };
+      };
+    };
+
+    devShells = forAllSystems (system:
+      let
+        pkgs = import nixpkgs {
+          inherit system;
+          overlays = [
+            self.overlays.default
+            quasar.overlays.default
+          ];
+        };
+        haskellPackages = getHaskellPackages pkgs "ghc94.";
+      in rec {
+        default = haskellPackages.shellFor {
+          packages = hpkgs: [
+            hpkgs.qbar
+          ];
+          nativeBuildInputs = [
+            haskellPackages.haskell-language-server
+            pkgs.cabal-install
+            pkgs.hlint
+
+            # in addition, for ghcid-wrapper
+            pkgs.entr
+            pkgs.ghcid
+            pkgs.zsh
+          ];
+        };
+      }
+    );
+  };
+}

ghcid-wrapper

+#!/usr/bin/env -S nix develop -L -c zsh
+
+set -euo pipefail
+
+readonly target=${1:-lib:qbar}
+readonly executable=${2:-}
+
+if [[ -n $executable ]]
+then
+  run_executable="cabal run \
+    --disable-optimisation \
+    --ghc-option -fdiagnostics-color=always \
+    $executable \
+    "
+else
+  run_executable=true
+fi
+
+print -P %F{yellow}Cleaning repository%f
+cabal clean
+
+(
+  git ls-files 'examples/*' '*/test' '*/*.cabal' 'flake.*'
+  echo "ghcid-wrapper"
+) | \
+  entr -r \
+    nix develop -L -c \
+      ghcid \
+        --warnings \
+        "--command=cabal repl $target" \
+        "--test=:! \
+          cabal test \
+            --disable-optimisation \
+            --test-show-details=direct \
+            --ghc-option -fdiagnostics-color=always && \
+          $run_executable && \
+          zsh -c 'print -P %F{green}Build and tests passed%f' \
+        "

hie.yaml

+cradle:
+  cabal:

package.yaml

-name:                qbar
-version:             0.1.0.0
-#github:              "githubuser/qbar"
-license:             BSD3
-author:              "Jens Nolte"
-#maintainer:          "example@example.com"
-copyright:           "2019 Jens Nolte"
-
-extra-source-files:
-- README.md
-- ChangeLog.md
-
-# Metadata used when publishing your package
-# synopsis:            Short description of your package
-# category:            Web
-
-# To avoid duplicated efforts in documentation and dealing with the
-# complications of embedding Haddock markup inside cabal files, it is
-# common to point users to the README.md file.
-#description:         Please see the README on GitHub at <https://github.com/githubuser/qbar#readme>
-
-dependencies:
-- base >= 4.7 && < 5
-- aeson
-- async
-- attoparsec
-- bytestring
-- colour
-- concurrent-extra
-- directory
-- filepath
-- lens
-- mtl
-- network
-- optparse-applicative
-- pipes
-- pipes-aeson
-- pipes-concurrency
-- pipes-network
-- pipes-parse
-- pipes-safe
-- random
-- sorted-list
-- stm
-- text
-- time
-- typed-process
-- unix
-- unordered-containers
-
-default-extensions:
-- OverloadedStrings
-- NamedFieldPuns
-- LambdaCase
-- MultiWayIf
-
-ghc-options:
-- -fwarn-unused-do-bind
-- -fwarn-tabs
-- -Wall
-- -Werror
-- -Wwarn=deprecations
-- -O2
-
-library:
-  source-dirs: src
-  other-modules:
-  - Prelude
-  - BasePrelude
-
-executables:
-  qbar:
-    main:                Main.hs
-    source-dirs:         app
-    ghc-options:
-    - -threaded
-    - -rtsopts
-    - -with-rtsopts=-N
-    - -with-rtsopts=-I0
-    dependencies:
-    - qbar
-
-tests:
-  qbar-test:
-    main:                Spec.hs
-    source-dirs:         test
-    ghc-options:
-    - -threaded
-    - -rtsopts
-    - -with-rtsopts=-N
-    dependencies:
-    - qbar

app/Main.hs → qbar/app/Main.hs

-module Main where
+module Main (main) where
 
 import QBar.Cli
+import QBar.Prelude
 
 main :: IO ()
 main = runQBar

qbar/qbar.cabal

+cabal-version: 3.0
+
+name:           qbar
+
+version:        0.1.0.0
+author:         Jens Nolte
+maintainer:     Jens Nolte
+copyright:      2019 Jens Nolte
+license:        BSD-3-Clause
+build-type:     Simple
+
+source-repository head
+  type: git
+  location: https://github.com/queezle42/qbar
+
+common shared-properties
+  default-language: GHC2021
+  default-extensions:
+    ApplicativeDo
+    DuplicateRecordFields
+    LambdaCase
+    MultiWayIf
+    NoImplicitPrelude
+    OverloadedStrings
+  ghc-options:
+    -Weverything
+    -Wno-all-missed-specialisations
+    -Wno-missing-deriving-strategies
+    -Wno-implicit-prelude
+    -Wno-missing-import-lists
+    -Wno-missing-kind-signatures
+    -Wno-missing-safe-haskell-mode
+    -Wno-unsafe
+    -Werror=incomplete-patterns
+    -Werror=missing-fields
+    -Werror=missing-home-modules
+    -Werror=missing-methods
+
+library
+  import: shared-properties
+  build-depends:
+    aeson,
+    async,
+    attoparsec,
+    base >=4.7 && <5,
+    binary,
+    bytestring,
+    colour,
+    concurrent-extra,
+    containers,
+    dbus,
+    directory,
+    filepath,
+    gitrev,
+    hostname,
+    lens,
+    mtl,
+    network,
+    optparse-applicative,
+    pipes,
+    pipes-aeson,
+    pipes-concurrency,
+    pipes-network,
+    pipes-parse,
+    pipes-safe,
+    quasar,
+    quasar-timer,
+    random,
+    sorted-list,
+    stm,
+    text,
+    time,
+    typed-process,
+    unix,
+    unordered-containers,
+  exposed-modules:
+    QBar.BlockHelper
+    QBar.BlockOutput
+    QBar.Blocks
+    QBar.Blocks.Battery
+    QBar.Blocks.CpuUsage
+    QBar.Blocks.Date
+    QBar.Blocks.DiskUsage
+    QBar.Blocks.NetworkManager
+    QBar.Blocks.Pipe
+    QBar.Blocks.Qubes
+    QBar.Blocks.Script
+    QBar.Blocks.Squeekboard
+    QBar.Blocks.Utils
+    QBar.Cli
+    QBar.Color
+    QBar.ControlSocket
+    QBar.Core
+    QBar.DefaultConfig
+    QBar.Host
+    QBar.Pango
+    QBar.Prelude
+    QBar.Qubes.AdminAPI
+    QBar.Server
+    QBar.TagParser
+    QBar.Theme
+    QBar.Time
+    QBar.Utils
+  other-modules:
+  hs-source-dirs:
+    src
+
+executable qbar
+  import: shared-properties
+  ghc-options:
+    -threaded
+    -rtsopts
+    "-with-rtsopts=-N -I0"
+  build-depends:
+    qbar,
+  hs-source-dirs:
+    app
+  main-is: Main.hs
+
+test-suite qbar-test
+  import: shared-properties
+  type: exitcode-stdio-1.0
+  ghc-options:
+    -threaded
+    -rtsopts
+    "-with-rtsopts=-N -I0"
+  main-is: Spec.hs
+  other-modules:
+    Paths_qbar
+  hs-source-dirs:
+    test
+  build-depends:
+    base >=4.7 && <5,

qbar/src/QBar/BlockHelper.hs

+module QBar.BlockHelper (
+  PollBlock',
+  PollBlock,
+  PollSignal,
+  Signal(..),
+  SignalBlock,
+  SignalBlockConfiguration(..),
+  respondBlockUpdate,
+  respondEmptyBlockUpdate,
+  runPollBlock',
+  runPollBlock,
+  runSignalBlock,
+  runSignalBlockConfiguration,
+  runSignalBlockFn',
+  runSignalBlockFn,
+  yieldBlockUpdate,
+  yieldEmptyBlockUpdate,
+) where
+
+import QBar.BlockOutput
+import QBar.Core
+import QBar.Prelude
+import QBar.Time
+
+import Control.Concurrent.Async
+import Control.Concurrent.Event qualified as Event
+import Control.Concurrent.STM.TChan
+import Control.Concurrent.STM.TVar
+import Control.Monad.Reader (ReaderT)
+import Control.Lens
+import Data.Either (isRight)
+import Pipes
+import Pipes.Concurrent
+import Pipes.Core
+import Pipes.Safe (bracket, runSafeT)
+
+data Signal a = RegularSignal | UserSignal a | EventSignal BlockEvent
+  deriving (Show, Eq)
+
+type SignalBlock a = (Signal a -> Server (Signal a) (Maybe BlockOutput) BarIO ExitBlock)
+
+-- |Block that 'respond's with an update whenever it receives a 'PollSignal'.
+type PollBlock = Server PollSignal (Maybe BlockOutput) BarIO ExitBlock
+type PollBlock' = Server PollSignal (Maybe BlockOutput) BarIO
+data PollSignal = PollSignal
+
+respondBlockUpdate :: BlockOutput -> Server' (Signal s) (Maybe BlockOutput) BarIO (Signal s)
+respondBlockUpdate blockOutput = respond $ Just blockOutput
+
+-- |Update a block by removing the current output
+respondEmptyBlockUpdate :: Server' (Signal s) (Maybe BlockOutput) BarIO (Signal s)
+respondEmptyBlockUpdate = respond Nothing
+
+
+yieldBlockUpdate :: BlockOutput -> Server' PollSignal (Maybe BlockOutput) BarIO ()
+yieldBlockUpdate blockOutput = void . respond $ Just blockOutput
+
+-- |Update a block by removing the current output
+yieldEmptyBlockUpdate :: Server' PollSignal (Maybe BlockOutput) BarIO ()
+yieldEmptyBlockUpdate = void . respond $ Nothing
+
+
+runSignalBlock :: forall a. Maybe Interval -> Maybe ((a -> IO ()) -> BarIO ()) -> SignalBlock a -> Block
+runSignalBlock maybeInterval maybeSignalSourceThread signalBlock' = runSignalBlockConfiguration $ SignalBlockConfiguration {
+  aquire = const $ return (),
+  release = return,
+  signalThread = const <$> maybeSignalSourceThread,
+  signalBlock = const signalBlock',
+  interval = maybeInterval
+}
+
+
+runSignalBlockFn :: forall a. Maybe Interval -> ((a -> IO ()) -> BarIO ()) -> ((a, Maybe BlockEvent) -> BarIO (Maybe BlockOutput)) -> Block
+runSignalBlockFn maybeInterval signalSourceThread renderFn = runSignalBlock maybeInterval (Just signalSourceThread) signalBlock
+  where
+    signalBlock :: SignalBlock a
+    signalBlock (UserSignal value) = signalBlock' value (UserSignal value)
+    signalBlock _ = signalBlock =<< respondEmptyBlockUpdate
+    signalBlock' :: a -> SignalBlock a
+    signalBlock' state RegularSignal = signalBlock' state =<< respond =<< lift (renderFn (state, Nothing))
+    signalBlock' _ (UserSignal value) = signalBlock' value =<< respond =<< lift (renderFn (value, Nothing))
+    signalBlock' state (EventSignal event) = signalBlock' state =<< respond =<< lift (renderFn (state, Just event))
+
+runSignalBlockFn' :: Maybe Interval -> (Maybe BlockEvent -> BarIO (Maybe BlockOutput)) -> Block
+runSignalBlockFn' maybeInterval renderFn = runSignalBlockConfiguration $ SignalBlockConfiguration {
+  aquire = const $ return (),
+  release = return,
+  signalThread = Nothing,
+  signalBlock = const eventBlock,
+  interval = maybeInterval
+}
+  where
+    eventBlock :: SignalBlock a
+    eventBlock (EventSignal event) = eventBlock =<< respond =<< lift (renderFn (Just event))
+    eventBlock _ = eventBlock =<< respond =<< lift (renderFn Nothing)
+
+
+
+data SignalBlockConfiguration c p = SignalBlockConfiguration {
+  aquire :: (p -> IO ()) -> BarIO c,
+  release :: c -> BarIO (),
+  signalThread :: Maybe (c -> (p -> IO ()) -> BarIO ()),
+  signalBlock :: c -> SignalBlock p,
+  interval :: Maybe Interval
+}
+
+runSignalBlockConfiguration :: forall c p. SignalBlockConfiguration c p -> Block
+runSignalBlockConfiguration SignalBlockConfiguration{aquire, release, signalThread, signalBlock, interval} = do
+  -- Initialize
+  signalChan <- liftIO newTChanIO
+  signalEvent <- liftIO Event.new
+  -- renderStateVar: (current BlockUpdate or Nothing when signal block terminated, invalidated)
+  renderStateVar <- liftIO $ newTVarIO (Just (Nothing, PollUpdate), False)
+  -- renderEvent: Signals an update to renderStateVar
+  renderEvent <- liftIO Event.new
+
+  runSignalBlockWithThreadInternal signalChan signalEvent renderStateVar renderEvent
+  where
+    runSignalBlockWithThreadInternal :: TChan (Signal p) -> Event.Event -> TVar (Maybe BlockUpdate, Bool) -> Event.Event -> Block
+    runSignalBlockWithThreadInternal signalChan signalEvent renderStateVar renderEvent = do
+      generatorTask <- barAsync $ bracket aquire' release' (\(context, _, _) -> runEffect $ void (signalBlock context +>> signalPipe))
+      liftIO $ link generatorTask
+      renderer
+      where
+        renderer :: Block
+        renderer = do
+          liftIO $ Event.wait renderEvent
+          liftIO $ Event.clear renderEvent
+
+          currentState <- liftIO (readTVarIO renderStateVar)
+          renderer' currentState
+          where
+            renderer' :: (Maybe BlockUpdate, Bool) -> Block
+            renderer' (Just (blockState, reason), invalidated) = do
+              yield $ if invalidated then (invalidateBlockState blockState, reason) else (blockState, reason)
+              renderer
+            renderer' (Nothing, _) = exitBlock
+
+        aquire' :: ReaderT Bar IO (c, Async (), Async ())
+        aquire' = runSafeT $ do
+          context <- aquire userSignalAction
+
+          -- Start signalSource thread
+          userTask <- barAsync $
+            case signalThread of
+              Just signalThread' -> signalThread' context userSignalAction
+              Nothing -> return ()
+          intervalTask <- barAsync intervalTimer
+
+          return (context, userTask, intervalTask)
+
+
+        release' :: (c, Async (), Async ()) -> ReaderT Bar IO ()
+        release' (context, userTask, intervalTask) = do
+          -- Signal block termination to render thread
+          liftIO . atomically $ modifyTVar renderStateVar (_1 .~ Nothing)
+
+          liftIO $ do
+            cancel userTask
+            cancel intervalTask
+
+          runSafeT $ release context
+
+
+        userSignalAction :: p -> IO ()
+        userSignalAction value = do
+          atomically $ writeTChan signalChan $ UserSignal value
+          Event.set signalEvent
+
+        mkBlockStateWithHandler :: Maybe BlockOutput -> BlockState
+        mkBlockStateWithHandler Nothing = Nothing
+        mkBlockStateWithHandler (Just output) = Just (output, Just signalEventHandler)
+
+        signalPipe :: Client (Signal p) (Maybe BlockOutput) BarIO ExitBlock
+        signalPipe = forever $ do
+          -- Handle all queued events
+          eventHandled <- sendQueuedSignals
+
+          -- If there was no queued event signal a regular event
+          unless eventHandled $ sendSignal RegularSignal
+
+          -- Wait for next event
+          liftIO $ Event.wait signalEvent
+          liftIO $ Event.clear signalEvent
+
+          where
+            sendQueuedSignals :: Client (Signal p) (Maybe BlockOutput) BarIO Bool
+            sendQueuedSignals = do
+              maybeSignal <- liftIO . atomically $ tryReadTChan signalChan
+              case maybeSignal of
+                Just signal -> sendSignal signal >> sendQueuedSignals >> return True
+                Nothing -> return False
+
+            sendSignal :: Signal p -> Client (Signal p) (Maybe BlockOutput) BarIO ()
+            sendSignal signal = do
+              maybeOutput <- request signal
+
+              let
+                updateInvalidatedState :: (Maybe BlockUpdate, Bool) -> (Maybe BlockUpdate, Bool)
+                updateInvalidatedState = if isEventSignal signal then _2 .~ False else id
+
+              let blockUpdate = (mkBlockStateWithHandler maybeOutput, signalToReason signal)
+              liftIO . atomically $ modifyTVar renderStateVar ((_1 . _Just .~ blockUpdate) . updateInvalidatedState)
+              liftIO $ Event.set renderEvent
+
+            signalToReason :: Signal a -> BlockUpdateReason
+            signalToReason (UserSignal _) = DefaultUpdate
+            signalToReason (EventSignal _) = EventUpdate
+            signalToReason RegularSignal = PollUpdate
+
+            isEventSignal :: Signal p -> Bool
+            isEventSignal (EventSignal _) = True
+            isEventSignal _ = False
+
+
+        intervalTimer :: BarIO ()
+        intervalTimer = do
+          scheduler <- askSleepScheduler
+          case interval of
+            Just interval' -> forever $ do
+              sleepUntilInterval' scheduler interval'
+              liftIO $ Event.set signalEvent
+            Nothing -> return ()
+
+        signalEventHandler :: BlockEventHandler
+        signalEventHandler event = do
+          wasInvalidatedBefore' <- liftIO . atomically $ do
+            (_, wasInvalidatedBefore) <- readTVar renderStateVar
+            unless wasInvalidatedBefore $ do
+              writeTChan signalChan $ EventSignal event
+              modifyTVar renderStateVar ((_2 .~ True) . (_1 . _Just . _2 .~ EventUpdate))
+            return wasInvalidatedBefore
+
+          unless wasInvalidatedBefore' $ liftIO $ do
+            Event.set renderEvent
+            Event.set signalEvent
+
+
+-- |Converts a 'PollBlock' to a 'Block' by running it whenever the 'defaultInterval' is triggered.
+runPollBlock :: PollBlock -> Block
+runPollBlock = runPollBlock' defaultInterval
+
+-- |Converts a 'PollBlock' to a 'Block' by running it whenever the provided 'Interval' is triggered.
+runPollBlock' :: Interval -> PollBlock -> Block
+runPollBlock' interval pb = do
+  event <- liftIO Event.new
+  pb >>~ addPollSignal >-> sleepToNextInterval event
+  where
+    addPollSignal :: a -> Proxy PollSignal a () a BarIO ExitBlock
+    addPollSignal = respond >=> const (request PollSignal) >=> addPollSignal
+
+    sleepToNextInterval :: Event.Event -> Pipe (Maybe BlockOutput) BlockUpdate BarIO ExitBlock
+    sleepToNextInterval event = sleepToNextInterval' False
+      where
+        sleepToNextInterval' :: Bool -> Pipe (Maybe BlockOutput) BlockUpdate BarIO ExitBlock
+        sleepToNextInterval' isEvent = do
+          maybeOutput <- await
+          -- Attach a click handler that will trigger a block update
+          let state = mkBlockStateWithHandler (triggerOnClick event) maybeOutput
+          yield (state, if isEvent then EventUpdate else PollUpdate)
+
+          scheduler <- askSleepScheduler
+          result <- liftIO $ do
+            timerTask <- async $ sleepUntilInterval' scheduler interval
+            eventTask <- async $ Event.wait event
+            waitEitherCancel timerTask eventTask
+
+          let isEventNew = isRight result
+
+          when isEventNew $ do
+            liftIO $ Event.clear event
+            yield (invalidateBlockState state, EventUpdate)
+
+          sleepToNextInterval' isEventNew
+
+
+    mkBlockStateWithHandler :: BlockEventHandler -> Maybe BlockOutput -> BlockState
+    mkBlockStateWithHandler _ Nothing = Nothing
+    mkBlockStateWithHandler handler (Just output) = Just (output, Just handler)
+
+    triggerOnClick :: Event.Event -> BlockEvent -> BarIO ()
+    triggerOnClick event _ = liftIO $ Event.set event

src/QBar/BlockOutput.hs → qbar/src/QBar/BlockOutput.hs

-{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -Wno-partial-fields #-}
 {-# LANGUAGE TemplateHaskell #-}
 
-module QBar.BlockOutput where
+module QBar.BlockOutput (
+  BlockOutput(..),
+  BlockText(..),
+  BlockTextSegment(..),
+  Importance(..),
+  activeImportantText,
+  activeText,
+  addIcon,
+  blockName,
+  criticalImportant',
+  criticalImportant,
+  emptyBlock,
+  errorImportant',
+  errorImportant,
+  fullText,
+  importantText,
+  invalid,
+  invalidateBlock,
+  isCritical,
+  isError,
+  isNormal,
+  isWarning,
+  mkBlockOutput',
+  mkBlockOutput,
+  mkErrorOutput,
+  mkStyledText,
+  mkText,
+  normalImportant',
+  normalImportant,
+  normalText,
+  printedLength,
+  rawText,
+  shortText,
+  surroundWith,
+  toImportance,
+  warnImportant',
+  warnImportant,
+) where
 
 import QBar.Color
+import QBar.Prelude
 
 import Control.Lens
 import Data.Aeson
-import Data.Aeson.TH
+import Data.Char
 import Data.Int (Int64)
-import qualified Data.Text.Lazy as T
+import Data.Text.Lazy qualified as T
+import GHC.Generics
 
 
 data BlockOutput = BlockOutput {
@@ -18,11 +57,10 @@ data BlockOutput = BlockOutput {
     _blockName :: Maybe T.Text,
     _invalid :: Bool
   }
-  deriving (Eq, Show)
-
+  deriving (Eq, Show, Generic)
 
 newtype BlockText = BlockText [BlockTextSegment]
-  deriving (Eq, Show)
+  deriving (Eq, Show, Generic)
 instance Semigroup BlockText where
   (BlockText a) <> (BlockText b) = BlockText (a <> b)
 instance Monoid BlockText where
@@ -38,16 +76,24 @@ data BlockTextSegment = BlockTextSegment {
     color :: Maybe Color,
     backgroundColor :: Maybe Color
   }
-  deriving (Eq, Show)
+  deriving (Eq, Show, Generic)
 
-type Importance = Float
+data Importance = NormalImportant Float | WarnImportant Float | ErrorImportant Float | CriticalImportant Float
+  deriving (Eq, Show, Generic)
 
+instance FromJSON BlockOutput
+instance ToJSON BlockOutput
 
-$(deriveJSON defaultOptions ''BlockOutput)
-makeLenses ''BlockOutput
-$(deriveJSON defaultOptions ''BlockTextSegment)
-$(deriveJSON defaultOptions ''BlockText)
+instance FromJSON BlockText
+instance ToJSON BlockText
+
+instance FromJSON BlockTextSegment
+instance ToJSON BlockTextSegment
+
+instance FromJSON Importance
+instance ToJSON Importance
 
+makeLenses ''BlockOutput
 
 mkBlockOutput :: BlockText -> BlockOutput
 mkBlockOutput text = BlockOutput {
@@ -76,67 +122,68 @@ addIcon icon = over fullText $ (<>) . normalText $ icon <> " "
 
 
 normalImportant :: Importance
-normalImportant = 1
+normalImportant = NormalImportant 0.5
+
+normalImportant' :: Float -> Importance
+normalImportant' = NormalImportant . min 1 . max 0
+
 warnImportant :: Importance
-warnImportant = 2
+warnImportant = WarnImportant 0.5
+
+warnImportant' :: Float -> Importance
+warnImportant' = WarnImportant . min 1 . max 0
+
 errorImportant :: Importance
-errorImportant = 3
+errorImportant = ErrorImportant 0.5
+
+errorImportant' :: Float -> Importance
+errorImportant' = ErrorImportant . min 1 . max 0
+
 criticalImportant :: Importance
-criticalImportant = 4
+criticalImportant = CriticalImportant 0.5
+
+criticalImportant' :: Float -> Importance
+criticalImportant' = CriticalImportant . min 1 . max 0
 
 isCritical :: Importance -> Bool
-isCritical i
-  | i >= criticalImportant = True
-  | otherwise = False
+isCritical (CriticalImportant _) = True
+isCritical _ = False
+
 isError :: Importance -> Bool
-isError i
-  | isCritical i = False
-  | i >= errorImportant = True
-  | otherwise = False
+isError (ErrorImportant _) = True
+isError _ = False
+
 isWarning :: Importance -> Bool
-isWarning i
-  | isCritical i = False
-  | isError i = False
-  | i >= warnImportant = True
-  | otherwise = False
+isWarning (WarnImportant _) = True
+isWarning _ = False
+
 isNormal :: Importance -> Bool
-isNormal i
-  | isCritical i = False
-  | isError i = False
-  | isWarning i = False
-  | otherwise = True
-
-toImportance :: Real a => (a, a, a, a, a, a) -> a -> Importance
-toImportance (tMax, tCritical, tError, tWarning, tNormal, tMinimal) =
-  toImportance' (Just tMax, tCritical, tError, tWarning, tNormal, Just tMinimal)
-
-toImportance' :: forall a. Real a => (Maybe a, a, a, a, a, Maybe a) -> a -> Importance
-toImportance' (tMax, tCritical, tError, tWarning, tNormal, tMinimal) val
-  | tCritical <= val = 4 + valueCritical tMax  tCritical val
-  | tError  <= val = 3 + linearMatch tCritical tError  val
-  | tWarning <= val = 2 + linearMatch tError  tWarning val
-  | tNormal <= val = 1 + linearMatch tWarning tNormal val
-  | otherwise = 0 + valueOtherwise tNormal tMinimal  val
+isNormal (NormalImportant _) = True
+isNormal _ = False
+
+toImportance :: Real a => (a, a, a, a, a) -> a -> Importance
+toImportance (tMin, tWarning, tError, tCritical, tMax) =
+  toImportance' (Just tMin, tWarning, tError, tCritical, Just tMax)
+
+toImportance' :: Real a => (Maybe a, a, a, a, Maybe a) -> a -> Importance
+toImportance' (tMin, tWarning, tError, tCritical, tMax) val
+  | tCritical <= val = criticalImportant' valueCritical
+  | tError <= val = errorImportant' $ linearMatch tCritical tError val
+  | tWarning <= val = warnImportant' $ linearMatch tError tWarning val
+  | otherwise = normalImportant' valueNormal
   where
-    e :: Importance
-    e = exp 1
-    linearMatch :: a -> a -> a -> Importance
-    linearMatch u l v = frac (v - l) (u - l)
-    logarithmicMatch :: a -> a -> Importance
-    logarithmicMatch l u = 1 - 1 / log (e + realToFrac (u - l))
-    frac :: a -> a -> Importance
-    frac a b = realToFrac a / realToFrac b
-    valueCritical :: Maybe a -> a -> a -> Importance
-    valueCritical (Just tMax') tCritical' v
-      | tMax' > v = linearMatch tMax' tCritical' v
-      | otherwise = 1
-    valueCritical Nothing tCritical' v = logarithmicMatch tCritical' v
-    valueOtherwise :: a -> Maybe a -> a -> Importance
-    valueOtherwise tNormal' (Just tMinimal') v
-      | tMinimal' < v = linearMatch tNormal' tMinimal' v
-      | otherwise = 0
-    valueOtherwise tNormal' Nothing v = 1 - logarithmicMatch v tNormal'
-
+    linearMatch :: Real a => a -> a -> a -> Float
+    linearMatch u l v = realToFrac (v - l) / realToFrac (u - l)
+    logarithmicMatch :: Real a => a -> a -> Float
+    logarithmicMatch l u = (\x -> 1 - 1 / (1 + x)) . log . realToFrac $ u - l
+    valueCritical :: Float
+    valueCritical = case tMax of
+      Just tMax' -> if tMax' > val then linearMatch tMax' tCritical val else 1
+      Nothing -> logarithmicMatch tCritical val
+    valueNormal :: Float
+    valueNormal = case tMin of
+      Just tMin' -> if tMin' < val then linearMatch tWarning tMin' val else 0
+      Nothing -> 1 - logarithmicMatch val tWarning
 
 invalidateBlock :: BlockOutput -> BlockOutput
 invalidateBlock block@BlockOutput{ _fullText, _shortText } = block {
@@ -163,8 +210,31 @@ printedLength (BlockText b) = sum . map segmentLength $ b
 mkText :: Bool -> Importance -> T.Text -> BlockText
 mkText active importance segmentText = BlockText [BlockTextSegment { segmentText = pangoFriendly segmentText, active, importance }]
   where
+    toHex :: Int -> T.Text
+    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
+      | x <= 0 = "0"
+      | otherwise = toHex (div x 16) <> toHex (mod x 16)
+    pangoFriendlyIcon :: Char -> T.Text
+    pangoFriendlyIcon x
+      | isAlphaNum x || isAscii x = T.singleton x
+      | otherwise = "&#x" <> toHex (ord x) <> ";"
     pangoFriendly :: T.Text -> T.Text
-    pangoFriendly = T.replace "<" "&lt;" . T.replace ">" "&gt;" . T.replace "&" "&amp;"
+    pangoFriendly = T.concatMap pangoFriendlyIcon . T.replace "<" "&lt;" . T.replace ">" "&gt;" . T.replace "&" "&amp;"
 
 activeImportantText :: Importance -> T.Text -> BlockText
 activeImportantText = mkText True

qbar/src/QBar/Blocks.hs

+module QBar.Blocks (
+  QBar.Blocks.Battery.batteryBlock,
+  QBar.Blocks.CpuUsage.cpuUsageBlock,
+  QBar.Blocks.Date.dateBlock,
+  QBar.Blocks.DiskUsage.diskUsageBlock,
+  QBar.Blocks.NetworkManager.networkManagerBlock,
+  QBar.Blocks.Qubes.diskUsageQubesBlock,
+  QBar.Blocks.Qubes.qubesMonitorPropertyBlock,
+  QBar.Blocks.Qubes.qubesVMCountBlock,
+  QBar.Blocks.Script.scriptBlock,
+  QBar.Blocks.Script.pollScriptBlock,
+  QBar.Blocks.Squeekboard.squeekboardBlock,
+) where
+
+import QBar.Blocks.Battery qualified
+import QBar.Blocks.CpuUsage qualified
+import QBar.Blocks.Date qualified
+import QBar.Blocks.DiskUsage qualified
+import QBar.Blocks.NetworkManager qualified
+import QBar.Blocks.Qubes qualified
+import QBar.Blocks.Script qualified
+import QBar.Blocks.Squeekboard qualified

src/QBar/Blocks/Battery.hs → qbar/src/QBar/Blocks/Battery.hs

-{-# LANGUAGE ScopedTypeVariables #-}
-
-
-module QBar.Blocks.Battery where
-
+module QBar.Blocks.Battery (
+  batteryBlock,
+) where
 
+import QBar.BlockHelper
 import QBar.Core
 import QBar.Blocks.Utils
 import QBar.BlockOutput
-
-import qualified Data.Text.Lazy as T
-import qualified Data.Text.Lazy.IO as TIO
-
-import System.Directory
-import Data.Maybe
-import Text.Read (readMaybe)
+import QBar.Prelude
 
 import Control.Lens
-
+import Data.Maybe (catMaybes, mapMaybe)
+import Data.Text.Lazy qualified as T
+import Data.Text.Lazy.IO qualified as TIO
+import System.Directory
 
 data BatteryStatus = BatteryCharging | BatteryDischarging | BatteryOther
-  deriving (Show)
+  deriving (Eq, Show)
 
-
-data BatteryState = BatteryState
-  { _status :: BatteryStatus
-  , _powerNow :: Maybe Int
-  , _energyNow :: Int
-  , _energyFull :: Int
+data BatteryState = BatteryState {
+  _status :: BatteryStatus,
+  _powerNow :: Maybe Int,
+  _energyNow :: Int,
+  _energyFull :: Int
 } deriving (Show)
 
-
 getBatteryState :: FilePath -> IO (Maybe BatteryState)
-getBatteryState path = tryMaybe $ do
-  status' <- TIO.readFile (path <> "/status")
-  powerNow' <- tryMaybe $ TIO.readFile (path <> "/power_now")
-  energyNow' <- readIO =<< readFile (path <> "/energy_now")
-  energyFull' <- readIO =<< readFile (path <> "/energy_full")
-  return BatteryState
-    { _status = batteryStatus . T.strip $ status'
-    , _powerNow = readMaybe . T.unpack =<< powerNow'
-    , _energyNow = energyNow'
-    , _energyFull = energyFull'
-    }
+getBatteryState path = maybe getBatteryStateCharge (return . Just) =<< getBatteryStateEnergy
   where
-    batteryStatus :: T.Text -> BatteryStatus
-    batteryStatus statusText
-      | statusText == "Charging" = BatteryCharging
-      | statusText == "Discharging" = BatteryDischarging
-      | otherwise = BatteryOther
-
-
-batteryBlock :: PullBlock
-batteryBlock = forever $ do
+    getVoltage :: IO Double
+    getVoltage = readIO =<< readFile (path <> "/voltage_now")
+    getBatteryStateEnergy :: IO (Maybe BatteryState)
+    getBatteryStateEnergy = tryMaybe $ do
+      status' <- batteryStatus
+      energyNow' <- readIO =<< readFile (path <> "/energy_now")
+      energyFull' <- readIO =<< readFile (path <> "/energy_full")
+      powerNow' <- batteryPower getVoltage
+      return BatteryState {
+        _status = status',
+        _powerNow = powerNow',
+        _energyNow = energyNow',
+        _energyFull = energyFull'
+      }
+    getBatteryStateCharge :: IO (Maybe BatteryState)
+    getBatteryStateCharge = tryMaybe $ do
+      status' <- batteryStatus
+      voltageNow' <- getVoltage
+      powerNow' <- batteryPower (return voltageNow')
+      chargeNow' <- readIO =<< readFile (path <> "/charge_now")
+      chargeFull' <- readIO =<< readFile (path <> "/charge_full")
+      return BatteryState {
+        _status = status',
+        _powerNow = powerNow',
+        _energyNow = round $ voltageNow' * chargeNow' / 1000000,
+        _energyFull = round $ voltageNow' * chargeFull' / 1000000
+      }
+    batteryPower :: IO Double -> IO (Maybe Int)
+    batteryPower getVoltage' = do
+      power' <- tryMaybe $ readIO =<< readFile (path <> "/power_now")
+      case power' of
+        power@(Just _) -> return power
+        Nothing -> tryMaybe $ do
+          current <- readIO =<< readFile (path <> "/current_now")
+          voltage <- getVoltage'
+          return $ round $ voltage * current / 1000000
+    batteryStatus :: IO BatteryStatus
+    batteryStatus = do
+      statusText <- tryMaybe $ T.strip <$> TIO.readFile (path <> "/status")
+      return $
+        if  | statusText == Just "Charging" -> BatteryCharging
+            | statusText == Just "Discharging" -> BatteryDischarging
+            | otherwise -> BatteryOther
+
+
+batteryBlock :: Block
+batteryBlock = runPollBlock $ forever $ do
   batteryPaths <- liftIO $ map ((apiPath <> "/") <>) . filter (T.isPrefixOf "BAT" . T.pack) <$> getDirectoryContents apiPath
   batteryStates <- liftIO $ mapM getBatteryState batteryPaths
   isPlugged <- liftIO getPluggedState
@@ -73,15 +95,15 @@ batteryBlock = forever $ do
             _ -> return . return $ False
 
 
-updateBatteryBlock :: Bool -> [BatteryState] -> Block ()
-updateBatteryBlock _ [] = updateBlockEmpty
-updateBatteryBlock isPlugged bs = updateBlock $ (shortText.~shortText') $ mkBlockOutput fullText'
+updateBatteryBlock :: Bool -> [BatteryState] -> PollBlock' ()
+updateBatteryBlock _ [] = yieldEmptyBlockUpdate
+updateBatteryBlock isPlugged bs = yieldBlockUpdate $ (shortText .~ shortText') $ mkBlockOutput fullText'
   where
     fullText' :: BlockText
-    fullText' = normalText (batteryIcon <> " ") <> overallPercentage <> optionalEachBattery <> optionalOverallEstimate
+    fullText' = overallPercentage <> optionalEachBattery <> optionalOverallEstimate
 
     shortText' :: Maybe BlockText
-    shortText' = Just $ normalText (batteryIcon <> " ") <> overallPercentage
+    shortText' = Just overallPercentage
 
     batteryIcon :: T.Text
     batteryIcon
@@ -91,6 +113,7 @@ updateBatteryBlock isPlugged bs = updateBlock $ (shortText.~shortText') $ mkBloc
     optionalEachBattery :: BlockText
     optionalEachBattery
       | length bs < 2 = mempty
+      | batteryIsFull bs = mempty
       | otherwise = normalText " " <> eachBattery
 
     eachBattery :: BlockText
@@ -106,15 +129,14 @@ updateBatteryBlock isPlugged bs = updateBlock $ (shortText.~shortText') $ mkBloc
     perSingleBattery b = importantText (batteryImportance [b]) $ perSingleBatteryArrow b <> (formatFloatN 0 . batteryPercentage) [b] <> "%"
 
     overallPercentage :: BlockText
-    overallPercentage = mkText (not isPlugged) (batteryImportance bs) $ (formatFloatN 0 . batteryPercentage $ bs) <> "%"
+    overallPercentage = mkText (not isPlugged) (batteryImportance bs) $ batteryIcon <> " " <> (formatFloatN 0 . batteryPercentage $ bs) <> "%"
 
     optionalOverallEstimate :: BlockText
-    optionalOverallEstimate = maybe mempty (\s -> surroundWith normalText " (" ")" s) . batteryEstimateFormated $ bs
+    optionalOverallEstimate = maybe mempty (surroundWith normalText " (" ")") . batteryEstimateFormated $ bs
 
 
 batteryImportance :: [BatteryState] -> Importance
-batteryImportance = toImportance (100, 90, 80, 60, 50, 0) . (100-) . batteryPercentage
-
+batteryImportance = toImportance (0, 60, 80, 90, 100) . (100 -) . batteryPercentage
 
 batteryPercentage :: [BatteryState] -> Float
 batteryPercentage batteryStates
@@ -137,6 +159,17 @@ batteryEstimateFormated batteryStates = do
   return $ normalText $ (T.pack . show $ allHours) <> ":" <> (T.justifyRight 2 '0' . T.pack . show $ minutes)
 
 
+batteryIsFull :: [BatteryState] -> Bool
+batteryIsFull = all singleBatteryIsFull
+  where
+    singleBatteryIsFull :: BatteryState -> Bool
+    singleBatteryIsFull bs@BatteryState{_status}
+      | _status == BatteryCharging = False
+      | _status == BatteryDischarging = False
+      | 95 >= batteryPercentage [bs] = False
+      | otherwise = True
+
+
 batteryIsCharging :: [BatteryState] -> Bool
 batteryIsCharging = any (singleBatteryIsCharging . _status)
   where
@@ -156,8 +189,8 @@ batteryIsDischarging = any (singleBatteryIsDischarging . _status)
 batteryEstimate :: [BatteryState] -> Maybe Int
 batteryEstimate batteryStates
   | batteryPowerNow == 0 = Nothing
-  | isCharging, not isDischarging = ensure (>0) batteryEstimateCharging
-  | isDischarging, not isCharging = ensure (>0) batteryEstimateDischarging
+  | isCharging, not isDischarging = ensure (> 0) batteryEstimateCharging
+  | isDischarging, not isCharging = ensure (> 0) batteryEstimateDischarging
   | otherwise = Nothing
   where
     isCharging :: Bool

src/QBar/Blocks/CpuUsage.hs → qbar/src/QBar/Blocks/CpuUsage.hs

 {-# LANGUAGE TemplateHaskell #-}
 
-module QBar.Blocks.CpuUsage where
+module QBar.Blocks.CpuUsage (
+  cpuUsageBlock,
+) where
 
-import Control.Applicative ((<|>))
-import Control.Lens
-import Control.Monad.State
-import qualified Data.Attoparsec.Text.Lazy as AT
-import qualified Data.Text.Lazy as T
+import QBar.BlockHelper
 import QBar.BlockOutput
 import QBar.Blocks.Utils
 import QBar.Core
+import QBar.Prelude
+
+import Control.Applicative ((<|>))
+import Control.Lens
+import Control.Monad.State (StateT, evalStateT, lift)
+import Data.Attoparsec.Text.Lazy qualified as AT
+import Data.Text.Lazy qualified as T
 
 {-
   For time accounting the guest fields need to be ignored according to the kernel source code
@@ -17,18 +22,16 @@ import QBar.Core
   the accounting also counts the guest time to user or nice respectively so applications
   that are not aware of the new fields do not loose time.
 -}
-data CpuStat
-  = CpuStat
-      { userTime :: Int,
-        niceTime :: Int,
-        systemTime :: Int,
-        idleTime :: Int,
-        iowaitTime :: Int,
-        irqTime :: Int,
-        softirqTime :: Int,
-        stealTime :: Int
-      }
-  deriving (Show)
+data CpuStat = CpuStat {
+  userTime :: Int,
+  niceTime :: Int,
+  systemTime :: Int,
+  idleTime :: Int,
+  iowaitTime :: Int,
+  irqTime :: Int,
+  softirqTime :: Int,
+  stealTime :: Int
+} deriving (Show)
 
 getCpuStat :: IO (Maybe CpuStat)
 getCpuStat = parseFile "/proc/stat" cpuStat
@@ -47,53 +50,48 @@ getCpuStat = parseFile "/proc/stat" cpuStat
       irqTime' <- AT.skipSpace *> AT.decimal
       softirqTime' <- AT.skipSpace *> AT.decimal
       stealTime' <- AT.skipSpace *> AT.decimal
-      return $
-        CpuStat
-          { userTime = userTime',
-            niceTime = niceTime',
-            systemTime = systemTime',
-            idleTime = idleTime',
-            iowaitTime = iowaitTime',
-            irqTime = irqTime',
-            softirqTime = softirqTime',
-            stealTime = stealTime'
-          }
+      return $ CpuStat {
+        userTime = userTime',
+        niceTime = niceTime',
+        systemTime = systemTime',
+        idleTime = idleTime',
+        iowaitTime = iowaitTime',
+        irqTime = irqTime',
+        softirqTime = softirqTime',
+        stealTime = stealTime'
+      }
 
 differenceCpuStat :: CpuStat -> CpuStat -> CpuStat
-differenceCpuStat a b =
-  CpuStat
-    { userTime = userTime a - userTime b,
-      niceTime = niceTime a - niceTime b,
-      systemTime = systemTime a - systemTime b,
-      idleTime = idleTime a - idleTime b,
-      iowaitTime = iowaitTime a - iowaitTime b,
-      irqTime = irqTime a - irqTime b,
-      softirqTime = softirqTime a - softirqTime b,
-      stealTime = stealTime a - stealTime b
-    }
+differenceCpuStat a b = CpuStat {
+    userTime = userTime a - userTime b,
+    niceTime = niceTime a - niceTime b,
+    systemTime = systemTime a - systemTime b,
+    idleTime = idleTime a - idleTime b,
+    iowaitTime = iowaitTime a - iowaitTime b,
+    irqTime = irqTime a - irqTime b,
+    softirqTime = softirqTime a - softirqTime b,
+    stealTime = stealTime a - stealTime b
+  }
 
 cpuTotalTime :: Num a => CpuStat -> a
 cpuTotalTime
-  CpuStat
-    { userTime,
-      niceTime,
-      systemTime,
-      idleTime,
-      iowaitTime,
-      irqTime,
-      softirqTime,
-      stealTime
-    } =
-    fromIntegral . sum $
-      [ userTime,
-        niceTime,
-        systemTime,
-        idleTime,
-        iowaitTime,
-        irqTime,
-        softirqTime,
-        stealTime
-      ]
+  CpuStat { userTime,
+    niceTime,
+    systemTime,
+    idleTime,
+    iowaitTime,
+    irqTime,
+    softirqTime,
+    stealTime
+  } = fromIntegral . sum $ [ userTime,
+    niceTime,
+    systemTime,
+    idleTime,
+    iowaitTime,
+    irqTime,
+    softirqTime,
+    stealTime
+  ]
 
 cpuUsage :: CpuStat -> Float
 cpuUsage stat@CpuStat {idleTime, iowaitTime} = 1 - (totalIdleTime / totalTime)
@@ -103,32 +101,29 @@ cpuUsage stat@CpuStat {idleTime, iowaitTime} = 1 - (totalIdleTime / totalTime)
     totalIdleTime :: Num a => a
     totalIdleTime = fromIntegral $ idleTime + iowaitTime
 
-data CpuBlockState
-  = CpuBlockState
-      { _lastCpuStat :: CpuStat,
-        _lastCpuUsage :: Float
-      }
-  deriving (Show)
+data CpuBlockState = CpuBlockState {
+  _lastCpuStat :: CpuStat,
+  _lastCpuUsage :: Float
+} deriving (Show)
 
 makeLenses ''CpuBlockState
 
-cpuUsageBlock :: Int -> PullBlock
-cpuUsageBlock decimalPlaces = evalStateT cpuUsageBlock' createState
+cpuUsageBlock :: Int -> Block
+cpuUsageBlock decimalPlaces = runPollBlock $ evalStateT cpuUsageBlock' createState
   where
-    cpuUsageBlock' :: StateT CpuBlockState Block PullMode
-    cpuUsageBlock' = do
+    cpuUsageBlock' :: StateT CpuBlockState PollBlock' ExitBlock
+    cpuUsageBlock' = forever $ do
       updateState
       importance <- cpuUsageImportance
-      updateBlock . mkBlockOutput . importantText importance =<< cpuUsageText
-      cpuUsageBlock'
+      text <- ("💻\xFE0E " <>) <$> cpuUsageText
+      lift $ yieldBlockUpdate $ mkBlockOutput $ importantText importance text
     createState :: CpuBlockState
-    createState =
-      CpuBlockState
-        { _lastCpuStat = CpuStat 0 0 0 0 0 0 0 0,
-          _lastCpuUsage = 0
-        }
+    createState = CpuBlockState {
+      _lastCpuStat = CpuStat 0 0 0 0 0 0 0 0,
+      _lastCpuUsage = 0
+    }
     cpuUsageImportance :: Monad m => StateT CpuBlockState m Importance
-    cpuUsageImportance = toImportance (100, 90, 80, 60, 50, 0) <$> use lastCpuUsage
+    cpuUsageImportance = toImportance (0, 60, 80, 90, 100) <$> use lastCpuUsage
     cpuUsageTextWidth :: Num a => a
     cpuUsageTextWidth
       | decimalPlaces == 0 = 3