chatty-utils 0.6 → 0.7.1

raw patch · 2 files changed

+91/−26 lines, 2 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/Chatty/Atoms.hs +90/−25
• chatty-utils.cabal +1/−1

@@ -1,3 +1,4 @@+{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables #-} {-   This module is part of Chatty.   Copyleft (c) 2014 Marvin Cohrs@@ -31,12 +32,34 @@ import Data.Typeable import Data.Chatty.AVL import Data.Chatty.Counter+import Unsafe.Coerce  -- | Phantom type for atom IDs-newtype Atom a = Atom Int deriving (Ord,Eq)+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 ()+ -- | The storage monad-newtype AtomStoreT m a = AtomStore { runAtomStoreT :: AVL (Int,Dynamic) -> m (a,AVL (Int,Dynamic)) }+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@@ -57,48 +80,90 @@ -- | Typeclass for all atom-storing monads. class ChCounter m => ChAtoms m where   -- | Reserve a new atom.-  newAtom :: Typeable v => m (Atom v)+  newAtom :: m (Atom v)+  newAtom = liftM Atom countOn+  -- | Construct a new functional atom.+  funAtom :: Atom b -> (b -> a) -> (b -> a -> b) -> m (Atom a)+  funAtom b r p = do+    i <- countOn+    return $ FunAtom i b r p+  -- | Construct a new doubly-source functional atom+  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   -- | Save a value for the given atom.-  putAtom :: Typeable v => Atom v -> v -> m ()+  putAtom :: Atom v -> v -> m ()   -- | Get the value from a given atom.-  getAtom :: Typeable v => Atom v -> m v+  getAtom :: Atom v -> m v   -- | Dispose the given atom.   dispAtom :: Atom v -> m ()   -- | Clone the given atom.-  cloneAtom :: Typeable v => Atom v -> m (Atom v)+  cloneAtom :: Atom v -> m (Atom v)   cloneAtom a = do     b <- newAtom     v <- getAtom a     putAtom b v     return b -instance (Functor m,ChCounter m) => ChAtoms (AtomStoreT m) where-  newAtom = fmap Atom $ lift countOn-  putAtom (Atom a) v = AtomStore $ \s -> return ((),avlInsert (a,toDyn v) s)-  getAtom (Atom a) = AtomStore $ \s -> let Just v = avlLookup a s in return (fromDyn v undefined,s)+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 () --- | Atomar operation (almost arrow)-newtype (Typeable a,Typeable b) => Atomar m a b = Atomar { runAtomar :: Atom a -> m (Atom b) }+-- Stop it. This just doesn't work safely.+{-- | Arrow type operating on atoms. Works by overwriting the educt. You should really *not* use+-- this for general a->b arrows, but only for a->a, unless you are sure that all Atom a references+-- are gone! Otherwise segfaults are waiting for you!+newtype Atomar m a b = Atomar { runAtomar :: Atom a -> m (Atom b) } -{-instance MonadAtoms m => C.Category (Atomar m) where+instance ChAtoms m => C.Category (Atomar m) where   id = Atomar return   a . b = Atomar (runAtomar a <=< runAtomar b) -instance MonadAtoms m => Arrow (Atomar m) where+instance ChAtoms m => Arrow (Atomar m) where   arr = Atomar . mapAtom   first f = Atomar $ \a -> do-    b <- cloneAtom a-    b' <- mapAtom fst b-    c <- runAtomar f b'-    v <- getAtom c-    mapAtom (first $ const v) a-    dispAtom c-}+    let afst = funAtom a fst $ \(_,s) f -> (f,s)+    mapAtom afst+-}  -- | Run a pure function on atoms.-mapAtom :: (Typeable a, Typeable b, ChAtoms m) => (a -> b) -> Atom a -> m (Atom b)-mapAtom f (Atom a) = do-  v <- getAtom (Atom a)-  putAtom (Atom a) $ f v-  return (Atom a)+mapAtom :: ChAtoms m => (a -> a) -> Atom a -> m ()+mapAtom f a = do+  v <- getAtom a+  putAtom a $ f v +-- | Arrow type operating on atoms. Works by cloning the educt, then overwriting the clone.+-- You shouldn't use this inside long-term environments, as massive usage blows up the memory.+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')

@@ -10,7 +10,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.6+version:             0.7.1  -- A short (one-line) description of the package. synopsis:            Some utilities every serious chatty-based application may need.