-- We intentionally specify more constraints than necessary for some exports.
{-# OPTIONS_GHC -Wno-redundant-constraints#-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

{-|
Copyright   : © 2022-2023 IOHK, 2023-2025 Cardano Foundation
License     : Apache-2.0
Description : Store a value of a given type outside of volatile memory.

'Store' represents a facility for storing one value of a given type.
Typically, this type is a collection type,
for example 'Data.Map.Map'@ @'Integer'@ @'String',
so that we actually stores multiple values.

The key benefit of a 'Store' is that it can store the value
__outside of volatile memory (RAM)__ —
for example, the value can be stored in a database file on disk,
that is on persistent storage.

* Read-access is done on parts of the value, through a query GADT
  that is an instance of the 'Query' class.
  In this way, we do not need to load the stored value
  fully into volatile memory.
* Updates are incremental and use delta types, see "Data.Delta".
  In this way, we can modify the persistent storage incrementally.

Conversely, there is no need to use 'Store' if
the value only ever lives in volatile memory
— in this case, it is much simpler to use a plain Haskell value,
introduced with @let@, @where@, or as a function argument.
-}
module Data.Store (
    -- * Store, definition
    -- ** Type
      Store (..)

    -- ** Properties
    -- $Properties

    -- *** Laws: Load and Write
    -- $LoadWriteLaws

    -- *** Laws: Update
    -- $UpdateLaws

    -- *** Laws: Query
    -- $QueryLaws

    -- *** Monad
    -- $StoreMonad

    -- *** updateS, Maybe argument
    -- $updateS

    -- *** loadS, SomeException
    -- $EitherSomeException

    -- * Store, functions
    -- ** Query
    , Query (..)
    , Whole (..)

    -- ** Constructors
    , SimpleStore
    , mkSimpleStore
    , UpdateStore
    , mkUpdateStore
    , mkQueryStore

    -- ** Combinators
    , hoistStore
    , embedStore
    , pairStores
    , newCachedStore

    -- ** Helpers
    , updateLoad
    , loadWhenNothing

    -- ** Testing
    , embedStore'
    , newStore
    , NotInitialized (..)
    , updateSequence
    ) where

import Prelude

import Control.Applicative
    ( liftA2
    )
import Control.Concurrent.Class.MonadSTM
    ( MonadSTM
    , atomically
    , modifyTVar'
    , newTVarIO
    , readTVar
    , readTVarIO
    , retry
    , writeTVar
    )
import Control.Exception
    ( Exception
    , SomeException (..)
    , toException
    )
import Control.Monad
    ( foldM_
    , join
    )
import Control.Monad.Class.MonadThrow
    ( MonadEvaluate
    , MonadMask
    , MonadThrow
    , evaluate
    , finally
    , mask
    , throwIO
    )
import Data.Delta
    ( Delta (..)
    , Embedding
    , Embedding' (..)
    , Replace (..)
    )
import Data.Delta.Embedding
    ( inject
    , project
    )
import Data.Delta.Embedding.Internal
    ( Machine (..)
    )
import Data.Kind
    ( Type
    )
import GHC.Generics
    ( (:+:) (..)
    )

{-------------------------------------------------------------------------------
    Store
-------------------------------------------------------------------------------}
{- |
A 'Store' is a storage facility for Haskell values of type
@a ~ @'Base'@ da ~ @'World'@ qa@.

Typical use cases are a file or a database on the hard disk.

The purpose of the type parameters is:

* The monad @m@ encapsulates access to the storage space.
* The query type @qa@ represents the specialized queries
  that this store supports.
* The delta type @da@ is used for incremental updates.

If you care about one these aspects, but not the others,
we recommend to use a specialized type synonym
such as 'SimpleStore' or 'UpdateStore'.
-}
data Store m (qa :: Type -> Type) da = Store
    {
      -- | Load the value from the store into memory, or fail.
      --
      -- This operation can be expensive.
      forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> m (Either SomeException (Base da))
loadS   :: m (Either SomeException (Base da))
      -- | Write a value from memory into the store.
    , forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Base da -> m ()
writeS  :: Base da -> m ()
      -- | Update the value in the store
      -- incrementally by using a 'Delta' type @da@.
      --
      -- For effiency,
      -- the first argument may supply the current value in-memory.
    , forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Maybe (Base da) -> da -> m ()
updateS
        :: Maybe (Base da) -- old value, for performance
        -> da -- delta to new value
        -> m () -- write new value
      -- | Run a specialized 'Query' on the value in the store.
      --
      -- This operation can be less expensive than 'loadS',
      -- because the query may not need to load the whole value into memory.
    , forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> forall b. qa b -> m b
queryS  :: forall b. qa b -> m b
    }

{- $Properties
Any implementation of 'Store' is expected to satisfy the __properties__
specified in this section.
We make no attempt at enforcing these properties on the type-level.
However, the module "Test.Store" provides QuickCheck code for these
properties for automated testing.
-}

-- Note [LoadWriteLaws]
{- $LoadWriteLaws

The most fundamental operations on a 'Store' are

* 'loadS' — loads the value contained in the 'Store' into memory.
* 'writeS' — writes a value from memory into the 'Store'.

These two operations are characterized by the following design:

1. The store __need not contain__ a properly formatted __value__.

    Loading a value from the store may fail, and this is why 'loadS'
    has an 'Either' result.
    For example, if the 'Store' represents
    a file on disk, then the file may corrupted or in an incompatible
    file format when first opened.
    In such a case of failure, the result 'Left'@ (e :: @'SomeException'@)@
    is returned, where the exception @e@ gives more information
    about the failure.

    However, loading a value after writing it should always succeed,
    we have

        > writeS s a >> loadS s  =  pure (Right a)

2. The store is __redundant__.

    Two stores with different internal contents may contain
    the same value of type @a@.
    For example, two files with different whitespace
    may describe the same JSON value.
    In general, loading a value and writing it again may change the
    internal store contents, i.e.

        > loadS s >>= either (\_ -> pure ()) (writeS s)  ≠  pure ()
-}

-- Note [UpdateLaws]
{- $UpdateLaws

In order to update the store content without loading all of it into memory,
'Store' supports the operation

* 'updateS' — updates the value contained in the 'Store' using a 'Delta' type.

This operation is characterized by the following law:

* Updating a store __commutes with 'apply'__.

    We have

        > updateS s (Just a) da >> loadS s  =  pure $ Right $ apply a da

    However, since the store is redundant, we often have

        > updateS s (Just a) da  ≠  writeS s (apply a da)

The combination of 'loadS', 'writeS', 'updateS' has many similarities
with an 'Embedding' of delta types. However, the main difference
is that manipulating a 'Store' involves side effects.
-}

-- Note [QueryLaws]
{- $QueryLaws

In order to query parts of the store content
without loading all of it into memory,
'Store' supports the operation

* 'queryS' — run a specialized 'Query' on the value contained in the 'Store'.

This operation is characterized by the following law:

* Querying a store __commutes with 'query'__:

        >  ∀q. query q <$> (loadS s >>= either throw pure)  =  queryS s q
-}

-- Note [updateS argument]
{- $updateS

The function 'updateS' applies a delta to the content of the 'Store'.
Depending on the implementation of the 'Store', this operation may
require large parts of the content to be loaded into memory,
which is expensive.
In some use cases such as 'Data.DBVar.DBVar', the value is already available
in memory and can be used for executing the update.
For these cases, the __first argument__ of 'updateS'
__may__ provide the __in-memory value__.
We expect that the following property holds:

>   updateS s Nothing da
> =
>   loadS s >>= \(Right a) -> updateS s (Just a) da

The helper 'loadWhenNothing' is useful for handling this argument.
-}

{- $StoreMonad

The monad @m@ in 'Store'@ m da@ provides the storage space for the value.
Put differently, we like to think of @m@ as a
'Control.Monad.Trans.State.State' monad whose state contains the value.
However, this monad @m@ could have __additional side effects__
such as exceptions, concurrency, non-determinism, and so on.
We would have to specify how a 'Store' should behave with regards to these
effects, which complicates matters significantly.
(In fact, the equality sign @=@ for the laws above has to be
interpreted "… equal effects as far as the 'Store' is concerned".
A proper approach to a specification would involve Hoare logic.)

For simplicity, we now assume that the monad @m@ only has
the effects __state__ and __exceptions__ —
we make no attempt at specifying how an implementation
should behave for concurrent usage of, say, 'updateS'.
This assumption ensures some composability of the 'Store' abstraction.
However, it also implies that choosing @m ~ @'Control.Monad.STM.STM'
results in specified semantics, whereas choosing @m ~ @'IO' can
result in unspecified behavior.
(TODO: Perhaps create a type class 'MonadSequential' to keep track
of this on the type level?)

More specifically, the interaction between 'Store' functions and
effects are as follows:

* __State__: The laws presented above specify the essentials
of how the store state changes. However, this specification is not complete,
other "expected" rules such as

    > writeS s a >> writeS s b  =  writeS s b

    etc. should also hold.

* __Exceptions__:

    * 'loadS' should not throw a synchronous exception,
      but return 'Left' instead.
    * 'queryS' should throw a synchronous exception iff 'loadS' returns 'Left'.
      Moving the error case into the monad @m@ simplifes the use of this operation.
    * 'writeS' and 'loadS' should not throw synchronous exceptions.
      However, in case they do throw an exception,
      the contents of the 'Store' should be treated as corrupted,
      and 'loadS' should return 'Left' subsequently.

* __Concurrency__: We do not specify behavior under concurrent operation.
    Concurrent access to a 'Store' is a frequent desideratum
    — but you will have to implement it yourself.

    One design pattern is to use a custom monad @m ~ MyMonad@
    that has a way of executing state changes atomically,

    > atomically :: MyMonad a -> IO a

    Specifically, @atomically@ either applies /all/ state changes,
    or /none/ of the state changes.
    For instance, SQL transactions can be used for this,
    see e.g. <https://www.sqlite.org/lang_transaction.html>.
    Then, you can implement a 'Store'@ MyMonad@ by composing smaller 'Store',
    and use @atomically@ in a scope where you want to use the 'Store'
    rather than implement it.

    Use 'hoistStore'@ atomically@ to map a 'Store'@ MyMonad@
    to a 'Store'@ IO@ where the monad has less atomicity.

* __Non-determinism__ or other effects: Here be dragons.

-}

-- Note [EitherSomeException]
{- $EitherSomeException

In the __error case__ that the store does not contain a value,
'loadS' returns a 'Left' value of type 'SomeException'.
This type is a disjoint sum of all possible
error types (that is, members of the 'Exception' class).

We could parametrize 'Store' by an additional type parameter @e@ representing
the possible error cases. However, we have opted to explore
a region of the design space where the number of type parameters
is kept to a minimum.

In fact, I would argue that making errors visible on the type level is not
very useful: we add much noise to the type level,
but we gain little type-safety in exchange.
Specifically, if we encounter an element of the 'SomeException' type that
we did not expect, we can always 'throw' it.
For example, consider the following code:

@
let ea :: Either SomeException ()
    ea = [..]
in
    case ea of
        Right _ -> "everything is ok"
        Left e -> case fromException e of
            Just (AssertionFailed _) -> "bad things happened"
            Nothing -> throw e
@

In this example, using the more specific type @ea :: Either AssertionFailed ()@
would have eliminated the 'Nothing' case.
However, this case has the sensible default value:
@throw e@, we rethrow the exception that we did not expect.
Ruling out this case on the type-level adds almost no value.
-}

{-------------------------------------------------------------------------------
    Constructors
-------------------------------------------------------------------------------}
{- HLINT ignore newStore "Use readTVarIO" -}
-- | An in-memory 'Store' from a mutable variable ('TVar').
-- Useful for testing.
newStore
    :: (MonadSTM m, MonadThrow m, Delta da, Query qa, Base da ~ World qa)
    => m (Store m qa da)
newStore :: forall (m :: * -> *) da (qa :: * -> *).
(MonadSTM m, MonadThrow m, Delta da, Query qa,
 Base da ~ World qa) =>
m (Store m qa da)
newStore = do
    TVar m (Either SomeException (World qa))
ref <- Either SomeException (World qa)
-> m (TVar m (Either SomeException (World qa)))
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO (Either SomeException (World qa)
 -> m (TVar m (Either SomeException (World qa))))
-> Either SomeException (World qa)
-> m (TVar m (Either SomeException (World qa)))
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException (World qa)
forall a b. a -> Either a b
Left (SomeException -> Either SomeException (World qa))
-> SomeException -> Either SomeException (World qa)
forall a b. (a -> b) -> a -> b
$ NotInitialized -> SomeException
forall e. Exception e => e -> SomeException
toException NotInitialized
NotInitialized
    let load :: m (Either SomeException (World qa))
load = STM m (Either SomeException (World qa))
-> m (Either SomeException (World qa))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TVar m (Either SomeException (World qa))
-> STM m (Either SomeException (World qa))
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (Either SomeException (World qa))
ref)
    Store m qa da -> m (Store m qa da)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Store m qa da -> m (Store m qa da))
