-- 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 Yamada Ryo
License     :  MPL-2.0 (see the file LICENSE)
Maintainer  :  ymdfield@outlook.jp
Stability   :  experimental
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.Effect.Interpreter.Heftia.KVStore where

import Control.Arrow ((>>>))
import Control.Effect (type (~>))
import Control.Effect.Hefty (Eff, interpret, raiseUnder)
import Control.Effect.Interpreter.Heftia.State (runState)
import Control.Freer (Freer)
import Control.Monad.State (StateT)
import Data.Effect.HFunctor (HFunctor)
import Data.Effect.KVStore (KVStore (LookupKV, UpdateKV), LKVStore)
import Data.Effect.State (LState, State, get, modify)
import Data.Functor ((<&>))
import Data.Hefty.Union (Member, Union)
import Data.Map (Map)
import Data.Map qualified as Map

runKVStorePure ::
    forall k v r a fr u c.
    ( Ord k
    , Freer c fr
    , Union u
    , HFunctor (u '[])
    , Member u (State (Map k v)) (LState (Map k v) ': r)
    , c (Eff u fr '[] r)
    , c (StateT (Map k v) (Eff u fr '[] r))
    , Monad (Eff u fr '[] r)
    , Monad (Eff u fr '[] (LState (Map k v) ': r))
    ) =>
    Map k v ->
    Eff u fr '[] (LKVStore k v ': r) a ->
    Eff u fr '[] r (Map k v, a)
runKVStorePure :: forall k v (r :: [(* -> *) -> * -> *]) a (fr :: (* -> *) -> * -> *)
       (u :: [(* -> *) -> * -> *] -> (* -> *) -> * -> *)
       (c :: (* -> *) -> Constraint).
(Ord k, Freer c fr, Union u, HFunctor (u '[]),
 Member u (State (Map k v)) (LState (Map k v) : r),
 c (Eff u fr '[] r), c (StateT (Map k v) (Eff u fr '[] r)),
 Monad (Eff u fr '[] r),
 Monad (Eff u fr '[] (LState (Map k v) : r))) =>
Map k v
-> Eff u fr '[] (LKVStore k v : r) a -> Eff u fr '[] r (Map k v, a)
runKVStorePure Map k v
initial =
    forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) (ehs :: [(* -> *) -> * -> *])
       (fr :: (* -> *) -> * -> *)
       (u :: [(* -> *) -> * -> *] -> (* -> *) -> * -> *)
       (c :: (* -> *) -> Constraint).
(Freer c fr, Union u, HFunctor (u ehs)) =>
Eff u fr ehs (e2 : r) ~> Eff u fr ehs (e2 : e1 : r)
raiseUnder
        forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall k v (r :: [(* -> *) -> * -> *]) (fr :: (* -> *) -> * -> *)
       (u :: [(* -> *) -> * -> *] -> (* -> *) -> * -> *)
       (c :: (* -> *) -> Constraint).
(Ord k, Freer c fr, Union u, Member u (State (Map k v)) r,
 Monad (Eff u fr '[] r), HFunctor (u '[])) =>
Eff u fr '[] (LKVStore k v : r) ~> Eff u fr '[] r
runKVStoreAsState
        forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall s (r :: [(* -> *) -> * -> *]) a (fr :: (* -> *) -> * -> *)
       (u :: [(* -> *) -> * -> *] -> (* -> *) -> * -> *)
       (c :: (* -> *) -> Constraint).
(Freer c fr, Union u, c (Eff u fr '[] r),
 c (StateT s (Eff u fr '[] r)), Applicative (Eff u fr '[] r)) =>
s -> Eff u fr '[] (LState s : r) a -> Eff u fr '[] r (s, a)
runState Map k v
initial
{-# INLINE runKVStorePure #-}

runKVStoreAsState ::
    forall k v r fr u c.
    ( Ord k
    , Freer c fr
    , Union u
    , Member u (State (Map k v)) r
    , Monad (Eff u fr '[] r)
    , HFunctor (u '[])
    ) =>
    Eff u fr '[] (LKVStore k v ': r) ~> Eff u fr '[] r
runKVStoreAsState :: forall k v (r :: [(* -> *) -> * -> *]) (fr :: (* -> *) -> * -> *)
       (u :: [(* -> *) -> * -> *] -> (* -> *) -> * -> *)
       (c :: (* -> *) -> Constraint).
(Ord k, Freer c fr, Union u, Member u (State (Map k v)) r,
 Monad (Eff u fr '[] r), HFunctor (u '[])) =>
Eff u fr '[] (LKVStore k v : r) ~> Eff u fr '[] r
runKVStoreAsState = forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *])
       (ehs :: [(* -> *) -> * -> *]) (fr :: (* -> *) -> * -> *)
       (u :: [(* -> *) -> * -> *] -> (* -> *) -> * -> *)
       (c :: (* -> *) -> Constraint).
(Freer c fr, Union u, HeadIns e) =>
(UnliftIfSingle e ~> Eff u fr ehs r)
-> Eff u fr '[] (e : r) ~> Eff u fr ehs r
interpret \case
    LookupKV k
k -> forall s (f :: * -> *). SendIns (State s) f => f s
get forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k
    UpdateKV k
k Maybe v
v -> forall s (m :: * -> *). (State s <: m, Monad m) => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update (forall a b. a -> b -> a
const Maybe v
v) k
k