objective 0.6.3 → 0.6.3.2

raw patch · 4 files changed

+63/−18 lines, 4 filesdep +transformers-compatdep ~adjunctionsdep ~elevatordep ~kan-extensions

Dependencies added: transformers-compat

Dependency ranges changed: adjunctions, elevator, kan-extensions, transformers

Files

CHANGELOG.md +4/−0
objective.cabal +16/−2
src/Control/Monad/Objective/Class.hs +4/−4
src/Control/Object.hs +39/−12

CHANGELOG.md view

@@ -1,3 +1,7 @@+0.6.3.1
+----
+* Reverted the fixity.
+
 0.6.3
 ----
 * Added `Variable`, an alias for `variable` objects.

objective.cabal view

@@ -1,5 +1,5 @@ name:                objective
-version:             0.6.3
+version:             0.6.3.2
 synopsis:            Extensible objects
 description:         Stateful effect transducer
 homepage:            https://github.com/fumieval/objective
@@ -25,7 +25,21 @@                      , Data.Functor.PushPull
   -- other-modules:
   other-extensions:    MultiParamTypeClasses, KindSignatures, TypeFamilies
-  build-depends:       base >=4.5 && <5, transformers >= 0.3 && <0.5, clean-unions < 0.2, elevator >= 0.1.2, containers, minioperational >= 0.4 && <0.5, profunctors >= 4.0 && <5, witherable <= 0.2, free >= 4.4 && <5, kan-extensions >= 4.1, unordered-containers, hashable >= 1.2 && <1.4, either, adjunctions
+  build-depends:       base >=4.5 && <5
+    , clean-unions < 0.2
+    , elevator >= 0.1.2 && <0.2
+    , containers
+    , minioperational >= 0.4 && <0.5
+    , profunctors >= 4.0 && <5
+    , witherable <= 0.2
+    , free >= 4.4 && <5
+    , kan-extensions >= 4.1 && <5
+    , unordered-containers
+    , hashable >= 1.2 && <1.4
+    , either
+    , adjunctions >= 4.0 && <5
+    , transformers >= 0.2 && <0.5
+    , transformers-compat >= 0.3
   ghc-options: -Wall
   hs-source-dirs:      src
   default-language:    Haskell2010

src/Control/Monad/Objective/Class.hs view

