{-# LANGUAGE RankNTypes, TypeFamilies, GADTs, CPP #-}
module Data.Acid.Abstract
    ( AcidState(..)
    , scheduleUpdate
    , groupUpdates
    , update
    , update'
    , query
    , query'
    , mkAnyState
    , downcast
    ) where

import Data.Acid.Common
import Data.Acid.Core

import Control.Concurrent      ( MVar, takeMVar )
import Data.ByteString.Lazy    ( ByteString )
import Control.Monad           ( void )
import Control.Monad.Trans     ( MonadIO(liftIO) )
#if __GLASGOW_HASKELL__ >= 707
import Data.Typeable           ( Typeable, gcast, typeOf )
#else
import Data.Typeable           ( Typeable1, gcast1, typeOf1 )
#endif

data AnyState st where
#if __GLASGOW_HASKELL__ >= 707
  AnyState :: Typeable sub_st => sub_st st -> AnyState st
#else
  AnyState :: Typeable1 sub_st => sub_st st -> AnyState st
#endif

-- Haddock doesn't get the types right on its own.
{-| State container offering full ACID (Atomicity, Consistency, Isolation and Durability)
    guarantees.

    [@Atomicity@]   State changes are all-or-nothing. This is what you'd expect
                    of any state variable in Haskell and AcidState doesn't
                    change that.
    [@Consistency@] No event or set of events will break your data invariants.
    [@Isolation@]   Transactions cannot interfere with each other even when
                    issued in parallel.
    [@Durability@]  Successful transaction are guaranteed to survive unexpected
                    system shutdowns (both those caused by hardware and software).
-}
data AcidState st
  = AcidState {
                forall st.
AcidState st
-> forall event.
   (UpdateEvent event, EventState event ~ st) =>
   event -> IO (MVar (EventResult event))
_scheduleUpdate :: forall event. (UpdateEvent event, EventState event ~ st) => event -> IO (MVar (EventResult event))
              , forall st.
AcidState st -> Tagged ByteString -> IO (MVar ByteString)
scheduleColdUpdate :: Tagged ByteString -> IO (MVar ByteString)
              , forall st.
AcidState st
-> forall event.
   (QueryEvent event, EventState event ~ st) =>
   event -> IO (EventResult event)
_query :: forall event. (QueryEvent event, EventState event ~ st) => event -> IO (EventResult event)
              , forall st. AcidState st -> Tagged ByteString -> IO ByteString
queryCold :: Tagged ByteString -> IO ByteString
              ,
-- | Take a snapshot of the state and save it to disk. Creating checkpoints
--   makes it faster to resume AcidStates and you're free to create them as
--   often or seldom as fits your needs. Transactions can run concurrently
--   with this call.
--
--   This call will not return until the operation has succeeded.
                forall st. AcidState st -> IO ()
createCheckpoint :: IO ()
-- | Move all log files that are no longer necessary for state restoration into the 'Archive'
--   folder in the state directory. This folder can then be backed up or thrown out as you see fit.
--   Reverting to a state before the last checkpoint will not be possible if the 'Archive' folder
--   has been thrown out.
--
--   This method is idempotent and does not block the normal operation of the AcidState.
              , forall st. AcidState st -> IO ()
createArchive :: IO ()
              ,
-- | Close an AcidState and associated resources.
--   Any subsequent usage of the AcidState will throw an exception.
                forall st. AcidState st -> IO ()
closeAcidState :: IO ()
              , forall st. AcidState st -> AnyState st
acidSubState :: AnyState st
              }

-- | Issue an Update event and return immediately. The event is not durable
--   before the MVar has been filled but the order of events is honored.
--   The behavior in case of exceptions is exactly the same as for 'update'.
--
--   If EventA is scheduled before EventB, EventA /will/ be executed before EventB:
--
--   @
--do scheduleUpdate acid EventA
--   scheduleUpdate acid EventB
--   @
scheduleUpdate :: UpdateEvent event => AcidState (EventState event) -> event -> IO (MVar (EventResult event))
scheduleUpdate :: forall event.
UpdateEvent event =>
AcidState (EventState event)
-> event -> IO (MVar (EventResult event))
scheduleUpdate AcidState (MethodState event)
acid = AcidState (MethodState event)
-> forall event.
   (UpdateEvent event, EventState event ~ MethodState event) =>
   event -> IO (MVar (EventResult event))
forall st.
AcidState st
-> forall event.
   (UpdateEvent event, EventState event ~ st) =>
   event -> IO (MVar (EventResult event))
_scheduleUpdate AcidState (MethodState event)
acid -- Redirection to make Haddock happy.

-- | Schedule multiple Update events and wait for them to be durable, but
--   throw away their results. This is useful for importing existing
--   datasets into an AcidState.
groupUpdates :: UpdateEvent event => AcidState (EventState event) -> [event] -> IO ()
groupUpdates :: forall event.
UpdateEvent event =>
AcidState (EventState event) -> [event] -> IO ()
groupUpdates AcidState (EventState event)
acidState [event]
events
  = [event] -> IO ()
go [event]
events
  where
    go :: [event] -> IO ()
go []     = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go [event
x]    = IO (MethodResult event) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (MethodResult event) -> IO ())
-> IO (MethodResult event) -> IO ()
forall a b. (a -> b) -> a -> b
$ AcidState (EventState event) -> event -> IO (MethodResult event)
forall event.
UpdateEvent event =>
AcidState (EventState event) -> event -> IO (EventResult event)
update AcidState (EventState event)
acidState event
x
    go (event
x:[event]
xs) = AcidState (EventState event)
-> event -> IO (MVar (MethodResult event))
forall event.
UpdateEvent event =>
AcidState (EventState event)
-> event -> IO (MVar (EventResult event))
scheduleUpdate AcidState (EventState event)
acidState event
x IO (MVar (MethodResult event)) -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [event] -> IO ()
go [event]
xs

