{-# LANGUAGE AllowAmbiguousTypes, TemplateHaskell #-}

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

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

    -- * Interpretations
  , runKVStoreAsState
  , runKVStorePurely
  ) 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


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 :: EffectRow).
Member (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 #-}


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 :: EffectRow).
Member (KVStore k v) r =>
k -> Maybe v -> Sem r ()
updateKV k
k (Maybe v
forall a. Maybe a
Nothing @v)
{-# INLINE deleteKV #-}


------------------------------------------------------------------------------
-- |
--
-- @since 0.3.1.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 :: EffectRow) 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 :: EffectRow).
Member (KVStore k v) r =>
k -> Sem r (Maybe v)
lookupKV k
k


------------------------------------------------------------------------------
-- |
--
-- @since 0.3.1.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 :: EffectRow).
Member (KVStore k v) r =>
k -> Sem r (Maybe v)
forall k v (r :: EffectRow).
Member (KVStore k v) r =>
k -> Sem r (Maybe v)
lookupKV @k @v


------------------------------------------------------------------------------
-- |
--
-- @since 0.3.1.0
modifyKV
    :: Member (KVStore k v) r
    => v  -- ^ Default value if the key isn't present
    -> (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 :: EffectRow).
Member (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 :: EffectRow).
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 :: EffectRow).
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


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 :: EffectRow) 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 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (r :: EffectRow) a.
FirstOrder e1 "reinterpret" =>
(forall (rInitial :: EffectRow) x.
 e1 (Sem rInitial) x -> Sem (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
reinterpret ((forall (rInitial :: EffectRow) 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 :: EffectRow) 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 :: EffectRow).
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 :: EffectRow).
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 #-}


runKVStorePurely
    :: Ord k
    => M.Map k v
    -> Sem (KVStore k v ': r) a
    -> Sem r (M.Map k v, a)
runKVStorePurely :: Map k v -> Sem (KVStore k v : r) a -> Sem r (Map k v, a)
runKVStorePurely Map k v
m = Map k v -> Sem (State (Map k v) : r) a -> Sem r (Map k v, a)
forall s (r :: EffectRow) 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 :: EffectRow) a.
Ord k =>
Sem (KVStore k v : r) a -> Sem (State (Map k v) : r) a
runKVStoreAsState
{-# INLINE runKVStorePurely #-}