-- | A monad for binding values to tags to ensure sharing, 
-- with the added twist that the value can be polymorphic
-- and each monomorphic instance is bound separately.
module Control.Monad.TagShare(
  -- ** Dynamic map
  DynMap,
  dynEmpty,
  dynInsert,
  dynLookup,
  -- ** Sharing monad
  Sharing,
  runSharing,
  share
  ) where
import Control.Monad.State
import Data.Typeable
import Data.Dynamic(Dynamic, fromDynamic, toDyn)
import Data.Map as M

-- |  A dynamic map with type safe
-- insertion and lookup.
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

 
-- | A sharing monad
-- with a function that binds a tag to a value.
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