ref-extras (empty) → 0.1.0

raw patch · 10 files changed

+393/−0 lines, 10 filesdep +basedep +little-riodep +microlenssetup-changed

Dependencies added: base, little-rio, microlens, stm, unliftio, unliftio-core

Files

• LICENSE +30/−0
• README.md +5/−0
• Setup.hs +2/−0
• ref-extras.cabal +50/−0
• src/RefExtras/Check.hs +44/−0
• src/RefExtras/Classes.hs +68/−0
• src/RefExtras/EVar.hs +56/−0
• src/RefExtras/LensRef.hs +55/−0
• src/RefExtras/SomeRef.hs +12/−0
• src/RefExtras/XVar.hs +71/−0

@@ -0,0 +1,30 @@+Copyright Eric Conlon (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Eric Conlon nor the names of other+      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+OWNER 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 @@+# ref-extras++[![CircleCI](https://circleci.com/gh/ejconlon/ref-extras/tree/master.svg?style=svg)](https://circleci.com/gh/ejconlon/ref-extras/tree/master)++Extra stuff for mutable references

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,50 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 9e81744739214454e5314bea860635661caf7b4f4296bb4c6f873e105c986c45++name:           ref-extras+version:        0.1.0+synopsis:       Extra stuff for mutable references+description:    Please see the README on GitHub at <https://github.com/ejconlon/ref-extras#readme>+category:       Data+homepage:       https://github.com/ejconlon/ref-extras#readme+bug-reports:    https://github.com/ejconlon/ref-extras/issues+author:         Eric Conlon+maintainer:     ejconlon@gmail.com+copyright:      (c) 2020 Eric Conlon+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/ejconlon/ref-extras++library+  exposed-modules:+      RefExtras.Check+      RefExtras.Classes+      RefExtras.EVar+      RefExtras.LensRef+      RefExtras.SomeRef+      RefExtras.XVar+  other-modules:+      Paths_ref_extras+  hs-source-dirs:+      src+  default-extensions: FlexibleInstances GADTs MultiParamTypeClasses Rank2Types+  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+    , little-rio >=0.1.1+    , microlens >=0.4+    , stm >=2.5+    , unliftio >=0.2+    , unliftio-core >=0.1+  default-language: Haskell2010

@@ -0,0 +1,44 @@+module RefExtras.Check+  ( CheckEffect (..)+  , checkEffectRef+  , checkEffectXVar+  , runCheckEffectRef+  , runCheckEffectXVar+  ) where++import Control.Monad.IO.Class (MonadIO)+import Control.Monad.IO.Unlift (MonadUnliftIO)+import RefExtras.Classes (AtomicRef, atomicModifyRef, readRef)+import RefExtras.XVar (XVar, atomicModifyXVarM)++-- 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.+checkEffectRef :: (MonadIO m, AtomicRef r m) => r a -> (a -> m (Either x b)) -> (x -> a -> (a, b)) -> m b+checkEffectRef ref prepare commit = do+  a <- readRef ref+  e <- prepare a+  case e of+    Left b -> atomicModifyRef ref (commit b)+    Right c -> pure c++-- 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+checkEffectXVar ref prepare commit = atomicModifyXVarM ref $ \a -> do+  e <- prepare a+  case e of+    Left b -> pure (commit b a)+    Right c -> pure (a, c)++-- 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++runCheckEffectRef :: (MonadIO m, AtomicRef r m) => r a -> CheckEffect m a b -> m b+runCheckEffectRef ref (CheckEffect prepare commit) = checkEffectRef ref prepare commit++runCheckEffectXVar :: MonadUnliftIO m => XVar a -> CheckEffect m a b -> m b+runCheckEffectXVar ref (CheckEffect prepare commit) = checkEffectXVar ref prepare commit

@@ -0,0 +1,68 @@+module RefExtras.Classes where++import Control.Concurrent.STM.TVar (TVar, readTVar, writeTVar)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.ST (ST)+import Control.Monad.STM (STM)+import Data.STRef (STRef, readSTRef, writeSTRef)+import LittleRIO (SomeRef, readSomeRef, writeSomeRef)+import UnliftIO.IORef (IORef, atomicModifyIORef', modifyIORef', readIORef, writeIORef)++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+-- 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.+unsafeModifyRef :: (Monad m, ReadWriteRef r m) => r a -> (a -> a) -> m ()+unsafeModifyRef ref f = do+  a <- readRef ref+  let a' = f a+  writeRef ref $! a'++-- See above notes on safety.+unsafeAtomicModifyRef :: (Monad m, ReadWriteRef r m) => r a -> (a -> (a, b)) -> m b+unsafeAtomicModifyRef ref f = do+  a <- readRef ref+  let (a', b) = f a+  writeRef ref $! a'+  pure $! b++class ReadWriteRef r m => ModifyRef r m where+  modifyRef :: r a -> (a -> a) -> m ()++class ModifyRef r m => AtomicRef r m where+  atomicModifyRef :: r a -> (a -> (a, b)) -> m b++instance MonadIO m => ReadWriteRef IORef m where+  readRef = readIORef+  writeRef = writeIORef++instance MonadIO m => ModifyRef IORef m where+  modifyRef = modifyIORef'++instance MonadIO m => AtomicRef IORef m where+  atomicModifyRef = atomicModifyIORef'++instance ReadWriteRef (STRef s) (ST s) where+  readRef = readSTRef+  writeRef = writeSTRef++instance ReadWriteRef TVar STM where+  readRef = readTVar+  writeRef = writeTVar++-- 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+  modifyRef = unsafeModifyRef++instance AtomicRef TVar STM where+  atomicModifyRef = unsafeAtomicModifyRef++instance MonadIO m => ReadWriteRef SomeRef m where+  readRef = readSomeRef+  writeRef = writeSomeRef

@@ -0,0 +1,56 @@+module RefExtras.EVar+  ( EVar+  , accessEVar+  , newEventualEVar+  , newReadyEVar+  , readEVar+  , tryReadEVar+  , writeEVar+  , modifyEVar+  ) where++import Control.Monad (join, void)+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)++newtype EVar a = EVar { unEVar :: MVar (Maybe a) }++-- 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+newEventualEVar :: MonadUnliftIO m => (EVar a -> m ()) -> m a -> m a+newEventualEVar share act = do+  w <- newEmptyMVar+  let e = EVar w+  share e+  -- Use IORef to ensure ONE put in the finally+  i <- newIORef Nothing+  flip finally (readIORef i >>= putMVar w) $ do+    a <- act+    atomicWriteIORef i (Just a)+    pure a++-- Non-blocking+newReadyEVar :: MonadIO m => a -> m (EVar a)+newReadyEVar = fmap EVar . newMVar . Just++-- Non-blocking+tryReadEVar :: MonadIO m => EVar a -> m (Maybe a)+tryReadEVar = fmap join . tryReadMVar . unEVar++-- Blocks on var+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)

