{-# OPTIONS_GHC -Wno-redundant-constraints#-}
-- We intentionally specify more constraints than necessary for some exports.
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Data.DBVar (
    -- * Synopsis
    -- | 'DBVar' represents a mutable variable whose value is kept in memory,
    -- but which is written to the hard drive on every update.
    -- This provides a convenient interface for persisting
    -- values across program runs.
    -- For efficient updates, delta encodings are used, see "Data.Delta".
    --
    -- 'Store' represent a storage facility to which the 'DBVar'
    -- is written.

    -- * DBVar
      DBVar
    , readDBVar, updateDBVar, modifyDBVar, modifyDBMaybe
    , initDBVar, loadDBVar

    -- * Store
    , Store (..)
    , newStore
    , NotInitialized (..)
    -- $EitherSomeException
    , embedStore, pairStores

    -- * Testing
    , embedStore'
    ) where

import Prelude

import Control.Applicative
    ( liftA2 )
import Control.Exception
    ( Exception, SomeException, toException )
import Control.Monad.Class.MonadSTM
    ( MonadSTM
    , atomically
    , modifyTVar'
    , newTVarIO
    , readTVar
    , readTVarIO
    , retry
    , writeTVar
    )
import Control.Monad.Class.MonadThrow
    ( MonadEvaluate, MonadMask, MonadThrow, bracket, evaluate, mask, throwIO )
import Data.Delta
    ( Delta (..), Embedding, Embedding' (..), Machine (..), inject, project )

{-------------------------------------------------------------------------------
    DBVar
-------------------------------------------------------------------------------}
-- | A 'DBVar'@ m delta@ is a mutable reference to a Haskell value of type @a@.
-- The type @delta@ is a delta encoding for this value type @a@,
-- that is we have @a ~ @'Base'@ delta@.
--
-- The Haskell value is cached in memory, in weak head normal form (WHNF).
-- However, whenever the value is updated, a copy of will be written
-- to persistent storage like a file or database on the hard disk;
-- any particular storage is specified by the 'Store' type.
-- For efficient updates, the delta encoding @delta@ is used in the update.
--
-- Concurrency:
--
-- * Updates are atomic and will block other updates.
-- * Reads will /not/ be blocked during an update
--   (except for a small moment where the new value atomically
--    replaces the old one).
data DBVar m delta = DBVar
    { DBVar m delta -> m (Base delta)
readDBVar_     :: m (Base delta)
    , DBVar m delta -> forall b. (Base delta -> (Maybe delta, b)) -> m b
modifyDBMaybe_ :: forall b. (Base delta -> (Maybe delta, b)) -> m b
    }

-- | Read the current value of the 'DBVar'.
readDBVar :: (Delta da, a ~ Base da) => DBVar m da -> m a
readDBVar :: DBVar m da -> m a
readDBVar = DBVar m da -> m a
forall (m :: * -> *) delta. DBVar m delta -> m (Base delta)
readDBVar_

-- | Update the value of the 'DBVar' using a delta encoding.
--
-- The new value will be evaluated to weak head normal form.
updateDBVar :: (Delta da, Monad m) => DBVar m da -> da -> m ()
updateDBVar :: DBVar m da -> da -> m ()
updateDBVar DBVar m da
var da
delta = DBVar m da -> (Base da -> (Maybe da, ())) -> m ()
forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar m da
var ((Base da -> (Maybe da, ())) -> m ())
-> (Base da -> (Maybe da, ())) -> m ()
forall a b. (a -> b) -> a -> b
$ \Base da
_ -> (da -> Maybe da
forall a. a -> Maybe a
Just da
delta,())

-- | Modify the value in a 'DBVar'.
--
-- The new value will be evaluated to weak head normal form.
modifyDBVar
    :: (Delta da, Monad m, a ~ Base da)
    => DBVar m da -> (a -> (da, b)) -> m b
modifyDBVar :: DBVar m da -> (a -> (da, b)) -> m b
modifyDBVar DBVar m da
var a -> (da, b)
f = DBVar m da -> (a -> (Maybe da, b)) -> m b
forall da (m :: * -> *) a b.
(Delta da, Monad m, a ~ Base da) =>
DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe DBVar m da
var ((a -> (Maybe da, b)) -> m b) -> (a -> (Maybe da, b)) -> m b
forall a b. (a -> b) -> a -> b
$ \a
a -> let (da
da,b
b) = a -> (da, b)
f a
a in (da -> Maybe da
forall a. a -> Maybe a
Just da
da,b
b)

-- | Maybe modify the value in a 'DBVar'
--
-- If updated, the new value will be evaluated to weak head normal form.
modifyDBMaybe
    :: (Delta da, Monad m, a ~ Base da)
    => DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe :: DBVar m da -> (a -> (Maybe da, b)) -> m b
modifyDBMaybe = DBVar m da -> (a -> (Maybe da, b)) -> m b
forall (m :: * -> *) delta.
DBVar m delta -> forall b. (Base delta -> (Maybe delta, b)) -> m b
modifyDBMaybe_

-- | Initialize a new 'DBVar' for a given 'Store'.
initDBVar
    ::  ( MonadSTM m, MonadThrow m, MonadEvaluate m, MonadMask m
        , Delta da, a ~ Base da
        )
    => Store m da -- ^ 'Store' for writing.
    -> a -- ^ Initial value.
    -> m (DBVar m da)
initDBVar :: Store m da -> a -> m (DBVar m da)
initDBVar Store m da
store a
v = do
    Store m da -> Base da -> m ()
forall (m :: * -> *) da. Store m da -> Base da -> m ()
writeS Store m da
store a
Base da
v
    (a -> da -> m ()) -> a -> m (DBVar m da)
forall (m :: * -> *) da a.
(MonadSTM m, MonadThrow m, MonadMask m, MonadEvaluate m, Delta da,
 a ~ Base da) =>
(a -> da -> m ()) -> a -> m (DBVar m da)
newWithCache (Store m da -> Base da -> da -> m ()
forall (m :: * -> *) da. Store m da -> Base da -> da -> m ()
updateS Store m da
store) a
v

-- | Create a 'DBVar' by loading its value from an existing 'Store'
-- Throws an exception if the value cannot be loaded.
loadDBVar
    ::  ( MonadSTM m, MonadThrow m, MonadEvaluate m, MonadMask m
        , Delta da
        )
    => Store m da -- ^ 'Store' for writing and for reading the initial value.
    -> m (DBVar m da)
loadDBVar :: Store m da -> m (DBVar m da)
loadDBVar Store m da
store =
    Store m da -> m (Either SomeException (Base da))
forall (m :: * -> *) da.
Store m da -> m (Either SomeException (Base da))
loadS Store m da
store m (Either SomeException (Base da))
-> (Either SomeException (Base da) -> m (DBVar m da))
-> m (DBVar m da)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left  SomeException
e -> SomeException -> m (DBVar m da)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
        Right Base da
a -> (Base da -> da -> m ()) -> Base da -> m (DBVar m da)
forall (m :: * -> *) da a.
(MonadSTM m, MonadThrow m, MonadMask m, MonadEvaluate m, Delta da,
 a ~ Base da) =>
(a -> da -> m ()) -> a -> m (DBVar m da)
newWithCache (Store m da -> Base da -> da -> m ()
forall (m :: * -> *) da. Store m da -> Base da -> da -> m ()
updateS Store m da
store) Base da
a

-- | Create 'DBVar' from an initial value and an update function
-- using a 'TVar' as in-memory cache.
--
-- Space: The value in the 'TVar' will be evaluated to weak head normal form.
--
-- Concurrency: The update function needs to be atomic even in the presence
-- of asynchronous exceptions.
newWithCache
    ::  ( MonadSTM m, MonadThrow m, MonadMask m, MonadEvaluate m
        , Delta da, a ~ Base da
        )
    => (a -> da -> m ()) -> a -> m (DBVar m da)
newWithCache :: (a -> da -> m ()) -> a -> m (DBVar m da)
newWithCache a -> da -> m ()
update a
a = do
    TVar m a
cache  <- a -> m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO a
a
    TVar m Bool
locked <- Bool -> m (TVar m Bool)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO Bool
False   -- lock for updating the cache
    DBVar m da -> m (DBVar m da)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DBVar m da -> m (DBVar m da)) -> DBVar m da -> m (DBVar m da)
forall a b. (a -> b) -> a -> b
$ DBVar :: forall (m :: * -> *) delta.
m (Base delta)
-> (forall b. (Base delta -> (Maybe delta, b)) -> m b)
-> DBVar m delta
DBVar
        { readDBVar_ :: m (Base da)
readDBVar_     = TVar m a -> m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> m a
readTVarIO TVar m a
cache
        , modifyDBMaybe_ :: forall b. (Base da -> (Maybe da, b)) -> m b
modifyDBMaybe_ = \Base da -> (Maybe da, b)
f -> do
            let before :: m a
before = STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m a -> m a) -> STM m a -> m a
forall a b. (a -> b) -> a -> b
$ do
                    TVar m Bool -> STM m Bool
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m Bool
locked STM m Bool -> (Bool -> STM m a) -> STM m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                        Bool
True  -> STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
                        Bool
False -> do
                            TVar m Bool -> Bool -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m Bool
locked Bool
True
                            TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m a
cache
                after :: a -> m ()
after a
_ = STM m () -> m ()
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 -> Bool -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m Bool
locked Bool
False
                action :: a -> m b
action a
old = do
                    let (Maybe da
mdelta, b
b) = Base da -> (Maybe da, b)
f a
Base da
old
                    case Maybe da
mdelta of
                        Maybe da
Nothing    -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                        Just da
delta -> do
                            a
new <- a -> m a
forall (m :: * -> *) a. MonadEvaluate m => a -> m a
evaluate (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ da -> Base da -> Base da
forall delta. Delta delta => delta -> Base delta -> Base delta
apply da
delta a
Base da
old
                            ((forall a. m a -> m a) -> m ()) -> m ()
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
                                -- We mask asynchronous exceptions here
                                -- to ensure that the TVar will be updated
                                -- whenever @update@ succeeds without exception.
                                m () -> m ()
forall a. m a -> m a
restore (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ a -> da -> m ()
update a
old da
delta
                                STM m () -> m ()
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 a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m a
cache a
new
                    b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b
            m a -> (a -> m ()) -> (a -> m b) -> m b
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket m a
before a -> m ()
after a -> m b
action
        }

{-------------------------------------------------------------------------------
    Store
-------------------------------------------------------------------------------}
{- |
A 'Store' is a storage facility for Haskell values of type @a ~@'Base'@ da@.
Typical use cases are a file or a database on the hard disk.

A 'Store' has many similarities with an 'Embedding'.
The main difference is that storing value in a 'Store' has side effects.
A 'Store' is described by three action:

* 'writeS' writes a value to the store.
* 'loadS' loads a value from the store.
* 'updateS' uses a delta encoding of type @da@ to efficiently update
    the store.
    In order to avoid performing an expensive 'loadS' operation,
    the action 'updateS' expects the value described by the store
    as an argument, but no check is performed whether the provided
    value matches the contents of the store.
    Also, not every store inspects this argument.

A 'Store' is characterized by the following properties:

* 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)

* The store is __redundant__:
    Two stores with different contents may describe
    the same value of type @a@.
    For example, two files with different whitespace
    may describe the same JSON value.
    In general, we have

        > loadS s >>= either (const $ pure ()) (writeS s) ≠  pure ()

* Updating a store __commutes with 'apply'__:
    We have

        > updateS s a da >> loadS s  =  pure $ Right $ apply a da

    However, since the store is redundant, we often have

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

* __Exceptions__:
    It is expected that the functions 'loadS', 'updateS', 'writeS'
    do not throw synchronous exceptions. In the worst case,
    'loadS' should return 'Left' after reading or writing
    to the store was unsuccessful.

* __Concurrency__:
    It is expected that the functions 'updateS' and 'writeS'
    are /atomic/: Either they succeed in updating / writing
    the new value in its entirety, or the old value is kept.
    In particular, we expect this even when one of these
    functions receives an asynchronous exception and needs to abort
    normal operation.
-}

data Store m da = Store
    { Store m da -> m (Either SomeException (Base da))
loadS   :: m (Either SomeException (Base da))
    , Store m da -> Base da -> m ()
writeS  :: Base da -> m ()
    , Store m da -> Base da -> da -> m ()
updateS
        :: Base da -- old value
        -> da -- delta to new value
        -> m () -- write new value
    }

{- HLINT ignore newStore "Use readTVarIO" -}
-- | An in-memory 'Store' from a mutable variable ('TVar').
-- Useful for testing.
newStore :: (Delta da, MonadSTM m) => m (Store m da)
newStore :: m (Store m da)
newStore = do
    TVar m (Either SomeException (Base da))
ref <- Either SomeException (Base da)
-> m (TVar m (Either SomeException (Base da)))
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO (Either SomeException (Base da)
 -> m (TVar m (Either SomeException (Base da))))
-> Either SomeException (Base da)
-> m (TVar 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 -> Either SomeException (Base da))
-> SomeException -> Either SomeException (Base da)
forall a b. (a -> b) -> a -> b
$ NotInitialized -> SomeException
forall e. Exception e => e -> SomeException
toException NotInitialized
NotInitialized
    Store m da -> m (Store m da)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Store m da -> m (Store m da)) -> Store m da -> m (Store m da)
