objective 0.6.3.3 → 0.6.5

raw patch · 8 files changed

+76/−82 lines, 8 filesdep +extensibledep −clean-unionsdep ~elevator

Dependencies added: extensible

Dependencies removed: clean-unions

Dependency ranges changed: elevator

Files

CHANGELOG.md +4/−0
objective.cabal +3/−3
src/Control/Monad/Objective/Class.hs +6/−3
src/Control/Object/Extra.hs +29/−39
src/Control/Object/Mortal.hs +12/−6
src/Control/Object/Object.hs +9/−18
src/Data/Functor/PushPull.hs +10/−10
src/Data/Functor/Request.hs +3/−3

CHANGELOG.md view

@@ -1,3 +1,7 @@+0.6.5
+----
+* Supported `elevator >= 0.2`.
+
 0.6.3.1
 ----
 * Reverted the fixity.

objective.cabal view

@@ -1,5 +1,5 @@ name:                objective
-version:             0.6.3.3
+version:             0.6.5
 synopsis:            Extensible objects
 description:         Stateful effect transducer
 homepage:            https://github.com/fumieval/objective
@@ -33,8 +33,8 @@   other-extensions:    MultiParamTypeClasses, KindSignatures, TypeFamilies
   build-depends:       base >=4.5 && <5
     , comonad
-    , clean-unions < 0.2
-    , elevator >= 0.1.2 && <0.2
+    , elevator >= 0.2 && <0.3
+    , extensible
     , containers
     , minioperational >= 0.4 && <0.5
     , profunctors >= 4.0 && <5

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

@@ -25,6 +25,7 @@ import Control.Elevator
 import Control.Monad.Trans.State.Strict
 import Control.Monad.Operational.Mini
+import Data.Functor.Identity
 import Control.Monad
 
 type Inst' f g = Inst g f g
@@ -38,6 +39,9 @@ 
 type MonadObjective b m = (ObjectiveBase b, Elevate b m, Monad m)
 