@@ -0,0 +1,55 @@+module RefExtras.LensRef+  ( LensRef+  , mkLensRef+  , wholeLensRef+  , zoomLensRef+  , readLensRef+  , writeLensRef+  , modifyLensRef+  , atomicModifyLensRef+  ) where++import Lens.Micro (Lens', over, set)+import Lens.Micro.Extras (view)+import RefExtras.Classes (AtomicRef (..), ModifyRef (..), ReadWriteRef (..))++data LensRef r a where+  LensRef :: !(r z) -> !(Lens' z a) -> LensRef r a++mkLensRef :: r z -> Lens' z a -> LensRef r a+mkLensRef = LensRef++wholeLensRef :: r a -> LensRef r a+wholeLensRef whole = LensRef whole id++zoomLensRef :: LensRef r a -> Lens' a b -> LensRef r b+zoomLensRef (LensRef whole part) sub = LensRef whole (part . sub)++readLensRef :: (Functor m, ReadWriteRef r m) => LensRef r a -> m a+readLensRef (LensRef whole part) = fmap (view part) (readRef whole)++writeLensRef :: ModifyRef r m => LensRef r a -> a -> m ()+writeLensRef (LensRef whole part) = modifyRef whole . set part++modifyLensRef :: ModifyRef r m => LensRef r a -> (a -> a) -> m ()+modifyLensRef (LensRef whole part) = modifyRef whole . over part++overWith :: Lens' z a -> (a -> (a, b)) -> z -> (z, b)+overWith l f z =+  let a = view l z+      (a', b) = f a+      z' = set l a' z+  in (z', b)++atomicModifyLensRef :: AtomicRef r m => LensRef r a -> (a -> (a, b)) -> m b+atomicModifyLensRef (LensRef whole part) = atomicModifyRef whole . overWith part++instance (Functor m, ModifyRef r m) => ReadWriteRef (LensRef r) m where+  readRef = readLensRef+  writeRef = writeLensRef++instance (Functor m, ModifyRef r m) => ModifyRef (LensRef r) m where+  modifyRef = modifyLensRef++instance (Functor m, AtomicRef r m) => AtomicRef (LensRef r) m where+  atomicModifyRef = atomicModifyLensRef

@@ -0,0 +1,12 @@+module RefExtras.SomeRef+  ( unliftSomeRef+  ) where++import Control.Monad.IO.Unlift (MonadUnliftIO, UnliftIO (..), askUnliftIO)+import LittleRIO (SomeRef (..))+import RefExtras.Classes (ReadWriteRef (..))++unliftSomeRef :: (MonadUnliftIO m, ReadWriteRef r m) => r a -> m (SomeRef a)+unliftSomeRef ref = do+  UnliftIO run <- askUnliftIO+  pure (SomeRef (run (readRef ref)) (run . writeRef ref))

@@ -0,0 +1,71 @@+module RefExtras.XVar+  ( XVar+  , newXVar+  , readXVar+  , writeXVar+  , modifyXVar+  , atomicModifyXVar+  , modifyXVarM+  , lockXVarM+  , atomicModifyXVarM+  , splitXVar+  ) where++import Control.Monad (void, when)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.IO.Unlift (MonadUnliftIO)+import RefExtras.Classes (AtomicRef (..), ModifyRef (..), ReadWriteRef (..))+import UnliftIO.Exception (finally)+import UnliftIO.MVar (MVar, modifyMVar, modifyMVar_, newMVar, putMVar, readMVar, swapMVar, takeMVar, withMVar)++newtype XVar a = XVar { unXVar :: MVar a } deriving (Eq)++newXVar :: MonadIO m => a -> m (XVar a)+newXVar = fmap XVar . newMVar++readXVar :: MonadIO m => XVar a -> m a+readXVar = readMVar . unXVar++writeXVar :: MonadIO m => XVar a -> a -> m ()+writeXVar (XVar m) = void . swapMVar m++modifyXVar :: MonadIO m => XVar a -> (a -> a) -> m ()+modifyXVar (XVar m) f = liftIO (modifyMVar_ m (pure . f))++atomicModifyXVar :: MonadIO m => XVar a -> (a -> (a, b)) -> m b+atomicModifyXVar (XVar m) f = liftIO (modifyMVar m (pure . f))++modifyXVarM :: MonadUnliftIO m => XVar a -> (a -> m a) -> m ()+modifyXVarM = modifyMVar_ . unXVar++lockXVarM :: MonadUnliftIO m => XVar a -> (a -> m b) -> m b+lockXVarM = withMVar . unXVar++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.+-- 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+-- all, the original value is restored.+splitXVar :: MonadUnliftIO m => XVar a -> (a -> (a -> m ()) -> m b) -> m b+splitXVar (XVar m) f = do+  a <- takeMVar m+  i <- newMVar True+  let write force x = modifyMVar_ i $ \p -> do+        if p+          then putMVar m x+          else when force (void (swapMVar m x))+        pure False+  finally (f a (write True)) (write False a)++instance MonadIO m => ReadWriteRef XVar m where+  readRef = readXVar+  writeRef = writeXVar++instance MonadIO m => ModifyRef XVar m where+  modifyRef = modifyXVar++instance MonadIO m => AtomicRef XVar m where+  atomicModifyRef = atomicModifyXVar