{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Tendermint.SDK.BaseApp.Effects.PureCoreEffs
  ( PureCoreEffs
  , PureContext(..)
  , pureContextLogConfig
  , pureContextVersions
  , pureContextDB
  , makePureContext
  , runPureCoreEffs
  ) where

import           Control.Lens                             (makeLenses)
import           Data.Text                                (Text)
import qualified Katip                                    as K
import           Polysemy                                 (Embed, Sem, runM)
import           Polysemy.Error                           (Error, runError)
import           Polysemy.Reader                          (Reader, runReader)
import           Tendermint.SDK.BaseApp.Errors            (AppError)
import qualified Tendermint.SDK.BaseApp.Logger.Katip      as KL
import qualified Tendermint.SDK.BaseApp.Store.MemoryStore as Memory

-- | CoreEffs is one level below BaseAppEffs, and provides one possible
-- | interpretation for its effects to IO.
type PureCoreEffs =
  '[ Reader KL.LogConfig
   , Reader Memory.DBVersions
   , Reader Memory.DB
   , Error AppError
   , Embed IO
   ]

-- | 'Context' is the environment required to run 'CoreEffsPure' to 'IO'
data PureContext = PureContext
  { PureContext -> LogConfig
_pureContextLogConfig :: KL.LogConfig
  , PureContext -> DB
_pureContextDB        :: Memory.DB
  , PureContext -> DBVersions
_pureContextVersions  :: Memory.DBVersions
  }

makeLenses ''PureContext

makePureContext
  :: KL.InitialLogNamespace
  -> IO PureContext
makePureContext :: InitialLogNamespace -> IO PureContext
makePureContext KL.InitialLogNamespace{..}  = do
  LogConfig
logCfg <- Text -> Text -> IO LogConfig
mkLogConfig Text
_initialLogEnvironment Text
_initialLogProcessName
  DBVersions
versions <- IO DBVersions
Memory.initDBVersions
  DB
db <- IO DB
Memory.initDB
  PureContext -> IO PureContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PureContext -> IO PureContext) -> PureContext -> IO PureContext
forall a b. (a -> b) -> a -> b
$ PureContext :: LogConfig -> DB -> DBVersions -> PureContext
PureContext
    { _pureContextLogConfig :: LogConfig
_pureContextLogConfig = LogConfig
logCfg
    , _pureContextVersions :: DBVersions
_pureContextVersions = DBVersions
versions
    , _pureContextDB :: DB
_pureContextDB = DB
db
    }
    where
      mkLogConfig :: Text -> Text -> IO KL.LogConfig
      mkLogConfig :: Text -> Text -> IO LogConfig
mkLogConfig env :: Text
env pName :: Text
pName = do
        let mkLogEnv :: IO LogEnv
mkLogEnv = Namespace -> Environment -> IO LogEnv
K.initLogEnv ([Text] -> Namespace
K.Namespace [Text
pName]) (Text -> Environment
K.Environment Text
env)
        LogEnv
le <- IO LogEnv
mkLogEnv
        LogConfig -> IO LogConfig
forall (m :: * -> *) a. Monad m => a -> m a
return (LogConfig -> IO LogConfig) -> LogConfig -> IO LogConfig
forall a b. (a -> b) -> a -> b
$ LogConfig :: Namespace -> LogContexts -> LogEnv -> LogConfig
KL.LogConfig
          { _logNamespace :: Namespace
_logNamespace = Namespace
forall a. Monoid a => a
mempty
          , _logContext :: LogContexts
_logContext = LogContexts
forall a. Monoid a => a
mempty
          , _logEnv :: LogEnv
_logEnv = LogEnv
le
          }

-- | The standard interpeter for 'PureCoreEffs'.
runPureCoreEffs
  :: PureContext
  -> forall a. Sem PureCoreEffs a -> IO (Either AppError a)
runPureCoreEffs :: PureContext
-> forall a. Sem PureCoreEffs a -> IO (Either AppError a)
runPureCoreEffs PureContext{..} =
  Sem '[Embed IO] (Either AppError a) -> IO (Either AppError a)
forall (m :: * -> *) a. Monad m => Sem '[Embed m] a -> m a
runM (Sem '[Embed IO] (Either AppError a) -> IO (Either AppError a))
-> (Sem PureCoreEffs a -> Sem '[Embed IO] (Either AppError a))
-> Sem PureCoreEffs a
-> IO (Either AppError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Sem '[Error AppError, Embed IO] a
-> Sem '[Embed IO] (Either AppError a)
forall e (r :: [(* -> *) -> * -> *]) a.
Sem (Error e : r) a -> Sem r (Either e a)
runError (Sem '[Error AppError, Embed IO] a
 -> Sem '[Embed IO] (Either AppError a))
-> (Sem PureCoreEffs a -> Sem '[Error AppError, Embed IO] a)
-> Sem PureCoreEffs a
-> Sem '[Embed IO] (Either AppError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    DB
-> Sem '[Reader DB, Error AppError, Embed IO] a
-> Sem '[Error AppError, Embed IO] a
forall i (r :: [(* -> *) -> * -> *]) a.
i -> Sem (Reader i : r) a -> Sem r a
runReader DB
_pureContextDB (Sem '[Reader DB, Error AppError, Embed IO] a
 -> Sem '[Error AppError, Embed IO] a)
-> (Sem PureCoreEffs a
    -> Sem '[Reader DB, Error AppError, Embed IO] a)
-> Sem PureCoreEffs a
-> Sem '[Error AppError, Embed IO] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    DBVersions
-> Sem '[Reader DBVersions, Reader DB, Error AppError, Embed IO] a
-> Sem '[Reader DB, Error AppError, Embed IO] a
forall i (r :: [(* -> *) -> * -> *]) a.
i -> Sem (Reader i : r) a -> Sem r a
runReader DBVersions
_pureContextVersions (Sem '[Reader DBVersions, Reader DB, Error AppError, Embed IO] a
 -> Sem '[Reader DB, Error AppError, Embed IO] a)
-> (Sem PureCoreEffs a
    -> Sem '[Reader DBVersions, Reader DB, Error AppError, Embed IO] a)
-> Sem PureCoreEffs a
-> Sem '[Reader DB, Error AppError, Embed IO] a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    LogConfig
-> Sem PureCoreEffs a
-> Sem '[Reader DBVersions, Reader DB, Error AppError, Embed IO] a
forall i (r :: [(* -> *) -> * -> *]) a.
i -> Sem (Reader i : r) a -> Sem r a
runReader LogConfig
_pureContextLogConfig