+(.->) :: (Monad m, ObjectiveBase m) => Inst m f m -> f a -> m a
+(.->) = invoke id id
+
 (.-) :: (MonadObjective b m, Elevate g m) => Inst b f g -> f a -> m a
 (.-) = invoke elevate elevate
 {-# INLINE (.-) #-}
@@ -53,10 +57,9 @@ -- | (.^) for StateT
 (.&) :: (MonadObjective b m, Elevate g m, Elevate (State s) f) => Inst b f g -> StateT s m a -> m a
 i .& m = do
-  s <- i .^ get
+  s <- i .^ StateT (\s -> Identity (s, s))
   (a, s') <- runStateT m s
-  i .^ put s'
-  return a
+  i .^ StateT (\_ -> Identity (a, s'))
 
 infixr 3 .&

src/Control/Object/Extra.hs view

@@ -1,7 +1,6 @@ {-# LANGUAGE Rank2Types, TypeOperators, FlexibleContexts, ConstraintKinds #-} module Control.Object.Extra where import Control.Object.Object-import Control.Object.Mortal import qualified Data.HashMap.Strict as HM import qualified Data.Map.Strict as Map import Data.Witherable@@ -10,14 +9,15 @@ import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Class import Control.Monad-import Control.Elevator import Data.Functor.Request import Data.Functor.PushPull import Control.Applicative-import Data.OpenUnion1.Clean import Data.Monoid import Data.Hashable import Data.Traversable as T+import Data.IORef+import Data.Profunctor.Unsafe+import Control.Monad.IO.Class  -- | Build an object using continuation passing style. oneshot :: (Functor f, Monad m) => (forall a. f (m a) -> m a) -> Object f m@@ -31,6 +31,7 @@   go m = Object $ \(Request k cont) -> case Map.lookup k m of     Just a -> return (cont a, go m)     Nothing -> f k >>= \a -> return (cont a, go $ Map.insert k a m)+{-# INLINE flyweight #-}  -- | Like 'flyweight', but it uses 'Data.HashMap.Strict' internally. flyweight' :: (Monad m, Eq k, Hashable k) => (k -> m a) -> Object (Request k a) m@@ -38,60 +39,38 @@   go m = Object $ \(Request k cont) -> case HM.lookup k m of     Just a -> return (cont a, go m)     Nothing -> f k >>= \a -> return (cont a, go $ HM.insert k a m)+{-# INLINE flyweight' #-}  animate :: (Applicative m, Num t) => (t -> m a) -> Object (Request t a) m animate f = go 0 where   go t = Object $ \(Request dt cont) -> (\x -> (cont x, go (t + dt))) <$> f t+{-# INLINE animate #-}  transit :: (Alternative m, Fractional t, Ord t) => t -> (t -> m a) -> Object (Request t a) m transit len f = go 0 where   go t     | t >= len = Object $ const empty     | otherwise = Object $ \(Request dt cont) -> (\x -> (cont x, go (t + dt))) <$> f (t / len)+{-# INLINE transit #-} -announce :: (T.Traversable t, Monad m, Elevate (State (t (Object f g))) m, Elevate g m) => f a -> m [a]-announce f = do-  t <- elevate get-  (t', Endo e) <- runWriterT $ T.mapM (\obj -> (lift . elevate) (runObject obj f)+announce :: (T.Traversable t, Monad m) => f a -> StateT (t (Object f m)) m [a]+announce f = StateT $ \t -> do+  (t', Endo e) <- runWriterT $ T.mapM (\obj -> lift (runObject obj f)       >>= \(x, obj') -> writer (obj', Endo (x:))) t-  elevate (put t')-  return (e [])+  return (e [], t') -announceMaybe :: (Witherable t-    , Monad m-    , Elevate (State (t (Object f Maybe))) m) => f a -> m [a]-announceMaybe f = elevate $ state+announceMaybe :: (Witherable t, Monad m) => f a -> StateT (t (Object f Maybe)) m [a]+announceMaybe f = StateT   $ \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 f = do-  t <- elevate get-  (t', Endo e) <- runWriterT $ witherM (\obj -> mapMaybeT (lift . elevate) (runObject obj f)-      >>= \(x, obj') -> lift (writer (obj', Endo (x:)))) t-  elevate (put t')-  return (e [])+                  Nothing -> mzero) t in return (e [], t') -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)+announceMaybeT :: (Witherable t, Monad m) => f a -> StateT (t (Object f (MaybeT m))) m [a]+announceMaybeT f = StateT $ \t -> do+  (t', Endo e) <- runWriterT $ witherM (\obj -> mapMaybeT lift (runObject obj f)       >>= \(x, obj') -> lift (writer (obj', Endo (x:)))) t-  elevate (put t')-  return (e [])-  where-    is (Left ()) = Nothing-    is (Right a) = Just a+  return (e [], t')  type Variable s = forall m. Monad m => Object (StateT s m) m @@ -112,3 +91,14 @@     Push a c -> let z = f a r in pure (c, z `seq` go z)     Pull cont -> pure (cont r, go r) {-# INLINE foldPP #-}++(*-) :: MonadIO m => IORef (Object f m) -> f a -> m a+r *- f = do+  obj <- liftIO $ readIORef r+  (a, obj') <- runObject obj f+  liftIO $ writeIORef r obj'+  return a++invoke :: f a -> StateT (Object f m) m a+invoke = StateT #. flip runObject+{-# INLINE invoke #-}

src/Control/Object/Mortal.hs view

@@ -5,6 +5,7 @@     mortal,     mortal_,     runMortal,+    runMortal',     immortal,     reincarnation     ) where@@ -35,18 +36,22 @@ instance Monad m => Monad (Mortal f m) where   return a = mortal $ const $ left a   {-# INLINE return #-}-  m >>= k = mortal $ \f -> lift (runMortal m f) >>= \r -> case r of-    Left a -> EitherT $ runMortal (k a) f+  m >>= k = mortal $ \f -> lift (runMortal' m f) >>= \r -> case r of+    Left a -> runMortal (k a) f     Right (x, m') -> return (x, m' >>= k)  mortal :: (forall x. f x -> EitherT a m (x, Mortal f m a)) -> Mortal f m a-mortal f = unsafeCoerce f+mortal f = Mortal (Object (fmap unsafeCoerce f)) {-# INLINE mortal #-} -runMortal :: Mortal f m a -> f x -> m (Either a (x, Mortal f m a))+runMortal :: Mortal f m a -> f x -> EitherT a m (x, Mortal f m a) runMortal = unsafeCoerce {-# INLINE runMortal #-} +runMortal' :: Mortal f m a -> f x -> m (Either a (x, Mortal f m a))+runMortal' = unsafeCoerce+{-# INLINE runMortal' #-}+ -- | Restricted 'Mortal' constuctor, which can be applied to 'transit', 'fromFoldable' without ambiguousness. mortal_ :: Object f (EitherT () g) -> Mortal f g () mortal_ = Mortal@@ -56,7 +61,8 @@ immortal obj = mortal $ \f -> EitherT $ runObject obj f >>= \(a, obj') -> return $ Right (a, immortal obj')  reincarnation :: Monad m => (a -> Mortal f m a) -> a -> Object f m-reincarnation g a0 = go (g a0) where-  go m = Object $ \f -> runMortal m f >>= \r -> case r of+reincarnation g = go . g where+  go m = Object $ \f -> runMortal' m f >>= \r -> case r of     Left a -> runObject (go (g a)) f     Right (a, m') -> return (a, go m')+{-# INLINE reincarnation #-}

src/Control/Object/Object.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE Rank2Types, CPP, TypeOperators #-}+{-# LANGUAGE Rank2Types, CPP, TypeOperators, DataKinds #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} #endif@@ -12,9 +12,10 @@ import qualified Control.Monad.Trans.Free as T import qualified Control.Monad.Trans.Operational.Mini as T import Control.Monad.Trans.State.Strict-import Data.OpenUnion1.Clean import Data.Typeable import Control.Applicative+import Data.Extensible+import Control.Arrow (first)  -- | The type @Object f g@ represents objects which can handle messages @f@, perform actions in the environment @g@. -- It can be thought of as an automaton that converts effects.@@ -72,7 +73,7 @@ -- @stateful t s = t ^>>@ variable s@ stateful :: Monad m => (forall a. f a -> StateT s m a) -> s -> Object f m stateful h = go where-  go s = Object $ liftM (\(a, s') -> (a, go s')) . flip runStateT s . h+  go s = Object $ \f -> runStateT (h f) s >>= \(a, s') -> s' `seq` return (a, go s') {-# INLINE stateful #-}  -- | Object-object composition@@ -86,7 +87,6 @@ {-# INLINE (@<<@) #-} infixl 1 @<<@ - -- | Object-function composition (@>>^) :: 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@@ -109,22 +109,13 @@   Right g -> fmap (fmap (a@||@)) (runObject b g) infixr 2 @||@ --- | An object that won't accept any messages.-loner :: Functor f => Object Nil f-loner = liftO exhaust---- | Extend an object by another independent object.-(@|>@) :: Functor g => Object f g -> Object (Union s) g -> Object (f |> Union s) g-p @|>@ q = Object $ fmap (fmap (@|>@q)) . runObject p ||> fmap (fmap (p @|>@)) . runObject q-infixr 3 @|>@- -- | Build a stateful object, sharing out the state.-sharing :: Monad m => (forall a. f a -> StateT s m a) -> s -> Object (State s |> f |> Nil) m+sharing :: Monad m => (forall a. f a -> StateT s m a) -> s -> Object (Union '[State s, f]) m sharing m = go where-  go s = Object $ \k -> liftM (fmap go) $ ($k)-    $ (\n -> return $ runState n s)-    ||> (\e -> runStateT (m e) s)-    ||> exhaust+  go s = Object $ \k -> liftM (fmap go) $ caseOf (getUnion k)+    $ (\n cont -> return $ first cont $ runState n s)+    <$?~ (\e cont -> first cont `liftM` runStateT (m e) s)+    <$?~ Nil {-# INLINE sharing #-}  (@!) :: Monad m => Object e m -> ReifiedProgram e a -> m (a, Object e m)

src/Data/Functor/PushPull.hs view

@@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE DeriveFunctor, DeriveDataTypeable, ConstraintKinds, FlexibleContexts, DataKinds, TypeFamilies, TypeOperators #-}
+{-# LANGUAGE ScopedTypeVariables, Rank2Types, DeriveFunctor, DeriveDataTypeable, ConstraintKinds, FlexibleContexts, DataKinds, TypeFamilies, TypeOperators #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Functor.PushPull
@@ -14,10 +14,10 @@ module Data.Functor.PushPull where
 import Data.Typeable
 import Control.Elevator
-import Data.OpenUnion1.Clean
 import Control.Applicative
 import Data.Profunctor
 import Data.Functor.Day
+import Data.Extensible
 
 -- | The type for asynchronous input/output.
 data PushPull a b r = Push a r | Pull (b -> r) deriving (Functor, Typeable)
@@ -29,18 +29,18 @@   dimap f g (Pull br) = Pull (dimap f g br)
 
 instance Tower (PushPull a b) where
-  type Floors (PushPull a b) = (,) a :> (->) b :> Empty
-  toLoft = uncurry Push ||> Pull ||> exhaust
+  type Floors (PushPull a b) = '[(,) a, (->) b]
+  stairs = uncurry Push `rung` Pull `rung` Nil
 
+push :: Elevate ((,) a) f => a -> f ()
+push a = elevate (a, ())
+
+pull :: Elevate ((->) a) f => f a
+pull = elevate id
+
 mapPush :: (a -> a') -> PushPull a b r -> PushPull a' b r
 mapPush f (Push a r) = Push (f a) r
 mapPush _ (Pull br) = Pull br
-
-push :: (Elevate (PushPull a b) f) => a -> f ()
-push a = elevate (Push a ())
-
-pull :: (Elevate (PushPull a b) f) => f b
-pull = elevate (Pull id)
 
 bipush :: (i -> (a, c)) -> (b -> d -> o) -> PushPull i o r -> Day (PushPull a b) (PushPull c d) r
 bipush f g = go where

src/Data/Functor/Request.hs view

@@ -14,10 +14,10 @@ module Data.Functor.Request where
 import Data.Typeable
 import Control.Elevator
+import Data.Extensible
 import Control.Monad
 import Data.Monoid
 import Control.Applicative
-import Data.OpenUnion1.Clean
 import Data.Profunctor
 
 -- | 'Request a b' is the type of a request that sends @a@ to receive @b@.
@@ -36,8 +36,8 @@   Request a c <*> Request b d = Request (mappend a b) (c <*> d)
 
 instance Tower (Request a b) where
-  type Floors (Request a b) = Empty
-  toLoft = exhaust
+  type Floors (Request a b) = '[]
+  stairs = Nil
 
 request :: (Elevate (Request a b) f) => a -> f b
 request a = elevate (Request a id)