    {-# 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 :: 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

    -- | 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 HashMap ConcreteTypeRep Dynamic
    a <> :: DynamicState -> DynamicState -> DynamicState
    <> DynamicState HashMap ConcreteTypeRep Dynamic
    b = HashMap ConcreteTypeRep Dynamic -> DynamicState
    DynamicState (HashMap ConcreteTypeRep Dynamic
    a HashMap ConcreteTypeRep Dynamic
    -> HashMap ConcreteTypeRep Dynamic
    -> HashMap ConcreteTypeRep Dynamic
    forall a. Semigroup a => a -> a -> a
    <> HashMap ConcreteTypeRep Dynamic
    b)
    #endif

    instance Monoid DynamicState where
    #if !MIN_VERSION_base(4,11,0)
      mappend (DynamicState a) (DynamicState b) = DynamicState (mappend a b)
    #endif
      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 :: 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)
        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 M.lookup ty dvs >>= 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 a b. m a -> m b -> m b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Maybe a -> m (Maybe a)
    forall a. a -> m 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 a. a -> m 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 :: 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
        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'
        put' $ DynamicState (M.insert (cTypeOf (undefined :: a)) (Dynamic v) 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

    -- 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?).