forall a b. (a -> b) -> a -> b
$ Store :: forall (m :: * -> *) da.
m (Either SomeException (Base da))
-> (Base da -> m ()) -> (Base da -> da -> m ()) -> Store m da
Store
        { loadS :: m (Either SomeException (Base da))
loadS   = STM m (Either SomeException (Base da))
-> m (Either SomeException (Base da))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Either SomeException (Base da))
 -> m (Either SomeException (Base da)))
-> STM m (Either SomeException (Base da))
-> m (Either SomeException (Base da))
forall a b. (a -> b) -> a -> b
$ TVar m (Either SomeException (Base da))
-> STM m (Either SomeException (Base da))
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m (Either SomeException (Base da))
ref
        , writeS :: Base da -> m ()
writeS  = STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> (Base da -> STM m ()) -> Base da -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar m (Either SomeException (Base da))
-> Either SomeException (Base da) -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m (Either SomeException (Base da))
ref (Either SomeException (Base da) -> STM m ())
-> (Base da -> Either SomeException (Base da))
-> Base da
-> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base da -> Either SomeException (Base da)
forall a b. b -> Either a b
Right
        , updateS :: Base da -> da -> m ()
updateS = \Base da
_ -> STM m () -> m ()
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 (Base da))
-> (Either SomeException (Base da)
    -> Either SomeException (Base da))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
