.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 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
-- containers
-- dbus
-- 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
-- ScopedTypeVariables
-
-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,

src/QBar/BlockHelper.hs → qbar/src/QBar/BlockHelper.hs

-{-# LANGUAGE RankNTypes #-}
-
-module QBar.BlockHelper where
+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 qualified Control.Concurrent.Event as Event
+import Control.Concurrent.Event qualified as Event
 import Control.Concurrent.STM.TChan
 import Control.Concurrent.STM.TVar
 import Control.Monad.Reader (ReaderT)
-import Control.Monad.State (StateT, evalStateT, get, put)
+import Control.Lens
 import Data.Either (isRight)
 import Pipes
 import Pipes.Concurrent
@@ -93,15 +109,33 @@ runSignalBlockConfiguration SignalBlockConfiguration{aquire, release, signalThre
   -- Initialize
   signalChan <- liftIO newTChanIO
   signalEvent <- liftIO Event.new
-  isInvalidatedVar <- liftIO $ newTVarIO False
+  -- 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 isInvalidatedVar
+  runSignalBlockWithThreadInternal signalChan signalEvent renderStateVar renderEvent
   where
-    runSignalBlockWithThreadInternal :: TChan (Signal p) -> Event.Event -> TVar Bool -> Block
-    runSignalBlockWithThreadInternal signalChan signalEvent isInvalidatedVar = do
-      bracket aquire' release' (\(context, _, _) -> void (signalBlock context +>> signalPipe))
-      exitBlock
+    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
@@ -118,6 +152,9 @@ runSignalBlockConfiguration SignalBlockConfiguration{aquire, release, signalThre
 
         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
@@ -130,63 +167,41 @@ runSignalBlockConfiguration SignalBlockConfiguration{aquire, release, signalThre
           atomically $ writeTChan signalChan $ UserSignal value
           Event.set signalEvent
 
-        signalPipe :: Proxy (Signal p) (Maybe BlockOutput) () BlockUpdate BarIO ExitBlock
-        signalPipe = do
-          initial <- request RegularSignal
-          let initialUpdate = (mkBlockStateWithHandler initial, PollUpdate)
-          yield initialUpdate
-          evalStateT stateSignalPipe initialUpdate
-
         mkBlockStateWithHandler :: Maybe BlockOutput -> BlockState
         mkBlockStateWithHandler Nothing = Nothing
         mkBlockStateWithHandler (Just output) = Just (output, Just signalEventHandler)
 
-        stateSignalPipe :: StateT BlockUpdate (Proxy (Signal p) (Maybe BlockOutput) () BlockUpdate BarIO) ExitBlock
-        stateSignalPipe = forever $ do
+        signalPipe :: Client (Signal p) (Maybe BlockOutput) BarIO ExitBlock
+        signalPipe = forever $ do
           -- Handle all queued events
-          eventHandled <- sendQueuedEvents
+          eventHandled <- sendQueuedSignals
 
           -- If there was no queued event signal a regular event
-          unless eventHandled $ outputAndStore RegularSignal
+          unless eventHandled $ sendSignal RegularSignal
 
           -- Wait for next event
           liftIO $ Event.wait signalEvent
           liftIO $ Event.clear signalEvent
 
           where
-            sendQueuedEvents :: StateT BlockUpdate (Proxy (Signal p) (Maybe BlockOutput) () BlockUpdate BarIO) Bool
-            sendQueuedEvents = do
+            sendQueuedSignals :: Client (Signal p) (Maybe BlockOutput) BarIO Bool
+            sendQueuedSignals = do
               maybeSignal <- liftIO . atomically $ tryReadTChan signalChan
               case maybeSignal of
-                Just signal -> do
-                  case signal of
-                    EventSignal _ -> do
-                      (state, _) <- get
-                      lift $ yield (invalidateBlockState state, EventUpdate)
-                    _ -> return ()
-                  outputAndStore signal
-                  void sendQueuedEvents
-                  return True
+                Just signal -> sendSignal signal >> sendQueuedSignals >> return True
                 Nothing -> return False
 
-            outputAndStore :: Signal p -> StateT BlockUpdate (Proxy (Signal p) (Maybe BlockOutput) () BlockUpdate BarIO) ()
-            outputAndStore signal = do
-              maybeOutput <- lift $ request signal
-
-              invalidate <- if isEventSignal signal
-                then do
-                  -- Reset invalidate flag
-                  liftIO . atomically $ writeTVar isInvalidatedVar False
-                  return False
-                else
-                  liftIO . atomically $ readTVar isInvalidatedVar
+            sendSignal :: Signal p -> Client (Signal p) (Maybe BlockOutput) BarIO ()
+            sendSignal signal = do
+              maybeOutput <- request signal
 
-              let state = mkBlockStateWithHandler maybeOutput
-              let state' = if invalidate then invalidateBlockState state else state
+              let
+                updateInvalidatedState :: (Maybe BlockUpdate, Bool) -> (Maybe BlockUpdate, Bool)
+                updateInvalidatedState = if isEventSignal signal then _2 .~ False else id
 
-              let update = (state', signalToReason signal)
-              put update
-              lift $ yield update
+              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
@@ -209,14 +224,16 @@ runSignalBlockConfiguration SignalBlockConfiguration{aquire, release, signalThre
 
         signalEventHandler :: BlockEventHandler
         signalEventHandler event = do
-          wasInvalidated' <- liftIO . atomically $ do
-            wasInvalidated <- readTVar isInvalidatedVar
-            unless wasInvalidated $ do
+          wasInvalidatedBefore' <- liftIO . atomically $ do
+            (_, wasInvalidatedBefore) <- readTVar renderStateVar
+            unless wasInvalidatedBefore $ do
               writeTChan signalChan $ EventSignal event
-              writeTVar isInvalidatedVar True
-            return wasInvalidated
+              modifyTVar renderStateVar ((_2 .~ True) . (_1 . _Just . _2 .~ EventUpdate))
+            return wasInvalidatedBefore
 
-          unless wasInvalidated' $ liftIO $ Event.set signalEvent
+          unless wasInvalidatedBefore' $ liftIO $ do
+            Event.set renderEvent
+            Event.set signalEvent
 
 
 -- |Converts a 'PollBlock' to a 'Block' by running it whenever the 'defaultInterval' is triggered.

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,18 +76,24 @@ data BlockTextSegment = BlockTextSegment {
     color :: Maybe Color,
     backgroundColor :: Maybe Color
   }
-  deriving (Eq, Show)
+  deriving (Eq, Show, Generic)
 
 data Importance = NormalImportant Float | WarnImportant Float | ErrorImportant Float | CriticalImportant Float
-  deriving (Eq, Show)
+  deriving (Eq, Show, Generic)
 
+instance FromJSON BlockOutput
+instance ToJSON BlockOutput
 
-$(deriveJSON defaultOptions ''BlockOutput)
-makeLenses ''BlockOutput
-$(deriveJSON defaultOptions ''Importance)
-$(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 {
@@ -166,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 MultiWayIf #-}
-{-# 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 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 = maybe getBatteryStateCharge (return . Just) =<< getBatteryStateEnergy
   where
@@ -40,12 +35,12 @@ getBatteryState path = maybe getBatteryStateCharge (return . Just) =<< getBatter
       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'
-        }
+      return BatteryState {
+        _status = status',
+        _powerNow = powerNow',
+        _energyNow = energyNow',
+        _energyFull = energyFull'
+      }
     getBatteryStateCharge :: IO (Maybe BatteryState)
     getBatteryStateCharge = tryMaybe $ do
       status' <- batteryStatus
@@ -53,12 +48,12 @@ getBatteryState path = maybe getBatteryStateCharge (return . Just) =<< getBatter
       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
-        }
+      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")
@@ -71,10 +66,10 @@ getBatteryState path = maybe getBatteryStateCharge (return . Just) =<< getBatter
     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
+      return $
+        if  | statusText == Just "Charging" -> BatteryCharging
+            | statusText == Just "Discharging" -> BatteryDischarging
+            | otherwise -> BatteryOther
 
 
 batteryBlock :: Block
@@ -102,7 +97,7 @@ batteryBlock = runPollBlock $ forever $ do
 
 updateBatteryBlock :: Bool -> [BatteryState] -> PollBlock' ()
 updateBatteryBlock _ [] = yieldEmptyBlockUpdate
-updateBatteryBlock isPlugged bs = yieldBlockUpdate $ (shortText.~shortText') $ mkBlockOutput fullText'
+updateBatteryBlock isPlugged bs = yieldBlockUpdate $ (shortText .~ shortText') $ mkBlockOutput fullText'
   where
     fullText' :: BlockText
     fullText' = overallPercentage <> optionalEachBattery <> optionalOverallEstimate
@@ -118,6 +113,7 @@ updateBatteryBlock isPlugged bs = yieldBlockUpdate $ (shortText.~shortText') $ m
     optionalEachBattery :: BlockText
     optionalEachBattery
       | length bs < 2 = mempty
+      | batteryIsFull bs = mempty
       | otherwise = normalText " " <> eachBattery
 
     eachBattery :: BlockText
@@ -142,7 +138,6 @@ updateBatteryBlock isPlugged bs = yieldBlockUpdate $ (shortText.~shortText') $ m
 batteryImportance :: [BatteryState] -> Importance
 batteryImportance = toImportance (0, 60, 80, 90, 100) . (100 -) . batteryPercentage
 
-
 batteryPercentage :: [BatteryState] -> Float
 batteryPercentage batteryStates
   | batteryEnergyFull == 0 = 0
@@ -164,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
@@ -183,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 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 qualified Data.Attoparsec.Text.Lazy as AT
-import qualified Data.Text.Lazy as T
-import QBar.BlockOutput
-import QBar.Blocks.Utils
-import QBar.Core
+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
@@ -19,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
@@ -49,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)
@@ -105,12 +101,10 @@ 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
 
@@ -124,13 +118,12 @@ cpuUsageBlock decimalPlaces = runPollBlock $ evalStateT cpuUsageBlock' createSta
       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 (0, 60, 80, 90 ,100) <$> use lastCpuUsage
+    cpuUsageImportance = toImportance (0, 60, 80, 90, 100) <$> use lastCpuUsage
     cpuUsageTextWidth :: Num a => a
     cpuUsageTextWidth
       | decimalPlaces == 0 = 3