Move Data.LVar to separate repo

ema.cabal

@@ -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
 

flake.lock

@@ -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"
       }
     }

flake.nix

@@ -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;
               [

src/Data/LVar.hs

@@ -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