lvar (empty) → 0.1.0.0

raw patch · 5 files changed

+234/−0 lines, 5 filesdep +basedep +containersdep +relude

Dependencies added: base, containers, relude, stm

Files

• CHANGELOG.md +5/−0
• LICENSE +29/−0
• README.md +5/−0
• lvar.cabal +53/−0
• src/Data/LVar.hs +142/−0

@@ -0,0 +1,5 @@+# Revision history for lvar++## 0.1.0.0 -- 2021-04-26++* First version. Released on an unsuspecting world.

@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2021, Sridhar Ratnakumar+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its+   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 HOLDER 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.

@@ -0,0 +1,5 @@+# `Data.LVar`++[`TMVar`](https://hackage.haskell.org/package/stm) with change notification.++Used in [Ema](https://ema.srid.ca/).

@@ -0,0 +1,53 @@+cabal-version:      2.4+name:               lvar+version:            0.1.0.0+license:            BSD-3-Clause+copyright:          2021 Sridhar Ratnakumar+maintainer:         srid@srid.ca+author:             Sridhar Ratnakumar+category:           Concurrency+synopsis:  TMVar that can be listened to+bug-reports: https://github.com/srid/lvar/issues+homepage: https://github.com/srid/lvar+description:+  LVar wraps a TMVar to allow multiple threads to listen to the underlying changes.++extra-source-files:+  CHANGELOG.md+  LICENSE+  README.md++library+  -- Modules included in this executable, other than Main.+  -- other-modules:++  -- LANGUAGE extensions used by modules in this package.+  -- other-extensions:+  build-depends:+    , base                   >=4.13.0.0 && <=4.17.0.0+    , containers+    , stm+    , relude+  mixins:+    base hiding (Prelude),+    relude (Relude as Prelude),+    relude+  ghc-options:+    -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns+  default-extensions:+    FlexibleContexts+    FlexibleInstances+    KindSignatures+    LambdaCase+    MultiParamTypeClasses+    MultiWayIf+    OverloadedStrings+    ScopedTypeVariables+    TupleSections+    ViewPatterns++  exposed-modules:+    Data.LVar++  hs-source-dirs:     src+  default-language:   Haskell2010

@@ -0,0 +1,142 @@+{-# LANGUAGE DeriveAnyClass #-}++-- | @LVar@ is like @Control.Concurrent.STM.TMVar@ but with a capability for+-- listening to its changes.+module Data.LVar+  ( -- * Types+    LVar,+    ListenerId,++    -- * Creating a LVar+    new,+    empty,++    -- * Modifying a LVar+    get,+    set,+    modify,++    -- * Listening to a LVar+    addListener,+    listenNext,+    removeListener,+  )+where++import Control.Exception (throw)+import qualified Data.Map.Strict as Map+import Prelude hiding (empty, get, modify)++-- A mutable variable (like @TMVar@), changes to which can be listened to from+-- multiple threads.+data LVar a = LVar+  { -- | A value that changes over time+    lvarCurrent :: TMVar a,+    -- | Subscribers listening on changes to the value+    lvarListeners :: TMVar (Map ListenerId (TMVar ()))+  }++type ListenerId = Int++-- | Create a new @LVar@ with the given initial value+new :: forall a m. MonadIO m => a -> m (LVar a)+new val = do+  LVar <$> newTMVarIO val <*> newTMVarIO mempty++-- | Like @new@, but there is no initial value. A @get@ will block until an+-- initial value is set using @set@ or @modify@+empty :: MonadIO m => m (LVar a)+empty =+  LVar <$> newEmptyTMVarIO <*> newTMVarIO mempty++-- | Get the value of the @LVar@+get :: MonadIO m => LVar a -> m a+get v =+  atomically $ readTMVar $ lvarCurrent v++-- | Set the @LVar@ value; active listeners are automatically notifed.+set :: MonadIO m => LVar a -> a -> m ()+set v val = do+  atomically $ do+    let var = lvarCurrent v+    isEmptyTMVar var >>= \case+      True -> putTMVar var val+      False -> void $ swapTMVar var val+    notifyListeners v++-- | Modify the @LVar@ value; active listeners are automatically notified.+modify :: MonadIO m => LVar a -> (a -> a) -> m ()+modify v f = do+  atomically $ do+    curr <- readTMVar (lvarCurrent v)+    void $ swapTMVar (lvarCurrent v) (f curr)+    notifyListeners v++notifyListeners :: LVar a -> STM ()+notifyListeners v' = do+  subs <- readTMVar $ lvarListeners v'+  forM_ (Map.elems subs) $ \subVar -> do+    tryPutTMVar subVar ()++data ListenerDead = ListenerDead+  deriving (Exception, Show)++-- | Create a listener for changes to the @LVar@, as they are set by @set@ or+-- @modify@ from this time onwards.+--+-- You must call @listenNext@ to get the next updated value (or current value if+-- there is one).+--+-- Returns a @ListenerId@ that can be used to stop listening later (via+-- @removeListener@)+addListener ::+  MonadIO m =>+  LVar a ->+  m ListenerId+addListener v = do+  atomically $ do+    subs <- readTMVar $ lvarListeners v+    let nextIdx = maybe 1 (succ . fst) $ Map.lookupMax subs+    notify <-+      tryReadTMVar (lvarCurrent v) >>= \case+        Nothing -> newEmptyTMVar+        -- As a value is already available, send that as first notification.+        --+        -- NOTE: Creating a TMVar that is "full" ensures that we send a current+        -- (which is not empty) value on @listenNext@).+        Just _ -> newTMVar ()+    void $ swapTMVar (lvarListeners v) $ Map.insert nextIdx notify subs+    pure nextIdx++-- | Listen for the next value update (since the last @listenNext@ or+-- @addListener@). Unless the @LVar@ was empty when @addListener@ was invoked,+-- the first invocation of @listenNext@ will return the current value even if+-- there wasn't an update.  Therefore, the *first* call to @listenNext@ will+-- *always* return immediately, unless the @LVar@ is empty.+--+-- Call this in a loop to listen on a series of updates.+--+-- Throws @ListenerDead@ if called with a @ListenerId@ that got already removed+-- by @removeListener@.+listenNext :: MonadIO m => LVar a -> ListenerId -> m a+listenNext v idx = do+  atomically $ do+    lookupListener v idx >>= \case+      Nothing ->+        -- FIXME: can we avoid this by design?+        throw ListenerDead+      Just listenVar -> do+        takeTMVar listenVar+        readTMVar (lvarCurrent v)+  where+    lookupListener :: LVar a -> ListenerId -> STM (Maybe (TMVar ()))+    lookupListener v' lId = do+      Map.lookup lId <$> readTMVar (lvarListeners v')++-- | Stop listening to the @LVar@+removeListener :: MonadIO m => LVar a -> ListenerId -> m ()+removeListener v lId = do+  atomically $ do+    subs <- readTMVar $ lvarListeners v+    whenJust (Map.lookup lId subs) $ \_sub -> do+      void $ swapTMVar (lvarListeners v) $ Map.delete lId subs