TVar m a -> (a -> a) -> STM m ()
modifyTVar' TVar m (Either SomeException (Base da))
ref ((Either SomeException (Base da) -> Either SomeException (Base da))
 -> STM m ())
-> (da
    -> Either SomeException (Base da)
    -> Either SomeException (Base da))
-> da
-> STM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Base da -> Base da)
-> Either SomeException (Base da) -> Either SomeException (Base da)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Base da -> Base da)
 -> Either SomeException (Base da)
 -> Either SomeException (Base da))
-> (da -> Base da -> Base da)
-> da
-> Either SomeException (Base da)
-> Either SomeException (Base da)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. da -> Base da -> Base da
forall delta. Delta delta => delta -> Base delta -> Base delta
apply
        }

{- | $EitherSomeException

NOTE: [EitherSomeException]

In this version of the library, the error case returned by 'loadS' and 'load'
is the general 'SomeException' type, which is a disjoint sum of all possible
error types (that is, members of the 'Exception' class).

In a future version of this library, this may be replaced by a more specific
error type, but at the price of introducing a new type parameter @e@ in the
'Store' type.

For now, I have opted to explore a region of the design space
where the number of type parameters is kept to a minimum.
I would argue that making errors visible on the type level is not as
useful as one might hope for, because in exchange for making the types noisier,
the amount of type-safety we gain is very small.
Specifically, if we encounter an element of the 'SomeException' type that
we did not expect, it is entirely ok to '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 need to handle the 'Nothing' case.
But as we are dealing with exceptions, this case does have a default handler,
and there is less need to exclude it at compile as opposed to, say,
the case of an empty list.
-}

