From 312d014afc571a61da06700e201ceac85acd67d5 Mon Sep 17 00:00:00 2001 From: drlkf Date: Tue, 27 Oct 2026 19:32:48 +0100 Subject: [PATCH] feat: add stm-based interpreter --- AGENTS.md | 13 ++++++ effectful-data-cache.cabal | 6 +++ package.yaml | 2 + src/Effectful/Cache/STM.hs | 83 +++++++++++++++++++++++++++++++++ test/Effectful/Cache/STMSpec.hs | 9 ++++ test/Effectful/CacheSpec.hs | 11 +++-- 6 files changed, 120 insertions(+), 4 deletions(-) create mode 100644 src/Effectful/Cache/STM.hs create mode 100644 test/Effectful/Cache/STMSpec.hs diff --git a/AGENTS.md b/AGENTS.md index a379941..56d7728 100644 --- a/AGENTS.md +++ b/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. diff --git a/effectful-data-cache.cabal b/effectful-data-cache.cabal index debfb81..5445e0a 100644 --- a/effectful-data-cache.cabal +++ b/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 diff --git a/package.yaml b/package.yaml index e69a105..1776aaa 100644 --- a/package.yaml +++ b/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 diff --git a/src/Effectful/Cache/STM.hs b/src/Effectful/Cache/STM.hs new file mode 100644 index 0000000..7927df7 --- /dev/null +++ b/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) diff --git a/test/Effectful/Cache/STMSpec.hs b/test/Effectful/Cache/STMSpec.hs new file mode 100644 index 0000000..351c5b0 --- /dev/null +++ b/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) diff --git a/test/Effectful/CacheSpec.hs b/test/Effectful/CacheSpec.hs index f75a2a7..b5bf572 100644 --- a/test/Effectful/CacheSpec.hs +++ b/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)