{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK show-extensions #-}

-- |
-- Module      :  Data.DynamicState.Serializable
-- License     :  GPL2
-- Maintainer  :  zcarterc@gmail.com
-- Stability   :  experimental
-- Portability :  portable
--
-- This module is HashMap ConcreteTypeRep Dynamic with a twist. The Dynamic
-- used can also be ByteString, to make repeated
-- reserialization cheap.
-- A user-provided State-like is used to store this.

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

-- | A Dynamic value, potentially stored serialized
data Dynamic
  = forall a. (Typeable a, Binary a) => Dynamic !a
  | Serial !ByteString

-- | Try to extract a value from the 'Dynamic', returning True if it was decoded from a 'Serial'
fromDynamic :: forall a. (Typeable a, Binary a) => Dynamic -> Maybe (a,Bool)
fromDynamic :: Dynamic -> Maybe (a, Bool)
fromDynamic (Dynamic b :: 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 bs :: 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) (\(_,_,a :: 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) = a -> ByteString
forall a. Binary a => a -> ByteString
encode a
a
    toSerialRep (Serial bs :: 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

-- | An extensible record, indexed by type, using state to cache deserializtion
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 a :: HashMap ConcreteTypeRep Dynamic
a) (DynamicState b :: 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

-- | Get a value, inside a State-like monad specified by the first two functions
getDyn :: forall m a. (Typeable a, Binary a, Monad m) => m DynamicState -> (DynamicState -> m ()) -> m (Maybe a)
getDyn :: m DynamicState -> (DynamicState -> m ()) -> m (Maybe a)
getDyn get' :: m DynamicState
get' put' :: 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 (val :: a
val,new :: 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)
      Nothing -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
-- | Set a value, inside a State-like monad specified by the first two functions
putDyn :: forall m a. (Typeable a, Binary a, Monad m) => m DynamicState -> (DynamicState -> m ()) -> a -> m ()
putDyn :: m DynamicState -> (DynamicState -> m ()) -> a -> m ()
putDyn get' :: m DynamicState
get' put' :: DynamicState -> m ()
put' v :: 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 ds :: 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

-- TODO: since a 'DynamicState' is now serialisable, it could potentially
-- exist for a long time (days/months?). No operations are provided to remove
-- entries. If these start accumulating a lot of junk,
-- it may be necessary to prune them (perhaps keep track of access date and
-- remove the ones more than a month old?).