{-# 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 = updateKV k . Just
{-# INLINE writeKV #-}


deleteKV :: forall k v r. Member (KVStore k v) r => k -> Sem r ()
deleteKV k = updateKV k (Nothing @v)
{-# INLINE deleteKV #-}


------------------------------------------------------------------------------
-- |
--
-- @since 0.3.1.0
lookupOrThrowKV
    :: Members '[ KVStore k v
                , Error e
                ] r
    => (k -> e)
    -> k
    -> Sem r v
lookupOrThrowKV f k =
  fromEither . maybe (Left $ f k) Right =<< lookupKV k


------------------------------------------------------------------------------
-- |
--
-- @since 0.3.1.0
existsKV :: forall k v r. Member (KVStore k v) r => k -> Sem r Bool
existsKV = fmap isJust . 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 d f k =
  lookupKV k >>= \case
    Just v  -> writeKV k $ f v
    Nothing -> writeKV k $ f d


runKVStoreAsState :: Ord k => Sem (KVStore k v ': r) a -> Sem (State (M.Map k v) ': r) a
runKVStoreAsState = reinterpret $ \case
  LookupKV k   -> gets $ M.lookup k
  UpdateKV k v -> modify $ M.alter (const v) k
{-# INLINE runKVStoreAsState #-}


runKVStorePurely
    :: Ord k
    => M.Map k v
    -> Sem (KVStore k v ': r) a
    -> Sem r (M.Map k v, a)
runKVStorePurely m = runState m . runKVStoreAsState
{-# INLINE runKVStorePurely #-}