6 files changed, 1125 insertions, 0 deletions
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