objective 1.0.2 → 1.0.3

raw patch · 4 files changed

+40/−45 lines, 4 files

Files

• CHANGELOG.md +9/−0
• objective.cabal +1/−1
• src/Control/Object/Mortal.hs +20/−41
• src/Control/Object/Object.hs +10/−3

@@ -1,3 +1,12 @@+1.0.3+----+* Added `apprisesOf`+* Added `(@~)`++1.0.2+----+* Made `(.-)` exception-safe+ 1.0.1 ---- * Switched to use TMVar for instances

@@ -1,5 +1,5 @@ name:                objective-version:             1.0.2+version:             1.0.3 synopsis:            Extensible objects description:         Stateful effect transducer homepage:            https://github.com/fumieval/objective

@@ -1,21 +1,17 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BangPatterns #-} module Control.Object.Mortal (     Mortal(..),     mortal,     mortal_,     runMortal,     immortal,-    apprise,+    apprisesOf,     apprises,-    apprises',-    apprises_,-    -- * Combinators-    gatherFst,-    gatherSnd,-    buildSingle,-    buildBoth,+    apprise,+    withBuilder,     ) where  import Control.Object.Object@@ -77,43 +73,26 @@ immortal obj = mortal $ \f -> EitherT $ runObject obj f >>= \(a, obj') -> return $ Right (a, immortal obj')  -- | Send a message to mortals in a container.-apprise :: (Witherable t, Monad m, Applicative m) => f a -> StateT (t (Mortal f m r)) m ([a], [r])-apprise f = buildBoth (apprises f)-{-# INLINE apprise #-}---- | Send a message to mortals in a container.-apprises :: (Witherable t, Monad m, Applicative m, Monoid r) => f a -> (a -> r) -> (b -> r) -> StateT (t (Mortal f m b)) m r-apprises f p q = StateT $ \t -> do-  (t', res) <- runWriterT $ flip wither t+apprisesOf :: (Monad m, Monoid r) => ((Mortal f m b -> WriterT r m (Maybe (Mortal f m b))) -> s -> WriterT r m s)+  -> f a -> (a -> r) -> (b -> r) -> StateT s m r+apprisesOf l f p q = StateT $ \t -> do+  (t', res) <- runWriterT $ flip l t     $ \obj -> lift (runEitherT $ runMortal obj f) >>= \case       Left r -> writer (Nothing, q r)       Right (x, obj') -> writer (Just obj', p x)   return (res, t')-{-# INLINE apprises #-} --- | Like apprises, but ignores the final results.-apprises' :: (Witherable t, Monad m, Applicative m, Monoid r) => f a -> (a -> r) -> StateT (t (Mortal f m b)) m r-apprises' f c = apprises f c (const mempty)-{-# INLINE apprises' #-}---- | Like apprises, but ignores the result.-apprises_ :: (Witherable t, Monad m, Applicative m, Monoid r) => f a -> (b -> r) -> StateT (t (Mortal f m b)) m r-apprises_ f = apprises f (const mempty)-{-# INLINE apprises_ #-}--gatherFst :: (Monoid r) => (a -> r) -> ((a -> r) -> (b -> r) -> k) -> k-gatherFst g f = f g (const mempty)-{-# INLINE gatherFst #-}--gatherSnd :: (Monoid r) => (b -> r) -> ((a -> r) -> (b -> r) -> k) -> k-gatherSnd g f = f (const mempty) g-{-# INLINE gatherSnd #-}+-- | Send a message to mortals in a container.+apprises :: (Witherable t, Monad m, Applicative m, Monoid r) => f a -> (a -> r) -> (b -> r) -> StateT (t (Mortal f m b)) m r+apprises = apprisesOf wither+{-# INLINE apprises #-} -buildSingle :: Functor f => ((a -> Endo [a]) -> f (Endo [a])) -> f [a]-buildSingle f = fmap (flip appEndo []) (f (Endo . (:)))-{-# INLINABLE buildSingle #-}+-- | Send a message to mortals in a container.+apprise :: (Witherable t, Monad m, Applicative m) => f a -> StateT (t (Mortal f m r)) m ([a], [r])+apprise f = fmap (flip appEndo [] *** flip appEndo [])+  $ apprises f (\a -> (Endo (a:), mempty)) (\b -> (mempty, Endo (b:)))+{-# INLINE apprise #-} -buildBoth :: Functor f => ((a -> (Endo [a], Endo [b])) -> (b -> (Endo [a], Endo [b])) -> f (Endo [a], Endo [b])) -> f ([a], [b])-buildBoth f = fmap (flip appEndo [] *** flip appEndo [])-  $ f (\a -> (Endo (a:), mempty)) (\b -> (mempty, Endo (b:)))-{-# INLINABLE buildBoth #-}+withBuilder :: Functor f => ((a -> Endo [a]) -> f (Endo [a])) -> f [a]+withBuilder f = fmap (flip appEndo []) (f (Endo . (:)))+{-# INLINABLE withBuilder #-}

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE Rank2Types, CPP, TypeOperators, DataKinds, TupleSections #-}+{-# LANGUAGE Rank2Types, CPP, TypeOperators, DataKinds, TupleSections, BangPatterns #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} #endif@@ -94,11 +94,17 @@ -- | Build a stateful object. -- -- @stateful t s = t ^>>@ variable s@-stateful :: Monad m => (forall a. f a -> StateT s m a) -> s -> Object f m+stateful :: Monad m => (forall a. t a -> StateT s m a) -> s -> Object t m stateful h = go where   go s = Object $ \f -> runStateT (h f) s >>= \(a, s') -> s' `seq` return (a, go s') {-# INLINE stateful #-} +-- | Flipped 'stateful'+(@~) :: Monad m => s -> (forall a. t a -> StateT s m a) -> Object t m+s @~ h = stateful h s+{-# INLINE (@~) #-}+infix 1 @~+ -- | Cascading iterObject :: Monad m => Object f m -> Free f a -> m (a, Object f m) iterObject obj (Pure a) = return (a, obj)@@ -111,7 +117,8 @@  -- | A mutable variable. variable :: Monad m => s -> Object (StateT s m) m-variable s = Object $ \m -> liftM (fmap variable) $ runStateT m s+variable = stateful id+{-# INLINE variable #-}  -- | Send a message to objects in a container. announce :: (T.Traversable t, Monad m) => f a -> StateT (t (Object f m)) m [a]