{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Acid.Common
-- Copyright   :  PublicDomain
--
-- Maintainer  :  lemmih@gmail.com
-- Portability :  non-portable (uses GHC extensions)
--
-- Common structures used by the various backends (local, memory).
--
module Data.Acid.Common where

import Data.Acid.Core

import Control.Monad
import Control.Monad.State   (MonadState, get, State)
import Control.Monad.Reader  (MonadReader, Reader, runReader)
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif


class IsAcidic st where
    acidEvents :: [Event st]
      -- ^ List of events capable of updating or querying the state.


-- | Context monad for Update events.
newtype Update st a = Update { forall st a. Update st a -> State st a
unUpdate :: State st a }
    deriving (Applicative (Update st)
Applicative (Update st)
-> (forall a b. Update st a -> (a -> Update st b) -> Update st b)
-> (forall a b. Update st a -> Update st b -> Update st b)
-> (forall a. a -> Update st a)
-> Monad (Update st)
forall {st}. Applicative (Update st)
forall a. a -> Update st a
forall st a. a -> Update st a
forall a b. Update st a -> Update st b -> Update st b
forall a b. Update st a -> (a -> Update st b) -> Update st b
forall st a b. Update st a -> Update st b -> Update st b
forall st a b. Update st a -> (a -> Update st b) -> Update st b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall st a b. Update st a -> (a -> Update st b) -> Update st b
>>= :: forall a b. Update st a -> (a -> Update st b) -> Update st b
$c>> :: forall st a b. Update st a -> Update st b -> Update st b
>> :: forall a b. Update st a -> Update st b -> Update st b
$creturn :: forall st a. a -> Update st a
return :: forall a. a -> Update st a
Monad, (forall a b. (a -> b) -> Update st a -> Update st b)
-> (forall a b. a -> Update st b -> Update st a)
-> Functor (Update st)
forall a b. a -> Update st b -> Update st a
forall a b. (a -> b) -> Update st a -> Update st b
forall st a b. a -> Update st b -> Update st a
forall st a b. (a -> b) -> Update st a -> Update st b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall st a b. (a -> b) -> Update st a -> Update st b
fmap :: forall a b. (a -> b) -> Update st a -> Update st b
$c<$ :: forall st a b. a -> Update st b -> Update st a
<$ :: forall a b. a -> Update st b -> Update st a
Functor, MonadState st)

-- mtl pre-2.0 doesn't have these instances to newtype-derive, but they're
-- simple enough.
instance Applicative (Update st) where
    pure :: forall a. a -> Update st a
pure = a -> Update st a
forall a. a -> Update st a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: forall a b. Update st (a -> b) -> Update st a -> Update st b
(<*>) = Update st (a -> b) -> Update st a -> Update st b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

-- | Context monad for Query events.
newtype Query st a  = Query { forall st a. Query st a -> Reader st a
unQuery :: Reader st a }
    deriving (Applicative (Query st)
Applicative (Query st)
-> (forall a b. Query st a -> (a -> Query st b) -> Query st b)
-> (forall a b. Query st a -> Query st b -> Query st b)
-> (forall a. a -> Query st a)
-> Monad (Query st)
forall {st}. Applicative (Query st)
forall a. a -> Query st a
forall st a. a -> Query st a
forall a b. Query st a -> Query st b -> Query st b
forall a b. Query st a -> (a -> Query st b) -> Query st b
forall st a b. Query st a -> Query st b -> Query st b
forall st a b. Query st a -> (a -> Query st b) -> Query st b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall st a b. Query st a -> (a -> Query st b) -> Query st b
>>= :: forall a b. Query st a -> (a -> Query st b) -> Query st b
$c>> :: forall st a b. Query st a -> Query st b -> Query st b
>> :: forall a b. Query st a -> Query st b -> Query st b
$creturn :: forall st a. a -> Query st a
return :: forall a. a -> Query st a
Monad, (forall a b. (a -> b) -> Query st a -> Query st b)
-> (forall a b. a -> Query st b -> Query st a)
-> Functor (Query st)
forall a b. a -> Query st b -> Query st a
forall a b. (a -> b) -> Query st a -> Query st b
forall st a b. a -> Query st b -> Query st a
forall st a b. (a -> b) -> Query st a -> Query st b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall st a b. (a -> b) -> Query st a -> Query st b
fmap :: forall a b. (a -> b) -> Query st a -> Query st b
$c<$ :: forall st a b. a -> Query st b -> Query st a
<$ :: forall a b. a -> Query st b -> Query st a
Functor, MonadReader st)

instance Applicative (Query st) where
    pure :: forall a. a -> Query st a
pure = a -> Query st a
forall a. a -> Query st a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: forall a b. Query st (a -> b) -> Query st a -> Query st b
(<*>) = Query st (a -> b) -> Query st a -> Query st b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

-- | Run a query in the Update Monad.
liftQuery :: Query st a -> Update st a
liftQuery :: forall st a. Query st a -> Update st a
liftQuery Query st a
query
    = do st
st <- Update st st
forall s (m :: * -> *). MonadState s m => m s
get
         a -> Update st a
forall a. a -> Update st a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reader st a -> st -> a
forall r a. Reader r a -> r -> a
runReader (Query st a -> Reader st a
forall st a. Query st a -> Reader st a
unQuery Query st a
query) st
st)

