objective 1.0.5 → 1.1
raw patch · 6 files changed
+37/−70 lines, 6 filesdep −monad-stmdep −stm
Dependencies removed: monad-stm, stm
Files
- CHANGELOG.md +5/−0
- objective.cabal +1/−3
- src/Control/Object.hs +0/−1
- src/Control/Object/Instance.hs +23/−55
- src/Control/Object/Object.hs +8/−10
- src/Data/Functor/Request.hs +0/−1
CHANGELOG.md view
@@ -1,3 +1,8 @@+1.1+----+* Removed `HProfunctor`, `(..-)`, `invokeOnSTM`, `newSTM`, `snapshot`+* Added `(?-)`+ 1.0.5 ---- * Added `filterO` and `filteredO`
objective.cabal view
@@ -1,5 +1,5 @@ name: objective-version: 1.0.5+version: 1.1 synopsis: Composable objects description: Composable objects homepage: https://github.com/fumieval/objective@@ -41,8 +41,6 @@ , profunctors , void , witherable >= 0.1.3- , stm- , monad-stm , monad-skeleton >= 0.1.1 && <0.3 , template-haskell ghc-options: -Wall
src/Control/Object.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Object
src/Control/Object/Instance.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE GADTs, Rank2Types #-}+{-# LANGUAGE GADTs, Rank2Types, LambdaCase #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Object.Instance@@ -13,84 +12,53 @@ ----------------------------------------------------------------------------- module Control.Object.Instance ( -- * Instantiation- Instance(..)+ Instance , new , newSettle- , newSTM -- * Invocation , invokeOn- , invokeOnSTM , (.-)- , (..-)- , snapshot+ , (?-) ) where-import Control.Concurrent.STM.TMVar-import Control.Monad.STM+import Control.Concurrent+import Control.Exception (evaluate) 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- InstRef :: (forall x. e x -> f x) -> (forall x. g x -> h x) -> TMVar (Object f g) -> Instance e h+import Control.Monad.Catch -instance HProfunctor Instance where- f ^>>@ InstRef l r v = InstRef (l . f) r v- {-# INLINE (^>>@) #-}- InstRef l r v @>>^ f = InstRef l (f . r) v- {-# INLINE (@>>^) #-}+type Instance f g = MVar (Object f g) -- | Invoke a method with an explicit landing function.+-- In case of exception, the original object will be set. invokeOn :: (MonadIO m, MonadMask m)- => (forall x. g x -> m x) -> Instance f g -> f a -> m a-invokeOn m (InstRef t l v) f = bracketOnError- (liftIO $ atomically $ takeTMVar v)- (\obj -> liftIO $ atomically $ do- _ <- tryTakeTMVar v- putTMVar v obj)- (\obj -> do- (a, obj') <- m $ l $ runObject obj (t f)- liftIO $ atomically $ putTMVar v obj'- return a)---- | Invoke a method with an explicit landing function.-invokeOnSTM :: (forall x. g x -> STM x) -> Instance f g -> f a -> STM a-invokeOnSTM m (InstRef t l v) f = do- obj <- takeTMVar v- (a, obj') <- m $ l $ runObject obj (t f)- putTMVar v obj'+ => (forall x. g x -> m x) -> MVar (Object f g) -> f a -> m a+invokeOn m v f = mask $ \restore -> do+ obj <- liftIO $ takeMVar v+ (a, obj') <- restore (m (runObject obj f) >>= liftIO . evaluate) `onException` liftIO (putMVar v obj)+ liftIO $ putMVar v obj' return a --- | Invoke a method, atomically.-(..-) :: MonadSTM m => Instance f STM -> f a -> m a-(..-) i = liftSTM . invokeOnSTM id i-{-# INLINE (..-) #-}-infixr 3 ..-- -- | Invoke a method.-(.-) :: (MonadIO m, MonadMask m) => Instance f m -> f a -> m a+(.-) :: (MonadIO m, MonadMask m) => MVar (Object f m) -> f a -> m a (.-) = invokeOn id {-# INLINE (.-) #-} infixr 3 .- --- | Take a snapshot of an instance.-snapshot :: (MonadSTM m, Functor g) => Instance f g -> m (Object f g)-snapshot (InstRef f g v) = liftSTM $ go `fmap` readTMVar v- where go (Object m) = Object $ fmap (fmap go) . g . m . f+-- | Try to invoke a method. If the instance is unavailable, it returns Nothing.+(?-) :: (MonadIO m, MonadMask m) => MVar (Object f m) -> f a -> m (Maybe a)+v ?- f = mask $ \restore -> liftIO (tryTakeMVar v) >>= \case+ Just obj -> do+ (a, obj') <- restore (runObject obj f >>= liftIO . evaluate) `onException` liftIO (putMVar v obj)+ liftIO $ putMVar v obj'+ return (Just a)+ Nothing -> return Nothing -- | Create a new instance. This can be used inside 'unsafePerformIO' to create top-level instances. new :: MonadIO m => Object f g -> m (Instance f g)-new = liftIO . liftM (InstRef id id) . newTMVarIO+new = liftIO . newMVar {-# INLINE new #-} -- | Create a new instance, having it sitting on the current environment. newSettle :: MonadIO m => Object f m -> m (Instance f m) newSettle = new {-# INLINE newSettle #-}---- | Create a new instance.-newSTM :: MonadSTM m => Object f g -> m (Instance f g)-newSTM = liftSTM . liftM (InstRef id id) . newTMVar-{-# INLINE newSTM #-}
src/Control/Object/Object.hs view
@@ -23,7 +23,8 @@ , (@>>@) , (@<<@) , liftO- , HProfunctor(..)+ , (^>>@)+ , (@>>^) , (@||@) -- * Stateful construction , unfoldO@@ -96,16 +97,13 @@ infixr 1 ^>>@ infixr 1 @>>^ --- | Higher-order profunctors-class HProfunctor k where- (^>>@) :: Functor h => (forall x. f x -> g x) -> k g h -> k f h- (@>>^) :: Functor h => k f g -> (forall x. g x -> h x) -> k f h+(^>>@) :: Functor h => (forall x. f x -> g x) -> Object g h -> Object f h+f ^>>@ m0 = go m0 where go (Object m) = Object $ fmap (fmap go) . m . f+{-# INLINE (^>>@) #-} -instance HProfunctor Object where- m0 @>>^ g = go m0 where go (Object m) = Object $ fmap (fmap go) . g . m- {-# INLINE (@>>^) #-}- f ^>>@ m0 = go m0 where go (Object m) = Object $ fmap (fmap go) . m . f- {-# INLINE (^>>@) #-}+(@>>^) :: Functor h => Object f g -> (forall x. g x -> h x) -> Object f h+m0 @>>^ g = go m0 where go (Object m) = Object $ fmap (fmap go) . g . m+{-# INLINE (@>>^) #-} -- | The trivial object echo :: Functor f => Object f f
src/Data/Functor/Request.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE Safe #-} {-# LANGUAGE CPP, DeriveFunctor, DeriveDataTypeable, ConstraintKinds, FlexibleContexts, TypeOperators, DataKinds, TypeFamilies #-} ----------------------------------------------------------------------------- -- |