diff --git a/.gitignore b/.gitignore index bbcf271df0386dbcaeba4dd0225cb5ee020ab1dc..996ce0797bd4600ff65da1c775ecefb86f5450f1 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,6 @@ -.stack-work/ -stack.yaml.lock -qbar.cabal *~ .*.swp +/result +/result-* +/dist-newstyle /TODO diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 index 9a994af677b0dfd41b4e3b76b3e7e604003d64e1..0000000000000000000000000000000000000000 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/app/Main.hs b/app/Main.hs index 8a4c11dbd846e2fbeb8604e395a24ca4e51e26ee..c0e6c83e0cec08954c428283893755a185739d33 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,7 @@ module Main where import QBar.Cli +import QBar.Prelude main :: IO () main = runQBar diff --git a/bin/run-sway b/bin/run-sway index d3275fb2d965acd9daa389e8686c219536d11754..8af98663bac47031ea570c04bd939071e4a37190 100755 --- a/bin/run-sway +++ b/bin/run-sway @@ -1,14 +1,18 @@ -#!/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 diff --git a/default.nix b/default.nix index b8c5877643a4767126a6b9f693a9201f52475d83..243321fec62ebad78a4f0d0a35ed8f28fef3309e 100644 --- a/default.nix +++ b/default.nix @@ -1,11 +1,8 @@ -{ pkgs ? import <nixpkgs> {}, haskellPackages ? pkgs.haskellPackages, args ? {}}: +{ pkgs ? import <nixpkgs> {}, haskellPackages ? pkgs.haskellPackages, args ? {} }: let - inherit (pkgs) lib haskell; - rawdrv = haskellPackages.callCabal2nix "qbar" ./. args; - drv = haskell.lib.generateOptparseApplicativeCompletions [ "qbar" ] rawdrv; + drv = pkgs.haskell.lib.generateOptparseApplicativeCompletions [ "qbar" ] rawdrv; in - - if lib.inNixShell then drv.env else drv + if pkgs.lib.inNixShell then rawdrv.env else drv diff --git a/flake.lock b/flake.lock index f1e7e05f0af4c07adcc6a71c9de85981ec545fc1..1d6fed0f6607e411659de8740b9a6eb253453036 100644 --- a/flake.lock +++ b/flake.lock @@ -2,11 +2,12 @@ "nodes": { "nixpkgs": { "locked": { - "lastModified": 1631118067, - "narHash": "sha256-tEcFvm3a6ToeBGwHdjfB2mVQwa4LZCZTQYE2LnY3ycA=", - "path": "/nix/store/6dcqil119qr3sad2lp9ykkkc852ppmqm-source", - "rev": "09cd65b33c5653d7d2954fef4b9f0e718c899743", - "type": "path" + "lastModified": 1648486164, + "narHash": "sha256-v2EOpYJkFS+L4TFoBWC1ZTKYm6FsNNIGyWraY5MtO+4=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "1be57bee8d0565a7bfd8745540fed257c8c7f523", + "type": "github" }, "original": { "id": "nixpkgs", diff --git a/flake.nix b/flake.nix index 4728067c32d762ba9706c0cd86d7cf107ff210a2..8d30d187145d2f92a5c3092a2848c6f16969a6f9 100644 --- a/flake.nix +++ b/flake.nix @@ -1,32 +1,46 @@ { - outputs = { self, nixpkgs }: let + outputs = { self, nixpkgs }: with nixpkgs.lib; let - lib = nixpkgs.lib; - - systems = lib.platforms.unix; - - forAllSystems = f: lib.genAttrs systems (system: f system); + systems = platforms.unix; + forAllSystems = f: genAttrs systems (system: f system); in { - packages = forAllSystems (system: { - qbar = import ./. { - pkgs = nixpkgs.legacyPackages."${system}"; - }; - }); + packages = forAllSystems (system: + let pkgs = import nixpkgs { inherit system; overlays = [ self.overlay ]; }; + in rec { + default = qbar; + qbar = pkgs.haskellPackages.qbar; + } + ); - overlay = self: super: { - qbar = self.haskellPackages.qd; - haskell = super.haskell // { - packageOverrides = hself: hsuper: super.haskell.packageOverrides hself hsuper // { - qbar = import ./. { pkgs = self; haskellPackages = hself; }; + defaultPackage = forAllSystems (system: self.packages.${system}.qbar); + + overlay = final: prev: { + haskell = prev.haskell // { + packageOverrides = hfinal: hprev: prev.haskell.packageOverrides hfinal hprev // { + qbar = import ./. { + pkgs = final; + haskellPackages = hfinal; + }; }; }; }; - defaultPackage = forAllSystems (system: self.packages.${system}.qbar); - - devShell = forAllSystems (system: self.packages.${system}.qbar.env); + devShell = forAllSystems (system: + let + pkgs = nixpkgs.legacyPackages.${system}; + in pkgs.mkShell { + inputsFrom = [ self.packages.${system}.default.env ]; + packages = [ + pkgs.cabal-install + pkgs.zsh + pkgs.entr + pkgs.ghcid + pkgs.haskell-language-server + ]; + } + ); }; } diff --git a/ghcid b/ghcid new file mode 100755 index 0000000000000000000000000000000000000000..c3d50ccb6cab4f1a767993720c0832b6f8b6c2b5 --- /dev/null +++ b/ghcid @@ -0,0 +1,16 @@ +#!/usr/bin/env -S nix develop . -c zsh + +print -P %F{yellow}Cleaning repository%f +nix develop -c cabal clean + +(git ls-files test; git ls-files '*.cabal'; git ls-files 'flake.*') | \ + entr -r \ + nix develop -c \ + ghcid \ + --warnings \ + "--command=cabal repl lib:qbar" \ + "--test=:! \ + cabal test --disable-optimisation --enable-debug-info=2 --test-show-details=direct --ghc-option -fdiagnostics-color=always && \ + cabal build --disable-optimisation --enable-debug-info=2 --ghc-option -fdiagnostics-color=always && \ + zsh -c 'print -P %F{green}Build and tests passed%f' \ + " diff --git a/load-all.ghci b/load-all.ghci deleted file mode 100644 index 38790aa13ff33775a16e25edd7e3f27d1c8e8e06..0000000000000000000000000000000000000000 --- a/load-all.ghci +++ /dev/null @@ -1,9 +0,0 @@ -:set -isrc -XOverloadedStrings -XNamedFieldPuns -XLambdaCase -XMultiWayIf -XScopedTypeVariables - -# see https://gitlab.haskell.org/ghc/ghc/-/issues/10920 -:set -XNoImplicitPrelude -:load src/Prelude.hs -:set -XImplicitPrelude - -:load src/QBar/Cli.hs src/QBar/Qubes/AdminAPI.hs -:m QBar.Cli QBar.Qubes.AdminAPI diff --git a/package.yaml b/package.yaml deleted file mode 100644 index beffc205ce1727fcbbd1e353b1742a0b0be42536..0000000000000000000000000000000000000000 --- a/package.yaml +++ /dev/null @@ -1,98 +0,0 @@ -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 -- 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 -- 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 diff --git a/qbar.cabal b/qbar.cabal new file mode 100644 index 0000000000000000000000000000000000000000..a9b6227336070f7f5ba68af5456e7ac88f6b2c07 --- /dev/null +++ b/qbar.cabal @@ -0,0 +1,198 @@ +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 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +--source-repository head +-- type: git +-- location: https://git.c3pb.de/jens/qbar.git + +common shared-properties + default-extensions: + AllowAmbiguousTypes + BangPatterns + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DisambiguateRecordFields + DuplicateRecordFields + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + InstanceSigs + LambdaCase + -- Enable once 9.0.1 is required + --LexicalNegation + MultiParamTypeClasses + NamedFieldPuns + NoImplicitPrelude + NumericUnderscores + OverloadedStrings + PolyKinds + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + ViewPatterns + default-language: Haskell2010 + ghc-options: + -Weverything + -Wno-all-missed-specialisations + -Wno-missing-safe-haskell-mode + -Wno-missing-kind-signatures + -Wno-missing-import-lists + -Wno-unsafe + -Werror=incomplete-patterns + -Werror=missing-fields + -Werror=missing-home-modules + -Werror=missing-methods + +common shared-executable-properties + import: shared-properties + ghc-options: + -threaded + -rtsopts + "-with-rtsopts=-N -I0" + +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, + 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 + hs-source-dirs: + src + default-extensions: + MultiWayIf + +executable qbar + import: shared-executable-properties + main-is: Main.hs + other-modules: + Paths_qbar + hs-source-dirs: + app + 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, + qbar, + random, + sorted-list, + stm, + text, + time, + typed-process, + unix, + unordered-containers, + +test-suite qbar-test + import: shared-executable-properties + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_qbar + hs-source-dirs: + test + build-depends: + base >=4.7 && <5, + qbar, \ No newline at end of file diff --git a/run-ghci.sh b/run-ghci.sh deleted file mode 100755 index afef36c301408afa66d9fedfaba451ad55dd6b6b..0000000000000000000000000000000000000000 --- a/run-ghci.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash -set -e -stack exec -- ghci -ghci-script load-all.ghci diff --git a/run-ghcid.sh b/run-ghcid.sh deleted file mode 100755 index c1bc375f260c2800241c3206d8aa1b944958b5f2..0000000000000000000000000000000000000000 --- a/run-ghcid.sh +++ /dev/null @@ -1,3 +0,0 @@ -#!/usr/bin/env bash -set -e -stack exec -- ghcid -c "ghci -ghci-script load-all.ghci" diff --git a/shell.nix b/shell.nix deleted file mode 100644 index c46699e638d326f083666fdb1172b8c1150c90a7..0000000000000000000000000000000000000000 --- a/shell.nix +++ /dev/null @@ -1,9 +0,0 @@ -{ pkgs ? import <nixpkgs> {} }: - -pkgs.mkShell { - buildInputs = with pkgs; [ - stack - zsh - jq - ]; -} diff --git a/src/BasePrelude.hs b/src/BasePrelude.hs deleted file mode 100644 index 0de4ba49536a43e02a979328518e613dc03e0652..0000000000000000000000000000000000000000 --- a/src/BasePrelude.hs +++ /dev/null @@ -1,9 +0,0 @@ -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module BasePrelude - ( module Prelude, - ) -where - -import "base" Prelude diff --git a/src/QBar/BlockHelper.hs b/src/QBar/BlockHelper.hs index 6fee5785e12f9f4008b67d5c0acf44612398109c..6707c2a1f36de18472b13df63d660083d2225964 100644 --- a/src/QBar/BlockHelper.hs +++ b/src/QBar/BlockHelper.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE RankNTypes #-} - module QBar.BlockHelper where import QBar.BlockOutput import QBar.Core +import QBar.Prelude import QBar.Time import Control.Concurrent.Async diff --git a/src/QBar/BlockOutput.hs b/src/QBar/BlockOutput.hs index 84a1fc61a55cbfcdeae62800b3e88ffa9ce3ce0d..35b1016775e2125fcbe11dbcf362951a3c51d8fb 100644 --- a/src/QBar/BlockOutput.hs +++ b/src/QBar/BlockOutput.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module QBar.BlockOutput where import QBar.Color +import QBar.Prelude import Control.Lens import Data.Aeson diff --git a/src/QBar/Blocks/Battery.hs b/src/QBar/Blocks/Battery.hs index 994195431ad9d893c9d5423f76d15c3b4ff4d028..a93b6f83104972024da6fafaea3641d1c149be33 100644 --- a/src/QBar/Blocks/Battery.hs +++ b/src/QBar/Blocks/Battery.hs @@ -1,34 +1,27 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE ScopedTypeVariables #-} - module QBar.Blocks.Battery where import QBar.BlockHelper import QBar.Core import QBar.Blocks.Utils import QBar.BlockOutput +import QBar.Prelude +import Control.Lens +import Data.Maybe (catMaybes, mapMaybe) import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.IO as TIO - import System.Directory -import Data.Maybe - -import Control.Lens - 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 +33,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 +46,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 +64,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 @@ -118,6 +111,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 +136,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 +157,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 +187,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 diff --git a/src/QBar/Blocks/CpuUsage.hs b/src/QBar/Blocks/CpuUsage.hs index e1177337447ecc7aa1c3306e4d55eb7401988dba..f74b05b9a1f1f8f4f4d7bdedd7cc6288f957d35b 100644 --- a/src/QBar/Blocks/CpuUsage.hs +++ b/src/QBar/Blocks/CpuUsage.hs @@ -6,6 +6,7 @@ import QBar.BlockHelper import QBar.BlockOutput import QBar.Blocks.Utils import QBar.Core +import QBar.Prelude import Control.Applicative ((<|>)) import Control.Lens @@ -19,18 +20,16 @@ import qualified Data.Text.Lazy as T 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 +48,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 +99,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 +116,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 diff --git a/src/QBar/Blocks/Date.hs b/src/QBar/Blocks/Date.hs index f731ed26d328a0d1dbe19438426072c141162d02..b60119e3f5186c2103778c1dcb68dba8186d7277 100644 --- a/src/QBar/Blocks/Date.hs +++ b/src/QBar/Blocks/Date.hs @@ -3,6 +3,7 @@ module QBar.Blocks.Date where import QBar.BlockHelper import QBar.BlockOutput import QBar.Core +import QBar.Prelude import QBar.Time import qualified Data.Text.Lazy as T diff --git a/src/QBar/Blocks/DiskUsage.hs b/src/QBar/Blocks/DiskUsage.hs index a0169b343ac6ba739d32f269175414050ab2d54b..e93adc89111d3cf91472113c5db1e0f8319ab5ce 100644 --- a/src/QBar/Blocks/DiskUsage.hs +++ b/src/QBar/Blocks/DiskUsage.hs @@ -3,6 +3,7 @@ module QBar.Blocks.DiskUsage where import QBar.BlockHelper import QBar.BlockOutput import QBar.Core +import QBar.Prelude import qualified Data.ByteString.Lazy.Char8 as C8 import qualified Data.Text.Lazy as T @@ -16,7 +17,7 @@ diskIcon = "💾\xFE0E" diskUsageBlock :: Text -> Block diskUsageBlock path = runPollBlock $ forever $ do output <- liftBarIO action - yieldBlockUpdate $ addIcon diskIcon output + yieldBlockUpdate $ addIcon diskIcon output where action :: BarIO BlockOutput action = do diff --git a/src/QBar/Blocks/NetworkManager.hs b/src/QBar/Blocks/NetworkManager.hs index b33e54f09b6a66f5c562dc840d36554efd568bb4..7aca6e6a375e8077be0ecb0937baff379456fa09 100644 --- a/src/QBar/Blocks/NetworkManager.hs +++ b/src/QBar/Blocks/NetworkManager.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} - module QBar.Blocks.NetworkManager where import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError) @@ -12,6 +10,7 @@ import QBar.BlockHelper import QBar.BlockOutput import QBar.Blocks.Utils import QBar.Core +import QBar.Prelude data ConnectionInfo = WifiConnection Text Int | WwanConnection Text Int | EthernetConnection Text deriving (Show) diff --git a/src/QBar/Blocks/Pipe.hs b/src/QBar/Blocks/Pipe.hs index 4ecce71b679f303633e8992ef31c70236617eec3..05b26a98ee1712a56fa88ef1efb5c8f608573a9e 100644 --- a/src/QBar/Blocks/Pipe.hs +++ b/src/QBar/Blocks/Pipe.hs @@ -2,6 +2,7 @@ module QBar.Blocks.Pipe where import QBar.ControlSocket import QBar.Core +import QBar.Prelude import QBar.TagParser import Control.Concurrent.Async diff --git a/src/QBar/Blocks/Qubes.hs b/src/QBar/Blocks/Qubes.hs index 267f8143b8d6cb2ef39d589b9211e0ea691558b1..092907a43c720c82441f6daf07303d9ce550660c 100644 --- a/src/QBar/Blocks/Qubes.hs +++ b/src/QBar/Blocks/Qubes.hs @@ -3,6 +3,7 @@ module QBar.Blocks.Qubes where import QBar.BlockHelper import QBar.BlockOutput import QBar.Core +import QBar.Prelude import QBar.Qubes.AdminAPI (qubesUsageOfDefaultPool, qubesMonitorProperty, qubesGetProperty, qubesEvents, QubesPropertyInfo (..), qubesListVMs, qubesListVMsP, QubesVMState (..), vmState) import qualified Data.ByteString.Lazy as BL @@ -19,7 +20,7 @@ diskIcon = "💾\xFE0E" diskUsageQubesBlock :: Block diskUsageQubesBlock = runPollBlock $ forever $ do output <- liftBarIO action - yieldBlockUpdate $ addIcon diskIcon output + yieldBlockUpdate $ addIcon diskIcon output where action :: BarIO BlockOutput action = liftIO qubesUsageOfDefaultPool >>= \case diff --git a/src/QBar/Blocks/Script.hs b/src/QBar/Blocks/Script.hs index 8f55daaa31e2299eeaef50bd383dbb8a945b8f04..3d1ffbd5c52c788596b08c7c77c4a38b91fe0295 100644 --- a/src/QBar/Blocks/Script.hs +++ b/src/QBar/Blocks/Script.hs @@ -3,6 +3,7 @@ module QBar.Blocks.Script where import QBar.BlockHelper import QBar.BlockOutput import QBar.Core +import QBar.Prelude import QBar.TagParser import QBar.Time diff --git a/src/QBar/Blocks/Squeekboard.hs b/src/QBar/Blocks/Squeekboard.hs index d32a589aac90176852dc3210d98742beebad3876..9b6b89617ffba1fe72b846d37f1289978a964cea 100644 --- a/src/QBar/Blocks/Squeekboard.hs +++ b/src/QBar/Blocks/Squeekboard.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} - module QBar.Blocks.Squeekboard where import Control.Monad.Except (MonadError) @@ -12,6 +10,7 @@ import QBar.BlockHelper import QBar.BlockOutput import QBar.Blocks.NetworkManager (getDBusProperty, runExceptT_) import QBar.Core +import QBar.Prelude squeekboardBlock :: Bool -> Block squeekboardBlock autoHide = runSignalBlockConfiguration $ SignalBlockConfiguration { diff --git a/src/QBar/Blocks/Utils.hs b/src/QBar/Blocks/Utils.hs index 3205bd751d7b6ad8aa6602789b2e64ebc3de0050..c894acc833566b7e8f29fb789767cef65d467a5a 100644 --- a/src/QBar/Blocks/Utils.hs +++ b/src/QBar/Blocks/Utils.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE ScopedTypeVariables #-} - module QBar.Blocks.Utils where +import QBar.Prelude + import Control.Exception (SomeException, catch) import qualified Data.Attoparsec.Text.Lazy as AT import qualified Data.Text.Lazy as T diff --git a/src/QBar/Cli.hs b/src/QBar/Cli.hs index 618c2b54a92554bbc862305f2b2866afdfa736fc..4689340241e0321cf5cbf2824d82694a26c02161 100644 --- a/src/QBar/Cli.hs +++ b/src/QBar/Cli.hs @@ -8,10 +8,11 @@ import QBar.Blocks.Pipe import QBar.ControlSocket import QBar.Core import QBar.DefaultConfig +import QBar.Prelude import QBar.Server -import QBar.Qubes.AdminAPI (printEvents, qubesVMStats, qubesEvents) import QBar.Theme import QBar.Time +import QBar.Qubes.AdminAPI (printEvents, qubesVMStats, qubesEvents) import Control.Monad (join) import Data.Maybe (fromMaybe) diff --git a/src/QBar/Color.hs b/src/QBar/Color.hs index 41e7ef038ede6e72ab65cbb9df51fb85bb7d8207..1b79b237549db8a7d28d73bf5e4320f1e2c3cdf4 100644 --- a/src/QBar/Color.hs +++ b/src/QBar/Color.hs @@ -1,5 +1,7 @@ module QBar.Color where +import QBar.Prelude + import Data.Aeson import Data.Bits ((.|.), shiftL) import Data.Char (ord) @@ -57,4 +59,3 @@ colorParser = do | w >= 97 = (a `shiftL` 4) .|. fromIntegral (w - 87) | otherwise = (a `shiftL` 4) .|. fromIntegral (w - 55) where w = ord c - diff --git a/src/QBar/ControlSocket.hs b/src/QBar/ControlSocket.hs index dab3e471e428bc3b015fc063d8fdddaa78cc0e5f..4986dec267e07eba65134ff4f8a035e7683897a6 100644 --- a/src/QBar/ControlSocket.hs +++ b/src/QBar/ControlSocket.hs @@ -1,18 +1,12 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE InstanceSigs #-} module QBar.ControlSocket where import QBar.BlockOutput import QBar.Core import QBar.Host +import QBar.Prelude import QBar.Time import QBar.Utils @@ -402,4 +396,3 @@ $(deriveJSON defaultOptions ''CommandResult) $(deriveJSON defaultOptions ''StreamType) $(deriveJSON defaultOptions ''BlockStream) $(deriveJSON defaultOptions ''MirrorStream) - diff --git a/src/QBar/Core.hs b/src/QBar/Core.hs index 300374b4308f368d9965a0804a5a25807f2fa1a7..945c47994179d62014c888e4066810fdcd6e5fe4 100644 --- a/src/QBar/Core.hs +++ b/src/QBar/Core.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RankNTypes #-} module QBar.Core where import QBar.BlockOutput +import QBar.Prelude import QBar.Time import QBar.Utils diff --git a/src/QBar/DefaultConfig.hs b/src/QBar/DefaultConfig.hs index e51da6755d969e4f115d82782bd2c9376a3ec7c1..8743526ff6aa33bbfa269d2f89fe8c440d04b4eb 100644 --- a/src/QBar/DefaultConfig.hs +++ b/src/QBar/DefaultConfig.hs @@ -2,6 +2,7 @@ module QBar.DefaultConfig where import QBar.Blocks import QBar.Core +import QBar.Prelude defaultBarConfig :: BarIO () defaultBarConfig = do @@ -14,4 +15,3 @@ defaultBarConfig = do --addBlock freeDiskSpaceBlock --addBlock cpuTemperatureBlock addBlock networkManagerBlock - diff --git a/src/QBar/Host.hs b/src/QBar/Host.hs index c2caaa8e5effd9380ea5bc3fb1395dc6a85aa6bc..db471003f3ae89f2493c34f5fd124b7324067cd2 100644 --- a/src/QBar/Host.hs +++ b/src/QBar/Host.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DuplicateRecordFields #-} - module QBar.Host where import QBar.BlockOutput import QBar.Core +import QBar.Prelude import QBar.Time import QBar.Utils diff --git a/src/QBar/Pango.hs b/src/QBar/Pango.hs index 4d5147079f2c913b6c2d286178d31cd755457f40..bbfa830fefd7091b2419d050ab11fe27d5fbc839 100644 --- a/src/QBar/Pango.hs +++ b/src/QBar/Pango.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE DuplicateRecordFields #-} - module QBar.Pango (PangoText, renderPango) where import QBar.Color +import QBar.Prelude import QBar.Theme type PangoText = Text diff --git a/src/Prelude.hs b/src/QBar/Prelude.hs similarity index 95% rename from src/Prelude.hs rename to src/QBar/Prelude.hs index 59ea17210a2071362cbc485f88c0d5e021c2193a..efa804626921596bc0eff39fc4edfdccf527d122 100644 --- a/src/Prelude.hs +++ b/src/QBar/Prelude.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Prelude - ( module BasePrelude, +module QBar.Prelude + ( module Prelude, ByteString.ByteString, (>=>), (<=<), @@ -30,13 +28,13 @@ module Prelude ) where -import BasePrelude hiding +import Prelude hiding ( error, errorWithoutStackTrace, head, undefined, ) -import qualified BasePrelude as P +import qualified Prelude as P import qualified Control.Monad import Control.Monad ((>=>), (<=<)) import qualified Control.Monad.IO.Class diff --git a/src/QBar/Qubes/AdminAPI.hs b/src/QBar/Qubes/AdminAPI.hs index bd1a458a44d66833b4661f63bb7aad9bec50e21b..ae8b08802840761ff4b2abac56546368f0e0c766 100644 --- a/src/QBar/Qubes/AdminAPI.hs +++ b/src/QBar/Qubes/AdminAPI.hs @@ -1,5 +1,7 @@ module QBar.Qubes.AdminAPI where +import QBar.Prelude + import Control.Monad (forM_, guard) import Data.Binary import Data.Binary.Get @@ -107,7 +109,7 @@ qubesAdminCallP serviceName args = do go = \case Done remainder _ value -> do yield value - go $ pushChunk (runGetIncremental get) remainder + go $ pushChunk (runGetIncremental get) remainder d@(Partial _) -> do chunk <- liftIO $ BS.hGetSome stdout 1024 if not (BS.null chunk) @@ -231,7 +233,7 @@ instance Read QubesVMState where (word, remainder) = span isAlphaNum s value = case word of "Running" -> VMRunning - "Halted" -> VMHalted + "Halted" -> VMHalted _ -> UnknownState qubesAdminCallLines :: BL.ByteString -> [BL.ByteString] -> IO [BL.ByteString] diff --git a/src/QBar/Server.hs b/src/QBar/Server.hs index b59c9e166cff9e35a12548ae0d629e89fc8464d8..ff8d4d81a2d0f8b37c095c2c4f049ce3affafcd6 100644 --- a/src/QBar/Server.hs +++ b/src/QBar/Server.hs @@ -1,12 +1,10 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE ScopedTypeVariables #-} - module QBar.Server where import QBar.BlockOutput import QBar.Core import QBar.ControlSocket import QBar.Host +import QBar.Prelude import QBar.Pango import QBar.Theme import QBar.Utils diff --git a/src/QBar/TagParser.hs b/src/QBar/TagParser.hs index 934d014bd9e511c7eee2eaafe5ff8a2b584e09c9..a81c59c518ffa3dd3c5b486dfe729dfe2da19456 100644 --- a/src/QBar/TagParser.hs +++ b/src/QBar/TagParser.hs @@ -2,6 +2,7 @@ module QBar.TagParser where import QBar.BlockOutput import QBar.Color +import QBar.Prelude import Control.Applicative ((<|>)) import Data.Attoparsec.Text.Lazy as A diff --git a/src/QBar/Theme.hs b/src/QBar/Theme.hs index e8648084013099c0dc85e4cda6b0c716f2b003c0..cb518506579bc96c5ad3f652e82c571bf0d4360e 100644 --- a/src/QBar/Theme.hs +++ b/src/QBar/Theme.hs @@ -1,10 +1,8 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE Rank2Types #-} - module QBar.Theme where import QBar.BlockOutput import QBar.Color +import QBar.Prelude import Control.Applicative ((<|>)) import Control.Lens ((^.)) diff --git a/src/QBar/Time.hs b/src/QBar/Time.hs index 8bf03fdde37fbd8053afb3362e6e2858e82ca056..c57d2978af80e12893f29c6b5b30ac5c010d40f7 100644 --- a/src/QBar/Time.hs +++ b/src/QBar/Time.hs @@ -2,6 +2,8 @@ module QBar.Time (SleepScheduler, HasSleepScheduler(..), Interval(..), createSleepScheduler, sleepUntil, sleepUntil', sleepUntilInterval, sleepUntilInterval', everyMinute, everyNSeconds, nextIntervalTime, humanReadableInterval) where +import QBar.Prelude + import Control.Concurrent.Async import Control.Concurrent.MVar import qualified Control.Concurrent.Event as Event diff --git a/src/QBar/Utils.hs b/src/QBar/Utils.hs index b2bdb2a17f7174569d57ef140ad2631ebe16c324..ca0c2fc7c4f95b41bb4dbb458539624de578dd12 100644 --- a/src/QBar/Utils.hs +++ b/src/QBar/Utils.hs @@ -1,5 +1,7 @@ module QBar.Utils where +import QBar.Prelude + import Control.Concurrent.Event as Event import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TChan diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index 05402ef01bbc13a52308daf7ad706b47b60163e1..0000000000000000000000000000000000000000 --- a/stack.yaml +++ /dev/null @@ -1,69 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# -# The location of a snapshot can be provided as a file or url. Stack assumes -# a snapshot provided as a file might change, whereas a url resource does not. -# -# resolver: ./custom-snapshot.yaml -# resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-16.25 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# subdirs: -# - auto-update -# - wai -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver -# using the same syntax as the packages field. -# (e.g., acme-missiles-0.3) -# extra-deps: [] - -# Disable pure nix-shell environment on NixOS, because access to XDG_RUNTIME_DIR is needed for the control socket -nix: - pure: false - packages: [ zlib coreutils ] - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=1.9" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor diff --git a/test/Spec.hs b/test/Spec.hs index cd4753fc9c10722ad5c3ec4fd34de99972243b6c..c1ddb62be3794b8aa5651d313a6e8c34040efdcb 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,4 @@ +import Prelude + main :: IO () main = putStrLn "Test suite not yet implemented"