srid/ema
1
1
Fork 0
mirror of https://github.com/srid/ema.git synced 2024-11-25 20:12:20 +03:00
Code Issues Projects Releases Wiki Activity

Move Data.LVar to separate repo

Browse Source
This commit is contained in:
Sridhar Ratnakumar 2021-04-26 13:36:34 -04:00
parent c86aad162a
commit 48c92c3204
4 changed files with 26 additions and 145 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
ema.cabal
View File

@ -2,7 +2,7 @@ cabal-version: 2.4
name: ema
version: 0.1.0.0
license: AGPL-3.0-only
copyright: 2020 Sridhar Ratnakumar
copyright: 2021 Sridhar Ratnakumar
maintainer: srid@srid.ca
author: Sridhar Ratnakumar
category: Web
@ -44,6 +44,7 @@ library
, directory
, filepath
, http-types
, lvar
, monad-logger
, monad-logger-extras
, neat-interpolation
@ -98,7 +99,6 @@ library
ViewPatterns
exposed-modules:
Data.LVar
Ema
Ema.CLI

17
flake.lock
View File

@ -31,6 +31,22 @@
"type": "github"
}
},
"lvar": {
"flake": false,
"locked": {
"lastModified": 1619458516,
"narHash": "sha256-4nuuDSKPWDIdjmZDxne9EDJvVcivPRaPRZ92dmhjb0Q=",
"owner": "srid",
"repo": "lvar",
"rev": "e68489533fcb67b7404c945b443bb58cdc23b710",
"type": "github"
},
"original": {
"owner": "srid",
"repo": "lvar",
"type": "github"
}
},
"nixpkgs": {
"locked": {
"lastModified": 1618909122,
@ -51,6 +67,7 @@
"inputs": {
"flake-compat": "flake-compat",
"flake-utils": "flake-utils",
"lvar": "lvar",
"nixpkgs": "nixpkgs"
}
}

8
flake.nix
View File

@ -7,6 +7,10 @@
url = "github:edolstra/flake-compat";
flake = false;
};
lvar = {
url = "github:srid/lvar";
flake = false;
};
};
outputs = inputs@{ self, nixpkgs, flake-utils, ... }:
flake-utils.lib.eachSystem [ "x86_64-linux" "x86_64-darwin" ] (system:
@ -21,7 +25,9 @@
inherit name returnShellEnv;
root = ./.;
withHoogle = false;
overrides = self: super: with pkgs.haskell.lib; { };
overrides = self: super: with pkgs.haskell.lib; {
lvar = self.callCabal2nix "lvar" inputs.lvar { };
};
modifier = drv:
pkgs.haskell.lib.addBuildTools drv (with pkgs.haskellPackages;
[

142
src/Data/LVar.hs
View File

@ -1,142 +0,0 @@
{-# 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