-- | Issue an Update event and wait for its result. Once this call returns, you are
--   guaranteed that the changes to the state are durable. Events may be issued in
--   parallel.
--
--   It's a run-time error to issue events that aren't supported by the AcidState.
update :: UpdateEvent event => AcidState (EventState event) -> event -> IO (EventResult event)
update :: forall event.
UpdateEvent event =>
AcidState (EventState event) -> event -> IO (EventResult event)
update AcidState (EventState event)
acidState event
event = MVar (MethodResult event) -> IO (MethodResult event)
forall a. MVar a -> IO a
takeMVar (MVar (MethodResult event) -> IO (MethodResult event))
-> IO (MVar (MethodResult event)) -> IO (MethodResult event)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AcidState (EventState event)
-> event -> IO (MVar (MethodResult event))
forall event.
UpdateEvent event =>
AcidState (EventState event)
-> event -> IO (MVar (EventResult event))
scheduleUpdate AcidState (EventState event)
acidState event
event

-- | Same as 'update' but lifted into any monad capable of doing IO.
update' :: (UpdateEvent event, MonadIO m) => AcidState (EventState event) -> event -> m (EventResult event)
update' :: forall event (m :: * -> *).
(UpdateEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
update' AcidState (EventState event)
acidState event
event = IO (MethodResult event) -> m (MethodResult event)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (AcidState (EventState event) -> event -> IO (MethodResult event)
forall event.
UpdateEvent event =>
AcidState (EventState event) -> event -> IO (EventResult event)
update AcidState (EventState event)
acidState event
event)

-- | Issue a Query event and wait for its result. Events may be issued in parallel.
query :: QueryEvent event => AcidState (EventState event) -> event -> IO (EventResult event)
query :: forall event.
QueryEvent event =>
AcidState (EventState event) -> event -> IO (EventResult event)
query AcidState (MethodState event)
acid = AcidState (MethodState event)
-> forall event.
   (QueryEvent event, EventState event ~ MethodState event) =>
   event -> IO (EventResult event)
forall st.
AcidState st
-> forall event.
   (QueryEvent event, EventState event ~ st) =>
   event -> IO (EventResult event)
_query AcidState (MethodState event)
acid -- Redirection to make Haddock happy.

-- | Same as 'query' but lifted into any monad capable of doing IO.
query' :: (QueryEvent event, MonadIO m) => AcidState (EventState event) -> event -> m (EventResult event)
query' :: forall event (m :: * -> *).
(QueryEvent event, MonadIO m) =>
AcidState (EventState event) -> event -> m (EventResult event)
query' AcidState (EventState event)
acidState event
event = IO (MethodResult event) -> m (MethodResult event)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (AcidState (EventState event) -> event -> IO (MethodResult event)
forall event.
QueryEvent event =>
AcidState (EventState event) -> event -> IO (EventResult event)
query AcidState (EventState event)
acidState event
event)

#if __GLASGOW_HASKELL__ >= 707
mkAnyState :: Typeable sub_st => sub_st st -> AnyState st
#else
mkAnyState :: Typeable1 sub_st => sub_st st -> AnyState st
#endif
mkAnyState :: forall (sub_st :: * -> *) st.
Typeable sub_st =>
sub_st st -> AnyState st
mkAnyState = sub_st st -> AnyState st
forall (sub_st :: * -> *) st.
Typeable sub_st =>
sub_st st -> AnyState st
AnyState

#if __GLASGOW_HASKELL__ >= 707
downcast :: (Typeable sub, Typeable st) => AcidState st -> sub st
downcast :: forall (sub :: * -> *) st.
(Typeable sub, Typeable st) =>
AcidState st -> sub st
downcast AcidState{acidSubState :: forall st. AcidState st -> AnyState st
acidSubState = AnyState sub_st st
sub}
  = sub st
r
 where
   r :: sub st
r = case Maybe (sub_st st) -> Maybe (Maybe (sub st))
forall {k} (a :: k) (b :: k) (c :: k -> *).
(Typeable a, Typeable b) =>
c a -> Maybe (c b)
gcast (sub_st st -> Maybe (sub_st st)
forall a. a -> Maybe a
Just sub_st st
sub) of
         Just (Just sub st
x) -> sub st
x
         Maybe (Maybe (sub st))
_ ->
           [Char] -> sub st
forall a. HasCallStack => [Char] -> a
error ([Char] -> sub st) -> [Char] -> sub st
forall a b. (a -> b) -> a -> b
$
            [Char]
"Data.Acid.Abstract: Invalid subtype cast: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (sub_st st -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf sub_st st
sub) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" -> " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TypeRep -> [Char]
forall a. Show a => a -> [Char]
show (sub st -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf sub st
r)
#else
downcast :: Typeable1 sub => AcidState st -> sub st
downcast AcidState{acidSubState = AnyState sub}
  = r
 where
   r = case gcast1 (Just sub) of
         Just (Just x) -> x
         _ ->
           error $
            "Data.Acid.Abstract: Invalid subtype cast: " ++ show (typeOf1 sub) ++ " -> " ++ show (typeOf1 r)
#endif