{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Polysemy.KVStore
  ( -- * Effect
    KVStore (..),

    -- * Actions
    lookupKV,
    lookupOrThrowKV,
    existsKV,
    writeKV,
    deleteKV,
    updateKV,
    modifyKV,

    -- * Interpretations
    runKVStoreAsState,
    runKVStorePure,
  )
where

import qualified Data.Map as M
import Data.Maybe (isJust)
import Polysemy
import Polysemy.Error
import Polysemy.State

-- | Models things like Redis, HTTP GET/POST, etc. Things that are keyed, have
-- a value, and may or may not be there.
data KVStore k v m a where
  LookupKV :: k -> KVStore k v m (Maybe v)
  UpdateKV :: k -> Maybe v -> KVStore k v m ()

makeSem ''KVStore

-- |
--
-- @since 0.1.0.0
writeKV :: Member (KVStore k v) r => k -> v -> Sem r ()
writeKV :: k -> v -> Sem r ()
writeKV k
k = k -> Maybe v -> Sem r ()
forall k v (r :: [Effect]).
MemberWithError (KVStore k v) r =>
k -> Maybe v -> Sem r ()
updateKV k
k (Maybe v -> Sem r ()) -> (v -> Maybe v) -> v -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> Maybe v
forall a. a -> Maybe a
Just
{-# INLINE writeKV #-}

-- |
--
-- @since 0.1.0.0
deleteKV :: forall k v r. Member (KVStore k v) r => k -> Sem r ()
deleteKV :: k -> Sem r ()
deleteKV k
k = k -> Maybe v -> Sem r ()
forall k v (r :: [Effect]).
MemberWithError (KVStore k v) r =>
k -> Maybe v -> Sem r ()
updateKV k
k (Maybe v
forall a. Maybe a
Nothing @v)
{-# INLINE deleteKV #-}

-- |
--
-- @since 0.1.0.0
lookupOrThrowKV ::
  Members
    '[ KVStore k v,
       Error e
     ]
    r =>
  (k -> e) ->
  k ->
  Sem r v
lookupOrThrowKV :: (k -> e) -> k -> Sem r v
lookupOrThrowKV k -> e
f k
k =
  Either e v -> Sem r v
forall e (r :: [Effect]) a.
Member (Error e) r =>
Either e a -> Sem r a
fromEither (Either e v -> Sem r v)
-> (Maybe v -> Either e v) -> Maybe v -> Sem r v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either e v -> (v -> Either e v) -> Maybe v -> Either e v
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> Either e v
forall a b. a -> Either a b
Left (e -> Either e v) -> e -> Either e v
forall a b. (a -> b) -> a -> b
$ k -> e
f k
k) v -> Either e v
forall a b. b -> Either a b
Right (Maybe v -> Sem r v) -> Sem r (Maybe v) -> Sem r v
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< k -> Sem r (Maybe v)
forall k v (r :: [Effect]).
MemberWithError (KVStore k v) r =>
k -> Sem r (Maybe v)
lookupKV k
k

-- |
--
-- @since 0.1.0.0
existsKV :: forall k v r. Member (KVStore k v) r => k -> Sem r Bool
existsKV :: k -> Sem r Bool
existsKV = (Maybe v -> Bool) -> Sem r (Maybe v) -> Sem r Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe v -> Bool
forall a. Maybe a -> Bool
isJust (Sem r (Maybe v) -> Sem r Bool)
-> (k -> Sem r (Maybe v)) -> k -> Sem r Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (r :: [Effect]).
MemberWithError (KVStore k v) r =>
k -> Sem r (Maybe v)
forall k v (r :: [Effect]).
MemberWithError (KVStore k v) r =>
k -> Sem r (Maybe v)
lookupKV @k @v

-- |
--
-- @since 0.1.0.0
modifyKV ::
  Member (KVStore k v) r =>
  -- | Default value if the key isn't present
  v ->
  (v -> v) ->
  k ->
  Sem r ()
modifyKV :: v -> (v -> v) -> k -> Sem r ()
modifyKV v
d v -> v
f k
k =
  k -> Sem r (Maybe v)
forall k v (r :: [Effect]).
MemberWithError (KVStore k v) r =>
k -> Sem r (Maybe v)
lookupKV k
k Sem r (Maybe v) -> (Maybe v -> Sem r ()) -> Sem r ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just v
v -> k -> v -> Sem r ()
forall k v (r :: [Effect]).
Member (KVStore k v) r =>
k -> v -> Sem r ()
writeKV k
k (v -> Sem r ()) -> v -> Sem r ()
forall a b. (a -> b) -> a -> b
$ v -> v
f v
v
    Maybe v
Nothing -> k -> v -> Sem r ()
forall k v (r :: [Effect]).
Member (KVStore k v) r =>
k -> v -> Sem r ()
writeKV k
k (v -> Sem r ()) -> v -> Sem r ()
forall a b. (a -> b) -> a -> b
$ v -> v
f v
d

-- | Run a `KVStore` as a `State` effect containing a `Map`.
--
-- @since 0.1.0.0
runKVStoreAsState :: Ord k => Sem (KVStore k v ': r) a -> Sem (State (M.Map k v) ': r) a
runKVStoreAsState :: Sem (KVStore k v : r) a -> Sem (State (Map k v) : r) a
runKVStoreAsState = (forall (rInitial :: [Effect]) x.
 KVStore k v (Sem rInitial) x -> Sem (State (Map k v) : r) x)
-> Sem (KVStore k v : r) a -> Sem (State (Map k v) : r) a
forall (e1 :: Effect) (e2 :: Effect) (r :: [Effect]) a.
FirstOrder e1 "reinterpret" =>
(forall (rInitial :: [Effect]) x.
 e1 (Sem rInitial) x -> Sem (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
reinterpret ((forall (rInitial :: [Effect]) x.
  KVStore k v (Sem rInitial) x -> Sem (State (Map k v) : r) x)
 -> Sem (KVStore k v : r) a -> Sem (State (Map k v) : r) a)
-> (forall (rInitial :: [Effect]) x.
    KVStore k v (Sem rInitial) x -> Sem (State (Map k v) : r) x)
-> Sem (KVStore k v : r) a
-> Sem (State (Map k v) : r) a
forall a b. (a -> b) -> a -> b
$ \case
  LookupKV k -> (Map k v -> Maybe v) -> Sem (State (Map k v) : r) (Maybe v)
forall s a (r :: [Effect]).
Member (State s) r =>
(s -> a) -> Sem r a
gets ((Map k v -> Maybe v) -> Sem (State (Map k v) : r) (Maybe v))
-> (Map k v -> Maybe v) -> Sem (State (Map k v) : r) (Maybe v)
forall a b. (a -> b) -> a -> b
$ k -> Map k v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k
  UpdateKV k v -> (Map k v -> Map k v) -> Sem (State (Map k v) : r) ()
forall s (r :: [Effect]).
Member (State s) r =>
(s -> s) -> Sem r ()
modify ((Map k v -> Map k v) -> Sem (State (Map k v) : r) ())
-> (Map k v -> Map k v) -> Sem (State (Map k v) : r) ()
forall a b. (a -> b) -> a -> b
$ (Maybe v -> Maybe v) -> k -> Map k v -> Map k v
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (Maybe v -> Maybe v -> Maybe v
forall a b. a -> b -> a
const Maybe v
v) k
k
{-# INLINE runKVStoreAsState #-}

-- | Run a `KVStore` purely as a `Map`.
--
-- @since 0.1.0.0
runKVStorePure ::
  Ord k =>
  M.Map k v ->
  Sem (KVStore k v ': r) a ->
  Sem r (M.Map k v, a)
runKVStorePure :: Map k v -> Sem (KVStore k v : r) a -> Sem r (Map k v, a)
runKVStorePure Map k v
m = Map k v -> Sem (State (Map k v) : r) a -> Sem r (Map k v, a)
forall s (r :: [Effect]) a.
s -> Sem (State s : r) a -> Sem r (s, a)
runState Map k v
m (Sem (State (Map k v) : r) a -> Sem r (Map k v, a))
-> (Sem (KVStore k v : r) a -> Sem (State (Map k v) : r) a)
-> Sem (KVStore k v : r) a
-> Sem r (Map k v, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (KVStore k v : r) a -> Sem (State (Map k v) : r) a
forall k v (r :: [Effect]) a.
Ord k =>
Sem (KVStore k v : r) a -> Sem (State (Map k v) : r) a
runKVStoreAsState
{-# INLINE runKVStorePure #-}