packages feed

effectful-data-cache (empty) → 0.1.0.1

raw patch · 8 files changed

+625/−0 lines, 8 filesdep +basedep +cachedep +clock

Dependencies added: base, cache, clock, effectful-core, effectful-data-cache, hashable, hs-opentelemetry-api, hs-opentelemetry-exporter-in-memory, hs-opentelemetry-sdk, hspec, text, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2026 drlkf++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1.  Redistributions of source code must retain the above copyright notice, this+    list of conditions and the following disclaimer.++2.  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.++3.  Neither the name of the copyright holder nor the names of its 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 HOLDER 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.
+ README.md view
@@ -0,0 +1,32 @@+# effectful-data-cache++```haskell+import Effectful+import Effectful.Cache+import Prelude hiding (lookup)++main :: IO ()+main = runEff . runCache Nothing $ do+  insert "key" (42 :: Int)+  v <- lookup @String @Int "key"+  liftIO $ print v+```++`runCache` creates a fresh store; `runCacheWith` wraps an existing+`Data.Cache.Cache` so it can be shared with non-effectful code.++## Tracing++`traceCache` wraps every operation in an OpenTelemetry span+(`cache.insert`, `cache.lookup`, …), with `cache.hit` on lookups and+`cache.size` on `size`/`keys`. Keys and values are never recorded.++```haskell+import Effectful.Cache.OpenTelemetry (traceCache)++main = runEff . runCache Nothing . traceCache tracer $ do+  insert "key" (42 :: Int)+```++It is an interposer, so it layers over any interpreter and can be omitted+without touching call sites.
+ effectful-data-cache.cabal view
@@ -0,0 +1,75 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.39.6.+--+-- see: https://github.com/sol/hpack++name:           effectful-data-cache+version:        0.1.0.1+synopsis:       Data cache effect for the `effectful` system+description:    Please see the README on GitHub at <https://github.com/haskell-github-trust/effectful-data-cache#readme>+category:       cache+homepage:       https://github.com/haskell-github-trust/effectful-data-cache#readme+bug-reports:    https://github.com/haskell-github-trust/effectful-data-cache/issues+author:         drlkf+maintainer:     drlkf <drlkf@drlkf.net>+copyright:      2026 drlkf+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/haskell-github-trust/effectful-data-cache++library+  exposed-modules:+      Effectful.Cache+      Effectful.Cache.OpenTelemetry+  other-modules:+      Paths_effectful_data_cache+  autogen-modules:+      Paths_effectful_data_cache+  hs-source-dirs:+      src+  ghc-options: -Wall -Wextra -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , cache >=0.1.3 && <0.2+    , clock ==0.8.*+    , effectful-core >=2.3 && <3+    , hashable >=1.5 && <2+    , hs-opentelemetry-api ==0.3.*+    , text >=2.1 && <3+  default-language: Haskell2010++test-suite effectful-data-cache-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Effectful.Cache.OpenTelemetrySpec+      Effectful.CacheSpec+      Paths_effectful_data_cache+  autogen-modules:+      Paths_effectful_data_cache+  hs-source-dirs:+      test+  ghc-options: -Wall -Wextra -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-tool-depends:+      hspec-discover:hspec-discover+  build-depends:+      base >=4.7 && <5+    , cache >=0.1.3 && <0.2+    , clock ==0.8.*+    , effectful-core+    , effectful-data-cache+    , hashable >=1.5 && <2+    , hs-opentelemetry-api+    , hs-opentelemetry-exporter-in-memory+    , hs-opentelemetry-sdk+    , hspec+    , text+    , unordered-containers+  default-language: Haskell2010
+ src/Effectful/Cache.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Effectful.Cache (+  Cache (..),+  insert,+  insert',+  lookup,+  lookup',+  keys,+  delete,+  filterWithKey,+  purge,+  purgeExpired,+  size,+  defaultExpiration,+  setDefaultExpiration,+  runCache,+  runCacheWith,+) where++import qualified Data.Cache as C+import Data.Hashable (Hashable)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Effectful (+  Dispatch (Dynamic),+  DispatchOf,+  Eff,+  Effect,+  IOE,+  MonadIO (liftIO),+  type (:>),+ )+import Effectful.Dispatch.Dynamic (interpret, send)+import System.Clock (TimeSpec)+import Prelude hiding (lookup)++-- | @since 0.1.0.0+data Cache k v :: Effect where+  Insert+    :: Hashable k+    => k+    -> v+    -> Cache k v m ()+  Insert'+    :: Hashable k+    => Maybe TimeSpec+    -> k+    -> v+    -> Cache k v m ()+  Lookup+    :: Hashable k+    => k+    -> Cache k v m (Maybe v)+  Lookup'+    :: Hashable k+    => k+    -> Cache k v m (Maybe v)+  Keys+    :: Hashable k => Cache k v m [k]+  Delete+    :: Hashable k+    => k+    -> Cache k v m ()+  FilterWithKey+    :: Hashable k+    => (k -> v -> Bool)+    -> Cache k v m ()+  Purge+    :: Hashable k+    => Cache k v m ()+  PurgeExpired+    :: Hashable k+    => Cache k v m ()+  Size+    :: Hashable k+    => Cache k v m Int+  DefaultExpiration+    :: Hashable k+    => Cache k v m (Maybe TimeSpec)+  SetDefaultExpiration+    :: Hashable k+    => Maybe TimeSpec+    -> Cache k v m ()++type instance DispatchOf (Cache k v) = Dynamic++-- | @since 0.1.0.0+insert+  :: forall k v es+   . Cache k v :> es+  => Hashable k+  => k+  -> v+  -> Eff es ()+insert k v = send (Insert k v :: Cache k v (Eff es) ())++-- | @since 0.1.0.0+insert'+  :: forall k v es+   . Cache k v :> es+  => Hashable k+  => Maybe TimeSpec+  -> k+  -> v+  -> Eff es ()+insert' ts k v = send (Insert' ts k v :: Cache k v (Eff es) ())++-- | @since 0.1.0.0+lookup+  :: forall k v es+   . Cache k v :> es+  => Hashable k+  => k+  -> Eff es (Maybe v)+lookup k = send (Lookup k :: Cache k v (Eff es) (Maybe v))++-- | Like 'lookup' but never evicts the expired entry it read.+-- @since 0.1.0.0+lookup'+  :: forall k v es+   . Cache k v :> es+  => Hashable k+  => k+  -> Eff es (Maybe v)+lookup' k = send (Lookup' k :: Cache k v (Eff es) (Maybe v))++-- | @since 0.1.0.0+keys+  :: forall k v es+   . Cache k v :> es+  => Hashable k+  => Eff es [k]+keys = send (Keys :: Cache k v (Eff es) [k])++-- | @since 0.1.0.0+delete+  :: forall k v es+   . Cache k v :> es+  => Hashable k+  => k+  -> Eff es ()+delete k = send (Delete k :: Cache k v (Eff es) ())++-- | @since 0.1.0.0+filterWithKey+  :: forall k v es+   . Cache k v :> es+  => Hashable k+  => (k -> v -> Bool)+  -> Eff es ()+filterWithKey p = send (FilterWithKey p :: Cache k v (Eff es) ())++-- | @since 0.1.0.0+purge+  :: forall k v es+   . Cache k v :> es+  => Hashable k+  => Eff es ()+purge = send (Purge :: Cache k v (Eff es) ())++-- | @since 0.1.0.0+purgeExpired+  :: forall k v es+   . Cache k v :> es+  => Hashable k+  => Eff es ()+purgeExpired = send (PurgeExpired :: Cache k v (Eff es) ())++-- | @since 0.1.0.0+size+  :: forall k v es+   . Cache k v :> es+  => Hashable k+  => Eff es Int+size = send (Size :: Cache k v (Eff es) Int)++-- | @since 0.1.0.0+defaultExpiration+  :: forall k v es+   . Cache k v :> es+  => Hashable k+  => Eff es (Maybe TimeSpec)+defaultExpiration = send (DefaultExpiration :: Cache k v (Eff es) (Maybe TimeSpec))++-- | @since 0.1.0.0+setDefaultExpiration+  :: forall k v es+   . Cache k v :> es+  => Hashable k+  => Maybe TimeSpec+  -> Eff es ()+setDefaultExpiration ts = send (SetDefaultExpiration ts :: Cache k v (Eff es) ())++-- | Run against a fresh store with the given default expiration.+-- @since 0.1.0.0+runCache+  :: forall k v es a+   . IOE :> es+  => Maybe TimeSpec+  -> Eff (Cache k v : es) a+  -> Eff es a+runCache ts eff = do+  c <- liftIO (C.newCache ts)+  runCacheWith c eff++-- | Run against an existing 'C.Cache', e.g. one shared with non-effectful code.+-- @since 0.1.0.0+runCacheWith+  :: forall k v es a+   . IOE :> es+  => C.Cache k v+  -> Eff (Cache k v : es) a+  -> Eff es a+runCacheWith c0 eff = do+  -- the ref only exists so SetDefaultExpiration can swap the record; the+  -- underlying store is shared by every copy.+  ref <- liftIO (newIORef c0)+  interpret (\_ op -> withCache ref op) eff++withCache+  :: IOE :> es+  => IORef (C.Cache k v)+  -> Cache k v m a+  -> Eff es a+withCache ref op = do+  c <- liftIO (readIORef ref)+  liftIO $ case op of+    Insert k v -> C.insert c k v+    Insert' ts k v -> C.insert' c ts k v+    Lookup k -> C.lookup c k+    Lookup' k -> C.lookup' c k+    Keys -> C.keys c+    Delete k -> C.delete c k+    FilterWithKey p -> C.filterWithKey p c+    Purge -> C.purge c+    PurgeExpired -> C.purgeExpired c+    Size -> C.size c+    DefaultExpiration -> pure (C.defaultExpiration c)+    SetDefaultExpiration ts -> writeIORef ref (C.setDefaultExpiration c ts)
+ src/Effectful/Cache/OpenTelemetry.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++-- | OpenTelemetry instrumentation for 'Cache', layered over any interpreter.+--+-- > runEff . runCache Nothing . traceCache tracer $ do ...+module Effectful.Cache.OpenTelemetry (+  traceCache,+) where++import Data.Maybe (isJust)+import Data.Text (Text)+import Effectful+import Effectful.Cache (Cache (..))+import Effectful.Dispatch.Dynamic (interpose, passthrough)+import OpenTelemetry.Trace.Core (+  Tracer,+  addAttribute,+  defaultSpanArguments,+  inSpan',+ )++-- | Wrap every cache operation in a span. Keys and values are never recorded:+-- unbounded cardinality, and likely user data.+-- @since 0.1.0.1+traceCache+  :: forall k v es a+   . Cache k v :> es+  => IOE :> es+  => Tracer+  -> Eff es a+  -> Eff es a+traceCache tracer = interpose @(Cache k v) $ \env op ->+  inSpan' tracer (opName op) defaultSpanArguments $ \sp -> do+    r <- passthrough env op+    case op of+      Lookup _ -> addAttribute sp "cache.hit" (isJust r)+      Lookup' _ -> addAttribute sp "cache.hit" (isJust r)+      Size -> addAttribute sp "cache.size" r+      Keys -> addAttribute sp "cache.size" (length r)+      _ -> pure ()+    pure r++opName+  :: Cache k v m a+  -> Text+opName = \case+  Insert{} -> "cache.insert"+  Insert'{} -> "cache.insert"+  Lookup{} -> "cache.lookup"+  Lookup'{} -> "cache.lookup"+  Keys{} -> "cache.keys"+  Delete{} -> "cache.delete"+  FilterWithKey{} -> "cache.filterWithKey"+  Purge{} -> "cache.purge"+  PurgeExpired{} -> "cache.purgeExpired"+  Size{} -> "cache.size"+  DefaultExpiration{} -> "cache.defaultExpiration"+  SetDefaultExpiration{} -> "cache.setDefaultExpiration"
+ test/Effectful/Cache/OpenTelemetrySpec.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Effectful.Cache.OpenTelemetrySpec (spec) where++import Data.IORef (readIORef)+import Data.Text (Text)+import Effectful+import Effectful.Cache+import Effectful.Cache.OpenTelemetry (traceCache)+import OpenTelemetry.Attributes (Attribute (..), PrimitiveAttribute (..), lookupAttribute)+import OpenTelemetry.Exporter.InMemory.Span (inMemoryListExporter)+import OpenTelemetry.Trace (+  ImmutableSpan (..),+  createTracerProvider,+  emptyTracerProviderOptions,+  makeTracer,+  shutdownTracerProvider,+  tracerOptions,+ )+import Test.Hspec+import Prelude hiding (lookup)++-- | Run the given cache program under a traced interpreter, returning its+-- result plus every span that was exported.+traced+  :: Eff '[Cache String Int, IOE] a+  -> IO (a, [ImmutableSpan])+traced prog = do+  (processor, ref) <- inMemoryListExporter+  provider <- createTracerProvider [processor] emptyTracerProviderOptions+  let tracer = makeTracer provider "effectful-data-cache-test" tracerOptions+  r <- runEff . runCache @String @Int Nothing $ traceCache @String @Int tracer prog+  shutdownTracerProvider provider+  spans <- readIORef ref+  pure (r, reverse spans)++attr+  :: ImmutableSpan+  -> Text+  -> Maybe Attribute+attr s k = lookupAttribute (spanAttributes s) k++spec :: Spec+spec = do+  it "emits a span per operation" $ do+    (_, spans) <- traced $ do+      insert @String @Int "a" (1 :: Int)+      _ <- lookup @String @Int "a"+      purge @String @Int+    map spanName spans `shouldBe` ["cache.insert", "cache.lookup", "cache.purge"]++  it "records hits and misses" $ do+    (_, spans) <- traced $ do+      insert @String @Int "a" (1 :: Int)+      _ <- lookup @String @Int "a"+      _ <- lookup @String @Int "nope"+      pure ()+    let hits = [attr s "cache.hit" | s <- spans, spanName s == "cache.lookup"]+    hits+      `shouldBe` [ Just (AttributeValue (BoolAttribute True))+                 , Just (AttributeValue (BoolAttribute False))+                 ]++  it "records the size" $ do+    (_, spans) <- traced $ do+      insert @String @Int "a" (1 :: Int)+      insert @String @Int "b" (2 :: Int)+      _ <- size @String @Int+      pure ()+    [attr s "cache.size" | s <- spans, spanName s == "cache.size"]+      `shouldBe` [Just (AttributeValue (IntAttribute 2))]++  it "still returns the underlying result" $ do+    (r, _) <- traced $ do+      insert @String @Int "a" (1 :: Int)+      lookup @String @Int "a"+    r `shouldBe` Just 1
+ test/Effectful/CacheSpec.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}++module Effectful.CacheSpec (spec) where++import Data.List (sort)+import Effectful+import Effectful.Cache+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++expired :: Maybe TimeSpec+expired = Just (TimeSpec (-1) 0)++spec :: Spec+spec = do+  it "looks up what it inserted" $ do+    r <- run Nothing $ do+      insert "a" (1 :: Int)+      lookup @String @Int "a"+    r `shouldBe` Just 1++  it "misses on an absent key" $ do+    r <- run Nothing $ lookup @String @Int "nope"+    r `shouldBe` Nothing++  it "deletes" $ do+    r <- run Nothing $ do+      insert "a" (1 :: Int)+      delete @String @Int "a"+      lookup @String @Int "a"+    r `shouldBe` Nothing++  it "lists keys and size" $ do+    (ks, n) <- run Nothing $ do+      insert "a" (1 :: Int)+      insert "b" (2 :: Int)+      (,) <$> keys @String @Int <*> size @String @Int+    sort ks `shouldBe` ["a", "b"]+    n `shouldBe` 2++  it "honours the default expiration" $ do+    r <- run expired $ do+      insert "a" (1 :: Int)+      lookup @String @Int "a"+    r `shouldBe` Nothing++  it "honours a per-entry expiration" $ do+    r <- run Nothing $ do+      insert' expired "a" (1 :: Int)+      lookup @String @Int "a"+    r `shouldBe` Nothing++  it "evicts on lookup but not on lookup'" $ do+    (afterLookup', afterLookup) <- run expired $ do+      insert "a" (1 :: Int)+      _ <- lookup' @String @Int "a"+      n1 <- size @String @Int+      _ <- lookup @String @Int "a"+      n2 <- size @String @Int+      pure (n1, n2)+    afterLookup' `shouldBe` 1+    afterLookup `shouldBe` 0++  it "filters with key" $ do+    ks <- run Nothing $ do+      insert "keep" (1 :: Int)+      insert "drop" (2 :: Int)+      filterWithKey @String @Int (\k _ -> k == "keep")+      keys @String @Int+    ks `shouldBe` ["keep"]++  it "purges everything" $ do+    n <- run Nothing $ do+      insert "a" (1 :: Int)+      insert "b" (2 :: Int)+      purge @String @Int+      size @String @Int+    n `shouldBe` 0++  it "purges only expired entries" $ do+    n <- run Nothing $ do+      insert' expired "old" (1 :: Int)+      insert "new" (2 :: Int)+      purgeExpired @String @Int+      size @String @Int+    n `shouldBe` 1++  it "round-trips the default expiration" $ do+    (old, new) <- run Nothing $ do+      b <- defaultExpiration @String @Int+      setDefaultExpiration @String @Int (Just (TimeSpec 5 0))+      a <- defaultExpiration @String @Int+      pure (b, a)+    old `shouldBe` Nothing+    new `shouldBe` Just (TimeSpec 5 0)
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}