-- | 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
/= :: NotInitialized -> NotInitialized -> Bool
$c/= :: NotInitialized -> NotInitialized -> Bool
== :: NotInitialized -> NotInitialized -> Bool
$c== :: 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
showList :: [NotInitialized] -> ShowS
$cshowList :: [NotInitialized] -> ShowS
show :: NotInitialized -> String
$cshow :: NotInitialized -> String
showsPrec :: Int -> NotInitialized -> ShowS
$cshowsPrec :: Int -> NotInitialized -> ShowS
Show)
instance Exception NotInitialized

{-
-- | 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: Safety with respect to asynchronous exceptions?
cachedStore
    :: forall m da. (MonadSTM m, Delta da)
    => Store m da -> m (Store m da)
cachedStore Store{loadS,writeS,updateS} = do
    -- Lock that puts loadS, writeS and updateS into sequence
    islocked <- newTVarIO False
    let withLock :: forall b. m b -> m b
        withLock action = do
            atomically $ readTVar islocked >>= \case
                True  -> retry
                False -> writeTVar islocked True
            a <- action
            atomically $ writeTVar islocked False
            pure a

    -- Cache that need not be filled in the beginning
    iscached <- newTVarIO False
    cache    <- newTVarIO (Nothing :: Maybe (Base da))
    let writeCache ma = writeTVar cache ma >> writeTVar iscached True

    -- Load the value from the Store only if it is not cached and
    -- nobody else is writing to the store.
    let load :: m (Maybe (Base da))
        load = do
            action <- atomically $
                readTVar iscached >>= \case
                    True  -> do
                        ma <- readTVar cache  -- read from cache
                        pure $ pure ma
                    False -> readTVar islocked >>= \case
                        True  -> retry  -- somebody is writing
                        False -> pure $ withLock $ do
                            ma <- loadS
                            atomically $ writeCache ma
                            pure ma
            action

    pure $ Store
        { loadS = load
        , writeS = \a -> withLock $ do
            atomically $ writeCache (Just a)
            writeS a
        , updateS = \old delta -> withLock $ do
            atomically $ writeCache $ Just $ apply delta old
            updateS old delta
        }
-}

