module Control.Monad.Atom
( AtomTable
, Atom
, AtomT
, toAtom
, fromAtom
, maybeToAtom
, empty
, evalAtom
, evalAtomT
, runAtom
, runAtomT
, mapping
)
where
import Control.Monad.State
import Control.Monad.Identity
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import GHC.Generics (Generic)
data AtomTable a = T { lastID :: !Int
, to :: !(Map.Map a Int)
, from :: !(IntMap.IntMap a) }
deriving (Generic)
newtype AtomT a m r = AtomT (StateT (AtomTable a) m r)
deriving (Functor, Monad, MonadTrans, MonadIO)
newtype Atom a r = Atom (AtomT a Identity r)
deriving (Functor, Monad)
class (Monad m) => MonadAtom m where
type Key m
toAtom :: Key m -> m Int
maybeToAtom :: Key m -> m (Maybe Int)
fromAtom :: Int -> m (Key m)
instance (Ord a, Monad m) => MonadAtom (AtomT a m) where
type Key (AtomT a m) = a
toAtom = AtomT . toAtom'
maybeToAtom = AtomT . maybeToAtom'
fromAtom = AtomT . fromAtom'
instance (Ord a) => MonadAtom (Atom a) where
type Key (Atom a) = a
toAtom = Atom . toAtom
maybeToAtom = Atom . maybeToAtom
fromAtom = Atom . fromAtom
runAtomT :: (Ord a, Monad m) => AtomT a m r -> AtomTable a -> m (r, AtomTable a)
runAtomT (AtomT x) = runStateT x
runAtom :: (Ord a) => Atom a r -> AtomTable a -> (r, AtomTable a)
runAtom (Atom x) s = runIdentity (runAtomT x s)
evalAtomT :: (Ord a, Monad m) => AtomT a m r -> m r
evalAtomT (AtomT x) = evalStateT x empty
evalAtom :: (Ord a) => Atom a r -> r
evalAtom (Atom x) = runIdentity (evalAtomT x)
toAtom' :: (Monad m, Ord a) => a -> StateT (AtomTable a) m Int
toAtom' x = do
let b = x
t <- get
case Map.lookup b (to t) of
Just j -> return $! j
Nothing -> do
let i = lastID t
i' = i + 1
!t' = t { lastID = i'
, to = Map.insert b i (to t)
, from = IntMap.insert i b (from t) }
put $! t'
return $! lastID t
maybeToAtom' :: (Ord a, Monad m) =>
a -> StateT (AtomTable a) m (Maybe Int)
maybeToAtom' x = do
t <- get
return $! Map.lookup x . to $ t
fromAtom' :: Monad m => Int -> StateT (AtomTable a) m a
fromAtom' i = do
t <- get
return $! from t IntMap.! i
empty :: (Ord a) => AtomTable a
empty = T 0 Map.empty IntMap.empty
mapping :: (Ord a) => AtomTable a -> Map.Map a Int
mapping = to