-> Store m qa da -> m (Store m qa da)
forall a b. (a -> b) -> a -> b
$ Store
        { loadS :: m (Either SomeException (Base da))
loadS   = m (Either SomeException (Base da))
m (Either SomeException (World qa))
load
        , queryS :: forall b. qa b -> m b
queryS  = \qa b
q -> qa b -> World qa -> b
forall b. qa b -> World qa -> b
forall (qa :: * -> *) b. Query qa => qa b -> World qa -> b
query qa b
q (World qa -> b) -> m (World qa) -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Either SomeException (World qa) -> m (World qa)
forall (m :: * -> *) b.
MonadThrow m =>
Either SomeException b -> m b
throwLeft (Either SomeException (World qa) -> m (World qa))
-> m (Either SomeException (World qa)) -> m (World qa)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Either SomeException (World qa))
load)
        , writeS :: Base da -> m ()
writeS  = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> (World qa -> STM m ()) -> World qa -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar m (Either SomeException (World qa))
-> Either SomeException (World qa) -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (Either SomeException (World qa))
ref (Either SomeException (World qa) -> STM m ())
-> (World qa -> Either SomeException (World qa))
-> World qa
-> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. World qa -> Either SomeException (World qa)
forall a b. b -> Either a b
Right
        , updateS :: Maybe (Base da) -> da -> m ()
