{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK show-extensions #-}
module Data.DynamicState.Serializable (
DynamicState(..),
getDyn,
putDyn
) where
import Data.Binary
import Data.HashMap.Strict as M
import Data.ConcreteTypeRep
import Data.Typeable
import Data.ByteString.Lazy(ByteString)
import Control.Monad
data Dynamic
= forall a. (Typeable a, Binary a) => Dynamic !a
| Serial !ByteString
fromDynamic :: forall a. (Typeable a, Binary a) => Dynamic -> Maybe (a,Bool)
fromDynamic :: forall a. (Typeable a, Binary a) => Dynamic -> Maybe (a, Bool)
fromDynamic (Dynamic a
b) = (,Bool
False) (a -> (a, Bool)) -> Maybe a -> Maybe (a, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
b
#if __GLASGOW_HASKELL__ < 708
fromDynamic (Serial bs) = (,True) <$> (Just $ decode bs)
#else
fromDynamic (Serial ByteString
bs) = let b :: Maybe a
b = ((ByteString, ByteOffset, String) -> Maybe a)
-> ((ByteString, ByteOffset, a) -> Maybe a)
-> Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
-> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> (ByteString, ByteOffset, String) -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) (\(ByteString
_,ByteOffset
_,a
a) -> a -> Maybe a
forall a. a -> Maybe a
Just a
a) (Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
-> Maybe a)
-> Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
-> Maybe a
forall a b. (a -> b) -> a -> b
$ ByteString
-> Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
forall a.
Binary a =>
ByteString
-> Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
decodeOrFail ByteString
bs in (,Bool
True) (a -> (a, Bool)) -> Maybe a -> Maybe (a, Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
b
#endif
instance Binary Dynamic where
put :: Dynamic -> Put
put = ByteString -> Put
forall t. Binary t => t -> Put
put (ByteString -> Put) -> (Dynamic -> ByteString) -> Dynamic -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dynamic -> ByteString
toSerialRep where
toSerialRep :: Dynamic -> ByteString
toSerialRep (Dynamic a
a) = a -> ByteString
forall a. Binary a => a -> ByteString
encode a
a
toSerialRep (Serial ByteString
bs) = ByteString
bs
get :: Get Dynamic
get = ByteString -> Dynamic
Serial (ByteString -> Dynamic) -> Get ByteString -> Get Dynamic
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
forall t. Binary t => Get t
get
newtype DynamicState = DynamicState { DynamicState -> HashMap ConcreteTypeRep Dynamic
unDynamicState :: M.HashMap ConcreteTypeRep Dynamic }
deriving (Typeable)
#if __GLASGOW_HASKELL__ >= 804
instance Semigroup DynamicState where
<> :: DynamicState -> DynamicState -> DynamicState
(<>) = DynamicState -> DynamicState -> DynamicState
forall a. Monoid a => a -> a -> a
mappend
#endif
instance Monoid DynamicState where
mappend :: DynamicState -> DynamicState -> DynamicState
mappend (DynamicState HashMap ConcreteTypeRep Dynamic
a) (DynamicState HashMap ConcreteTypeRep Dynamic
b) = HashMap ConcreteTypeRep Dynamic -> DynamicState
DynamicState (HashMap ConcreteTypeRep Dynamic
-> HashMap ConcreteTypeRep Dynamic
-> HashMap ConcreteTypeRep Dynamic
forall a. Monoid a => a -> a -> a
mappend HashMap ConcreteTypeRep Dynamic
a HashMap ConcreteTypeRep Dynamic
b)
mempty :: DynamicState
mempty = HashMap ConcreteTypeRep Dynamic -> DynamicState
DynamicState HashMap ConcreteTypeRep Dynamic
forall a. Monoid a => a
mempty
getDyn :: forall m a. (Typeable a, Binary a, Monad m) => m DynamicState -> (DynamicState -> m ()) -> m (Maybe a)
getDyn :: forall (m :: * -> *) a.
(Typeable a, Binary a, Monad m) =>
m DynamicState -> (DynamicState -> m ()) -> m (Maybe a)
getDyn m DynamicState
get' DynamicState -> m ()
put' = do
let ty :: ConcreteTypeRep
ty = a -> ConcreteTypeRep
forall a. Typeable a => a -> ConcreteTypeRep
cTypeOf (a
forall a. HasCallStack => a
undefined::a)
HashMap ConcreteTypeRep Dynamic
dvs <- (DynamicState -> HashMap ConcreteTypeRep Dynamic)
-> m DynamicState -> m (HashMap ConcreteTypeRep Dynamic)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM DynamicState -> HashMap ConcreteTypeRep Dynamic
unDynamicState m DynamicState
get'
case ConcreteTypeRep -> HashMap ConcreteTypeRep Dynamic -> Maybe Dynamic
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup ConcreteTypeRep
ty HashMap ConcreteTypeRep Dynamic
dvs Maybe Dynamic -> (Dynamic -> Maybe (a, Bool)) -> Maybe (a, Bool)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Dynamic -> Maybe (a, Bool)
forall a. (Typeable a, Binary a) => Dynamic -> Maybe (a, Bool)
fromDynamic of
Just (a
val,Bool
new) -> (Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
new (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ DynamicState -> m ()
put' (DynamicState -> m ()) -> DynamicState -> m ()
forall a b. (a -> b) -> a -> b
$ HashMap ConcreteTypeRep Dynamic -> DynamicState
DynamicState (HashMap ConcreteTypeRep Dynamic -> DynamicState)
-> HashMap ConcreteTypeRep Dynamic -> DynamicState
forall a b. (a -> b) -> a -> b
$ ConcreteTypeRep
-> Dynamic
-> HashMap ConcreteTypeRep Dynamic
-> HashMap ConcreteTypeRep Dynamic
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert ConcreteTypeRep
ty (a -> Dynamic
forall a. (Typeable a, Binary a) => a -> Dynamic
Dynamic a
val) HashMap ConcreteTypeRep Dynamic
dvs) m () -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
val)
Maybe (a, Bool)
Nothing -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
putDyn :: forall m a. (Typeable a, Binary a, Monad m) => m DynamicState -> (DynamicState -> m ()) -> a -> m ()
putDyn :: forall (m :: * -> *) a.
(Typeable a, Binary a, Monad m) =>
m DynamicState -> (DynamicState -> m ()) -> a -> m ()
putDyn m DynamicState
get' DynamicState -> m ()
put' a
v = do
HashMap ConcreteTypeRep Dynamic
dvs <- (DynamicState -> HashMap ConcreteTypeRep Dynamic)
-> m DynamicState -> m (HashMap ConcreteTypeRep Dynamic)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM DynamicState -> HashMap ConcreteTypeRep Dynamic
unDynamicState m DynamicState
get'
DynamicState -> m ()
put' (DynamicState -> m ()) -> DynamicState -> m ()
forall a b. (a -> b) -> a -> b
$ HashMap ConcreteTypeRep Dynamic -> DynamicState
DynamicState (ConcreteTypeRep
-> Dynamic
-> HashMap ConcreteTypeRep Dynamic
-> HashMap ConcreteTypeRep Dynamic
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert (a -> ConcreteTypeRep
forall a. Typeable a => a -> ConcreteTypeRep
cTypeOf (a
forall a. HasCallStack => a
undefined :: a)) (a -> Dynamic
forall a. (Typeable a, Binary a) => a -> Dynamic
Dynamic a
v) HashMap ConcreteTypeRep Dynamic
dvs)
instance Binary DynamicState where
put :: DynamicState -> Put
put (DynamicState HashMap ConcreteTypeRep Dynamic
ds) = [(ConcreteTypeRep, Dynamic)] -> Put
forall t. Binary t => t -> Put
put (HashMap ConcreteTypeRep Dynamic -> [(ConcreteTypeRep, Dynamic)]
forall k v. HashMap k v -> [(k, v)]
M.toList HashMap ConcreteTypeRep Dynamic
ds)
get :: Get DynamicState
get = HashMap ConcreteTypeRep Dynamic -> DynamicState
DynamicState (HashMap ConcreteTypeRep Dynamic -> DynamicState)
-> ([(ConcreteTypeRep, Dynamic)]
-> HashMap ConcreteTypeRep Dynamic)
-> [(ConcreteTypeRep, Dynamic)]
-> DynamicState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ConcreteTypeRep, Dynamic)] -> HashMap ConcreteTypeRep Dynamic
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(ConcreteTypeRep, Dynamic)] -> DynamicState)
-> Get [(ConcreteTypeRep, Dynamic)] -> Get DynamicState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get [(ConcreteTypeRep, Dynamic)]
forall t. Binary t => Get t
get