summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.envrc1
-rw-r--r--.gitignore1
-rw-r--r--LICENSE30
-rw-r--r--app/Main.hs240
-rw-r--r--app/Pretty.hs89
-rw-r--r--app/Pretty/Color.hs58
-rw-r--r--app/Sensor.hs520
-rw-r--r--app/Ui.hs200
-rw-r--r--app/Util.hs18
-rw-r--r--astatusbar.cabal38
-rw-r--r--default.nix66
-rw-r--r--nix/sources.json20
-rw-r--r--nix/sources.nix198
-rw-r--r--shell.nix1
14 files changed, 1480 insertions, 0 deletions
diff --git a/.envrc b/.envrc
new file mode 100644
index 0000000..1d953f4
--- /dev/null
+++ b/.envrc
@@ -0,0 +1 @@
+use nix
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..8075013
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+/dist-newstyle
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..c90516a
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2024, Alexander Foremny
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Alexander Foremny nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
index 0000000..8dc5d5f
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,240 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Main where
+
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Control.Monad.Identity
+import Data.Bits
+import Data.List
+import Data.Map qualified as M
+import GHC.Ptr (Ptr)
+import Graphics.X11 qualified as X
+import Graphics.X11.Xft qualified as X
+import Graphics.X11.Xlib.Extras qualified as X
+import Pretty qualified as P
+import Sensor
+import Ui hiding (Env)
+import Ui qualified
+import UnliftIO.STM
+
+data Env = Env
+ { dpy :: X.Display,
+ win :: X.Window,
+ swidth :: Int,
+ sheight :: Int,
+ wwidth :: Int,
+ wheight :: Int,
+ wleft :: Int,
+ wtop :: Int,
+ gc :: X.GC,
+ pixm :: X.Pixmap,
+ fnt :: X.XftFont,
+ drw :: X.XftDraw,
+ cmap :: X.Colormap,
+ vis :: X.Visual
+ }
+
+type Colors = M.Map (P.Intensity, P.Color) X.XftColor
+
+data State = State
+ { dirty :: Bool,
+ ui :: Ui TVar P.Doc
+ }
+
+main :: IO ()
+main = do
+ bracket createWindow destroyWindow $ \(env, stateT) ->
+ withColors env (run env stateT)
+
+data LastRun = LastRun
+ { pUi :: Ui Identity P.Doc,
+ lUi :: Ui'
+ }
+
+run :: Env -> TVar State -> Colors -> IO ()
+run env stateT colors = do
+ let loop = (loop . Just =<<) . go
+ loop Nothing
+ where
+ go Nothing = do
+ pUi <- atomically do
+ state@State {..} <- readTVar stateT
+ writeTVar stateT state {dirty = False}
+ pollUi ui
+ lUi <- paint env colors Nothing pUi
+ pure (LastRun pUi lUi)
+ go (Just (LastRun {pUi = pUi', lUi = lUi'})) = do
+ (pUi, dirty) <- atomically do
+ state@State {..} <- readTVar stateT
+ pUi <- pollUi ui
+ checkSTM (dirty || pUi /= pUi')
+ writeTVar stateT state {dirty = False}
+ pure (pUi, dirty)
+ lUi <- paint env colors (if dirty then Nothing else Just lUi') pUi
+ pure (LastRun pUi lUi)
+
+processEvents :: Ptr X.XEvent -> Env -> TVar State -> IO ()
+processEvents ev env@(Env {..}) stateT = do
+ timeOut <- X.waitForEvent dpy 1_000_000_000
+ unless timeOut do
+ processEvent ev env stateT
+ processEvents ev env stateT
+
+processEvent :: Ptr X.XEvent -> Env -> TVar State -> IO ()
+processEvent ev (Env {..}) stateT = do
+ X.nextEvent dpy ev
+ e <- X.getEvent ev
+ if
+ | X.ExposeEvent {} <- e -> atomically do
+ state <- readTVar stateT
+ writeTVar stateT state {dirty = True}
+ | otherwise -> pure ()
+
+paint ::
+ Env ->
+ Colors ->
+ Maybe Ui' ->
+ Ui Identity P.Doc ->
+ IO Ui'
+paint Env {..} colors Nothing ui = do
+ let env' = Ui.Env {..}
+ ui' <- layOutUi env' ui
+ renderUi env' colors ui'
+ X.copyArea dpy pixm win gc 0 0 (fi wwidth) (fi wheight) 0 0
+ X.sync dpy False
+ pure ui'
+paint Env {..} colors (Just ui') ui = do
+ let env' = Ui.Env {..}
+ ui'' <- layOutUi env' ui
+ renderUi' env' colors ui' ui''
+ X.copyArea dpy pixm win gc 0 0 (fi wwidth) (fi wheight) 0 0
+ X.sync dpy False
+ pure ui''
+
+destroyWindow :: (Env, TVar State) -> IO ()
+destroyWindow (Env {..}, _) = do
+ X.destroyWindow dpy win
+
+createWindow :: IO (Env, TVar State)
+createWindow = do
+ dpy <- X.openDisplay ""
+ let scrn = X.defaultScreen dpy
+ scr = X.defaultScreenOfDisplay dpy
+ root = X.defaultRootWindow dpy
+ trueColor = 4
+ Just vinfo <- X.matchVisualInfo dpy scrn 32 trueColor
+ let cls = X.inputOutput
+ dpth = X.visualInfo_depth vinfo
+ vis = X.visualInfo_visual vinfo
+ vmsk = X.cWColormap .|. X.cWBorderPixel .|. X.cWBackingPixel .|. X.cWOverrideRedirect
+ swidth = fi (X.displayWidth dpy scrn)
+ sheight = fi (X.displayHeight dpy scrn)
+ wwidth = swidth - 16
+ wheight = 32
+ wleft = 8
+ wtop = 8
+ cmap <- X.createColormap dpy root vis X.allocNone
+ win <- X.allocaSetWindowAttributes $ \attr -> do
+ X.set_colormap attr cmap
+ X.set_border_pixel attr 0
+ X.set_background_pixel attr 0
+ X.set_override_redirect attr True
+ X.createWindow dpy root (fi wleft) (fi wtop) (fi wwidth) (fi wheight) 0 dpth cls vis vmsk attr
+ atom <- X.internAtom dpy "ATOM" True
+ wmState <- X.internAtom dpy "_NET_WM_STATE" False
+ wmStateSticky <- X.internAtom dpy "_NET_WM_STATE_STICKY" False
+ wmStateAbove <- X.internAtom dpy "_NET_WM_STATE_ABOVE" False
+ wmWindowType <- X.internAtom dpy "_NET_WM_WINDOW_TYPE" False
+ wmWindowTypeDock <- X.internAtom dpy "_NET_WM_WINDOW_TYPE_DOCK" False
+ wmStrut <- X.internAtom dpy "_NET_WM_STRUT" False
+ wmStrutPartial <- X.internAtom dpy "_NET_WM_STRUT_PARTIAL" False
+ X.changeProperty32 dpy win wmState atom X.propModeReplace $
+ [ fi wmStateAbove,
+ fi wmStateSticky
+ ]
+ X.changeProperty32 dpy win wmWindowType atom X.propModeReplace $
+ [ fi wmWindowTypeDock
+ ]
+ X.changeProperty32 dpy win wmStrut atom X.propModeReplace $
+ [0, 0, fi wheight + 8, 0]
+ X.changeProperty32 dpy win wmStrutPartial atom X.propModeReplace $
+ [0, 0, fi wheight + 8, 0, 0, 0, 0, 0, fi wleft, fi wwidth, 0, 0]
+ pixm <- X.createPixmap dpy win (fi wwidth) (fi wheight) dpth
+ gc <- X.createGC dpy win
+ drw <- X.xftDrawCreate dpy pixm vis cmap
+ fnt <- X.xftFontOpen dpy scr "Free Mono:size=15"
+ X.mapWindow dpy win
+ let dirty = True
+ ui <-
+ runSensorM . initUi . Ui $
+ intercalate [lit " "] $
+ [ [sens wmWorkspaces],
+ [sens wmName, fill],
+ [lit "cpu ", sens cpu],
+ [lit "mem ", sens mem],
+ [lit "disk ", sens disk],
+ [lit "io ", sens io],
+ [lit "net ", sens net],
+ [lit "snd ", sens Sensor.snd],
+ [lit "bat ", sens bat],
+ [lit "date ", sens date],
+ [lit "time ", sens time]
+ ]
+ let env = Env {..}
+ stateT <- newTVarIO State {..}
+ void $ forkIO $ X.allocaXEvent $ \ev -> forever do
+ processEvents ev env stateT
+ pure (env, stateT)
+
+withColors :: Env -> (Colors -> IO a) -> IO a
+withColors Env {..} act = do
+ X.withXftColorName dpy vis cmap (P.toRgb (P.Vivid, P.Black)) $ \black -> do
+ X.withXftColorName dpy vis cmap (P.toRgb (P.Vivid, P.Red)) $ \red -> do
+ X.withXftColorName dpy vis cmap (P.toRgb (P.Vivid, P.Green)) $ \green -> do
+ X.withXftColorName dpy vis cmap (P.toRgb (P.Vivid, P.Yellow)) $ \yellow -> do
+ X.withXftColorName dpy vis cmap (P.toRgb (P.Vivid, P.Blue)) $ \blue -> do
+ X.withXftColorName dpy vis cmap (P.toRgb (P.Vivid, P.Magenta)) $ \magenta -> do
+ X.withXftColorName dpy vis cmap (P.toRgb (P.Vivid, P.Cyan)) $ \cyan -> do
+ X.withXftColorName dpy vis cmap (P.toRgb (P.Vivid, P.White)) $ \white -> do
+ X.withXftColorName dpy vis cmap (P.toRgb (P.Dull, P.Black)) $ \dullBlack -> do
+ X.withXftColorName dpy vis cmap (P.toRgb (P.Dull, P.Red)) $ \dullRred -> do
+ X.withXftColorName dpy vis cmap (P.toRgb (P.Dull, P.Green)) $ \dullGreen -> do
+ X.withXftColorName dpy vis cmap (P.toRgb (P.Dull, P.Yellow)) $ \dullYellow -> do
+ X.withXftColorName dpy vis cmap (P.toRgb (P.Dull, P.Blue)) $ \dullBlue -> do
+ X.withXftColorName dpy vis cmap (P.toRgb (P.Dull, P.Magenta)) $ \dullMagenta -> do
+ X.withXftColorName dpy vis cmap (P.toRgb (P.Dull, P.Cyan)) $ \dullCyan -> do
+ X.withXftColorName dpy vis cmap (P.toRgb (P.Dull, P.White)) $ \dullWhite -> do
+ let colors =
+ M.fromList
+ [ ((P.Vivid, P.Black), black),
+ ((P.Vivid, P.Red), red),
+ ((P.Vivid, P.Green), green),
+ ((P.Vivid, P.Yellow), yellow),
+ ((P.Vivid, P.Blue), blue),
+ ((P.Vivid, P.Magenta), magenta),
+ ((P.Vivid, P.Cyan), cyan),
+ ((P.Vivid, P.White), white),
+ ((P.Dull, P.Black), dullBlack),
+ ((P.Dull, P.Red), dullRred),
+ ((P.Dull, P.Green), dullGreen),
+ ((P.Dull, P.Yellow), dullYellow),
+ ((P.Dull, P.Blue), dullBlue),
+ ((P.Dull, P.Magenta), dullMagenta),
+ ((P.Dull, P.Cyan), dullCyan),
+ ((P.Dull, P.White), dullWhite)
+ ]
+
+ act colors
+
+fi :: (Integral a, Num b) => a -> b
+fi = fromIntegral
+
+clamp :: (Ord a) => a -> a -> a -> a
+clamp mi ma = max mi . min ma
diff --git a/app/Pretty.hs b/app/Pretty.hs
new file mode 100644
index 0000000..8054acc
--- /dev/null
+++ b/app/Pretty.hs
@@ -0,0 +1,89 @@
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+
+module Pretty
+ ( Doc (..),
+ Pretty,
+ pretty,
+ diagram,
+ module Pretty.Color,
+ color,
+ colorDull,
+ )
+where
+
+import Pretty.Color
+
+data Doc
+ = Col [Doc]
+ | Lit (Maybe (Intensity, Color)) String
+ deriving (Show, Eq)
+
+class Pretty a where
+ pretty :: a -> Doc
+
+instance Pretty Char where
+ pretty = pretty . (: [])
+
+instance Pretty String where
+ pretty = Lit Nothing
+
+diagram :: Int -> [Float] -> Doc
+diagram w xs = Col (map chart (discretize xs'))
+ where
+ xs' = replicate (2 * w - length xs) 0 ++ reverse (take (2 * w) xs)
+
+ chart :: (Int, Int) -> Doc
+ chart n = colorize n (pretty (chart' n))
+
+ chart' (0, 0) = '⠀'
+ chart' (0, 1) = '⢀'
+ chart' (0, 2) = '⢠'
+ chart' (0, 3) = '⢰'
+ chart' (0, 4) = '⢸'
+ chart' (1, 0) = '⡀'
+ chart' (1, 1) = '⣀'
+ chart' (1, 2) = '⣠'
+ chart' (1, 3) = '⣰'
+ chart' (1, 4) = '⣸'
+ chart' (2, 0) = '⡄'
+ chart' (2, 1) = '⣄'
+ chart' (2, 2) = '⣤'
+ chart' (2, 3) = '⣴'
+ chart' (2, 4) = '⣼'
+ chart' (3, 0) = '⡆'
+ chart' (3, 1) = '⣆'
+ chart' (3, 2) = '⣦'
+ chart' (3, 3) = '⣶'
+ chart' (3, 4) = '⣾'
+ chart' (4, 0) = '⡇'
+ chart' (4, 1) = '⣇'
+ chart' (4, 2) = '⣧'
+ chart' (4, 3) = '⣷'
+ chart' (4, 4) = '⣿'
+ chart' _ = error "chart': argument >4 (or <0)"
+
+ colorize (n, m) = colorize' (max n m)
+
+ colorize' 0 = colorDull Green
+ colorize' 1 = color Green
+ colorize' 2 = colorDull Yellow
+ colorize' 3 = color Yellow
+ colorize' 4 = color Red
+ colorize' _ = error "colorize': argument >4 (or <0)"
+
+ discretize :: [Float] -> [(Int, Int)]
+ discretize [] = []
+ discretize (_ : []) = []
+ discretize (x1 : x2 : xs) =
+ (round (x1 * 4), round (x2 * 4)) : discretize xs
+
+color :: Color -> Doc -> Doc
+color c = color' (Vivid, c)
+
+colorDull :: Color -> Doc -> Doc
+colorDull c = color' (Dull, c)
+
+color' :: (Intensity, Color) -> Doc -> Doc
+color' c (Lit _ s) = Lit (Just c) s
+color' c (Col ds) = Col (map (color' c) ds)
diff --git a/app/Pretty/Color.hs b/app/Pretty/Color.hs
new file mode 100644
index 0000000..e8e48dd
--- /dev/null
+++ b/app/Pretty/Color.hs
@@ -0,0 +1,58 @@
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+
+module Pretty.Color
+ ( Color (..),
+ toRgb,
+ Intensity (..),
+ )
+where
+
+data Color
+ = Black
+ | Red
+ | Green
+ | Yellow
+ | Blue
+ | Magenta
+ | Cyan
+ | White
+ deriving (Show, Eq, Ord)
+
+toRgb :: (Intensity, Color) -> String
+toRgb (Dull, Black) = base00 -- color0
+toRgb (Dull, Red) = base08 -- color1
+toRgb (Dull, Green) = base0B -- color2
+toRgb (Dull, Yellow) = base0A -- color3
+toRgb (Dull, Blue) = base0D -- color4
+toRgb (Dull, Magenta) = base0E -- color5
+toRgb (Dull, Cyan) = base0C -- color6
+toRgb (Dull, White) = base05 -- color7
+toRgb (Vivid, Black) = base03 -- color8
+toRgb (Vivid, Red) = base08 -- color9
+toRgb (Vivid, Green) = base0B -- color10
+toRgb (Vivid, Yellow) = base0A -- color11
+toRgb (Vivid, Blue) = base0D -- color12
+toRgb (Vivid, Magenta) = base0E -- color13
+toRgb (Vivid, Cyan) = base0C -- color14
+toRgb (Vivid, White) = base07 -- color15
+
+data Intensity = Vivid | Dull
+ deriving (Show, Eq, Ord)
+
+base00, base01, base02, base03, base04, base05, base06, base07, base08, base09, base0A, base0B, base0C, base0D, base0E, base0F :: String
+base00 = "#263238"
+base01 = "#2E3C43"
+base02 = "#314549"
+base03 = "#546E7A"
+base04 = "#B2CCD6"
+base05 = "#EEFFFF"
+base06 = "#EEFFFF"
+base07 = "#FFFFFF"
+base08 = "#F07178"
+base09 = "#F78C6C"
+base0A = "#FFCB6B"
+base0B = "#C3E88D"
+base0C = "#89DDFF"
+base0D = "#82AAFF"
+base0E = "#C792EA"
+base0F = "#FF5370"
diff --git a/app/Sensor.hs b/app/Sensor.hs
new file mode 100644
index 0000000..2342807
--- /dev/null
+++ b/app/Sensor.hs
@@ -0,0 +1,520 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+
+module Sensor
+ ( SensorM,
+ runSensorM,
+ poll,
+ Sensor (..),
+ cpu,
+ io,
+ net,
+ mem,
+ bat,
+ Sensor.snd,
+ disk,
+ date,
+ time,
+ wmName,
+ wmWorkspaces,
+ )
+where
+
+import Control.Monad
+import Control.Monad.Reader
+import Data.Char
+import Data.Dynamic
+import Data.Functor.WithIndex
+import Data.List
+import Data.Map qualified as M
+import Data.Maybe
+import Data.Set qualified as S
+import Data.Time.Clock
+import Data.Time.Format
+import Data.Time.LocalTime
+import Graphics.X11 qualified as X
+import Graphics.X11.Xlib.Extras qualified as X
+import Pretty qualified as P
+import Process.Shell (sh)
+import Safe
+import System.FilePath
+import System.IO.Error
+import System.Linux.Inotify qualified as I
+import System.Posix.StatVFS
+import Text.Printf
+import UnliftIO.Concurrent
+import UnliftIO.Exception
+import UnliftIO.Memoize
+import UnliftIO.STM
+import Witherable (ifilter)
+
+type SensorM a =
+ ReaderT (MVar (M.Map String (Memoized Dynamic))) IO a
+
+runSensorM :: SensorM a -> IO a
+runSensorM m = do
+ g <- newMVar M.empty
+ runReaderT m g
+
+poll :: (Typeable a) => Sensor a -> SensorM (TVar a)
+poll (Sensor id vM') = do
+ gM <- ask
+ g <- takeMVar gM
+ vM <- case M.lookup id g of
+ Just vM -> do
+ putMVar gM g
+ pure (fromJust . fromDynamic <$> vM)
+ Nothing -> do
+ -- liftIO (printf "[%s] start\n" id)
+ vM <- vM'
+ putMVar gM (M.insert id (toDyn <$> vM) g)
+ pure vM
+ runMemoized vM
+
+data Sensor a = Sensor String (SensorM (Memoized (TVar a)))
+
+data CpuStat = CpuStat
+ { total :: Int,
+ idle :: Int
+ }
+ deriving (Show, Eq)
+
+cpuStat :: Sensor CpuStat
+cpuStat = pollFile "cpuStat" aggregate "/proc/stat" (5 * 10 ^ 5)
+ where
+ aggregate fp = liftIO do
+ stat <- readFile fp
+ case filter ("cpu " `isPrefixOf`) (lines stat) of
+ [] -> error "/proc/stat: no cpu line"
+ (cpu : _) ->
+ case map read (drop 1 (words cpu)) of
+ xs@(_ : _ : _ : idle : _) ->
+ pure $ CpuStat (sum xs) idle
+ _ -> error "/proc/stat: unexpected cpu line"
+
+cpu' :: Sensor [CpuStat]
+cpu' = histogram "cpu'" [] (\b a -> take 7 (a : b)) cpuStat
+
+data Cpu = Cpu {unCpu :: [Float]}
+
+instance P.Pretty Cpu where
+ pretty = P.diagram 3 . unCpu
+
+cpu :: Sensor Cpu
+cpu = transform "cpu" f cpu'
+ where
+ f xs = do
+ let xs' =
+ zipWith
+ ( \next prev ->
+ let total = next.total - prev.total
+ idle = next.idle - prev.idle
+ in fromIntegral (total - idle) / fromIntegral total
+ )
+ (fromMaybe [] (initMay xs))
+ (fromMaybe [] (tailMay xs))
+ pure (Cpu xs')
+
+data IoStat = IoStat {unIoStat :: Int} deriving (Show, Eq)
+
+ioStat :: Sensor IoStat
+ioStat = pollFile "ioStat" aggregate "/sys/block/nvme0n1/stat" (5 * 10 ^ 5)
+ where
+ aggregate fp = liftIO do
+ stat <- readFile fp
+ case words stat of
+ [_, _, read', _, _, _, write', _, _, _, _, _, _, _, _, _, _] ->
+ pure (IoStat ((read read') + (read write')))
+ _ -> error "/sys/block/nvme0n1/stat: malformed"
+
+io' :: Sensor [IoStat]
+io' = histogram "io'" [] (\b a -> take 7 (a : b)) ioStat
+
+data Io = Io {unIo :: [Float]} deriving (Show, Eq)
+
+instance P.Pretty Io where
+ pretty = P.diagram 3 . unIo
+
+io :: Sensor Io
+io = transform "io" f io'
+ where
+ f (map unIoStat -> xs) = do
+ let xs' =
+ zipWith
+ (-)
+ (fromMaybe [] (initMay xs))
+ (fromMaybe [] (tailMay xs))
+ x' = max 1 (fromMaybe 0 (maximumMay xs'))
+ pure . Io $
+ map (\x -> fromIntegral x / fromIntegral x') xs'
+
+data NetStat = NetStat {unNetStat :: Int} deriving (Show, Eq)
+
+netStat :: Sensor NetStat
+netStat =
+ pollFile
+ "netStat"
+ aggregate
+ "/sys/class/net/wlan0/statistics/rx_bytes"
+ (5 * 10 ^ 5)
+ where
+ aggregate fp = liftIO do
+ NetStat
+ <$> ( (+)
+ <$> (read <$> readFile fp)
+ <*> (read <$> readFile (takeDirectory fp </> "tx_bytes"))
+ )
+
+net' :: Sensor [NetStat]
+net' = histogram "net'" [] (\b a -> take 7 (a : b)) netStat
+
+data Net = Net {unNet :: [Float]} deriving (Show, Eq)
+
+instance P.Pretty Net where
+ pretty = P.diagram 3 . unNet
+
+net :: Sensor Net
+net = transform "net" f net'
+ where
+ f (map unNetStat -> xs) = do
+ let xs' =
+ zipWith
+ (-)
+ (fromMaybe [] (initMay xs))
+ (fromMaybe [] (tailMay xs))
+ x' = max 1 (fromMaybe 0 (maximumMay xs'))
+ pure $ Net $ map (\x -> fromIntegral x / fromIntegral x') xs'
+
+data MemStat = MemStat {unMemStat :: Float} deriving (Show, Eq)
+
+memStat :: Sensor MemStat
+memStat = pollFile "memStat" aggregate "/proc/meminfo" (5 * 10 ^ 5)
+ where
+ aggregate fp = liftIO do
+ meminfo <- readFile fp
+ case foldl
+ ( \(total, avail) xs ->
+ case xs of
+ ["MemTotal:", v, "kB"] -> (Just (read v), avail)
+ ["MemAvailable:", v, "kB"] -> (total, Just (read v))
+ _ -> (total, avail)
+ )
+ (Nothing, Nothing)
+ (map words (lines meminfo)) of
+ (Just total, Just avail) -> pure $ MemStat (1 - avail / total)
+ (Nothing, _) -> error (printf "%s: MemTotal missing" fp)
+ (_, Nothing) -> error (printf "%s: MemAvail missing" fp)
+
+mem' :: Sensor [MemStat]
+mem' = histogram "mem'" [] (\b a -> take 7 (a : b)) memStat
+
+data Mem = Mem {unMem :: [Float]} deriving (Show, Eq)
+
+instance P.Pretty Mem where
+ pretty = P.diagram 3 . unMem
+
+mem :: Sensor Mem
+mem = transform "mem" (\(map unMemStat -> xs) -> pure (Mem xs)) mem'
+
+data BatStat = BatStat {unBatStat :: Float} deriving (Show, Eq)
+
+batStat :: Sensor BatStat
+batStat = pollFile "batStat" aggregate "/sys/class/power_supply/macsmc-battery/charge_now" (5 * 10 ^ 5)
+ where
+ aggregate fp = liftIO do
+ BatStat
+ <$> ( (\now full -> fromIntegral now / fromIntegral full)
+ <$> (read <$> readFile fp)
+ <*> (read <$> readFile (takeDirectory fp </> "charge_full"))
+ )
+
+bat' :: Sensor [BatStat]
+bat' = histogram "bat'" [] (\b a -> take 7 (a : b)) batStat
+
+data Bat = Bat {unBat :: [Float]} deriving (Show, Eq)
+
+instance P.Pretty Bat where
+ pretty = P.diagram 1 . unBat
+
+bat :: Sensor Bat
+bat = transform "bat" (\(map unBatStat -> xs) -> pure (Bat xs)) bat'
+
+data Snd = Snd {unSnd :: Float} deriving (Show, Eq)
+
+instance P.Pretty Snd where
+ pretty = P.diagram 1 . (: []) . unSnd
+
+snd :: Sensor Snd
+snd = Sensor "snd" $ memoizeMVar do
+ stateT <- newTVarIO (Snd 1)
+ void $ forkIO $ forever do
+ x <- liftIO aggregate
+ atomically do writeTVar stateT (Snd x)
+ threadDelay (2 * 10 ^ 6)
+ pure stateT
+ where
+ aggregate = do
+ (/ 153) . read <$> [sh|pamixer --get-volume|]
+
+data Disk = Disk {unDisk :: [Float]} deriving (Show, Eq)
+
+instance P.Pretty Disk where
+ pretty = P.diagram 1 . unDisk
+
+disk :: Sensor Disk
+disk = Sensor "disk" $ memoizeMVar do
+ stateT <- newTVarIO (Disk [])
+ void $ forkIO $ forever do
+ x <- liftIO aggregate
+ atomically do
+ readTVar stateT >>= \(Disk xs) ->
+ writeTVar stateT (Disk (x : xs))
+ threadDelay (2 * 10 ^ 6)
+ pure stateT
+ where
+ aggregate = do
+ stat <- statVFS "/"
+ pure $
+ (fromIntegral stat.statVFS_bfree)
+ / fromIntegral (stat.statVFS_bfree + stat.statVFS_bavail)
+
+currentTime :: Sensor UTCTime
+currentTime = Sensor "currentTime" $ memoizeMVar do
+ stateT <- newTVarIO =<< liftIO getCurrentTime
+ void $ forkIO $ forever do
+ x <- liftIO getCurrentTime
+ atomically . writeTVar stateT =<< liftIO getCurrentTime
+ threadDelay (((10 ^ 12) - (fromEnum (utctDayTime x) `mod` (10 ^ 12))) `div` (10 ^ 6))
+ pure stateT
+
+data Date = Date {unDate :: String} deriving (Show, Eq)
+
+instance P.Pretty Date where
+ pretty = P.color P.White . P.pretty . unDate
+
+date :: Sensor Date
+date = transform "date" f currentTime
+ where
+ f x = do
+ z <- liftIO getCurrentTimeZone
+ pure . Date . formatTime defaultTimeLocale "%b %e" $
+ utcToLocalTime z x
+
+data Time = Time {unTime :: String} deriving (Show, Eq)
+
+instance P.Pretty Time where
+ pretty = P.color P.White . P.pretty . unTime
+
+time :: Sensor Time
+time = transform "time" f currentTime
+ where
+ f x = do
+ z <- liftIO getCurrentTimeZone
+ pure . Time . formatTime defaultTimeLocale "%R" $
+ utcToLocalTime z x
+
+data WmName = WmName {unWmName :: String} deriving (Show, Eq)
+
+instance P.Pretty WmName where
+ pretty = P.color P.White . P.pretty . unWmName
+
+wmName' :: Sensor WmName
+wmName' = watchXPropertyChanges "wmName'" as aggregate
+ where
+ as = ["_NET_ACTIVE_WINDOW"]
+ aggregate dpy = liftIO do
+ let root = X.rootWindowOfScreen (X.defaultScreenOfDisplay dpy)
+ netActiveWindow <- X.internAtom dpy "_NET_ACTIVE_WINDOW" False
+ X.getWindowProperty32 dpy netActiveWindow root >>= \case
+ Just (win : _) -> do
+ netWmName <- X.internAtom dpy "_NET_WM_NAME" False
+ fmap (WmName . strip . head) . X.wcTextPropertyToTextList dpy
+ =<< do
+ let loop 0 = do
+ error "failed to read _NET_WM_NAME"
+ loop n = do
+ catch
+ (X.getTextProperty dpy (fromIntegral win) netWmName)
+ ( \(e :: IOError) -> do
+ if isUserError e
+ then threadDelay 1000 >> loop (n - 1)
+ else throwIO e
+ )
+ loop 16
+ _ -> pure (WmName "")
+ strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace
+
+wmName :: Sensor String
+wmName = transform "wmName" (\(WmName x) -> pure x) wmName'
+
+data WmWorkspaces = WmWorkspaces {unWmWorkspaces :: [Workspace]}
+ deriving (Show, Eq)
+
+data Workspace
+ = Active String
+ | Inactive String
+ deriving (Show, Eq)
+
+instance P.Pretty WmWorkspaces where
+ pretty =
+ P.Col . intersperse (P.pretty " ") . map P.pretty . unWmWorkspaces
+
+instance P.Pretty Workspace where
+ pretty (Active s) = P.color P.White (P.pretty s)
+ pretty (Inactive s) = P.colorDull P.White (P.pretty s)
+
+wmWorkspaces :: Sensor WmWorkspaces
+wmWorkspaces = watchXPropertyChanges "wmWorkspaces" as aggregate
+ where
+ as =
+ [ "_NET_CLIENT_LIST",
+ "_NET_CURRENT_DESKTOP",
+ "_NET_DESKTOP_NAMES",
+ "_NET_WM_DESKTOP"
+ ]
+ aggregate dpy = liftIO do
+ let root = X.rootWindowOfScreen (X.defaultScreenOfDisplay dpy)
+ netClientList <- liftIO $ X.internAtom dpy "_NET_CLIENT_LIST" False
+ netCurrentDesktop <- liftIO $ X.internAtom dpy "_NET_CURRENT_DESKTOP" False
+ netDesktopNames <- liftIO $ X.internAtom dpy "_NET_DESKTOP_NAMES" False
+ netWmDesktop <- liftIO $ X.internAtom dpy "_NET_WM_DESKTOP" False
+ currentDesktop <- fmap (fromIntegral . head) <$> X.getWindowProperty32 dpy netCurrentDesktop root
+ occupiedDesktops <-
+ fmap (S.unions . catMaybes)
+ . mapM
+ ( \win -> do
+ fmap (S.singleton . fromIntegral . head)
+ <$> X.getWindowProperty32 dpy netWmDesktop win
+ )
+ . map fromIntegral
+ . fromMaybe []
+ =<< X.getWindowProperty32 dpy netClientList root
+ fmap
+ ( WmWorkspaces
+ . ifilter (\i _ -> Just i == currentDesktop || i `S.member` occupiedDesktops)
+ . imap
+ ( \i ->
+ if Just i == currentDesktop
+ then Active
+ else Inactive
+ )
+ )
+ . X.wcTextPropertyToTextList dpy
+ =<< X.getTextProperty dpy root netDesktopNames
+
+watchFile :: String -> (FilePath -> SensorM a) -> FilePath -> Sensor a
+watchFile id aggregate fp = Sensor id $ memoizeMVar do
+ i <- liftIO do
+ i <- I.init
+ void (I.addWatch i fp I.in_CLOSE)
+ pure i
+ stateT <- newTVarIO =<< aggregate fp
+ void $ forkIO $ forever do
+ void (liftIO (I.getEvent i))
+ -- liftIO (printf "[%s] aggregate\n" id)
+ x <- aggregate fp
+ atomically (writeTVar stateT x)
+ pure stateT
+
+pollFile :: String -> (FilePath -> SensorM a) -> FilePath -> Int -> Sensor a
+pollFile id aggregate fp delay = Sensor id $ memoizeMVar do
+ stateT <- newTVarIO =<< aggregate fp
+ void $ forkIO $ forever do
+ -- liftIO (printf "[%s] aggregate\n" id)
+ x <- aggregate fp
+ threadDelay delay
+ atomically (writeTVar stateT x)
+ pure stateT
+
+watchXPropertyChanges ::
+ String ->
+ [String] ->
+ (X.Display -> SensorM a) ->
+ Sensor a
+watchXPropertyChanges id as' aggregate = Sensor id $ memoizeMVar do
+ (dpy, as) <- liftIO do
+ dpy <- X.openDisplay ""
+ let root = X.rootWindowOfScreen (X.defaultScreenOfDisplay dpy)
+ X.selectInput dpy root X.propertyChangeMask
+ as <- S.fromList <$> mapM (\a -> X.internAtom dpy a False) as'
+ pure (dpy, as)
+ stateT <- newTVarIO =<< aggregate dpy
+ void $ forkIO $ forever $ do
+ as' <- liftIO $ X.allocaXEvent $ \ev -> do
+ X.nextEvent dpy ev
+ e <- X.getEvent ev
+ let loop es = do
+ isTimeout <- X.waitForEvent dpy 0
+ if isTimeout
+ then pure (S.fromList (map (X.ev_atom) es))
+ else do
+ X.nextEvent dpy ev
+ e <- X.getEvent ev
+ loop (e : es)
+ loop [e]
+ unless (S.null (as `S.intersection` as')) do
+ atomically . writeTVar stateT =<< aggregate dpy
+ pure stateT
+
+histogram ::
+ (Eq a, Typeable a) =>
+ String ->
+ b ->
+ (b -> a -> b) ->
+ Sensor a ->
+ Sensor b
+histogram id def acc sensor = transform' id def f sensor
+ where
+ f b a = pure (acc b a)
+
+transform' ::
+ (Eq a, Typeable a) =>
+ String ->
+ b ->
+ (b -> a -> SensorM b) ->
+ Sensor a ->
+ Sensor b
+transform' id def fM sensor = Sensor id $ memoizeMVar do
+ xT <- poll sensor
+ x <- readTVarIO xT
+ x'T <- newTVarIO x
+ stateT <- newTVarIO =<< fM def x
+ void $ forkIO $ forever $ do
+ (def, x) <- atomically do
+ x' <- readTVar x'T
+ x <- readTVar xT
+ checkSTM (x /= x')
+ def <- readTVar stateT
+ writeTVar x'T x
+ pure (def, x)
+ atomically . writeTVar stateT =<< fM def x
+ pure stateT
+
+transform ::
+ (Eq a, Typeable a) =>
+ String ->
+ (a -> SensorM b) ->
+ Sensor a ->
+ Sensor b
+transform id fM sensor = Sensor id $ memoizeMVar do
+ xT <- poll sensor
+ x <- readTVarIO xT
+ x'T <- newTVarIO x
+ stateT <- newTVarIO =<< fM x
+ void $ forkIO $ forever $ do
+ x <- atomically do
+ x' <- readTVar x'T
+ x <- readTVar xT
+ checkSTM (x /= x')
+ writeTVar x'T x
+ pure x
+ atomically . writeTVar stateT =<< fM x
+ pure stateT
diff --git a/app/Ui.hs b/app/Ui.hs
new file mode 100644
index 0000000..fa1b38e
--- /dev/null
+++ b/app/Ui.hs
@@ -0,0 +1,200 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE NoFieldSelectors #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+
+module Ui
+ ( Ui (Ui),
+ lit,
+ fill,
+ sens,
+ initUi,
+ pollUi,
+ Env (..),
+ Ui',
+ layOutUi,
+ renderUi,
+ renderUi',
+ )
+where
+
+import Control.Concurrent.STM
+import Control.Monad.Identity
+import Control.Monad.Reader
+import Control.Monad.State (evalStateT, get, modify)
+import Data.Default
+import Data.Dynamic
+import Data.Map qualified as M
+import Data.Maybe
+import GHC.Generics (Generic)
+import Graphics.X11 qualified as X
+import Graphics.X11.Xft qualified as X
+import Graphics.X11.Xrender qualified as X
+import Pretty qualified as P
+import Sensor hiding (io)
+
+data Ui f a = Ui [Block f a]
+
+instance Eq (Ui Identity P.Doc) where
+ Ui bs == Ui bs' = bs == bs'
+
+data Block f a
+ = Lit P.Doc
+ | Fill
+ | forall o. (Typeable o) => Sens (o -> a) (f o)
+
+instance Eq (Block Identity P.Doc) where
+ (Lit doc) == (Lit doc') = doc == doc'
+ Fill == Fill = True
+ Sens toOut (Identity x) == Sens toOut' (Identity x') = toOut x == toOut' x'
+ _ == _ = False
+
+lit :: (P.Pretty a) => a -> Block f P.Doc
+lit = Lit . P.pretty
+
+fill :: Block f a
+fill = Fill
+
+sens :: (P.Pretty o, Typeable o) => f o -> Block f P.Doc
+sens = Sens P.pretty
+
+initUi ::
+ Ui Sensor P.Doc ->
+ SensorM (Ui TVar P.Doc)
+initUi (Ui bs) = Ui <$> mapM go bs
+ where
+ go (Lit s) = pure (Lit s)
+ go Fill = pure Fill
+ go (Sens toOut s) = Sens toOut <$> poll s
+
+pollUi ::
+ Ui TVar P.Doc ->
+ STM (Ui Identity P.Doc)
+pollUi (Ui bs) = Ui <$> mapM go bs
+ where
+ go (Lit s) = pure (Lit s)
+ go Fill = pure Fill
+ go (Sens toOut vT) = Sens toOut . Identity <$> readTVar vT
+
+layOutUi ::
+ Env ->
+ Ui Identity P.Doc ->
+ IO Ui'
+layOutUi env (Ui bs) = layOut env (Ui' (concatMap go bs))
+ where
+ go (Lit doc) = go' doc
+ go (Sens toOut (runIdentity -> toOut -> doc)) = go' doc
+ go Fill =
+ [ C
+ { rect = def,
+ fill = True,
+ color = Nothing,
+ string = ""
+ }
+ ]
+
+ go' (P.Lit color string) =
+ [ C
+ { rect = def,
+ fill = False,
+ ..
+ }
+ ]
+ go' (P.Col docs) =
+ concatMap go' docs
+
+layOut :: Env -> Ui' -> IO Ui'
+layOut env@Env {..} (Ui' cs) = do
+ cs' <- evalStateT (mapM pack cs) 0
+ let rwidth = wwidth - sum (map (.rect.width) cs')
+ pure (Ui' (expa rwidth cs'))
+ where
+ pack c = do
+ rect <- io (extents env c)
+ left <- get <* modify (+ rect.width)
+ pure c {rect = rect {left = left}}
+
+ expa rwidth (c@C {fill = True} : cs) =
+ do
+ c {rect = c.rect {width = c.rect.width + rwidth}}
+ : map (\c -> c {rect = c.rect {left = c.rect.left + rwidth}}) cs
+ expa rwidth (c : cs) = c : expa rwidth cs
+ expa _ [] = []
+
+extents :: Env -> C -> IO Rect
+extents Env {..} (C {..}) = do
+ glyphInfo <- X.xftTextExtents dpy fnt string
+ pure
+ ( Rect
+ { top = 0,
+ left = 0,
+ width = X.xglyphinfo_xOff glyphInfo,
+ height = X.xglyphinfo_height glyphInfo
+ }
+ )
+
+data Env = Env
+ { dpy :: X.Display,
+ pixm :: X.Pixmap,
+ gc :: X.GC,
+ wwidth :: Int,
+ wheight :: Int,
+ vis :: X.Visual,
+ cmap :: X.Colormap,
+ fnt :: X.XftFont,
+ drw :: X.XftDraw
+ }
+
+type Colors = M.Map (P.Intensity, P.Color) X.XftColor
+
+renderUi :: Env -> Colors -> Ui' -> IO ()
+renderUi Env {..} colors (Ui' cs) = do
+ let bg = colors M.! (P.Dull, P.Black)
+ X.xftDrawRect drw bg 0 0 wwidth wheight
+ let h = maximum (map (.rect.height) cs)
+ mapM_ (go h) cs
+ where
+ go h (C {..}) = do
+ let fg = colors M.! fromMaybe (P.Dull, P.White) color
+ liftIO (X.xftDrawString drw fg fnt rect.left h string)
+
+renderUi' :: Env -> Colors -> Ui' -> Ui' -> IO ()
+renderUi' env@Env {..} colors (Ui' cs') ui@(Ui' cs)
+ | length cs' /= length cs = renderUi env colors ui
+ | otherwise = do
+ let h = maximum (map (.rect.height) cs)
+ cs'' = catMaybes (zipWith (\c' c -> if c /= c' then Just c else Nothing) cs' cs)
+ mapM_ (go h) cs''
+ where
+ go h (C {..}) = io do
+ let bg = colors M.! (P.Dull, P.Black)
+ let fg = colors M.! (fromMaybe (P.Dull, P.White) color)
+ X.xftDrawRect drw bg rect.left 0 rect.width wheight
+ X.xftDrawString drw fg fnt rect.left h string
+
+data Ui' = Ui' [C] deriving (Show)
+
+data C = C
+ { rect :: Rect,
+ fill :: Bool,
+ color :: Maybe (P.Intensity, P.Color),
+ string :: String
+ }
+ deriving (Show, Eq)
+
+data Rect = Rect
+ { top :: Int,
+ left :: Int,
+ width :: Int,
+ height :: Int
+ }
+ deriving (Generic, Default, Show, Eq)
+
+io :: (MonadIO m) => IO a -> m a
+io = liftIO
diff --git a/app/Util.hs b/app/Util.hs
new file mode 100644
index 0000000..308ef88
--- /dev/null
+++ b/app/Util.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE BlockArguments #-}
+
+module Util
+ ( stmChanges,
+ )
+where
+
+import UnliftIO.STM
+
+stmChanges :: (Eq a) => STM a -> IO (STM a)
+stmChanges mkX = do
+ x'T <- newTVarIO Nothing
+ pure do
+ x' <- readTVar x'T
+ x <- mkX
+ checkSTM (Just x /= x')
+ writeTVar x'T (Just x)
+ pure x
diff --git a/astatusbar.cabal b/astatusbar.cabal
new file mode 100644
index 0000000..432c36c
--- /dev/null
+++ b/astatusbar.cabal
@@ -0,0 +1,38 @@
+cabal-version: 3.4
+name: astatusbar
+version: 0.1.0.0
+license: BSD-3-Clause
+license-file: LICENSE
+maintainer: aforemny@posteo.de
+author: Alexander Foremny
+build-type: Simple
+
+executable astatusbar
+ main-is: Main.hs
+ hs-source-dirs: app
+ other-modules:
+ Pretty
+ Pretty.Color
+ Sensor
+ Ui
+ Util
+
+ default-language: GHC2021
+ ghc-options: -Wall -threaded -O1
+ build-depends:
+ base,
+ containers,
+ data-default,
+ filepath,
+ indexed-traversable,
+ linux-inotify,
+ mtl,
+ safe,
+ sh,
+ statvfs,
+ stm,
+ time,
+ unliftio,
+ witherable,
+ X11,
+ X11-xft
diff --git a/default.nix b/default.nix
new file mode 100644
index 0000000..a0d748b
--- /dev/null
+++ b/default.nix
@@ -0,0 +1,66 @@
+{ pkgs ? import (import ./nix/sources.nix).nixpkgs { } }:
+let
+ haskellPackages = pkgs.haskellPackages.override {
+ overrides = self: super: {
+ astatusbar = self.callCabal2nix "astatusbar" ./. { };
+ sh = pkgs.haskell.lib.dontCheck (self.callCabal2nix "sh" (import ./nix/sources.nix).sh { });
+ statvfs = pkgs.haskell.lib.markUnbroken (super.statvfs.overrideAttrs (oldAtts: {
+ patches = [
+ (pkgs.writers.writeText "statvfs.patch" ''
+ diff --git a/Setup.hs b/Setup.hs
+ index 7cf9bfd..54f57d6 100644
+ --- a/Setup.hs
+ +++ b/Setup.hs
+ @@ -3,4 +3,4 @@ module Main (main) where
+ import Distribution.Simple
+
+ main :: IO ()
+ -main = defaultMainWithHooks defaultUserHooks
+ +main = defaultMainWithHooks autoconfUserHooks
+ '')
+ ];
+ }));
+ X11 = (self.callCabal2nix "X11"
+ (pkgs.fetchFromGitHub {
+ owner = "xmonad";
+ repo = "X11";
+ rev = "1ead9698c89e78884ac771c93822447999a1dc46";
+ hash = "sha256-OAZ3gnUezsumBC8VwhcsKq+Nrq44L4xY/z6exK7InLo=";
+ })
+ { }).overrideAttrs (oldAttrs: {
+ preConfigure = oldAttrs.preConfigure or "" + ''
+ ${pkgs.autoconf}/bin/autoreconf'';
+ patches = oldAttrs.patches or [ ] ++ [
+ (pkgs.writers.writeText "X11-safe-select.patch" ''
+ diff --git a/Graphics/X11/Xlib/Event.hsc b/Graphics/X11/Xlib/Event.hsc
+ index 842fc2f..869aba8 100644
+ --- a/Graphics/X11/Xlib/Event.hsc
+ +++ b/Graphics/X11/Xlib/Event.hsc
+ @@ -419,7 +419,7 @@ newtype FdSet = FdSet (Ptr FdSet)
+ foreign import ccall unsafe "HsXlib.h" fdZero :: Ptr FdSet -> IO ()
+ foreign import ccall unsafe "HsXlib.h" fdSet :: CInt -> Ptr FdSet -> IO ()
+
+ -foreign import ccall unsafe "HsXlib.h" select ::
+ +foreign import ccall safe "HsXlib.h" select ::
+ CInt -> Ptr FdSet -> Ptr FdSet -> Ptr FdSet -> Ptr TimeVal -> IO CInt
+
+ -- | This function is somewhat compatible with Win32's @TimeGetTime()@
+ '')
+ ];
+ });
+ };
+ };
+in
+rec {
+ inherit haskellPackages;
+ inherit (haskellPackages) astatusbar;
+ shell = haskellPackages.shellFor {
+ packages = _: [ haskellPackages.astatusbar ];
+ buildInputs = [
+ pkgs.cabal-install
+ pkgs.niv
+ pkgs.ormolu
+ ];
+ withHoogle = true;
+ };
+}
diff --git a/nix/sources.json b/nix/sources.json
new file mode 100644
index 0000000..3185bc5
--- /dev/null
+++ b/nix/sources.json
@@ -0,0 +1,20 @@
+{
+ "nixpkgs": {
+ "branch": "release-23.11",
+ "description": "Nix Packages collection",
+ "homepage": null,
+ "owner": "NixOS",
+ "repo": "nixpkgs",
+ "rev": "af7e9fb77b8993a7b5f01282c869e503d6cc9e6e",
+ "sha256": "174r9nhpmvgrjlr46gvs5vvn38nmlzz0hhr27xz5qaabnlwi6b8m",
+ "type": "tarball",
+ "url": "https://github.com/NixOS/nixpkgs/archive/af7e9fb77b8993a7b5f01282c869e503d6cc9e6e.tar.gz",
+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
+ },
+ "sh": {
+ "branch": "main",
+ "repo": "git@code.nomath.org:~/sh",
+ "rev": "3ea4e6459333409c60f66a5745bb472d136da741",
+ "type": "git"
+ }
+}
diff --git a/nix/sources.nix b/nix/sources.nix
new file mode 100644
index 0000000..fe3dadf
--- /dev/null
+++ b/nix/sources.nix
@@ -0,0 +1,198 @@
+# This file has been generated by Niv.
+
+let
+
+ #
+ # The fetchers. fetch_<type> fetches specs of type <type>.
+ #
+
+ fetch_file = pkgs: name: spec:
+ let
+ name' = sanitizeName name + "-src";
+ in
+ if spec.builtin or true then
+ builtins_fetchurl { inherit (spec) url sha256; name = name'; }
+ else
+ pkgs.fetchurl { inherit (spec) url sha256; name = name'; };
+
+ fetch_tarball = pkgs: name: spec:
+ let
+ name' = sanitizeName name + "-src";
+ in
+ if spec.builtin or true then
+ builtins_fetchTarball { name = name'; inherit (spec) url sha256; }
+ else
+ pkgs.fetchzip { name = name'; inherit (spec) url sha256; };
+
+ fetch_git = name: spec:
+ let
+ ref =
+ spec.ref or (
+ if spec ? branch then "refs/heads/${spec.branch}" else
+ if spec ? tag then "refs/tags/${spec.tag}" else
+ abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"
+ );
+ submodules = spec.submodules or false;
+ submoduleArg =
+ let
+ nixSupportsSubmodules = builtins.compareVersions builtins.nixVersion "2.4" >= 0;
+ emptyArgWithWarning =
+ if submodules
+ then
+ builtins.trace
+ (
+ "The niv input \"${name}\" uses submodules "
+ + "but your nix's (${builtins.nixVersion}) builtins.fetchGit "
+ + "does not support them"
+ )
+ { }
+ else { };
+ in
+ if nixSupportsSubmodules
+ then { inherit submodules; }
+ else emptyArgWithWarning;
+ in
+ builtins.fetchGit
+ ({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg);
+
+ fetch_local = spec: spec.path;
+
+ fetch_builtin-tarball = name: throw
+ ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`.
+ $ niv modify ${name} -a type=tarball -a builtin=true'';
+
+ fetch_builtin-url = name: throw
+ ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`.
+ $ niv modify ${name} -a type=file -a builtin=true'';
+
+ #
+ # Various helpers
+ #
+
+ # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695
+ sanitizeName = name:
+ (
+ concatMapStrings (s: if builtins.isList s then "-" else s)
+ (
+ builtins.split "[^[:alnum:]+._?=-]+"
+ ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name)
+ )
+ );
+
+ # The set of packages used when specs are fetched using non-builtins.
+ mkPkgs = sources: system:
+ let
+ sourcesNixpkgs =
+ import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; };
+ hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
+ hasThisAsNixpkgsPath = <nixpkgs> == ./.;
+ in
+ if builtins.hasAttr "nixpkgs" sources
+ then sourcesNixpkgs
+ else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then
+ import <nixpkgs> { }
+ else
+ abort
+ ''
+ Please specify either <nixpkgs> (through -I or NIX_PATH=nixpkgs=...) or
+ add a package called "nixpkgs" to your sources.json.
+ '';
+
+ # The actual fetching function.
+ fetch = pkgs: name: spec:
+
+ if ! builtins.hasAttr "type" spec then
+ abort "ERROR: niv spec ${name} does not have a 'type' attribute"
+ else if spec.type == "file" then fetch_file pkgs name spec
+ else if spec.type == "tarball" then fetch_tarball pkgs name spec
+ else if spec.type == "git" then fetch_git name spec
+ else if spec.type == "local" then fetch_local spec
+ else if spec.type == "builtin-tarball" then fetch_builtin-tarball name
+ else if spec.type == "builtin-url" then fetch_builtin-url name
+ else
+ abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}";
+
+ # If the environment variable NIV_OVERRIDE_${name} is set, then use
+ # the path directly as opposed to the fetched source.
+ replace = name: drv:
+ let
+ saneName = stringAsChars (c: if (builtins.match "[a-zA-Z0-9]" c) == null then "_" else c) name;
+ ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";
+ in
+ if ersatz == "" then drv else
+ # this turns the string into an actual Nix path (for both absolute and
+ # relative paths)
+ if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}";
+
+ # Ports of functions for older nix versions
+
+ # a Nix version of mapAttrs if the built-in doesn't exist
+ mapAttrs = builtins.mapAttrs or (
+ f: set: with builtins;
+ listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set))
+ );
+
+ # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295
+ range = first: last: if first > last then [ ] else builtins.genList (n: first + n) (last - first + 1);
+
+ # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257
+ stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1));
+
+ # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269
+ stringAsChars = f: s: concatStrings (map f (stringToCharacters s));
+ concatMapStrings = f: list: concatStrings (map f list);
+ concatStrings = builtins.concatStringsSep "";
+
+ # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331
+ optionalAttrs = cond: as: if cond then as else { };
+
+ # fetchTarball version that is compatible between all the versions of Nix
+ builtins_fetchTarball = { url, name ? null, sha256 }@attrs:
+ let
+ inherit (builtins) lessThan nixVersion fetchTarball;
+ in
+ if lessThan nixVersion "1.12" then
+ fetchTarball ({ inherit url; } // (optionalAttrs (name != null) { inherit name; }))
+ else
+ fetchTarball attrs;
+
+ # fetchurl version that is compatible between all the versions of Nix
+ builtins_fetchurl = { url, name ? null, sha256 }@attrs:
+ let
+ inherit (builtins) lessThan nixVersion fetchurl;
+ in
+ if lessThan nixVersion "1.12" then
+ fetchurl ({ inherit url; } // (optionalAttrs (name != null) { inherit name; }))
+ else
+ fetchurl attrs;
+
+ # Create the final "sources" from the config
+ mkSources = config:
+ mapAttrs
+ (
+ name: spec:
+ if builtins.hasAttr "outPath" spec
+ then
+ abort
+ "The values in sources.json should not have an 'outPath' attribute"
+ else
+ spec // { outPath = replace name (fetch config.pkgs name spec); }
+ )
+ config.sources;
+
+ # The "config" used by the fetchers
+ mkConfig =
+ { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null
+ , sources ? if sourcesFile == null then { } else builtins.fromJSON (builtins.readFile sourcesFile)
+ , system ? builtins.currentSystem
+ , pkgs ? mkPkgs sources system
+ }: rec {
+ # The sources, i.e. the attribute set of spec name to spec
+ inherit sources;
+
+ # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers
+ inherit pkgs;
+ };
+
+in
+mkSources (mkConfig { }) // { __functor = _: settings: mkSources (mkConfig settings); }
diff --git a/shell.nix b/shell.nix
new file mode 100644
index 0000000..a6bdf20
--- /dev/null
+++ b/shell.nix
@@ -0,0 +1 @@
+(import ./. { }).shell
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-23 04:02:17 +0000