updateS = \Maybe (Base da)
_ -> STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> (da -> STM m ()) -> da -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar m (Either SomeException (World qa))
-> (Either SomeException (World qa)
    -> Either SomeException (World qa))
-> STM m ()
forall a. TVar m a -> (a -> a) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
TVar m a -> (a -> a) -> STM m ()
modifyTVar' TVar m (Either SomeException (World qa))
ref ((Either SomeException (World qa)
  -> Either SomeException (World qa))
 -> STM m ())
-> (da
    -> Either SomeException (World qa)
    -> Either SomeException (World qa))
-> da
-> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (World qa -> World qa)
-> Either SomeException (World qa)
-> Either SomeException (World qa)
forall a b.
(a -> b) -> Either SomeException a -> Either SomeException b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((World qa -> World qa)
 -> Either SomeException (World qa)
 -> Either SomeException (World qa))
-> (da -> World qa -> World qa)
-> da
-> Either SomeException (World qa)
-> Either SomeException (World qa)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. da -> Base da -> Base da
da -> World qa -> World qa
forall delta. Delta delta => delta -> Base delta -> Base delta
apply
        }

-- | Failure that occurs when calling 'loadS' on a 'newStore' that is empty.
data NotInitialized = NotInitialized deriving (NotInitialized -> NotInitialized -> Bool
(NotInitialized -> NotInitialized -> Bool)
-> (NotInitialized -> NotInitialized -> Bool) -> Eq NotInitialized
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NotInitialized -> NotInitialized -> Bool
== :: NotInitialized -> NotInitialized -> Bool
$c/= :: NotInitialized -> NotInitialized -> Bool
/= :: NotInitialized -> NotInitialized -> Bool
Eq, Int -> NotInitialized -> ShowS
[NotInitialized] -> ShowS
NotInitialized -> String
(Int -> NotInitialized -> ShowS)
-> (NotInitialized -> String)
-> ([NotInitialized] -> ShowS)
-> Show NotInitialized
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NotInitialized -> ShowS
showsPrec :: Int -> NotInitialized -> ShowS
$cshow :: NotInitialized -> String
show :: NotInitialized -> String
$cshowList :: [NotInitialized] -> ShowS
showList :: [NotInitialized] -> ShowS
Show)
instance Exception NotInitialized

-- | A 'Store' which supports 'loadS' and 'writeS',
-- but no fancy query or update operations.
type SimpleStore m a = Store m (Whole a) (Replace a)

-- | @mkSimpleStore loadS writeS@ constructs a 'SimpleStore'
-- from the given operations.
mkSimpleStore
    :: forall m a
     . (Monad m, MonadThrow m)
    => m (Either SomeException a)
    -> (a -> m ())
    -> SimpleStore m a
mkSimpleStore :: forall (m :: * -> *) a.
(Monad m, MonadThrow m) =>
m (Either SomeException a) -> (a -> m ()) -> SimpleStore m a
mkSimpleStore m (Either SomeException a)
loadS a -> m ()
writeS =
    m (Either SomeException a)
-> (a -> m ())
-> (Maybe a -> Replace a -> m ())
-> UpdateStore m (Replace a)
forall (m :: * -> *) a da.
(Monad m, MonadThrow m, a ~ Base da, Delta da) =>
m (Either SomeException a)
-> (a -> m ()) -> (Maybe a -> da -> m ()) -> UpdateStore m da
mkUpdateStore m (Either SomeException a)
loadS a -> m ()
writeS Maybe a -> Replace a -> m ()
update'
  where
    update' :: Maybe a -> Replace a -> m ()
update' Maybe a
_ (Replace a
a) = a -> m ()
writeS a
a

-- | A 'Store' whose focus lies on updating the value rather than querying it.
type UpdateStore m da = Store m (Whole (Base da)) da

-- | @mkUpdateStore loadS writeS updateS@ constructs an 'UpdateStore'
-- from the given operations.
mkUpdateStore
    :: forall m a da
     . (Monad m, MonadThrow m, a ~ Base da, Delta da)
    => m (Either SomeException a)
    -> (a -> m ())
    -> (Maybe a -> da -> m ())
    -> UpdateStore m da
