module Control.Monad.TagShare(
DynMap,
dynEmpty,
dynInsert,
dynLookup,
Sharing,
runSharing,
share
) where
import Control.Monad.State
import Data.Typeable
import Data.Dynamic(Dynamic, fromDynamic, toDyn)
import Data.Map as M
newtype DynMap tag =
DynMap (M.Map (tag, TypeRep) Dynamic)
deriving Int -> DynMap tag -> ShowS
[DynMap tag] -> ShowS
DynMap tag -> String
(Int -> DynMap tag -> ShowS)
-> (DynMap tag -> String)
-> ([DynMap tag] -> ShowS)
-> Show (DynMap tag)
forall tag. Show tag => Int -> DynMap tag -> ShowS
forall tag. Show tag => [DynMap tag] -> ShowS
forall tag. Show tag => DynMap tag -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DynMap tag] -> ShowS
$cshowList :: forall tag. Show tag => [DynMap tag] -> ShowS
show :: DynMap tag -> String
$cshow :: forall tag. Show tag => DynMap tag -> String
showsPrec :: Int -> DynMap tag -> ShowS
$cshowsPrec :: forall tag. Show tag => Int -> DynMap tag -> ShowS
Show
dynEmpty :: DynMap tag
dynEmpty :: forall tag. DynMap tag
dynEmpty = Map (tag, TypeRep) Dynamic -> DynMap tag
forall tag. Map (tag, TypeRep) Dynamic -> DynMap tag
DynMap Map (tag, TypeRep) Dynamic
forall k a. Map k a
M.empty
dynInsert :: (Typeable a, Ord tag) =>
tag -> a -> DynMap tag -> DynMap tag
dynInsert :: forall a tag.
(Typeable a, Ord tag) =>
tag -> a -> DynMap tag -> DynMap tag
dynInsert tag
u a
a (DynMap Map (tag, TypeRep) Dynamic
m) =
Map (tag, TypeRep) Dynamic -> DynMap tag
forall tag. Map (tag, TypeRep) Dynamic -> DynMap tag
DynMap ((tag, TypeRep)
-> Dynamic
-> Map (tag, TypeRep) Dynamic
-> Map (tag, TypeRep) Dynamic
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (tag
u,a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a) (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn a
a) Map (tag, TypeRep) Dynamic
m)
dynLookup :: (Typeable a, Ord tag) =>
tag -> DynMap tag -> Maybe a
dynLookup :: forall a tag. (Typeable a, Ord tag) => tag -> DynMap tag -> Maybe a
dynLookup tag
u (DynMap Map (tag, TypeRep) Dynamic
m) = (TypeRep -> Maybe a) -> a -> Maybe a
forall a. Typeable a => (TypeRep -> Maybe a) -> a -> Maybe a
hlp TypeRep -> Maybe a
forall {b}. Typeable b => TypeRep -> Maybe b
fun a
forall a. HasCallStack => a
undefined where
hlp :: Typeable a =>
(TypeRep -> Maybe a) -> a -> Maybe a
hlp :: forall a. Typeable a => (TypeRep -> Maybe a) -> a -> Maybe a
hlp TypeRep -> Maybe a
f a
a = TypeRep -> Maybe a
f (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a)
fun :: TypeRep -> Maybe b
fun TypeRep
tr = (tag, TypeRep) -> Map (tag, TypeRep) Dynamic -> Maybe Dynamic
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (tag
u,TypeRep
tr) Map (tag, TypeRep) Dynamic
m Maybe Dynamic -> (Dynamic -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Dynamic -> Maybe b
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic
type Sharing tag a = State (DynMap tag) a
runSharing :: Sharing tag a -> a
runSharing :: forall tag a. Sharing tag a -> a
runSharing Sharing tag a
m = Sharing tag a -> DynMap tag -> a
forall s a. State s a -> s -> a
evalState Sharing tag a
m DynMap tag
forall tag. DynMap tag
dynEmpty
share :: (Typeable a, Ord tag) =>
tag -> Sharing tag a -> Sharing tag a
share :: forall a tag.
(Typeable a, Ord tag) =>
tag -> Sharing tag a -> Sharing tag a
share tag
t Sharing tag a
m = do
Maybe a
mx <- (DynMap tag -> Maybe a) -> StateT (DynMap tag) Identity (Maybe a)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((DynMap tag -> Maybe a) -> StateT (DynMap tag) Identity (Maybe a))
-> (DynMap tag -> Maybe a)
-> StateT (DynMap tag) Identity (Maybe a)
forall a b. (a -> b) -> a -> b
$ (tag -> DynMap tag -> Maybe a
forall a tag. (Typeable a, Ord tag) => tag -> DynMap tag -> Maybe a
dynLookup tag
t)
case Maybe a
mx of
Just a
e -> a -> Sharing tag a
forall (m :: * -> *) a. Monad m => a -> m a
return a
e
Maybe a
Nothing -> (a -> Sharing tag a) -> Sharing tag a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((a -> Sharing tag a) -> Sharing tag a)
-> (a -> Sharing tag a) -> Sharing tag a
forall a b. (a -> b) -> a -> b
$ \a
e -> do
(DynMap tag -> DynMap tag) -> StateT (DynMap tag) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (tag -> a -> DynMap tag -> DynMap tag
forall a tag.
(Typeable a, Ord tag) =>
tag -> a -> DynMap tag -> DynMap tag
dynInsert tag
t a
e)
Sharing tag a
m