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

-- |
-- Module      :  Data.DynamicState
-- License     :  GPL2
-- Maintainer  :  zcarterc@gmail.com
-- Stability   :  experimental
-- Portability :  portable
--
-- This module implements a simple HashMap ConcreteTypeRep Dynamic

module Data.DynamicState (
  DynamicState(..),
  getDyn,
  setDyn,
  _dyn
  ) where

import Data.Dynamic
import Data.HashMap.Strict as M
import Data.ConcreteTypeRep

-- | An extensible record, indexed by type
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 a. Typeable a => DynamicState -> Maybe a
getDyn :: forall a. Typeable a => DynamicState -> Maybe a
getDyn (DynamicState HashMap ConcreteTypeRep Dynamic
ds) = ConcreteTypeRep -> HashMap ConcreteTypeRep Dynamic -> Maybe Dynamic
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup (a -> ConcreteTypeRep
forall a. Typeable a => a -> ConcreteTypeRep
cTypeOf (a
forall a. HasCallStack => a
undefined :: a)) HashMap ConcreteTypeRep Dynamic
ds Maybe Dynamic -> (Dynamic -> Maybe a) -> Maybe a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic

setDyn :: forall a. Typeable a => DynamicState -> a -> DynamicState
setDyn :: forall a. Typeable a => DynamicState -> a -> DynamicState
setDyn (DynamicState HashMap ConcreteTypeRep Dynamic
ds) a
x = 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 (a -> ConcreteTypeRep
forall a. Typeable a => a -> ConcreteTypeRep
cTypeOf (a
forall a. HasCallStack => a
undefined :: a)) (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn a
x) HashMap ConcreteTypeRep Dynamic
ds

-- | Lens with default value
_dyn :: (Typeable a, Functor f) => a -> (a -> f a) -> DynamicState -> f DynamicState
_dyn :: forall a (f :: * -> *).
(Typeable a, Functor f) =>
a -> (a -> f a) -> DynamicState -> f DynamicState
_dyn a
def a -> f a
afb DynamicState
s = DynamicState -> a -> DynamicState
forall a. Typeable a => DynamicState -> a -> DynamicState
setDyn DynamicState
s (a -> DynamicState) -> f a -> f DynamicState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f a
afb (a -> (a -> a) -> Maybe a -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
def a -> a
forall a. a -> a
id (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ DynamicState -> Maybe a
forall a. Typeable a => DynamicState -> Maybe a
getDyn DynamicState
s)