mkUpdateStore :: forall (m :: * -> *) a da.
(Monad m, MonadThrow m, a ~ Base da, Delta da) =>
m (Either SomeException a)
-> (a -> m ()) -> (Maybe a -> da -> m ()) -> UpdateStore m da
mkUpdateStore m (Either SomeException a)
loadS a -> m ()
writeS Maybe a -> da -> m ()
updateS =
    Store{m (Either SomeException a)
m (Either SomeException (Base da))
loadS :: m (Either SomeException (Base da))
loadS :: m (Either SomeException a)
loadS, queryS :: forall b. Whole a b -> m b
queryS=Whole a b -> m b
forall b. Whole a b -> m b
query', a -> m ()
Base da -> m ()
writeS :: Base da -> m ()
writeS :: a -> m ()
writeS, Maybe a -> da -> m ()
Maybe (Base da) -> da -> m ()
updateS :: Maybe (Base da) -> da -> m ()
updateS :: Maybe a -> da -> m ()
updateS}
  where
    query' :: forall b. Whole a b -> m b
    query' :: forall b. Whole a b -> m b
query' Whole a b
Whole = m (Either SomeException a)
loadS m (Either SomeException a)
-> (Either SomeException a -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either SomeException a -> m a
Either SomeException a -> m b
forall (m :: * -> *) b.
MonadThrow m =>
Either SomeException b -> m b
throwLeft

-- | @mkQueryStore queryS store@ constructs a 'Store'
-- from a query and an 'UpdateStore'.
mkQueryStore :: forall m qa da
     . (MonadThrow m, Delta da, Query qa, Base da ~ World qa)
    => (forall b. qa b -> m b)
    -> UpdateStore m da
    -> Store m qa da
mkQueryStore :: forall (m :: * -> *) (qa :: * -> *) da.
(MonadThrow m, Delta da, Query qa, Base da ~ World qa) =>
(forall b. qa b -> m b) -> UpdateStore m da -> Store m qa da
mkQueryStore forall b. qa b -> m b
queryS Store{m (Either SomeException (Base da))
loadS :: forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> m (Either SomeException (Base da))
loadS :: m (Either SomeException (Base da))
loadS,Base da -> m ()
writeS :: forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Base da -> m ()
writeS :: Base da -> m ()
writeS,Maybe (Base da) -> da -> m ()
updateS :: forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Maybe (Base da) -> da -> m ()
updateS :: Maybe (Base da) -> da -> m ()
updateS} =
    Store{qa b -> m b
forall b. qa b -> m b
queryS :: forall b. qa b -> m b
queryS :: forall b. qa b -> m b
queryS,m (Either SomeException (Base da))
loadS :: m (Either SomeException (Base da))
loadS :: m (Either SomeException (Base da))
loadS,Base da -> m ()
writeS :: Base da -> m ()
writeS :: Base da -> m ()
writeS,Maybe (Base da) -> da -> m ()
updateS :: Maybe (Base da) -> da -> m ()
updateS :: Maybe (Base da) -> da -> m ()
updateS}

{-------------------------------------------------------------------------------
    Query
-------------------------------------------------------------------------------}
-- | A __query__ @qa b@ for the type @a ~ World qa@
-- corresponds to a function @a -> b@.
-- Put differently, a query allows us to extract some information of type @b@
-- from the larger type @a@.
--
-- Typically, instances of 'Query' are
-- generalized algebraic data types (GADT).
class Query qa where
    type family World qa
    query :: qa b -> World qa -> b

-- | The query that retrieves the whole value.
data Whole a b where
    Whole :: Whole a a

instance Query (Whole a) where
    type World (Whole a) = a
    query :: forall b. Whole a b -> World (Whole a) -> b
query Whole a b
Whole World (Whole a)
a = b
World (Whole a)
a

{-------------------------------------------------------------------------------
    Combinators
-------------------------------------------------------------------------------}
-- | Add a caching layer to a 'Store'.
--
-- Access to the underlying 'Store' is enforced to be sequential,
-- but the cache can be accessed in parallel.
--
-- FIXME: There is still a small race condition where the cache
-- could be written twice before it is filled. 🤔
-- TODO: Think about whether it is really necessary to handle concurrency here.
-- I think the answer is "yes", but only because the mutable variables
-- provided by the monad @m@ do not work together with e.g. SQL transactions.
newCachedStore
    :: forall m qa da
      . ( MonadSTM m, MonadThrow m, MonadEvaluate m
        , Delta da, Query qa, Base da ~ World qa
        )
    => Store m qa da -> m (Store m qa da)
newCachedStore :: forall (m :: * -> *) (qa :: * -> *) da.
(MonadSTM m, MonadThrow m, MonadEvaluate m, Delta da, Query qa,
 Base da ~ World qa) =>
Store m qa da -> m (Store m qa da)
newCachedStore Store{m (Either SomeException (Base da))
loadS :: forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> m (Either SomeException (Base da))
loadS :: m (Either SomeException (Base da))
loadS,Base da -> m ()
writeS :: forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Base da -> m ()
writeS :: Base da -> m ()
writeS,Maybe (Base da) -> da -> m ()
updateS :: forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Maybe (Base da) -> da -> m ()
updateS :: Maybe (Base da) -> da -> m ()
updateS} = do
    -- Lock that puts loadS, writeS and updateS into sequence
    TVar m Bool
islocked <- Bool -> m (TVar m Bool)
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO Bool
False
    let withLock :: forall b. m b -> m b
        withLock :: forall b. m b -> m b
withLock m b
action = do
            STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ TVar m Bool -> STM m Bool
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m Bool
islocked STM m Bool -> (Bool -> STM m ()) -> STM m ()
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Bool
True  -> STM m ()
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
                Bool
False -> TVar m Bool -> Bool -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m Bool
islocked Bool
True
            m b
action m b -> m () -> m b
forall a b. m a -> m b -> m a
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally` STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (TVar m Bool -> Bool -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m Bool
islocked Bool
False)

    -- Cache that need not be filled in the beginning
    TVar m (Maybe (World qa))
cache    <- Maybe (World qa) -> m (TVar m (Maybe (World qa)))
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO (Maybe (Base da)
Maybe (World qa)
forall a. Maybe a
Nothing :: Maybe (Base da))
    let writeCache :: Maybe (World qa) -> STM m ()
writeCache = TVar m (Maybe (World qa)) -> Maybe (World qa) -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (Maybe (World qa))
cache

    -- Load the value from the Store only if it is not cached and
    -- nobody else is writing to the store.
    let load :: m (Either SomeException (Base da))
        load :: m (Either SomeException (Base da))
load = m (m (Either SomeException (Base da)))
-> m (Either SomeException (Base da))
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m (Either SomeException (Base da)))
 -> m (Either SomeException (Base da)))
-> m (m (Either SomeException (Base da)))
-> m (Either SomeException (Base da))
forall a b. (a -> b) -> a -> b
$ STM m (m (Either SomeException (Base da)))
-> m (m (Either SomeException (Base da)))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (m (Either SomeException (Base da)))
 -> m (m (Either SomeException (Base da))))
-> STM m (m (Either SomeException (Base da)))
-> m (m (Either SomeException (Base da)))
forall a b. (a -> b) -> a -> b
$ do
            Maybe (World qa)
ma <- TVar m (Maybe (World qa)) -> STM m (Maybe (World qa))
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (Maybe (World qa))
cache
            case Maybe (World qa)
ma of
                Maybe (World qa)
Nothing -> TVar m Bool -> STM m Bool
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m Bool
islocked STM m Bool
-> (Bool -> STM m (m (Either SomeException (World qa))))
-> STM m (m (Either SomeException (World qa)))
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Bool
True  -> STM m (m (Either SomeException (World qa)))
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry  -- somebody is writing
                    Bool
False -> m (Either SomeException (World qa))
-> STM m (m (Either SomeException (World qa)))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (Either SomeException (World qa))
 -> STM m (m (Either SomeException (World qa))))
-> m (Either SomeException (World qa))
-> STM m (m (Either SomeException (World qa)))
forall a b. (a -> b) -> a -> b
$ m (Either SomeException (World qa))
-> m (Either SomeException (World qa))
forall b. m b -> m b
withLock (m (Either SomeException (World qa))
 -> m (Either SomeException (World qa)))
-> m (Either SomeException (World qa))
-> m (Either SomeException (World qa))
forall a b. (a -> b) -> a -> b
$ do
                        Either SomeException (World qa)
ea <- m (Either SomeException (Base da))
m (Either SomeException (World qa))
loadS
                        case Either SomeException (World qa)
ea of
                            Left  SomeException
e -> Either SomeException (World qa)
-> m (Either SomeException (World qa))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException (World qa)
 -> m (Either SomeException (World qa)))
-> Either SomeException (World qa)
-> m (Either SomeException (World qa))
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException (World qa)
forall a b. a -> Either a b
Left SomeException
e
                            Right World qa
a -> do
                                STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe (World qa) -> STM m ()
writeCache (Maybe (World qa) -> STM m ()) -> Maybe (World qa) -> STM m ()
forall a b. (a -> b) -> a -> b
$ World qa -> Maybe (World qa)
forall a. a -> Maybe a
Just World qa
a
                                Either SomeException (World qa)
-> m (Either SomeException (World qa))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException (World qa)
 -> m (Either SomeException (World qa)))
-> Either SomeException (World qa)
-> m (Either SomeException (World qa))
forall a b. (a -> b) -> a -> b
$ World qa -> Either SomeException (World qa)
forall a b. b -> Either a b
Right World qa
a
                Just World qa
a -> m (Either SomeException (World qa))
-> STM m (m (Either SomeException (World qa)))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (Either SomeException (World qa))
 -> STM m (m (Either SomeException (World qa))))
-> m (Either SomeException (World qa))
-> STM m (m (Either SomeException (World qa)))
forall a b. (a -> b) -> a -> b
$ Either SomeException (World qa)
-> m (Either SomeException (World qa))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException (World qa)
 -> m (Either SomeException (World qa)))
-> Either SomeException (World qa)
-> m (Either SomeException (World qa))
forall a b. (a -> b) -> a -> b
$ World qa -> Either SomeException (World qa)
forall a b. b -> Either a b
Right World qa
a

    Store m qa da -> m (Store m qa da)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Store m qa da -> m (Store m qa da))
-> Store m qa da -> m (Store m qa da)
forall a b. (a -> b) -> a -> b
$ Store
        { loadS :: m (Either SomeException (Base da))
loadS = m (Either SomeException (Base da))
load
        , queryS :: forall b. qa b -> m b
queryS = \qa b
q -> qa b -> World qa -> b
forall b. qa b -> World qa -> b
forall (qa :: * -> *) b. Query qa => qa b -> World qa -> b
query qa b
q (World qa -> b) -> m (World qa) -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Either SomeException (World qa) -> m (World qa)
forall (m :: * -> *) b.
MonadThrow m =>
Either SomeException b -> m b
throwLeft (Either SomeException (World qa) -> m (World qa))
-> m (Either SomeException (World qa)) -> m (World qa)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Either SomeException (Base da))
m (Either SomeException (World qa))
load)
        , writeS :: Base da -> m ()
writeS = \Base da
a -> m () -> m ()
forall b. m b -> m b
withLock (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe (World qa) -> STM m ()
writeCache (World qa -> Maybe (World qa)
forall a. a -> Maybe a
Just Base da
World qa
a)
            Base da -> m ()
writeS Base da
a
        , updateS :: Maybe (Base da) -> da -> m ()
updateS = m (Either SomeException (Base da))
-> (SomeException -> m ())
-> (Base da -> da -> m ())
-> Maybe (Base da)
-> da
-> m ()
forall e (m :: * -> *) t b da.
(Exception e, Monad m) =>
m (Either e t)
-> (e -> m b) -> (t -> da -> m b) -> Maybe t -> da -> m b
updateLoad m (Either SomeException (Base da))
load SomeException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ((Base da -> da -> m ()) -> Maybe (Base da) -> da -> m ())
-> (Base da -> da -> m ()) -> Maybe (Base da) -> da -> m ()
forall a b. (a -> b) -> a -> b
$ \Base da
old da
delta -> m () -> m ()
forall b. m b -> m b
withLock (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            World qa
new <- World qa -> m (World qa)
forall a. a -> m a
forall (m :: * -> *) a. MonadEvaluate m => a -> m a
evaluate (World qa -> m (World qa)) -> World qa -> m (World qa)
forall a b. (a -> b) -> a -> b
$ da -> Base da -> Base da
forall delta. Delta delta => delta -> Base delta -> Base delta
apply da
delta Base da
old
            STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe (World qa) -> STM m ()
writeCache (Maybe (World qa) -> STM m ()) -> Maybe (World qa) -> STM m ()
forall a b. (a -> b) -> a -> b
$ World qa -> Maybe (World qa)
forall a. a -> Maybe a
Just World qa
new
            Maybe (Base da) -> da -> m ()
updateS (World qa -> Maybe (World qa)
forall a. a -> Maybe a
Just Base da
World qa
old) da
delta
        }

-- | Store one type in the 'Store' of another type by using an 'Embedding'.
embedStore :: (MonadSTM m, MonadMask m, Delta da)
    => Embedding da db -> UpdateStore m db -> m (UpdateStore m da)
embedStore :: forall (m :: * -> *) da db.
(MonadSTM m, MonadMask m, Delta da) =>
Embedding da db -> UpdateStore m db -> m (UpdateStore m da)
embedStore Embedding da db
embed UpdateStore m db
bstore = do
    -- For reasons of efficiency, we have to store the 'Machine'
    -- that is created within the 'Embedding'.
    TVar m (Maybe (Machine da db))
machine <- Maybe (Machine da db) -> m (TVar m (Maybe (Machine da db)))
forall a. a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO Maybe (Machine da db)
forall a. Maybe a
Nothing
    let readMachine :: m (Maybe (Machine da db))
readMachine  = TVar m (Maybe (Machine da db)) -> m (Maybe (Machine da db))
forall a. TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m (Maybe (Machine da db))
machine
        writeMachine :: Machine da db -> m ()
writeMachine = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ())
-> (Machine da db -> STM m ()) -> Machine da db -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar m (Maybe (Machine da db)) -> Maybe (Machine da db) -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (Maybe (Machine da db))
machine (Maybe (Machine da db) -> STM m ())
-> (Machine da db -> Maybe (Machine da db))
-> Machine da db
-> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Machine da db -> Maybe (Machine da db)
forall a. a -> Maybe a
Just

    -- Operations of the result 'Store'.
    let load :: m (Either SomeException (Base da))
load = UpdateStore m db -> m (Either SomeException (Base db))
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> m (Either SomeException (Base da))
loadS UpdateStore m db
bstore m (Either SomeException (Base db))
-> (Either SomeException (Base db)
    -> m (Either SomeException (Base da)))
-> m (Either SomeException (Base da))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left  SomeException
e -> Either SomeException (Base da)
-> m (Either SomeException (Base da))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException (Base da)
 -> m (Either SomeException (Base da)))
-> Either SomeException (Base da)
-> m (Either SomeException (Base da))
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException (Base da)
forall a b. a -> Either a b
Left SomeException
e
            Right Base db
b -> case Embedding da db
-> Base db -> Either SomeException (Base da, Machine da db)
forall da db.
Embedding da db
-> Base db -> Either SomeException (Base da, Machine da db)
project Embedding da db
embed Base db
b of
                Left  SomeException
e       -> Either SomeException (Base da)
-> m (Either SomeException (Base da))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException (Base da)
 -> m (Either SomeException (Base da)))
-> Either SomeException (Base da)
-> m (Either SomeException (Base da))
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException (Base da)
forall a b. a -> Either a b
Left SomeException
e
                Right (Base da
a,Machine da db
mab) -> do
                    Machine da db -> m ()
writeMachine Machine da db
mab
                    Either SomeException (Base da)
-> m (Either SomeException (Base da))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException (Base da)
 -> m (Either SomeException (Base da)))
-> Either SomeException (Base da)
-> m (Either SomeException (Base da))
forall a b. (a -> b) -> a -> b
$ Base da -> Either SomeException (Base da)
forall a b. b -> Either a b
Right Base da
a
        write :: Base da -> m ()
write Base da
a = do
            let mab :: Machine da db
mab = Embedding da db -> Base da -> Machine da db
forall da db. Embedding da db -> Base da -> Machine da db
inject Embedding da db
embed Base da
a
            ((forall a. m a -> m a) -> m ()) -> m ()
forall b. ((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m ()) -> m ())
-> ((forall a. m a -> m a) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
                m () -> m ()
forall a. m a -> m a
restore (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ UpdateStore m db -> Base db -> m ()
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Base da -> m ()
writeS UpdateStore m db
bstore (Machine da db -> Base db
forall da db. Machine da db -> Base db
state_ Machine da db
mab)
                Machine da db -> m ()
writeMachine Machine da db
mab
        update :: Maybe (Base da) -> da -> m ()
update = m (Either SomeException (Base da))
-> (SomeException -> m ())
-> (Base da -> da -> m ())
-> Maybe (Base da)
-> da
-> m ()
forall e (m :: * -> *) t b da.
(Exception e, Monad m) =>
m (Either e t)
-> (e -> m b) -> (t -> da -> m b) -> Maybe t -> da -> m b
updateLoad m (Either SomeException (Base da))
load SomeException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO ((Base da -> da -> m ()) -> Maybe (Base da) -> da -> m ())
-> (Base da -> da -> m ()) -> Maybe (Base da) -> da -> m ()
forall a b. (a -> b) -> a -> b
$ \Base da
a da
da -> do
            m (Maybe (Machine da db))
readMachine m (Maybe (Machine da db))
-> (Maybe (Machine da db) -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe (Machine da db)
Nothing   -> do -- we were missing the initial write
                    Base da -> m ()
write (da -> Base da -> Base da
forall delta. Delta delta => delta -> Base delta -> Base delta
apply da
da Base da
a)
                Just Machine da db
mab1 -> do -- advance the machine by one step
                    let (db
db, Machine da db
mab2) = Machine da db -> (Base da, da) -> (db, Machine da db)
forall da db. Machine da db -> (Base da, da) -> (db, Machine da db)
step_ Machine da db
mab1 (Base da
a,da
da)
                    ((forall a. m a -> m a) -> m ()) -> m ()
forall b. ((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m ()) -> m ())
-> ((forall a. m a -> m a) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
                        m () -> m ()
forall a. m a -> m a
restore (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ UpdateStore m db -> Maybe (Base db) -> db -> m ()
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Maybe (Base da) -> da -> m ()
updateS UpdateStore m db
bstore (Base db -> Maybe (Base db)
forall a. a -> Maybe a
Just (Base db -> Maybe (Base db)) -> Base db -> Maybe (Base db)
forall a b. (a -> b) -> a -> b
$ Machine da db -> Base db
forall da db. Machine da db -> Base db
state_ Machine da db
mab2) db
db
                        Machine da db -> m ()
writeMachine Machine da db
mab2
    UpdateStore m da -> m (UpdateStore m da)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UpdateStore m da -> m (UpdateStore m da))
-> UpdateStore m da -> m (UpdateStore m da)
forall a b. (a -> b) -> a -> b
$ m (Either SomeException (Base da))
-> (Base da -> m ())
-> (Maybe (Base da) -> da -> m ())
-> UpdateStore m da
forall (m :: * -> *) a da.
(Monad m, MonadThrow m, a ~ Base da, Delta da) =>
m (Either SomeException a)
-> (a -> m ()) -> (Maybe a -> da -> m ()) -> UpdateStore m da
mkUpdateStore m (Either SomeException (Base da))
load Base da -> m ()
write Maybe (Base da) -> da -> m ()
update

-- | Store one type in the 'Store' of another type by using an 'Embedding'.
--
-- Note: This function is exported for testing and documentation only,
-- use the more efficient 'embedStore' instead.
embedStore'
    :: (Monad m, MonadThrow m)
    => Embedding' da db -> UpdateStore m db -> UpdateStore m da
embedStore' :: forall (m :: * -> *) da db.
(Monad m, MonadThrow m) =>
Embedding' da db -> UpdateStore m db -> UpdateStore m da
embedStore' Embedding'{b -> Either SomeException a
load :: b -> Either SomeException a
load :: ()
load,a -> b
write :: a -> b
write :: ()
write,a -> b -> da -> db
update :: a -> b -> da -> db
update :: ()
update} Store{m (Either SomeException (Base db))
loadS :: forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> m (Either SomeException (Base da))
loadS :: m (Either SomeException (Base db))
loadS,Base db -> m ()
writeS :: forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Base da -> m ()
writeS :: Base db -> m ()
writeS,Maybe (Base db) -> db -> m ()
updateS :: forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Maybe (Base da) -> da -> m ()
updateS :: Maybe (Base db) -> db -> m ()
updateS} =
    let
        loadL :: m (Either SomeException a)
loadL =  (b -> Either SomeException a
load (b -> Either SomeException a)
-> Either SomeException b -> Either SomeException a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (Either SomeException b -> Either SomeException a)
-> m (Either SomeException b) -> m (Either SomeException a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Either SomeException b)
m (Either SomeException (Base db))
loadS
        updateL :: Maybe a -> da -> m ()
updateL Maybe a
ma da
da = case Maybe a
ma of
            Just a
a -> m (Either SomeException b)
m (Either SomeException (Base db))
loadS m (Either SomeException b)
-> (Either SomeException b -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Left  SomeException
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                Right b
b -> Maybe (Base db) -> db -> m ()
updateS (b -> Maybe b
forall a. a -> Maybe a
Just b
b) (a -> b -> da -> db
update a
a b
b da
da)
            Maybe a
Nothing -> do
                Either SomeException a
ea <- m (Either SomeException a)
loadL
                case Either SomeException a
ea of
                    Left  SomeException
e -> SomeException -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
                    Right a
a -> Maybe a -> da -> m ()
updateL (a -> Maybe a
forall a. a -> Maybe a
Just a
a) da
da
    in  m (Either SomeException a)
-> (a -> m ())
-> (Maybe a -> da -> m ())
-> Store m (Whole (Base da)) da
forall (m :: * -> *) a da.
(Monad m, MonadThrow m, a ~ Base da, Delta da) =>
m (Either SomeException a)
-> (a -> m ()) -> (Maybe a -> da -> m ()) -> UpdateStore m da
mkUpdateStore m (Either SomeException a)
loadL (b -> m ()
Base db -> m ()
writeS (b -> m ()) -> (a -> b) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
write) Maybe a -> da -> m ()
updateL

-- | Lift
hoistStore
    :: Monad m
    => (forall a. m a -> n a)
    -> Store m qa da
    -> Store n qa da
hoistStore :: forall (m :: * -> *) (n :: * -> *) (qa :: * -> *) da.
Monad m =>
(forall a. m a -> n a) -> Store m qa da -> Store n qa da
hoistStore forall a. m a -> n a
f Store{m (Either SomeException (Base da))
loadS :: forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> m (Either SomeException (Base da))
loadS :: m (Either SomeException (Base da))
loadS,Base da -> m ()
writeS :: forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Base da -> m ()
writeS :: Base da -> m ()
writeS,Maybe (Base da) -> da -> m ()
updateS :: forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Maybe (Base da) -> da -> m ()
updateS :: Maybe (Base da) -> da -> m ()
updateS,forall b. qa b -> m b
queryS :: forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> forall b. qa b -> m b
queryS :: forall b. qa b -> m b
queryS} = Store
    { loadS :: n (Either SomeException (Base da))
loadS = m (Either SomeException (Base da))
-> n (Either SomeException (Base da))
forall a. m a -> n a
f m (Either SomeException (Base da))
loadS
    , writeS :: Base da -> n ()
writeS = m () -> n ()
forall a. m a -> n a
f (m () -> n ()) -> (Base da -> m ()) -> Base da -> n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base da -> m ()
writeS
    , updateS :: Maybe (Base da) -> da -> n ()
updateS = \Maybe (Base da)
ma -> m () -> n ()
forall a. m a -> n a
f (m () -> n ()) -> (da -> m ()) -> da -> n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Base da) -> da -> m ()
updateS Maybe (Base da)
ma
    , queryS :: forall b. qa b -> n b
queryS = m b -> n b
forall a. m a -> n a
f (m b -> n b) -> (qa b -> m b) -> qa b -> n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. qa b -> m b
forall b. qa b -> m b
queryS
    }

-- | Combine two 'Stores' into a 'Store' for pairs.
--
-- TODO: Handle the case where 'writeS' or 'updateS' throw an exception
-- and partially break the 'Store'.
pairStores
    :: Monad m
    => Store m qa da
    -> Store m qb db
    -> Store m (qa :+: qb) (da,db)
pairStores :: forall (m :: * -> *) (qa :: * -> *) da (qb :: * -> *) db.
Monad m =>
Store m qa da -> Store m qb db -> Store m (qa :+: qb) (da, db)
pairStores Store m qa da
sa Store m qb db
sb = Store
    { loadS :: m (Either SomeException (Base (da, db)))
loadS = (Base da -> Base db -> (Base da, Base db))
-> Either SomeException (Base da)
-> Either SomeException (Base db)
-> Either SomeException (Base da, Base db)
forall a b c.
(a -> b -> c)
-> Either SomeException a
-> Either SomeException b
-> Either SomeException c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (Either SomeException (Base da)
 -> Either SomeException (Base db)
 -> Either SomeException (Base da, Base db))
-> m (Either SomeException (Base da))
-> m (Either SomeException (Base db)
      -> Either SomeException (Base da, Base db))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Store m qa da -> m (Either SomeException (Base da))
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> m (Either SomeException (Base da))
loadS Store m qa da
sa m (Either SomeException (Base db)
   -> Either SomeException (Base da, Base db))
-> m (Either SomeException (Base db))
-> m (Either SomeException (Base da, Base db))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Store m qb db -> m (Either SomeException (Base db))
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> m (Either SomeException (Base da))
loadS Store m qb db
sb
    , queryS :: forall b. (:+:) qa qb b -> m b
queryS = \case
        L1 qa b
qa -> Store m qa da -> forall b. qa b -> m b
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> forall b. qa b -> m b
queryS Store m qa da
sa qa b
qa
        R1 qb b
qb -> Store m qb db -> forall b. qb b -> m b
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> forall b. qa b -> m b
queryS Store m qb db
sb qb b
qb
    , writeS :: Base (da, db) -> m ()
writeS = \(Base da
a,Base db
b) -> Store m qa da -> Base da -> m ()
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Base da -> m ()
writeS Store m qa da
sa Base da
a m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Store m qb db -> Base db -> m ()
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Base da -> m ()
writeS Store m qb db
sb Base db
b
    , updateS :: Maybe (Base (da, db)) -> (da, db) -> m ()
updateS = \Maybe (Base (da, db))
mi (da
da,db
db) ->
        case Maybe (Base (da, db))
mi of
            Maybe (Base (da, db))
Nothing -> Store m qa da -> Maybe (Base da) -> da -> m ()
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Maybe (Base da) -> da -> m ()
updateS Store m qa da
sa Maybe (Base da)
forall a. Maybe a
Nothing da
da m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Store m qb db -> Maybe (Base db) -> db -> m ()
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Maybe (Base da) -> da -> m ()
updateS Store m qb db
sb Maybe (Base db)
forall a. Maybe a
Nothing db
db
            Just (Base da
a,Base db
b) -> Store m qa da -> Maybe (Base da) -> da -> m ()
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Maybe (Base da) -> da -> m ()
updateS Store m qa da
sa (Base da -> Maybe (Base da)
forall a. a -> Maybe a
Just Base da
a) da
da m () -> m () -> m ()
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Store m qb db -> Maybe (Base db) -> db -> m ()
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> Maybe (Base da) -> da -> m ()
updateS Store m qb db
sb (Base db -> Maybe (Base db)
forall a. a -> Maybe a
Just Base db
b) db
db
    }

{-------------------------------------------------------------------------------
    Helpers
-------------------------------------------------------------------------------}
-- | Helper for implementing `updateS`
-- for the case where a value is not yet loaded.
updateLoad :: (Exception e, Monad m)
    => m (Either e t) -- ^ How to load the value.
    -> (e -> m b) -- ^ What to do with the error when loading the value.
    -> (t -> da -> m b) -- ^ What to do with the value.
    -> Maybe t -- ^ Value, maybe loaded, maybe not.
    -> da -- ^ Delta.
    -> m b
updateLoad :: forall e (m :: * -> *) t b da.
(Exception e, Monad m) =>
m (Either e t)
-> (e -> m b) -> (t -> da -> m b) -> Maybe t -> da -> m b
updateLoad m (Either e t)
load e -> m b
handle t -> da -> m b
update' Maybe t
Nothing da
da = do
    Either e t
ea <- m (Either e t)
load
    case Either e t
ea of
        Left e
e -> e -> m b
handle e
e
        Right t
x -> t -> da -> m b
update' t
x da
da
updateLoad m (Either e t)
_load e -> m b
_  t -> da -> m b
update' (Just t
x) da
da = t -> da -> m b
update' t
x da
da

-- | Throw 'Left' as an exception in the monad.
throwLeft :: MonadThrow m => Either SomeException b -> m b
throwLeft :: forall (m :: * -> *) b.
MonadThrow m =>
Either SomeException b -> m b
throwLeft = \case
    Left (SomeException e
e) -> e -> m b
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO e
e
    Right b
a -> b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
a

-- | Helper for implementing `updateS`.
-- Call 'loadS' from a 'Store' if the value is not already given in memory.
loadWhenNothing
    :: (Monad m, MonadThrow m, Delta da)
    => Maybe (Base da) -> Store m qa da -> m (Base da)
loadWhenNothing :: forall (m :: * -> *) da (qa :: * -> *).
(Monad m, MonadThrow m, Delta da) =>
Maybe (Base da) -> Store m qa da -> m (Base da)
loadWhenNothing (Just Base da
a) Store m qa da
_ = Base da -> m (Base da)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Base da
a
loadWhenNothing Maybe (Base da)
Nothing Store m qa da
store = Store m qa da -> m (Either SomeException (Base da))
forall (m :: * -> *) (qa :: * -> *) da.
Store m qa da -> m (Either SomeException (Base da))
loadS Store m qa da
store m (Either SomeException (Base da))
-> (Either SomeException (Base da) -> m (Base da)) -> m (Base da)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either SomeException (Base da) -> m (Base da)
forall (m :: * -> *) b.
MonadThrow m =>
Either SomeException b -> m b
throwLeft

updateSequence
    :: (Monad m, Delta delta)
    => (Base delta -> delta -> m ())
    -> Base delta
    -> [delta]
    -> m ()
updateSequence :: forall (m :: * -> *) delta.
(Monad m, Delta delta) =>
(Base delta -> delta -> m ()) -> Base delta -> [delta] -> m ()
updateSequence Base delta -> delta -> m ()
f Base delta
s = (Base delta -> delta -> m (Base delta))
-> Base delta -> [delta] -> m ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ Base delta -> delta -> m (Base delta)
update' Base delta
s ([delta] -> m ()) -> ([delta] -> [delta]) -> [delta] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [delta] -> [delta]
forall a. [a] -> [a]
reverse
  where
    update' :: Base delta -> delta -> m (Base delta)
update' Base delta
s' delta
da = Base delta -> delta -> m ()
f Base delta
s' delta
da m () -> m (Base delta) -> m (Base delta)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Base delta -> m (Base delta)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (delta
da delta -> Base delta -> Base delta
forall delta. Delta delta => delta -> Base delta -> Base delta
`apply` Base delta
s')