-- | Events return the same thing as Methods. The exact type of 'EventResult'
--   depends on the event.
type EventResult ev = MethodResult ev

type EventState ev = MethodState ev

-- | We distinguish between events that modify the state and those that do not.
--
--   UpdateEvents are executed in a MonadState context and have to be serialized
--   to disk before they are considered durable.
--
--   QueryEvents are executed in a MonadReader context and obviously do not have
--   to be serialized to disk.
data Event st where
    UpdateEvent :: UpdateEvent ev => (ev -> Update (EventState ev) (EventResult ev)) -> MethodSerialiser ev -> Event (EventState ev)
    QueryEvent  :: QueryEvent  ev => (ev -> Query (EventState ev) (EventResult ev)) -> MethodSerialiser ev -> Event (EventState ev)


-- | All UpdateEvents are also Methods.
class Method ev => UpdateEvent ev
-- | All QueryEvents are also Methods.
class Method ev => QueryEvent ev


eventsToMethods :: [Event st] -> [MethodContainer st]
eventsToMethods :: forall st. [Event st] -> [MethodContainer st]
eventsToMethods = (Event st -> MethodContainer st)
-> [Event st] -> [MethodContainer st]
forall a b. (a -> b) -> [a] -> [b]
map Event st -> MethodContainer st
forall st. Event st -> MethodContainer st
worker
    where worker :: Event st -> MethodContainer st
          worker :: forall st. Event st -> MethodContainer st
worker (UpdateEvent ev -> Update (MethodState ev) (EventResult ev)
fn MethodSerialiser ev
ms) = MethodBody ev
-> MethodSerialiser ev -> MethodContainer (MethodState ev)
forall method.
Method method =>
MethodBody method
-> MethodSerialiser method -> MethodContainer (MethodState method)
Method (Update st (EventResult ev) -> State st (EventResult ev)
forall st a. Update st a -> State st a
unUpdate (Update st (EventResult ev) -> State st (EventResult ev))
-> (ev -> Update st (EventResult ev))
-> ev
-> State st (EventResult ev)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ev -> Update st (EventResult ev)
ev -> Update (MethodState ev) (EventResult ev)
fn) MethodSerialiser ev
ms
          worker (QueryEvent  ev -> Query (MethodState ev) (EventResult ev)
fn MethodSerialiser ev
ms) = MethodBody ev
-> MethodSerialiser ev -> MethodContainer (MethodState ev)
forall method.
Method method =>
MethodBody method
-> MethodSerialiser method -> MethodContainer (MethodState method)
Method (\ev
ev -> do st
st <- StateT st Identity st
forall s (m :: * -> *). MonadState s m => m s
get
                                                         EventResult ev -> StateT st Identity (EventResult ev)
forall a. a -> StateT st Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reader st (EventResult ev) -> st -> EventResult ev
forall r a. Reader r a -> r -> a
runReader (Query (MethodState ev) (EventResult ev)
-> Reader (MethodState ev) (EventResult ev)
forall st a. Query st a -> Reader st a
unQuery (Query (MethodState ev) (EventResult ev)
 -> Reader (MethodState ev) (EventResult ev))
-> Query (MethodState ev) (EventResult ev)
-> Reader (MethodState ev) (EventResult ev)
forall a b. (a -> b) -> a -> b
$ ev -> Query (MethodState ev) (EventResult ev)
fn ev
ev) st
st)
                                              ) MethodSerialiser ev
ms