@@ -42,13 +42,13 @@ (.-) = invoke elevate elevate
 {-# INLINE (.-) #-}
 
-infixr 5 .-
+infixr 3 .-
 
 -- | Invoke a method.
 (.^) :: (MonadObjective b m, Elevate g m, Elevate e f) => Inst b f g -> e a -> m a
 i .^ e = i .- elevate e
 {-# INLINE (.^) #-}
-infixr 5 .^
+infixr 3 .^
 
 -- | (.^) for StateT
 (.&) :: (MonadObjective b m, Elevate g m, Elevate (State s) f) => Inst b f g -> StateT s m a -> m a
@@ -58,12 +58,12 @@   i .^ put s'
   return a
 
-infixr 5 .&
+infixr 3 .&
 
 (.!) :: (MonadObjective b m, Elevate g m) => Inst b f g -> Program f a -> m a
 (.!) i = interpret (i.-)
 
-infixr 5 .!
+infixr 3 .!
 
 -- | We can convert method invocation into an object trivially.
 -- @invocation i = liftO (i.-)@

src/Control/Object.hs view

@@ -62,6 +62,7 @@   announce,
   announceMaybe,
   announceMaybeT,
+  announceMortal,
   Process(..),
   _Process,
   Mortal(..),
@@ -129,7 +130,7 @@ (@-) :: Object f g -> f x -> g (x, Object f g)
 (@-) = runObject
 {-# INLINE (@-) #-}
-infixr 5 @-
+infixr 3 @-
 
 -- | The identity object
 echo :: Functor f => Object f f
@@ -137,7 +138,7 @@ 
 -- | Object-object composition
 (@>>@) :: Functor h => Object f g -> Object g h -> Object f h
-Object m @>>@ Object n = Object $ \e -> fmap (\((x, m'), n') -> (x, m' @>>@ n')) $ n (m e)
+Object m @>>@ Object n = Object $ fmap (\((x, m'), n') -> (x, m' @>>@ n')) . n . m
 infixr 1 @>>@
 
 -- | Object-function composition
@@ -240,13 +241,13 @@ (@!) :: Monad m => Object e m -> ReifiedProgram e a -> m (a, Object e m)
 obj @! Return a = return (a, obj)
 obj @! (e :>>= cont) = runObject obj e >>= \(a, obj') -> obj' @! cont a
-infixr 5 @!
+infixr 3 @!
 
 (@!!) :: Monad m => Object e m -> T.ReifiedProgramT e m a -> m (a, Object e m)
 obj @!! T.Return a = return (a, obj)
 obj @!! T.Lift m cont = m >>= (obj @!!) . cont
 obj @!! (e T.:>>= cont) = runObject obj e >>= \(a, obj') -> obj' @!! cont a
-infixr 5 @!!
+infixr 3 @!!
 
 iterObject :: Monad m => Object f m -> Free f a -> m (a, Object f m)
 iterObject obj (Pure a) = return (a, obj)
@@ -303,14 +304,20 @@   elevate (put t')
   return (e [])
 
-announceMaybe :: (Witherable t, Monad m, Elevate (State (t (Object f Maybe))) m) => f a -> m [a]
+announceMaybe :: (Witherable t
+    , Monad m
+    , Elevate (State (t (Object f Maybe))) m) => f a -> m [a]
 announceMaybe f = elevate $ state
   $ \t -> let (t', Endo e) = runWriter
                 $ witherM (\obj -> case runObject obj f of
                   Just (x, obj') -> lift $ writer (obj', Endo (x:))
                   Nothing -> mzero) t in (e [], t')
 
-announceMaybeT :: (Witherable t, Monad m, State (t (Object f (MaybeT g))) ∈ Floors1 m, g ∈ Floors1 m, Tower m) => f a -> m [a]
+announceMaybeT :: (Witherable t
+  , Monad m
+  , State (t (Object f (MaybeT g))) ∈ Floors1 m
+  , g ∈ Floors1 m
+  , Tower m) => f a -> m [a]
 announceMaybeT f = do
   t <- elevate get
   (t', Endo e) <- runWriterT $ witherM (\obj -> mapMaybeT (lift . elevate) (runObject obj f)
@@ -318,6 +325,21 @@   elevate (put t')
   return (e [])
 
+announceMortal :: (Witherable t
+  , Monad m
+  , State (t (Mortal f g ())) ∈ Floors1 m
+  , g ∈ Floors1 m
+  , Tower m) => f a -> m [a]
+announceMortal f = do
+  t <- elevate get
+  (t', Endo e) <- runWriterT $ witherM (\obj -> MaybeT (lift $ liftM is $ elevate $ runMortal obj f)
+      >>= \(x, obj') -> lift (writer (obj', Endo (x:)))) t
+  elevate (put t')
+  return (e [])
+  where
+    is (Left ()) = Nothing
+    is (Right a) = Just a
+
 -- | An object which is specialized to be a Mealy machine
 newtype Process m a b = Process { unProcess :: Object (Request a b) m }
 
@@ -416,13 +438,18 @@   (<*>) = ap
 
 instance Monad m => Monad (Mortal f m) where
-  return a = Mortal $ Object $ const $ E.left a
-  Mortal obj >>= k = unsafeCoerce $ \f -> lift (runEitherT (runObject obj f)) >>= \r -> case r of
-    Left a -> runObject (unMortal (k a)) f
-    Right (x, obj') -> return (x, unMortal (Mortal obj' >>= k))
+  return a = mortal $ const $ E.left a
+  m >>= k = mortal $ \f -> lift (runMortal m f) >>= \r -> case r of
+    Left a -> EitherT $ runMortal (k a) f
+    Right (x, m') -> return (x, m' >>= k)
 
-runMortal :: Monad m => Mortal f m a -> f x -> m (Either a (x, Mortal f m a))
-runMortal = unsafeCoerce runObject
+mortal :: (forall x. f x -> EitherT a m (x, Mortal f m a)) -> Mortal f m a
+mortal f = unsafeCoerce f
+{-# INLINE mortal #-}
+
+runMortal :: Mortal f m a -> f x -> m (Either a (x, Mortal f m a))
+runMortal = unsafeCoerce
+{-# INLINE runMortal #-}
 
 -- | For every adjunction f ⊣ g, we can "connect" @Object g m@ and @Object f m@ permanently.
 ($$) :: (Monad m, Adjunction f g) => Object g m -> Object f m -> m x