{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE UndecidableInstances #-}

-- SPDX-License-Identifier: MPL-2.0

{- |
Copyright   :  (c) 2025 Sayo contributors
License     :  MPL-2.0 (see the file LICENSE)
Maintainer  :  ymdfield@outlook.jp

This module provides the t`KVStore` effect, comes
from [@Polysemy.KVStore@](https://hackage.haskell.org/package/polysemy-kvstore-0.1.3.0/docs/Polysemy-KVStore.html)
in the @polysemy-kvstore@ package.
-}
module Data.Effect.KVStore where

import Control.Arrow ((>>>))
import Control.Effect.Transform (raiseUnder)
import Data.Effect (Emb)
import Data.Effect.Except (Throw, throw)
import Data.Effect.State (State, get, modify, runStateIORef)
import Data.Functor ((<&>))
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (isJust)

data KVStore k v :: Effect where
    LookupKV :: k -> KVStore k v f (Maybe v)
    UpdateKV :: k -> Maybe v -> KVStore k v f ()

makeEffectF ''KVStore

lookupOrThrowKV
    :: forall k v e es ff c
     . (KVStore k v :> es, Throw e :> es, Monad (Eff ff es), Free c ff)
    => (k -> e)
    -> k
    -> Eff ff es v
lookupOrThrowKV :: forall k v e (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(KVStore k v :> es, Throw e :> es, Monad (Eff ff es), Free c ff) =>
(k -> e) -> k -> Eff ff es v
lookupOrThrowKV k -> e
err k
k =
    k -> Eff ff es (Maybe v)
forall k v (f :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, KVStore k v :> es) =>
k -> f (Maybe v)
lookupKV k
k Eff ff es (Maybe v) -> (Maybe v -> Eff ff es v) -> Eff ff es v
forall a b. Eff ff es a -> (a -> Eff ff es b) -> Eff ff es b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Eff ff es v -> (v -> Eff ff es v) -> Maybe v -> Eff ff es v
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> Eff ff es v
forall e b (a :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, a ~ Eff ff es, Throw e :> es) =>
e -> a b
throw (e -> Eff ff es v) -> e -> Eff ff es v
forall a b. (a -> b) -> a -> b
$ k -> e
err k
k) v -> Eff ff es v
forall a. a -> Eff ff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE lookupOrThrowKV #-}

existsKV :: forall v k es ff c. (KVStore k v :> es, Functor (Eff ff es), Free c ff) => k -> Eff ff es Bool
existsKV :: forall v k (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(KVStore k v :> es, Functor (Eff ff es), Free c ff) =>
k -> Eff ff es Bool
existsKV = (Maybe v -> Bool) -> Eff ff es (Maybe v) -> Eff ff es Bool
forall a b. (a -> b) -> Eff ff es a -> Eff ff es b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe v -> Bool
forall a. Maybe a -> Bool
isJust (Eff ff es (Maybe v) -> Eff ff es Bool)
-> (k -> Eff ff es (Maybe v)) -> k -> Eff ff es Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v (f :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, KVStore k v :> es) =>
k -> f (Maybe v)
lookupKV @k @v
{-# INLINE existsKV #-}

writeKV :: forall k v es ff c. (KVStore k v :> es, Free c ff) => k -> v -> Eff ff es ()
writeKV :: forall k v (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(KVStore k v :> es, Free c ff) =>
k -> v -> Eff ff es ()
writeKV k
k v
v = k -> Maybe v -> Eff ff es ()
forall k v (f :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, KVStore k v :> es) =>
k -> Maybe v -> f ()
updateKV k
k (v -> Maybe v
forall a. a -> Maybe a
Just v
v)
{-# INLINE writeKV #-}

deleteKV :: forall v k es ff c. (KVStore k v :> es, Free c ff) => k -> Eff ff es ()
deleteKV :: forall v k (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(KVStore k v :> es, Free c ff) =>
k -> Eff ff es ()
deleteKV k
k = forall k v (f :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, KVStore k v :> es) =>
k -> Maybe v -> f ()
updateKV @k @v k
k Maybe v
forall a. Maybe a
Nothing
{-# INLINE deleteKV #-}

modifyKV
    :: forall k v es ff c
     . (KVStore k v :> es, Monad (Eff ff es), Free c ff)
    => v
    -> (v -> v)
    -> k
    -> Eff ff es ()
modifyKV :: forall k v (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(KVStore k v :> es, Monad (Eff ff es), Free c ff) =>
v -> (v -> v) -> k -> Eff ff es ()
modifyKV v
vDefault v -> v
f k
k = do
    Maybe v
v <- k -> Eff ff es (Maybe v)
forall k v (f :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, KVStore k v :> es) =>
k -> f (Maybe v)
lookupKV k
k
    k -> Maybe v -> Eff ff es ()
forall k v (f :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, f ~ Eff ff es, KVStore k v :> es) =>
k -> Maybe v -> f ()
updateKV k
k (v -> Maybe v
forall a. a -> Maybe a
Just (v -> Maybe v) -> v -> Maybe v
forall a b. (a -> b) -> a -> b
$ v -> (v -> v) -> Maybe v -> v
forall b a. b -> (a -> b) -> Maybe a -> b
maybe v
vDefault v -> v
f Maybe v
v)
{-# INLINE modifyKV #-}

runKVStoreIORef
    :: forall k v a es ff c
     . (Ord k, Emb IO :> es, forall es'. Monad (Eff ff es'), Free c ff)
    => Map k v
    -> Eff ff (KVStore k v ': es) a
    -> Eff ff es (Map k v, a)
runKVStoreIORef :: forall k v a (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Ord k, Emb IO :> es, forall (es' :: [Effect]). Monad (Eff ff es'),
 Free c ff) =>
Map k v -> Eff ff (KVStore k v : es) a -> Eff ff es (Map k v, a)
runKVStoreIORef Map k v
initial =
    Eff ff (KVStore k v : es) a
-> Eff ff (KVStore k v : State (Map k v) : es) a
forall (e0 :: Effect) (e1 :: Effect) (es :: [Effect]) a
       (ff :: Effect) (c :: (* -> *) -> Constraint).
Free c ff =>
Eff ff (e0 : es) a -> Eff ff (e0 : e1 : es) a
raiseUnder
        (Eff ff (KVStore k v : es) a
 -> Eff ff (KVStore k v : State (Map k v) : es) a)
-> (Eff ff (KVStore k v : State (Map k v) : es) a
    -> Eff ff es (Map k v, a))
-> Eff ff (KVStore k v : es) a
-> Eff ff es (Map k v, a)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Eff ff (KVStore k v : State (Map k v) : es) a
-> Eff ff (State (Map k v) : es) a
Eff ff (KVStore k v : State (Map k v) : es)
~> Eff ff (State (Map k v) : es)
forall k v (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Ord k, State (Map k v) :> es, Monad (Eff ff es), Free c ff) =>
Eff ff (KVStore k v : es) ~> Eff ff es
runKVStoreAsState
        (Eff ff (KVStore k v : State (Map k v) : es) a
 -> Eff ff (State (Map k v) : es) a)
-> (Eff ff (State (Map k v) : es) a -> Eff ff es (Map k v, a))
-> Eff ff (KVStore k v : State (Map k v) : es) a
-> Eff ff es (Map k v, a)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Map k v
-> Eff ff (State (Map k v) : es) a -> Eff ff es (Map k v, a)
forall s (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(Emb IO :> es, Monad (Eff ff es), Free c ff) =>
s -> Eff ff (State s : es) a -> Eff ff es (s, a)
runStateIORef Map k v
initial
{-# INLINE runKVStoreIORef #-}

runKVStoreAsState
    :: forall k v es ff c
     . (Ord k, State (Map k v) :> es, Monad (Eff ff es), Free c ff)
    => Eff ff (KVStore k v ': es) ~> Eff ff es
runKVStoreAsState :: forall k v (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Ord k, State (Map k v) :> es, Monad (Eff ff es), Free c ff) =>
Eff ff (KVStore k v : es) ~> Eff ff es
runKVStoreAsState = (KVStore k v ~~> Eff ff es)
-> Eff ff (KVStore k v : es) x -> Eff ff es x
forall (e :: Effect) (es :: [Effect]) (ff :: Effect) a
       (c :: (* -> *) -> Constraint).
(KnownOrder e, Free c ff) =>
(e ~~> Eff ff es) -> Eff ff (e : es) a -> Eff ff es a
interpret \case
    LookupKV k
k -> Eff ff es (Map k v)
forall s (a :: * -> *) (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(Free c ff, a ~ Eff ff es, State s :> es) =>
a s
get Eff ff es (Map k v) -> (Map k v -> x) -> Eff ff es x
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> k -> Map k v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k
    UpdateKV k
k Maybe v
v -> (Map k v -> Map k v) -> Eff ff es ()
forall s (es :: [Effect]) (ff :: Effect)
       (c :: (* -> *) -> Constraint).
(State s :> es, Monad (Eff ff es), Free c ff) =>
(s -> s) -> Eff ff es ()
modify ((Map k v -> Map k v) -> Eff ff es ())
-> (Map k v -> Map k v) -> Eff ff es ()
forall a b. (a -> b) -> a -> b
$ (v -> Maybe v) -> k -> Map k v -> Map k v
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update (Maybe v -> v -> Maybe v
forall a b. a -> b -> a
const Maybe v
v) k
k
{-# INLINE runKVStoreAsState #-}