packages feed

ref-extras 0.1.1 → 0.2.0

raw patch · 9 files changed

+115/−49 lines, 9 filesdep ~hashabledep ~little-riodep ~microlens

Dependency ranges changed: hashable, little-rio, microlens, stm, unliftio, unliftio-core, unordered-containers

Files

ref-extras.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 0c53a1b53092126beb62eea99bfb47ad42c02b42aef27681ee3434592b29b682+-- hash: b9a615ad370284799172b41317daac33b8bcecdcf7411334176b94d2d7105985  name:           ref-extras-version:        0.1.1+version:        0.2.0 synopsis:       Extra stuff for mutable references description:    Please see the README on GitHub at <https://github.com/ejconlon/ref-extras#readme> category:       Data@@ -34,6 +34,7 @@       RefExtras.LensRef       RefExtras.Memo       RefExtras.SomeRef+      RefExtras.UVar       RefExtras.XVar   other-modules:       Paths_ref_extras@@ -43,11 +44,11 @@   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds   build-depends:       base >=4.12 && <5-    , hashable >=1.3-    , little-rio >=0.1.1-    , microlens >=0.4-    , stm >=2.5-    , unliftio >=0.2-    , unliftio-core >=0.1-    , unordered-containers >=0.2+    , hashable >=1.3 && <2+    , little-rio >=0.2.1 && <1+    , microlens >=0.4 && <1+    , stm >=2.5 && <3+    , unliftio >=0.2 && <1+    , unliftio-core >=0.1 && <1+    , unordered-containers >=0.2 && <1   default-language: Haskell2010
src/RefExtras/Check.hs view
@@ -11,7 +11,7 @@ import RefExtras.Classes (AtomicRef, atomicModifyRef, readRef) import RefExtras.XVar (XVar, atomicModifyXVarM) --- Conditionally updates an AtomicRef. First reads the value with the prepare function, which+-- | Conditionally updates an AtomicRef. First reads the value with the prepare function, which -- chooses to write with the commit function or chooses to return. This function allows you to -- sequence a read, some effectful operation, and an optional write, all with the caveat that -- the ref may have changed between the read and the write.@@ -23,7 +23,7 @@     Left b -> atomicModifyRef ref (commit b)     Right c -> pure c --- checkEffectRef but locking around the effectful prepare function. You will block for the duration+-- | checkEffectRef but locking around the effectful prepare function. You will block for the duration -- of the prepare and commit functions but are guaranteed that the var does not change in the -- meantime. checkEffectXVar :: MonadUnliftIO m => XVar a -> (a -> m (Either x b)) -> (x -> a -> (a, b)) -> m b@@ -33,7 +33,7 @@     Left b -> pure (commit b a)     Right c -> pure (a, c) --- The two prepare and commit functions packaged up.+-- | The two prepare and commit functions packaged up. data CheckEffect m a b where   CheckEffect :: !(a -> m (Either x b)) -> !(x -> a -> (a, b)) -> CheckEffect m a b
src/RefExtras/Classes.hs view
@@ -1,3 +1,4 @@+-- | Classes that generalize operations on mutable references. module RefExtras.Classes where  import Control.Concurrent.STM.TVar (TVar, readTVar, writeTVar)@@ -8,11 +9,13 @@ import LittleRIO (SomeRef, readSomeRef, writeSomeRef) import UnliftIO.IORef (IORef, atomicModifyIORef', modifyIORef', readIORef, writeIORef) +-- | A reference that we can read and write, but not necessarily without+-- contending with intervening mutations. class ReadWriteRef r m where   readRef :: r a -> m a   writeRef :: r a -> a -> m () --- "Unsafe" in the sense that in most cases we can implement modify by+-- | /Unsafe/ in the sense that in most cases we can implement modify by -- reading then writing, but we're not guaranteed that no writes have occurred in -- the meantime. This is true for IORefs, which is why we need a separate core method. -- It is not true for STM, which means this is actually safe for TVars.@@ -22,7 +25,7 @@   let a' = f a   writeRef ref $! a' --- See above notes on safety.+-- | See notes on safety for 'unsafeModifyRef'. unsafeAtomicModifyRef :: (Monad m, ReadWriteRef r m) => r a -> (a -> (a, b)) -> m b unsafeAtomicModifyRef ref f = do   a <- readRef ref@@ -30,12 +33,19 @@   writeRef ref $! a'   pure $! b +-- | A reference that offers the ability to mutate with a pure function.+-- However, we might not be able to observe the result without intervening mutations. class ReadWriteRef r m => ModifyRef r m where   modifyRef :: r a -> (a -> a) -> m () +-- | A reference that we can mutate *and observe* with a pure function. class ModifyRef r m => AtomicRef r m where   atomicModifyRef :: r a -> (a -> (a, b)) -> m b +-- | Atomically swap a value in a reference.+swapRef :: AtomicRef r m => r a -> a -> m a+swapRef r a = atomicModifyRef r (\z -> (a, z))+ instance MonadIO m => ReadWriteRef IORef m where   readRef = readIORef   writeRef = writeIORef@@ -54,7 +64,7 @@   readRef = readTVar   writeRef = writeTVar --- These "unsafe" impls are safe for TVars because STM guarantees that+-- These /unsafe/ impls are safe for TVars because STM guarantees that -- the vars don't change between reading and writing.  instance ModifyRef TVar STM where
src/RefExtras/EVar.hs view
@@ -5,24 +5,31 @@   , newReadyEVar   , readEVar   , tryReadEVar-  , writeEVar-  , modifyEVar   ) where -import Control.Monad (join, void)+import Control.Monad (join) import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Unlift (MonadUnliftIO) import UnliftIO.Exception (finally) import UnliftIO.IORef (atomicWriteIORef, newIORef, readIORef)-import UnliftIO.MVar (MVar, modifyMVar, newEmptyMVar, newMVar, putMVar, readMVar, swapMVar, tryReadMVar)+import UnliftIO.MVar (MVar, modifyMVar, newEmptyMVar, newMVar, putMVar, readMVar, tryReadMVar) +-- | The /E/ in 'EVar' stands for /Eventual/.+-- It may or may not have a value, but once it does, it doesn't change. newtype EVar a = EVar { unEVar :: MVar (Maybe a) } --- Blocks on var and action+-- | You can /access/ an 'EVar' by telling it how to compute the value!+-- If there is already a value, it simply returns it instead of computing it.+-- If the computation fails, the exception propagates, leaving the EVar empty.+-- Blocks on var and action. accessEVar :: MonadUnliftIO m => EVar a -> m a -> m a accessEVar (EVar w) act = modifyMVar w (fmap (\a -> (Just a, a)) . maybe act pure) --- Blocks on action+-- | Creates a new 'EVar' with a the given computation.+-- Note that this does not /return/ an 'EVar', but instead creates+-- and shares the 'EVar' before computing it so you can updates references+-- to it first in case of exceptions.+-- Blocks on action. newEventualEVar :: MonadUnliftIO m => (EVar a -> m ()) -> m a -> m a newEventualEVar share act = do   w <- newEmptyMVar@@ -35,22 +42,14 @@     atomicWriteIORef i (Just a)     pure a --- Non-blocking+-- | Creates an 'EVar' with an already-computed value. newReadyEVar :: MonadIO m => a -> m (EVar a) newReadyEVar = fmap EVar . newMVar . Just --- Non-blocking+-- | Returns the value if the 'EVar' is computed. Non-blocking. tryReadEVar :: MonadIO m => EVar a -> m (Maybe a) tryReadEVar = fmap join . tryReadMVar . unEVar --- Blocks on var+-- | Returns the value of the 'EVar', blocking on pending computations. readEVar :: MonadIO m => EVar a -> m (Maybe a) readEVar = readMVar . unEVar---- Blocks on var-writeEVar :: MonadIO m => EVar a -> a -> m ()-writeEVar (EVar w) = void . swapMVar w . Just---- Blocks on var and action-modifyEVar :: MonadUnliftIO m => EVar a -> m a -> (a -> (a, b)) -> m b-modifyEVar (EVar w) act f = modifyMVar w (fmap (\a -> let (a', b) = f a in (Just a', b)) . maybe act pure)
src/RefExtras/LensRef.hs view
@@ -13,24 +13,33 @@ import Lens.Micro.Extras (view) import RefExtras.Classes (AtomicRef (..), ModifyRef (..), ReadWriteRef (..)) +-- | A reference /focusing in/ on a part of a larger structure. data LensRef r a where   LensRef :: !(r z) -> !(Lens' z a) -> LensRef r a +-- | 'LensRef' constructor mkLensRef :: r z -> Lens' z a -> LensRef r a mkLensRef = LensRef +-- | A trivial 'LensRef' that focuses on the whole structure wholeLensRef :: r a -> LensRef r a wholeLensRef whole = LensRef whole id +-- | /Zooms/ into a smaller part of the structure zoomLensRef :: LensRef r a -> Lens' a b -> LensRef r b zoomLensRef (LensRef whole part) sub = LensRef whole (part . sub) +-- | Read the reference through the lens. readLensRef :: (Functor m, ReadWriteRef r m) => LensRef r a -> m a readLensRef (LensRef whole part) = fmap (view part) (readRef whole) +-- | Write the reference through the lens.+-- The 'ModifyRef' constraint is necessary to ensure we read and write+-- the same structure! writeLensRef :: ModifyRef r m => LensRef r a -> a -> m () writeLensRef (LensRef whole part) = modifyRef whole . set part +-- | Modify the reference through the lens. modifyLensRef :: ModifyRef r m => LensRef r a -> (a -> a) -> m () modifyLensRef (LensRef whole part) = modifyRef whole . over part @@ -41,6 +50,7 @@       z' = set l a' z   in (z', b) +-- | Atomically modify the reference through the lens. atomicModifyLensRef :: AtomicRef r m => LensRef r a -> (a -> (a, b)) -> m b atomicModifyLensRef (LensRef whole part) = atomicModifyRef whole . overWith part
src/RefExtras/Memo.hs view
@@ -1,12 +1,11 @@ module RefExtras.Memo   ( Memo   , accessMemo-  , clearMemo   , freezeMemo   , newMemo   , thawMemo   , tryReadMemo-  , writeMemo+  , readMemo   ) where  import Control.Monad (join)@@ -16,23 +15,30 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Prelude-import RefExtras.EVar (EVar, accessEVar, newEventualEVar, newReadyEVar, tryReadEVar, writeEVar)-import RefExtras.XVar (XVar, newXVar, readXVar, splitXVar, writeXVar)+import RefExtras.EVar (EVar, accessEVar, newEventualEVar, newReadyEVar, readEVar, tryReadEVar)+import RefExtras.XVar (XVar, newXVar, readXVar, splitXVar) +-- | A 'Memo' lets us cache the results of computations by key,+-- ensuring that we compute only as necessary and in order of access.+-- All operations are guaranteed not to lock the structure while computing+-- or waiting for results. newtype Memo k a = Memo { unMemo :: XVar (HashMap k (EVar a)) } +-- | Creates a new empty 'Memo'. newMemo :: MonadIO m => m (Memo k a) newMemo = fmap Memo (newXVar HashMap.empty) -clearMemo :: MonadIO m => Memo k a -> m ()-clearMemo (Memo v) = writeXVar v HashMap.empty-+-- | You can /access/ an 'Memo' by telling it how to compute the value!+-- If there is already a value, it simply returns it instead of computing it.+-- If the computation fails, the exception propagates, leaving that 'Memo' cell empty.+-- Blocks on var and action. accessMemo :: (MonadUnliftIO m, Eq k, Hashable k) => Memo k a -> k -> m a -> m a accessMemo (Memo v) k act = splitXVar v $ \m write ->   case HashMap.lookup k m of-    Just w -> write m >> accessEVar w act+    Just w -> write m *> accessEVar w act     Nothing -> newEventualEVar (\w -> write (HashMap.insert k w m)) act +-- | Reads the memoized value if present and ready now. Non-blocking. tryReadMemo :: (MonadIO m, Eq k, Hashable k) => Memo k a -> k -> m (Maybe a) tryReadMemo (Memo v) k = do   m <- readXVar v@@ -40,18 +46,18 @@     Nothing -> pure Nothing     Just w -> tryReadEVar w --- Blocks if k is being populated-writeMemo :: (MonadUnliftIO m, Eq k, Hashable k) => Memo k a -> k -> a -> m ()-writeMemo (Memo v) k a = splitXVar v $ \m write ->+-- | Reads the memoized value if present, blocking on computations.+readMemo :: (MonadIO m, Eq k, Hashable k) => Memo k a -> k -> m (Maybe a)+readMemo (Memo v) k = do+  m <- readXVar v   case HashMap.lookup k m of-    Just w -> write m >> writeEVar w a-    Nothing -> do-      w <- newReadyEVar a-      write (HashMap.insert k w m)+    Nothing -> pure Nothing+    Just w -> readEVar w  bindFor :: (Monad t, Traversable t, Applicative f) => t a -> (a -> f (t b)) -> f (t b) bindFor t f = fmap join (traverse f t) +-- | Freeze the 'Memo' with all values ready now. Non-blocking. freezeMemo :: (MonadIO m, Eq k, Hashable k) => Memo k a -> m (HashMap k a) freezeMemo (Memo v) = do   m <- readXVar v@@ -61,6 +67,7 @@       Just a -> pure [(k, a)]       _ -> pure [] +-- | Thaw a 'HashMap' into a new 'Memo'. thawMemo :: MonadIO m => HashMap k a -> m (Memo k a) thawMemo m = do   n <- traverse newReadyEVar m
src/RefExtras/SomeRef.hs view
@@ -6,6 +6,8 @@ import LittleRIO (SomeRef (..)) import RefExtras.Classes (ReadWriteRef (..)) +-- | We can /demote/ any 'ReadWriteRef' to a 'SomeRef'.+-- ('RIO' uses 'SomeRef' to represent 'State' and 'Writer' references, for example.) unliftSomeRef :: (MonadUnliftIO m, ReadWriteRef r m) => r a -> m (SomeRef a) unliftSomeRef ref = do   UnliftIO run <- askUnliftIO
+ src/RefExtras/UVar.hs view
@@ -0,0 +1,29 @@+module RefExtras.UVar+  ( UVar+  , newUVar+  , takeUVar+  , isTakenUVar+  , cloneUVar+  ) where++import Control.Monad.IO.Class (MonadIO)+import UnliftIO.MVar (MVar, isEmptyMVar, newEmptyMVar, newMVar, tryTakeMVar)++-- | A "unique var" - something that can only be taken once.+newtype UVar a = UVar { unUVar :: MVar a }++newUVar :: MonadIO m => a -> m (UVar a)+newUVar = fmap UVar . newMVar++takeUVar :: MonadIO m => UVar a -> m (Maybe a)+takeUVar = tryTakeMVar . unUVar++isTakenUVar :: MonadIO m => UVar a -> m Bool+isTakenUVar = isEmptyMVar . unUVar++-- | Create a new 'UVar' with the contents of this.+-- If this is taken, the created 'UVar' is empty.+-- Otherwise, takes this and creates the other.+-- In all cases, this is left taken.+cloneUVar :: MonadIO m => UVar a -> m (UVar a)+cloneUVar u = takeUVar u >>= maybe (fmap UVar newEmptyMVar) newUVar
src/RefExtras/XVar.hs view
@@ -3,6 +3,7 @@   , newXVar   , readXVar   , writeXVar+  , swapXVar   , modifyXVar   , atomicModifyXVar   , modifyXVarM@@ -14,10 +15,14 @@ import Control.Monad (void, when) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.IO.Unlift (MonadUnliftIO)-import RefExtras.Classes (AtomicRef (..), ModifyRef (..), ReadWriteRef (..))+import RefExtras.Classes (AtomicRef (..), ModifyRef (..), ReadWriteRef (..), swapRef) import UnliftIO.Exception (finally) import UnliftIO.MVar (MVar, modifyMVar, modifyMVar_, newMVar, putMVar, readMVar, swapMVar, takeMVar, withMVar) +-- | The /X/ in 'XVar' stands for /eXclusive/.+-- All 'XVar' operations leave it with a value (unlike 'MVar').+-- However, operations like 'lockXVarM' can /lock/ the 'XVar' and perform+-- monadic effects, unlocking correctly on exceptions. newtype XVar a = XVar { unXVar :: MVar a } deriving (Eq)  newXVar :: MonadIO m => a -> m (XVar a)@@ -29,6 +34,9 @@ writeXVar :: MonadIO m => XVar a -> a -> m () writeXVar (XVar m) = void . swapMVar m +swapXVar :: MonadIO m => XVar a -> a -> m a+swapXVar = swapRef+ modifyXVar :: MonadIO m => XVar a -> (a -> a) -> m () modifyXVar (XVar m) f = liftIO (modifyMVar_ m (pure . f)) @@ -44,7 +52,7 @@ atomicModifyXVarM :: MonadUnliftIO m => XVar a -> (a -> m (a, b)) -> m b atomicModifyXVarM = modifyMVar . unXVar --- Locks the XVar and runs a function with the current value and a write callback.+-- | Locks the XVar and runs a function with the current value and a write callback. -- The XVar is unlocked when the function completes or the *first* time the -- write callback is invoked. Subsequent calls overwrite the XVar, but may -- be interleaved with other writes. If the write callback is not invoked at