From 07acb8985844bf1df34eeab13abc0f6ca279d93f Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
Date: Sun, 21 Jul 2024 17:41:45 +0200
Subject: fix: depend on sensors

---
 app/Main.hs | 77 +++++++++++++++++++++++++++----------------------------------
 1 file changed, 34 insertions(+), 43 deletions(-)

(limited to 'app/Main.hs')

diff --git a/app/Main.hs b/app/Main.hs
index 09f0d50..66883b9 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -11,11 +11,12 @@ module Main where
 import Control.Concurrent
 import Control.Exception
 import Control.Monad
-import Control.Monad.Identity
+import Control.Monad.Trans
 import Data.Bits
 import Data.List
 import Data.Map qualified as M
 import Data.Maybe
+import Data.Sensor qualified as S
 import GHC.Ptr (Ptr)
 import Graphics.X11 qualified as X
 import Graphics.X11.Xft qualified as X
@@ -62,7 +63,7 @@ type Colors = M.Map (P.Intensity, P.Color) X.XftColor
 
 data State = State
   { dirty :: Bool,
-    ui :: Ui TVar P.Doc
+    ui :: Ui (S.Sensor (S.SensorT IO) () (Block P.Doc))
   }
 
 main :: IO ()
@@ -71,32 +72,25 @@ main = do
     bracket (createWindow args) 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
+  -- XXX `ui` lives in state, but we treat is as if it was constant
+  -- XXX this is supposed to NOT wait for the next event if `state.dirty`
+  S.runSensorT . S.sample' go . pollUi . (.ui) =<< atomically do readTVar stateT
   where
-    go Nothing = do
-      pUi <- atomically do
+    go Nothing pUi = do
+      atomically do
+        writeTVar stateT . (\state -> state {dirty = False})
+          =<< readTVar stateT
+      lUi <- liftIO (paint env colors Nothing pUi)
+      pure lUi
+    go (Just lUi') pUi = do
+      dirty <- 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)
+        pure dirty
+      lUi <- liftIO (paint env colors (if dirty then Nothing else Just lUi') pUi)
+      pure lUi
 
 processEvents :: Ptr X.XEvent -> Env -> TVar State -> IO ()
 processEvents ev env@(Env {..}) stateT = do
@@ -115,12 +109,7 @@ processEvent ev (Env {..}) stateT = do
         writeTVar stateT state {dirty = True}
     | otherwise -> pure ()
 
-paint ::
-  Env ->
-  Colors ->
-  Maybe Ui' ->
-  Ui Identity P.Doc ->
-  IO Ui'
+paint :: Env -> Colors -> Maybe Ui' -> Ui (Block P.Doc) -> IO Ui'
 paint Env {..} colors Nothing ui = do
   let env' = Ui.Env {..}
   ui' <- layOutUi env' ui
@@ -190,20 +179,22 @@ createWindow args = do
   drw <- X.xftDrawCreate dpy pixm vis cmap
   X.mapWindow dpy win
   let dirty = True
-  ui <-
-    runSensorM . initUi . Ui $
-      intercalate [lit " "] $
-        [ [sens wmWorkspaces],
-          [sens wmName, fill],
-          [lit (if args.icons then "\xf4bc  " else "cpu "), sens cpu],
-          [lit (if args.icons then "\xf035b  " else "mem "), sens mem],
-          [lit (if args.icons then "\xf0a0  " else "disk "), sens disk],
-          [lit (if args.icons then "\xf1638  " else "io "), sens io],
-          [lit (if args.icons then "\xf0200  " else "net "), sens net],
-          [lit (if args.icons then "\xf028  " else "snd "), sens Sensor.snd],
-          [lit (if args.icons then "\xf240  " else "bat "), sens bat],
-          [lit " ", sens date, lit ", ", sens time]
-        ]
+  let ui :: Ui (S.Sensor (S.SensorT IO) () (Block P.Doc))
+      ui =
+        Ui $
+          intercalate [pure (lit " ")] $
+            [ [lit <$> wmWorkspaces],
+              [lit <$> wmName, pure fill],
+              [pure (lit (if args.icons then "\xf4bc  " else "cpu ")), lit <$> cpu],
+              [pure (lit (if args.icons then "\xf035b  " else "mem ")), lit <$> mem],
+              [pure (lit (if args.icons then "\xf0a0  " else "disk ")), lit <$> disk],
+              [pure (lit (if args.icons then "\xf1638  " else "io ")), lit <$> io],
+              [pure (lit (if args.icons then "\xf0200  " else "net ")), lit <$> net],
+              [pure (lit (if args.icons then "\xf028  " else "snd ")), lit <$> Sensor.snd],
+              [pure (lit (if args.icons then "\xf240  " else "bat ")), lit <$> bat],
+              [pure (lit " "), lit <$> date, pure (lit ", "), lit <$> time],
+              []
+            ]
   xcolors <- do
     X.rmInitialize
     rdb <- X.rmGetStringDatabase (X.resourceManagerString dpy)
-- 
cgit v1.2.3