Can’t have a status-script without GADTs can we?

home-manager/roles/status-script.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE ExtendedDefaultRules #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -19,6 +20,7 @@ import Data.ByteString.Char8 qualified as ByteString
 import Data.ByteString.Lazy qualified as LBS
 import Data.String.Interpolate (i)
 import Data.Text qualified as Text
+import Data.Unique qualified as Unique
 import Relude
 import Say (sayErr)
 import Shh (ExecReference (Absolute), Proc, captureTrim, exe, ignoreFailure, load, readInputLines, (|>))
@@ -47,35 +49,54 @@ isUnpushed gitDir = do
 tryCmd :: Proc a -> IO LBS.ByteString
 tryCmd x = ignoreFailure x |> captureTrim
 
-data Var a = MkVar
+newtype Var a = MkVar
-  { value :: TVar a
+  { value :: TVar (a, Unique.Unique)
-  , update :: TMVar ()
   }
 
+getUnique = fmap snd . readTVar . value
+getVal = fmap fst . readTVar . value
+
 newVar :: a -> IO (Var a)
-newVar initial_value = atomically $ MkVar <$> newTVar initial_value <*> newEmptyTMVar
+newVar initial_value = do
+  unique <- Unique.newUnique
+  MkVar <$> newTVarIO (initial_value, unique)
 
 newMaybeVar :: IO (Var (Maybe a))
-newMaybeVar = atomically $ MkVar <$> newTVar Nothing <*> newEmptyTMVar
+newMaybeVar = newVar Nothing
 
 type Vars = [Var (Maybe Text)]
 type Module a = Var a -> IO Void
 
-repeatM :: IO a -> IO Void
-repeatM action = fix (action >>)
-
 writeVars :: Vars -> IO Void
-writeVars vars = repeatM do
+writeVars vars = onUpdatesMono vars do
-  outputs <- atomically $ do
+  outputs <- atomically $ mapM getVal vars
-    updates <- forM vars $ \MkVar{update} -> tryTakeTMVar update
-    STM.check $ any isJust updates
-    forM vars \MkVar{value} -> readTVar value
   writeFileText "/run/user/1000/status-bar" $
     Text.replace "&" "&amp;" $
       Text.unwords $
         ("<executor.markup.true>" :) $
           catMaybes outputs
 
+data AnyVar where
+  AVar :: Var a -> AnyVar
+
+onUpdate :: Var a -> (a -> IO ()) -> IO Void
+onUpdate var action = onUpdatesMono [var] do
+  action =<< atomically (getVal var)
+
+onUpdatesMono :: [Var a] -> IO () -> IO Void
+onUpdatesMono = onUpdates . fmap AVar
+
+onUpdates :: [AnyVar] -> IO () -> IO Void
+onUpdates vars action = go []
+ where
+  go previous_uniques = do
+    next_uniques <- atomically $ do
+      current_uniques <- mapM (\(AVar a) -> getUnique a) vars
+      STM.check $ previous_uniques /= current_uniques
+      pure current_uniques
+    action
+    go next_uniques
+
 runModules :: [Module (Maybe Text)] -> IO ()
 runModules modules = do
   (vars, actions) <-
@@ -90,16 +111,17 @@ foldConcurrently_ = Async.mapConcurrently_ id
 oneSecond :: Int
 oneSecond = 1000000
 
-updateVarIfChanged :: Eq a => Var a -> a -> STM ()
+updateVarIfChanged :: Eq a => Var a -> a -> IO ()
-updateVarIfChanged MkVar{value, update} new_value = do
+updateVarIfChanged var@MkVar{value} new_value = do
-  old_value <- readTVar value
+  new_unique <- Unique.newUnique
-  unless (old_value == new_value) do
+  atomically do
-    writeTVar value new_value
+    old_value <- getVal var
-    putTMVar update ()
+    unless (old_value == new_value) do
+      writeTVar value (new_value, new_unique)
 
 simpleModule :: Eq a => Int -> IO a -> Module a
-simpleModule delay action var = repeatM do
+simpleModule delay action var = forever do
-  atomically . updateVarIfChanged var =<< action
+  updateVarIfChanged var =<< action
   Concurrent.threadDelay delay
 
 withColor :: Monad m => Text -> Text -> m (Maybe Text)
@@ -115,8 +137,7 @@ playerModule :: Module (Maybe Text)
 playerModule = \var ->
   let update_lines =
         mapM_
-          ( atomically
+          ( updateVarIfChanged var
-              . updateVarIfChanged var
               . Just
               . Text.replace "@Stopped" "⏹"
               . Text.replace "@Playing" "▶"
@@ -131,7 +152,7 @@ playerModule = \var ->
 main :: IO ()
 main = do
   mode_var <- newVar Unrestricted
-  let read_mode = readTVarIO (value mode_var)
+  let read_mode = fst <$> readTVarIO (value mode_var)
       modules =
         [ simpleModule (5 * oneSecond) $ do
             appointments <- lines . decodeUtf8 <$> tryCmd (khal ["list", "-a", "Standard", "-a", "Planung", "-a", "Uni", "-a", "Maltaire", "now", "2h", "-df", ""])
@@ -196,9 +217,8 @@ main = do
                 when' (system_dirty || modes_dirty) $ withColor "ffff00" [i|Current #{case (system_dirty,modes_dirty) of (True, True) -> "home and system"; (True, _) -> "system"; _ -> "home"} stale|]
               )
               var
-        , \var -> forever do
+        , \var ->
-            atomically . updateVarIfChanged var =<< withColor "7287fd" . show =<< read_mode
+            onUpdate mode_var $ updateVarIfChanged var . runIdentity . withColor "7287fd" . show
-            atomically $ takeTMVar (update mode_var)
         ]
   foldConcurrently_
     [ void $ simpleModule oneSecond getMode mode_var