feat: add stm-based interpreter

AGENTS.md

@@ -16,3 +16,16 @@ CI (`.github/workflows/stack.yml`) runs all of the above; keep it green.
 - curried constraints: `Read a => Ord a => a`, not `(Read a, Ord a) => a`;
   not enforced by tooling
 - `-Wredundant-constraints` on: only add `Show e` for `throwError` where needed
+
+# Dependencies
+
+- public Hackage only: no git or private `extra-deps`.
+- `http-client-effectful-1.0.0` caps `effectful < 2.7`; GHC 9.12 nightly config
+  relaxes bounds with `allow-newer-deps` instead of pinning older
+- `package.yaml` version bounds span the versions both CI configs resolve; widen them
+  when a snapshot moves
+
+# Versioning
+
+Do not edit this package's version files or `@since` comments, they are
+generated by CI.

effectful-data-cache.cabal

@@ -29,6 +29,7 @@ source-repository head
 library
   exposed-modules:
       Effectful.Cache
+      Effectful.Cache.STM
   other-modules:
       Paths_effectful_data_cache
   autogen-modules:
@@ -42,12 +43,15 @@ library
     , clock ==0.8.*
     , effectful-core >=2.3 && <3
     , hashable >=1.5 && <2
+    , stm >=2.5 && <3
+    , unordered-containers ==0.2.*
   default-language: Haskell2010
 
 test-suite effectful-data-cache-test
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
+      Effectful.Cache.STMSpec
       Effectful.CacheSpec
       Paths_effectful_data_cache
   autogen-modules:
@@ -65,4 +69,6 @@ test-suite effectful-data-cache-test
     , effectful-data-cache
     , hashable >=1.5 && <2
     , hspec
+    , stm >=2.5 && <3
+    , unordered-containers ==0.2.*
   default-language: Haskell2010

package.yaml

@@ -25,6 +25,8 @@ dependencies:
   - clock >= 0.8 && < 0.9
   - effectful-core >= 2.3 && < 3
   - hashable >= 1.5 && < 2
+  - stm >= 2.5 && < 3
+  - unordered-containers >= 0.2 && < 0.3
 
 ghc-options:
   - -Wall

src/Effectful/Cache/STM.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | 'Cache' interpreter over a 'HashMap' in a 'TVar', without "Data.Cache".
+module Effectful.Cache.STM (
+  Store,
+  newStore,
+  runCacheSTM,
+  runCacheSTMWith,
+) where
+
+import Control.Concurrent.STM (
+  STM,
+  TVar,
+  atomically,
+  modifyTVar',
+  newTVarIO,
+  readTVar,
+  writeTVar,
+ )
+import qualified Data.HashMap.Strict as HM
+import Effectful (Eff, IOE, MonadIO (liftIO), type (:>))
+import Effectful.Cache (Cache (..))
+import Effectful.Dispatch.Dynamic (interpret)
+import System.Clock (Clock (Monotonic), TimeSpec, getTime)
+
+-- | Entries with their absolute expiration, and the default expiration.
+data Store k v = Store (TVar (HM.HashMap k (v, Maybe TimeSpec))) (TVar (Maybe TimeSpec))
+
+-- | Fresh store with the given default expiration.
+newStore :: Maybe TimeSpec -> IO (Store k v)
+newStore ts = Store <$> newTVarIO HM.empty <*> newTVarIO ts
+
+-- | Run against a fresh store with the given default expiration.
+runCacheSTM
+  :: forall k v es a
+   . IOE :> es
+  => Maybe TimeSpec
+  -> Eff (Cache k v : es) a
+  -> Eff es a
+runCacheSTM ts eff = do
+  s <- liftIO (newStore ts)
+  runCacheSTMWith s eff
+
+-- | Run against an existing 'Store', e.g. one shared between threads.
+runCacheSTMWith
+  :: forall k v es a
+   . IOE :> es
+  => Store k v
+  -> Eff (Cache k v : es) a
+  -> Eff es a
+runCacheSTMWith s = interpret $ \_ op -> liftIO $ do
+  now <- getTime Monotonic
+  atomically (withStore s now op)
+
+withStore :: Store k v -> TimeSpec -> Cache k v m a -> STM a
+withStore (Store ref def) now op = case op of
+  Insert k v -> readTVar def >>= \ts -> modifyTVar' ref (HM.insert k (v, (now +) <$> ts))
+  Insert' ts k v -> modifyTVar' ref (HM.insert k (v, (now +) <$> ts))
+  Lookup k -> do
+    m <- HM.lookup k <$> readTVar ref
+    case m of
+      Just (v, e) | live e -> pure (Just v)
+      Just _ -> Nothing <$ modifyTVar' ref (HM.delete k)
+      Nothing -> pure Nothing
+  Lookup' k -> do
+    m <- HM.lookup k <$> readTVar ref
+    pure $ case m of
+      Just (v, e) | live e -> Just v
+      _ -> Nothing
+  Keys -> HM.keys <$> readTVar ref
+  Delete k -> modifyTVar' ref (HM.delete k)
+  FilterWithKey p -> modifyTVar' ref (HM.filterWithKey (\k (v, _) -> p k v))
+  Purge -> writeTVar ref HM.empty
+  PurgeExpired -> modifyTVar' ref (HM.filter (live . snd))
+  Size -> HM.size <$> readTVar ref
+  DefaultExpiration -> readTVar def
+  SetDefaultExpiration ts -> writeTVar def ts
+ where
+  live = maybe True (> now)

test/Effectful/Cache/STMSpec.hs

@@ -0,0 +1,9 @@
+module Effectful.Cache.STMSpec (spec) where
+
+import Effectful (runEff)
+import Effectful.Cache.STM (runCacheSTM)
+import Effectful.CacheSpec (specWith)
+import Test.Hspec (Spec)
+
+spec :: Spec
+spec = specWith (\ts -> runEff . runCacheSTM ts)

test/Effectful/CacheSpec.hs

@@ -1,7 +1,8 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeApplications #-}
 
-module Effectful.CacheSpec (spec) where
+module Effectful.CacheSpec (spec, specWith) where
 
 import Data.List (sort)
 import Effectful
@@ -10,14 +11,16 @@ import System.Clock (TimeSpec (..))
 import Test.Hspec
 import Prelude hiding (lookup)
 
-run :: Maybe TimeSpec -> Eff '[Cache String Int, IOE] a -> IO a
-run ts = runEff . runCache ts
+type Runner = forall a. Maybe TimeSpec -> Eff '[Cache String Int, IOE] a -> IO a
 
 expired :: Maybe TimeSpec
 expired = Just (TimeSpec (-1) 0)
 
 spec :: Spec
-spec = do
+spec = specWith (\ts -> runEff . runCache ts)
+
+specWith :: Runner -> Spec
+specWith run = do
   it "looks up what it inserted" $ do
     r <- run Nothing $ do
       insert "a" (1 :: Int)