objective 1.0.1 → 1.0.2

raw patch · 4 files changed

+34/−17 lines, 4 filesdep +exceptionsdep +monad-stm

Dependencies added: exceptions, monad-stm

Files

objective.cabal +3/−1
src/Control/Object/Instance.hs +16/−9
src/Control/Object/Mortal.hs +13/−1
src/Data/Functor/Request.hs +2/−6

objective.cabal view

@@ -1,5 +1,5 @@ name:                objective-version:             1.0.1+version:             1.0.2 synopsis:            Extensible objects description:         Stateful effect transducer homepage:            https://github.com/fumieval/objective@@ -30,6 +30,7 @@   other-extensions:    MultiParamTypeClasses, KindSignatures, TypeFamilies   build-depends:       base >=4.6 && <5     , either >= 4.3 && <4.5+    , exceptions >= 0.8     , containers >= 0.5.0.0 && <0.6     , unordered-containers >= 0.2.0.0 && <0.3     , transformers >= 0.3@@ -39,6 +40,7 @@     , void     , witherable     , stm+    , monad-stm   ghc-options: -Wall   hs-source-dirs:      src   default-language:    Haskell2010

src/Control/Object/Instance.hs view

@@ -4,7 +4,9 @@ import Control.Monad.STM import Control.Object.Object import Control.Monad.IO.Class+import Control.Monad.STM.Class import Control.Monad+import Control.Monad.Catch (MonadMask, bracketOnError)  -- | TMVar-based instance data Instance f g where@@ -19,12 +21,17 @@   {-# INLINE (@>>^) #-}  -- | Invoke a method with an explicit landing function.-invokeOn :: MonadIO m => (forall x. g x -> m x) -> Instance f g -> f a -> m a-invokeOn m (InstRef v) f = do-  obj <- liftIO $ atomically $ takeTMVar v-  (a, obj') <- m (runObject obj f)-  liftIO $ atomically $ putTMVar v obj'-  return a+invokeOn :: (MonadIO m, MonadMask m)+         => (forall x. g x -> m x) -> Instance f g -> f a -> m a+invokeOn m (InstRef v) f = bracketOnError+  (liftIO $ atomically $ takeTMVar v)+  (\obj -> liftIO $ atomically $ do+    _ <- tryTakeTMVar v+    putTMVar v obj)+  (\obj -> do+    (a, obj') <- m (runObject obj f)+    liftIO $ atomically $ putTMVar v obj'+    return a) invokeOn m (InstLmap t i) f = invokeOn m i (t f) invokeOn m (InstRmap i t) f = invokeOn (m . t) i f @@ -39,13 +46,13 @@ invokeOnSTM m (InstRmap i t) f = invokeOnSTM (m . t) i f  -- | Invoke a method, atomically.-(..-) :: Instance f STM -> f a -> STM a-(..-) i = invokeOnSTM id i+(..-) :: MonadSTM m => Instance f STM -> f a -> m a+(..-) i = liftSTM . invokeOnSTM id i {-# INLINE (..-) #-} infixr 3 ..-  -- | Invoke a method.-(.-) :: MonadIO m => Instance f m -> f a -> m a+(.-) :: (MonadIO m, MonadMask m) => Instance f m -> f a -> m a (.-) = invokeOn id {-# INLINE (.-) #-} infixr 3 .-

src/Control/Object/Mortal.hs view

@@ -9,6 +9,8 @@     immortal,     apprise,     apprises,+    apprises',+    apprises_,     -- * Combinators     gatherFst,     gatherSnd,@@ -81,13 +83,23 @@  -- | 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+apprises f p q = StateT $ \t -> do   (t', res) <- runWriterT $ flip wither 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)

src/Data/Functor/Request.hs view

@@ -21,7 +21,7 @@ import Data.Hashable import Control.Arrow --- | 'Request a b' is the type of a request that sends @a@ to receive @b@.+-- | @'Request' a b@ is the type of a request that sends @a@ to receive @b@. data Request a b r = Request a (b -> r) deriving (Functor, Typeable)  mapRequest :: (a -> a') -> Request a b r -> Request a' b r@@ -46,15 +46,11 @@ accept f = \(Request a cont) -> cont <$> f a {-# INLINE accept #-} -{-# DEPRECATED handles "Use mealy instead" #-}-handles :: Functor m => (a -> m (b, Object (Request a b) m)) -> Object (Request a b) m-handles = mealy- mealy :: Functor m => (a -> m (b, Object (Request a b) m)) -> Object (Request a b) m mealy f = Object $ \(Request a cont) -> first cont <$> f a {-# INLINE mealy #-} --- | Like 'flyweight', but it uses 'Data.HashMap.Strict' internally.+-- | The flyweight pattern flyweight :: (Applicative m, Eq k, Hashable k) => (k -> m a) -> Object (Request k a) m flyweight f = go HM.empty where   go m = mealy $ \k -> case HM.lookup k m of