module DomainDriven.Persistance.ForgetfulInMemory where

import Data.List (foldl')
import DomainDriven.Persistance.Class
import GHC.Generics (Generic)
import qualified Streamly.Prelude as S
import UnliftIO
import Prelude

createForgetful
    :: MonadIO m
    => (model -> Stored event -> model)
    -> model
    -- ^ initial model
    -> m (ForgetfulInMemory model event)
createForgetful :: forall (m :: * -> *) model event.
MonadIO m =>
(model -> Stored event -> model)
-> model -> m (ForgetfulInMemory model event)
createForgetful model -> Stored event -> model
appEvent model
m0 = do
    IORef model
state <- forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef model
m0
    IORef [Stored event]
evs <- forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef []
    QSem
lock <- forall (m :: * -> *). MonadIO m => Int -> m QSem
newQSem Int
1
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall model event.
IORef model
-> (model -> Stored event -> model)
-> model
-> IORef [Stored event]
-> QSem
-> ForgetfulInMemory model event
ForgetfulInMemory IORef model
state model -> Stored event -> model
appEvent model
m0 IORef [Stored event]
evs QSem
lock

-- | STM state without event persistance
data ForgetfulInMemory model event = ForgetfulInMemory
    { forall model event. ForgetfulInMemory model event -> IORef model
stateRef :: IORef model
    , forall model event.
ForgetfulInMemory model event -> model -> Stored event -> model
apply :: model -> Stored event -> model
    , forall model event. ForgetfulInMemory model event -> model
seed :: model
    , forall model event.
ForgetfulInMemory model event -> IORef [Stored event]
events :: IORef [Stored event]
    , forall model event. ForgetfulInMemory model event -> QSem
lock :: QSem
    }
    deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall model event x.
Rep (ForgetfulInMemory model event) x
-> ForgetfulInMemory model event
forall model event x.
ForgetfulInMemory model event
-> Rep (ForgetfulInMemory model event) x
$cto :: forall model event x.
Rep (ForgetfulInMemory model event) x
-> ForgetfulInMemory model event
$cfrom :: forall model event x.
ForgetfulInMemory model event
-> Rep (ForgetfulInMemory model event) x
Generic)

instance ReadModel (ForgetfulInMemory model e) where
    type Model (ForgetfulInMemory model e) = model
    type Event (ForgetfulInMemory model e) = e
    applyEvent :: ForgetfulInMemory model e
-> Model (ForgetfulInMemory model e)
-> Stored (Event (ForgetfulInMemory model e))
-> Model (ForgetfulInMemory model e)
applyEvent ForgetfulInMemory model e
ff = forall model event.
ForgetfulInMemory model event -> model -> Stored event -> model
apply ForgetfulInMemory model e
ff
    getModel :: ForgetfulInMemory model e -> IO (Model (ForgetfulInMemory model e))
getModel ForgetfulInMemory model e
ff = forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef forall a b. (a -> b) -> a -> b
$ forall model event. ForgetfulInMemory model event -> IORef model
stateRef ForgetfulInMemory model e
ff
    getEventList :: ForgetfulInMemory model e
-> IO [Stored (Event (ForgetfulInMemory model e))]
getEventList ForgetfulInMemory model e
ff = forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef forall a b. (a -> b) -> a -> b
$ forall model event.
ForgetfulInMemory model event -> IORef [Stored event]
events ForgetfulInMemory model e
ff
    getEventStream :: ForgetfulInMemory model e
-> SerialT IO (Stored (Event (ForgetfulInMemory model e)))
getEventStream ForgetfulInMemory model e
ff = do
        [Stored e]
l <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall p. ReadModel p => p -> IO [Stored (Event p)]
getEventList ForgetfulInMemory model e
ff
        forall (m :: * -> *) (t :: (* -> *) -> * -> *) a.
(Monad m, IsStream t) =>
[a] -> t m a
S.fromList [Stored e]
l

instance WriteModel (ForgetfulInMemory model e) where
    transactionalUpdate :: forall (m :: * -> *) a.
MonadUnliftIO m =>
ForgetfulInMemory model e
-> (Model (ForgetfulInMemory model e)
    -> m (Model (ForgetfulInMemory model e) -> a,
          [Event (ForgetfulInMemory model e)]))
-> m a
transactionalUpdate ForgetfulInMemory model e
ff Model (ForgetfulInMemory model e)
-> m (Model (ForgetfulInMemory model e) -> a,
      [Event (ForgetfulInMemory model e)])
evalCmd =
        forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> m b -> m c -> m c
bracket_ (forall (m :: * -> *). MonadIO m => QSem -> m ()
waitQSem forall a b. (a -> b) -> a -> b
$ forall model event. ForgetfulInMemory model event -> QSem
lock ForgetfulInMemory model e
ff) (forall (m :: * -> *). MonadIO m => QSem -> m ()
signalQSem forall a b. (a -> b) -> a -> b
$ forall model event. ForgetfulInMemory model event -> QSem
lock ForgetfulInMemory model e
ff) forall a b. (a -> b) -> a -> b
$ do
            model
model <- forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef forall a b. (a -> b) -> a -> b
$ forall model event. ForgetfulInMemory model event -> IORef model
stateRef ForgetfulInMemory model e
ff
            (model -> a
returnFun, [e]
evs) <- Model (ForgetfulInMemory model e)
-> m (Model (ForgetfulInMemory model e) -> a,
      [Event (ForgetfulInMemory model e)])
evalCmd model
model
            [Stored e]
storedEvs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) e. MonadIO m => e -> m (Stored e)
toStored [e]
evs
            let newModel :: model
newModel = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall model event.
ForgetfulInMemory model event -> model -> Stored event -> model
apply ForgetfulInMemory model e
ff) model
model [Stored e]
storedEvs
            forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef (forall model event.
ForgetfulInMemory model event -> IORef [Stored event]
events ForgetfulInMemory model e
ff) (forall a. Semigroup a => a -> a -> a
<> [Stored e]
storedEvs)
            forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef (forall model event. ForgetfulInMemory model event -> IORef model
stateRef ForgetfulInMemory model e
ff) model
newModel
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ model -> a
returnFun model
newModel