diff --git a/quasar.cabal b/quasar.cabal index d6eab27b187b6170e290cbee894881157cef9978..28a8fc62fd11af656c08eb72a237706e099a38c4 100644 --- a/quasar.cabal +++ b/quasar.cabal @@ -103,6 +103,7 @@ library Quasar.Timer.TimerFd Quasar.Utils.Exceptions Quasar.Utils.ExtraT + Quasar.Utils.TOnce hs-source-dirs: src diff --git a/src/Quasar/Utils/TOnce.hs b/src/Quasar/Utils/TOnce.hs new file mode 100644 index 0000000000000000000000000000000000000000..bd1dba8491b3bacb8522ecb205fb82f45ca76e4c --- /dev/null +++ b/src/Quasar/Utils/TOnce.hs @@ -0,0 +1,53 @@ +module Quasar.Utils.TOnce ( + TOnce, + newTOnce, + newTOnceIO, + mapFinalizeTOnce, + finalizeTOnce, + readTOnceState, + readTOnceResult, +) where + +import Control.Concurrent.STM +import Quasar.Awaitable +import Quasar.Prelude + +data TOnceAlreadyFinalized = TOnceAlreadyFinalized + deriving (Eq, Show, Exception) + +newtype TOnce a b = TOnce (TVar (Either a b)) + +instance IsAwaitable b (TOnce a b) where + toAwaitable = unsafeAwaitSTM . readTOnceResult + +newTOnce :: a -> STM (TOnce a b) +newTOnce initial = TOnce <$> newTVar (Left initial) + +newTOnceIO :: a -> IO (TOnce a b) +newTOnceIO initial = TOnce <$> newTVarIO (Left initial) + + +mapFinalizeTOnce :: TOnce a b -> (a -> STM b) -> STM b +mapFinalizeTOnce (TOnce var) fn = + readTVar var >>= \case + Left initial -> do + final <- fn initial + writeTVar var (Right final) + pure final + Right final -> pure final + +finalizeTOnce :: TOnce a b -> b -> STM () +finalizeTOnce (TOnce var) value = + readTVar var >>= \case + Left _ -> writeTVar var (Right value) + Right _ -> throwSTM TOnceAlreadyFinalized + + +readTOnceState :: TOnce a b -> STM (Either a b) +readTOnceState (TOnce var) = readTVar var + +readTOnceResult :: TOnce a b -> STM b +readTOnceResult switch = + readTOnceState switch >>= \case + Right final -> pure final + _ -> retry