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

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

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

    -- * Interpreters
    runKVStoreAsState,
    runKVStorePure,
    runKVStoreAsKVStore,
    runKVStoreAsKVStoreSem,
  )
where

import           Data.Kind      (Type)
import qualified Data.Map       as M
import           Data.Maybe     (isJust)
import           Polysemy       (Member, Members, Sem, interpret, makeSem,
                                 reinterpret)
import           Polysemy.Error (Error, fromEither)
import           Polysemy.State (State, gets, modify, runState)

-- | Models things like Redis, HTTP GET/POST, etc. Things that are keyed, have
-- a value, and may or may not be there.
type KVStore :: Type -> Type -> (Type -> Type) -> Type -> Type
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 :: 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 #-}

-- |
--
-- @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 :: 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.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 :: 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.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 :: 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.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 :: 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

-- | 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 :: 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 #-}

-- | 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 :: 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 runKVStorePure #-}

-- | Run a `KVStore` in terms of another `KVStore` by way of pure key and value
-- transformations.
--
-- @since 0.1.1.0
runKVStoreAsKVStore ::
  forall k v k' v' r a.
  -- | A function to transform the key into the interpreted key.
  (k -> k') ->
  -- | A function to transform the value into the interpreted value.
  (v -> v') ->
  -- | A function to transform the interpreted key back into the current value.
  (v' -> v) ->
  Sem (KVStore k v ': r) a ->
  Sem (KVStore k' v' ': r) a
runKVStoreAsKVStore :: (k -> k')
-> (v -> v')
-> (v' -> v)
-> Sem (KVStore k v : r) a
-> Sem (KVStore k' v' : r) a
runKVStoreAsKVStore k -> k'
f v -> v'
g v' -> v
h = (forall (rInitial :: EffectRow) x.
 KVStore k v (Sem rInitial) x -> Sem (KVStore k' v' : r) x)
-> Sem (KVStore k v : r) a -> Sem (KVStore 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 \case
  LookupKV k   -> (v' -> v) -> Maybe v' -> Maybe v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v' -> v
h (Maybe v' -> Maybe v)
-> Sem (KVStore k' v' : r) (Maybe v')
-> Sem (KVStore k' v' : r) (Maybe v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> k' -> Sem (KVStore k' v' : r) (Maybe v')
forall k v (r :: EffectRow).
Member (KVStore k v) r =>
k -> Sem r (Maybe v)
lookupKV @k' @v' (k -> k'
f k
k)
  UpdateKV k x -> k' -> Maybe v' -> Sem (KVStore k' v' : r) ()
forall k v (r :: EffectRow).
Member (KVStore k v) r =>
k -> Maybe v -> Sem r ()
updateKV @k' @v' (k -> k'
f k
k) ((v -> v') -> Maybe v -> Maybe v'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap v -> v'
g Maybe v
x)
{-# INLINE runKVStoreAsKVStore #-}

-- | Run a `KVStore` in terms of another `KVStore` by way of transforming the
-- keys and values with Sem functions.
--
-- @since 0.1.1.0
runKVStoreAsKVStoreSem ::
  forall k v k' v' r a.
  Members '[KVStore k' v'] r =>
  -- | A function to transform the key into the interpreted key.
  (k -> Sem r k') ->
  -- | A function to transform the value into the interpreted value.
  (v -> Sem r v') ->
  -- | A function to transform the interpreted value back into the current value.
  (v' -> Sem r v) ->
  Sem (KVStore k v ': r) a ->
  Sem r a
runKVStoreAsKVStoreSem :: (k -> Sem r k')
-> (v -> Sem r v')
-> (v' -> Sem r v)
-> Sem (KVStore k v : r) a
-> Sem r a
runKVStoreAsKVStoreSem k -> Sem r k'
f v -> Sem r v'
g v' -> Sem r v
h = (forall (rInitial :: EffectRow) x.
 KVStore k v (Sem rInitial) x -> Sem r x)
-> Sem (KVStore k v : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
  LookupKV k -> k -> Sem r k'
f k
k Sem r k' -> (k' -> Sem r (Maybe v')) -> Sem r (Maybe v')
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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' Sem r (Maybe v')
-> (Maybe v' -> Sem r (Maybe v)) -> Sem r (Maybe v)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (v' -> Sem r v) -> Maybe v' -> Sem r (Maybe v)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM v' -> Sem r v
h
  UpdateKV k x -> do
    k'
z <- k -> Sem r k'
f k
k
    Maybe v'
z' <- (v -> Sem r v') -> Maybe v -> Sem r (Maybe v')
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM v -> Sem r v'
g Maybe v
x
    k' -> Maybe v' -> Sem r ()
forall k v (r :: EffectRow).
Member (KVStore k v) r =>
k -> Maybe v -> Sem r ()
updateKV @k' @v' k'
z Maybe v'
z'
{-# INLINE runKVStoreAsKVStoreSem #-}