-- This Source Code Form is subject to the terms of the Mozilla Public
-- License, v. 2.0. If a copy of the MPL was not distributed with this
-- file, You can obtain one at https://mozilla.org/MPL/2.0/.

{- |
Copyright   :  (c) 2024 Sayo Koyoneda
License     :  MPL-2.0 (see the LICENSE file)
Maintainer  :  ymdfield@outlook.jp
Portability :  portable

This module provides handlers for 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 Control.Monad.Hefty.KVStore where

import Control.Arrow ((>>>))
import Control.Monad.Hefty (Eff, interpret, raiseUnder, type (<|), type (~>))
import Control.Monad.Hefty.State (runState)
import Data.Effect.KVStore (KVStore (LookupKV, UpdateKV))
import Data.Effect.State (State, get, modify)
import Data.Functor ((<&>))
import Data.Map (Map)
import Data.Map qualified as Map

runKVStorePure
    :: forall k v r a
     . (Ord k)
    => Map k v
    -> Eff '[] (KVStore k v ': r) a
    -> Eff '[] r (Map k v, a)
runKVStorePure :: forall k v (r :: [* -> *]) a.
Ord k =>
Map k v -> Eff '[] (KVStore k v : r) a -> Eff '[] r (Map k v, a)
runKVStorePure Map k v
initial =
    Eff '[] (KVStore k v : r) a
-> Eff '[] (KVStore k v : State (Map k v) : r) a
forall (e1 :: * -> *) (e2 :: * -> *) (ef :: [* -> *])
       (eh :: [EffectH]) x.
Eff eh (e1 : ef) x -> Eff eh (e1 : e2 : ef) x
raiseUnder
        (Eff '[] (KVStore k v : r) a
 -> Eff '[] (KVStore k v : State (Map k v) : r) a)
-> (Eff '[] (KVStore k v : State (Map k v) : r) a
    -> Eff '[] r (Map k v, a))
-> Eff '[] (KVStore k v : r) a
-> Eff '[] r (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 '[] (KVStore k v : State (Map k v) : r) a
-> Eff '[] (State (Map k v) : r) a
Eff '[] (KVStore k v : State (Map k v) : r)
~> Eff '[] (State (Map k v) : r)
forall k v (r :: [* -> *]).
(Ord k, State (Map k v) <| r) =>
Eff '[] (KVStore k v : r) ~> Eff '[] r
runKVStoreAsState
        (Eff '[] (KVStore k v : State (Map k v) : r) a
 -> Eff '[] (State (Map k v) : r) a)
-> (Eff '[] (State (Map k v) : r) a -> Eff '[] r (Map k v, a))
-> Eff '[] (KVStore k v : State (Map k v) : r) a
-> Eff '[] r (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 '[] (State (Map k v) : r) a -> Eff '[] r (Map k v, a)
forall s (ef :: [* -> *]) a.
s -> Eff '[] (State s : ef) a -> Eff '[] ef (s, a)
runState Map k v
initial

runKVStoreAsState
    :: forall k v r
     . (Ord k, State (Map k v) <| r)
    => Eff '[] (KVStore k v ': r) ~> Eff '[] r
runKVStoreAsState :: forall k v (r :: [* -> *]).
(Ord k, State (Map k v) <| r) =>
Eff '[] (KVStore k v : r) ~> Eff '[] r
runKVStoreAsState = (KVStore k v ~> Eff '[] r)
-> Eff '[] (KVStore k v : r) ~> Eff '[] r
forall (e :: * -> *) (ef :: [* -> *]) (eh :: [EffectH]).
(e ~> Eff eh ef) -> Eff eh (e : ef) ~> Eff eh ef
interpret \case
    LookupKV k
k -> Eff '[] r (Map k v)
forall s (f :: * -> *). SendFOE (State s) f => f s
get Eff '[] r (Map k v) -> (Map k v -> x) -> Eff '[] r 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 '[] r ()
forall s (m :: * -> *). (State s <: m, Monad m) => (s -> s) -> m ()
modify ((Map k v -> Map k v) -> Eff '[] r ())
-> (Map k v -> Map k v) -> Eff '[] r ()
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