ref-extras 0.1.0 → 0.1.1

raw patch · 2 files changed

+73/−2 lines, 2 filesdep +hashabledep +unordered-containers

Dependencies added: hashable, unordered-containers

Files

• ref-extras.cabal +5/−2
• src/RefExtras/Memo.hs +68/−0

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 9e81744739214454e5314bea860635661caf7b4f4296bb4c6f873e105c986c45+-- hash: 0c53a1b53092126beb62eea99bfb47ad42c02b42aef27681ee3434592b29b682  name:           ref-extras-version:        0.1.0+version:        0.1.1 synopsis:       Extra stuff for mutable references description:    Please see the README on GitHub at <https://github.com/ejconlon/ref-extras#readme> category:       Data@@ -32,6 +32,7 @@       RefExtras.Classes       RefExtras.EVar       RefExtras.LensRef+      RefExtras.Memo       RefExtras.SomeRef       RefExtras.XVar   other-modules:@@ -42,9 +43,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   default-language: Haskell2010

@@ -0,0 +1,68 @@+module RefExtras.Memo+  ( Memo+  , accessMemo+  , clearMemo+  , freezeMemo+  , newMemo+  , thawMemo+  , tryReadMemo+  , writeMemo+  ) where++import Control.Monad (join)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.IO.Unlift (MonadUnliftIO)+import Data.Hashable (Hashable)+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)++newtype Memo k a = Memo { unMemo :: XVar (HashMap k (EVar a)) }++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++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+    Nothing -> newEventualEVar (\w -> write (HashMap.insert k w m)) act++tryReadMemo :: (MonadIO m, Eq k, Hashable k) => Memo k a -> k -> m (Maybe a)+tryReadMemo (Memo v) k = do+  m <- readXVar v+  case HashMap.lookup k m of+    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 ->+  case HashMap.lookup k m of+    Just w -> write m >> writeEVar w a+    Nothing -> do+      w <- newReadyEVar a+      write (HashMap.insert k w m)++bindFor :: (Monad t, Traversable t, Applicative f) => t a -> (a -> f (t b)) -> f (t b)+bindFor t f = fmap join (traverse f t)++freezeMemo :: (MonadIO m, Eq k, Hashable k) => Memo k a -> m (HashMap k a)+freezeMemo (Memo v) = do+  m <- readXVar v+  fmap HashMap.fromList $ bindFor (HashMap.toList m) $ \(k, w) -> do+    ma <- tryReadEVar w+    case ma of+      Just a -> pure [(k, a)]+      _ -> pure []++thawMemo :: MonadIO m => HashMap k a -> m (Memo k a)+thawMemo m = do+  n <- traverse newReadyEVar m+  v <- newXVar n+  pure (Memo v)