module Data.Chatty.Atoms where
import Control.Applicative
import Control.Arrow
import qualified Control.Category as C
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import Data.Dynamic
import Data.Typeable
import Data.Chatty.AVL
import Data.Chatty.Counter
import Unsafe.Coerce
data Atom a = Atom Int
| forall b. FunAtom Int (Atom b) (b -> a) (b -> a -> b)
| forall b c. FunAtom2 Int (Atom b) (Atom c) ((b,c) -> a) ((b,c) -> a -> (b,c))
instance Eq (Atom a) where
(Atom n) == (Atom m) = n == m
(FunAtom i _ _ _) == (FunAtom j _ _ _) = i == j
(FunAtom2 i _ _ _ _) == (FunAtom2 j _ _ _ _) = i == j
_ == _ = False
instance Ord (Atom a) where
(Atom n) `compare` (Atom m) = n `compare` m
(FunAtom i _ _ _) `compare` (Atom m) = i `compare` m
(FunAtom2 i _ _ _ _) `compare` (Atom m) = i `compare` m
(Atom n) `compare` (FunAtom j _ _ _) = n `compare` j
(FunAtom i _ _ _) `compare` (FunAtom j _ _ _) = i `compare` j
(FunAtom2 i _ _ _ _) `compare` (FunAtom j _ _ _) = i `compare` j
(Atom n) `compare` (FunAtom2 j _ _ _ _) = n `compare` j
(FunAtom i _ _ _) `compare` (FunAtom2 j _ _ _ _) = i `compare` j
(FunAtom2 i _ _ _ _) `compare` (FunAtom2 j _ _ _ _) = i `compare` j
newtype Container = Container ()
newtype AtomStoreT m a = AtomStore { runAtomStoreT :: AVL (Int, Container) -> m (a,AVL (Int,Container)) }
instance Functor m => Functor (AtomStoreT m) where
fmap f a = AtomStore $ \s -> fmap (first f) $ runAtomStoreT a s
instance (Functor m, Monad m) => Applicative (AtomStoreT m) where
pure = return
(<*>) = ap
instance Monad m => Monad (AtomStoreT m) where
return a = AtomStore $ \s -> return (a,s)
m >>= f = AtomStore $ \s -> do (a,s') <- runAtomStoreT m s; runAtomStoreT (f a) s'
instance MonadTrans AtomStoreT where
lift m = AtomStore $ \s -> do a <- m; return (a,s)
instance MonadIO m => MonadIO (AtomStoreT m) where
liftIO = lift . liftIO
instance ChCounter m => ChCounter (AtomStoreT m) where
countOn = lift countOn
class ChCounter m => ChAtoms m where
newAtom :: m (Atom v)
newAtom = liftM Atom countOn
funAtom :: Atom b -> (b -> a) -> (b -> a -> b) -> m (Atom a)
funAtom b r p = do
i <- countOn
return $ FunAtom i b r p
funAtom2 :: Atom b -> Atom c -> ((b,c) -> a) -> ((b,c) -> a -> (b,c)) -> m (Atom a)
funAtom2 b c r p = do
i <- countOn
return $ FunAtom2 i b c r p
putAtom :: Atom v -> v -> m ()
getAtom :: Atom v -> m v
dispAtom :: Atom v -> m ()
cloneAtom :: Atom v -> m (Atom v)
cloneAtom a = do
b <- newAtom
v <- getAtom a
putAtom b v
return b
instance ChCounter m => ChAtoms (AtomStoreT m) where
putAtom (Atom a) v = AtomStore $ \s -> return ((),avlInsert (a,unsafeCoerce v) s)
putAtom (FunAtom _ b _ p) v = do
bv <- getAtom b
putAtom b $ p bv v
putAtom (FunAtom2 _ b c _ p) v = do
bv <- getAtom b
cv <- getAtom c
let (bv',cv') = p (bv, cv) v
putAtom b bv'
putAtom c cv'
getAtom (Atom a) = AtomStore $ \s -> let Just v = avlLookup a s in return (unsafeCoerce v,s)
getAtom (FunAtom _ b g _) = liftM g $ getAtom b
getAtom (FunAtom2 _ b c g _) = do
bv <- getAtom b
cv <- getAtom c
return $ g (bv,cv)
dispAtom (Atom a) = AtomStore $ \s -> return ((),avlRemove a s)
dispAtom (FunAtom _ _ _ _) = return ()
dispAtom (FunAtom2 _ _ _ _ _) = return ()
mapAtom :: ChAtoms m => (a -> a) -> Atom a -> m ()
mapAtom f a = do
v <- getAtom a
putAtom a $ f v
newtype Redundant m a b = Redundant { runRedundant :: Atom a -> m (Atom b) }
instance ChAtoms m => C.Category (Redundant m) where
id = Redundant return
a . b = Redundant (runRedundant a <=< runRedundant b)
instance ChAtoms m => Arrow (Redundant m) where
arr f = Redundant $ \a -> do
v <- getAtom a
b <- newAtom
putAtom b $ f v
return b
first f = Redundant $ \a -> do
c <- runRedundant f =<< funAtom a fst (\(_, s) f -> (f, s))
funAtom2 a c (\((_,s),f) -> (f,s)) $ \((e,s),f) (f',s') -> ((e,s'),f')