embedStore :: (MonadSTM m, MonadMask m, Delta da)
    => Embedding da db -> Store m db -> m (Store m da)
embedStore :: Embedding da db -> Store m db -> m (Store m da)
embedStore Embedding da db
embed Store 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 (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 (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 (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 (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 = Store m db -> m (Either SomeException (Base db))
forall (m :: * -> *) da.
Store m da -> m (Either SomeException (Base da))
loadS Store m db
bstore m (Either SomeException (Base db))
-> (Either SomeException (Base db)
    -> m (Either SomeException (Base da)))
-> m (Either SomeException (Base da))
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 (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 (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 (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 (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
$ Store m db -> Base db -> m ()
forall (m :: * -> *) da. Store m da -> Base da -> m ()
writeS Store 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 :: Base da -> da -> m ()
update Base da
a da
da = do
            m (Maybe (Machine da db))
readMachine m (Maybe (Machine da db))
-> (Maybe (Machine da db) -> m ()) -> m ()
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 (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
$ Store m db -> Base db -> db -> m ()
forall (m :: * -> *) da. Store m da -> Base da -> da -> m ()
updateS Store m db
bstore (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
    Store m da -> m (Store m da)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Store m da -> m (Store m da)) -> Store m da -> m (Store m da)
forall a b. (a -> b) -> a -> b
$ Store :: forall (m :: * -> *) da.
m (Either SomeException (Base da))
-> (Base da -> m ()) -> (Base da -> da -> m ()) -> Store m da
Store {loadS :: m (Either SomeException (Base da))
loadS=m (Either SomeException (Base da))
load,writeS :: Base da -> m ()
writeS=Base da -> m ()
write,updateS :: Base da -> da -> m ()
updateS=Base da -> da -> m ()
update}


-- | Obtain a 'Store' for one type @a1@ from a 'Store' for another type @a2@
-- via an 'Embedding'' of the first type into the second type.
--
-- Note: This function is exported for testing and documentation only,
-- use the more efficient 'embedStore' instead.
embedStore'
    :: (Monad m, MonadThrow m)
    => Embedding' da db -> Store m db -> Store m da
embedStore' :: Embedding' da db -> Store m db -> Store m da
embedStore' Embedding'{b -> Either SomeException a
load :: ()
load :: b -> Either SomeException a
load,a -> b
write :: ()
write :: a -> b
write,a -> b -> da -> db
update :: ()
update :: a -> b -> da -> db
update} Store{m (Either SomeException (Base db))
loadS :: m (Either SomeException (Base db))
loadS :: forall (m :: * -> *) da.
Store m da -> m (Either SomeException (Base da))
loadS,Base db -> m ()
writeS :: Base db -> m ()
writeS :: forall (m :: * -> *) da. Store m da -> Base da -> m ()
writeS,Base db -> db -> m ()
updateS :: Base db -> db -> m ()
updateS :: forall (m :: * -> *) da. Store m da -> Base da -> da -> m ()
updateS} = Store :: forall (m :: * -> *) da.
m (Either SomeException (Base da))
-> (Base da -> m ()) -> (Base da -> da -> m ()) -> Store m da
Store
    { loadS :: m (Either SomeException (Base da))
loadS   = (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
    , writeS :: Base da -> m ()
writeS  = 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
    , updateS :: Base da -> da -> m ()
updateS = \Base da
a da
da -> m (Either SomeException b)
m (Either SomeException (Base db))
loadS m (Either SomeException b)
-> (Either SomeException b -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left  SomeException
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Right b
b -> Base db -> db -> m ()
updateS b
Base db
b (a -> b -> da -> db
update a
Base da
a b
b da
da)
    }

-- | Combine two 'Stores' into a store for pairs.
--
-- WARNING: The 'updateS' and 'writeS' functions of the result are not atomic
-- in the presence of asynchronous exceptions.
-- For example, the update of the first store may succeed while the update of
-- the second store may fail.
-- In other words, this combinator works for some monads, such as @m = @'STM',
-- but fails for others, such as @m = 'IO'@.
pairStores :: Monad m => Store m da -> Store m db -> Store m (da, db)
pairStores :: Store m da -> Store m db -> Store m (da, db)
pairStores Store m da
sa Store m db
sb = Store :: forall (m :: * -> *) da.
m (Either SomeException (Base da))
-> (Base da -> m ()) -> (Base da -> da -> m ()) -> Store m da
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 (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 da -> m (Either SomeException (Base da))
forall (m :: * -> *) da.
Store m da -> m (Either SomeException (Base da))
loadS Store m 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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Store m db -> m (Either SomeException (Base db))
forall (m :: * -> *) da.
Store m da -> m (Either SomeException (Base da))
loadS Store m db
sb
    , writeS :: Base (da, db) -> m ()
writeS = \(a,b) -> Store m da -> Base da -> m ()
forall (m :: * -> *) da. Store m da -> Base da -> m ()
writeS Store m da
sa Base da
a m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Store m db -> Base db -> m ()
forall (m :: * -> *) da. Store m da -> Base da -> m ()
writeS Store m db
sb Base db
b
    , updateS :: Base (da, db) -> (da, db) -> m ()
updateS = \(a,b) (da
da,db
db) -> Store m da -> Base da -> da -> m ()
forall (m :: * -> *) da. Store m da -> Base da -> da -> m ()
updateS Store m da
sa Base da
a da
da m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Store m db -> Base db -> db -> m ()
forall (m :: * -> *) da. Store m da -> Base da -> da -> m ()
updateS Store m db
sb Base db
b db
db
    }