#if __GLASGOW_HASKELL__ >= 707
#endif
module Control.Object (
Object(..),
(@-),
liftO,
echo,
oneshot,
stateful,
variable,
Variable,
unfoldO,
unfoldOM,
foldP,
foldP',
sharing,
animate,
transit,
(@>>@),
(@>>^),
(^>>@),
(@**@),
(@||@),
loner,
(@|>@),
transObject,
adaptObject,
($$),
($$!),
(!$$),
(!$$!),
(@!),
(@!!),
sequential,
sequentialT,
iterObject,
iterTObject,
iterative,
iterativeT,
flyweight,
flyweight',
announce,
announceMaybe,
announceMaybeT,
Process(..),
_Process,
Mortal(..),
runMortal,
)
where
import Control.Applicative
import Control.Arrow as A
import Control.Elevator
import Control.Monad
import Control.Monad.Free
import Control.Monad.Operational.Mini
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Writer.Strict
import Data.Functor.Day
import Data.Functor.PushPull
import Data.Functor.Request
import Data.Functor.Sum as F
import Data.Hashable
import Data.Monoid
import Data.OpenUnion1.Clean
import Data.Profunctor
import Data.Typeable
import Data.Witherable
import qualified Control.Category as C
import qualified Control.Monad.Trans.Free as T
import qualified Control.Monad.Trans.Operational.Mini as T
import qualified Data.HashMap.Strict as HM
import qualified Data.Map.Strict as Map
import qualified Data.Traversable as T
import Control.Monad.Trans.Either as E
import Unsafe.Coerce
import Data.Functor.Rep
import Data.Functor.Adjunction
newtype Object f g = Object { runObject :: forall x. f x -> g (x, Object f g) }
#if __GLASGOW_HASKELL__ >= 707
deriving (Typeable)
#else
instance (Typeable1 f, Typeable1 g) => Typeable (Object f g) where
typeOf t = mkTyConApp objectTyCon [typeOf1 (f t), typeOf1 (g t)] where
f :: Object f g -> f a
f = undefined
g :: Object f g -> g a
g = undefined
objectTyCon :: TyCon
#if __GLASGOW_HASKELL__ < 704
objectTyCon = mkTyCon "Control.Object.Object"
#else
objectTyCon = mkTyCon3 "object" "Control.Object" "Object"
#endif
#endif
(@-) :: Object f g -> f x -> g (x, Object f g)
(@-) = runObject
infixr 5 @-
echo :: Functor f => Object f f
echo = Object (fmap (\x -> (x, echo)))
(@>>@) :: 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)
infixr 1 @>>@
(@>>^) :: 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
infixr 1 @>>^
(^>>@) :: 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
infixr 1 ^>>@
(@**@) :: Applicative m => Object f m -> Object g m -> Object (Day f g) m
a @**@ b = Object $ \(Day f g r) -> (\(x, a') (y, b') -> (r x y, a' @**@ b')) <$> runObject a f <*> runObject b g
infixr 3 @**@
(@||@) :: Functor m => Object f m -> Object g m -> Object (F.Sum f g) m
a @||@ b = Object $ \r -> case r of
InL f -> fmap (fmap (@||@b)) (runObject a f)
InR g -> fmap (fmap (a@||@)) (runObject b g)
infixr 2 @||@
liftO :: Functor g => (forall x. f x -> g x) -> Object f g
liftO f = go where go = Object $ fmap (\x -> (x, go)) . f
transObject :: Functor g => (forall x. f x -> g x) -> Object e f -> Object e g
transObject f = (@>>^f)
adaptObject :: Functor m => (forall x. g x -> f x) -> Object f m -> Object g m
adaptObject f = (f^>>@)
oneshot :: (Functor f, Monad m) => (forall a. f (m a) -> m a) -> Object f m
oneshot m = go where
go = Object $ \e -> m (fmap return e) >>= \a -> return (a, go)
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
unfoldO :: Functor g => (forall a. r -> f a -> g (a, r)) -> r -> Object f g
unfoldO h = go where go r = Object $ fmap (fmap go) . h r
unfoldOM :: Monad m => (forall a. r -> f a -> m (a, r)) -> r -> Object f m
unfoldOM h = go where go r = Object $ liftM (fmap go) . h r
type Variable s = forall m. Monad m => Object (StateT s m) m
variable :: s -> Variable s
variable s = Object $ \m -> liftM (fmap variable) $ runStateT m s
sharing :: Monad m => (forall a. f a -> StateT s m a) -> s -> Object (State s |> f |> Nil) m
sharing m = go where
go s = Object $ \k -> liftM (fmap go) $ ($k)
$ (\n -> return $ runState n s)
||> (\e -> runStateT (m e) s)
||> exhaust
loner :: Functor f => Object Nil f
loner = liftO exhaust
(@|>@) :: 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 @|>@
flyweight :: (Monad m, Ord k) => (k -> m a) -> Object (Request k a) m
flyweight f = go Map.empty where
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)
flyweight' :: (Monad m, Eq k, Hashable k) => (k -> m a) -> Object (Request k a) m
flyweight' f = go HM.empty where
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)
(@!) :: 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 @!
(@!!) :: 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 @!!
iterObject :: Monad m => Object f m -> Free f a -> m (a, Object f m)
iterObject obj (Pure a) = return (a, obj)
iterObject obj (Free f) = runObject obj f >>= \(cont, obj') -> iterObject obj' cont
iterTObject :: Monad m => Object f m -> T.FreeT f m a -> m (a, Object f m)
iterTObject obj m = T.runFreeT m >>= \r -> case r of
T.Pure a -> return (a, obj)
T.Free f -> runObject obj f >>= \(cont, obj') -> iterTObject obj' cont
sequential :: Monad m => Object e m -> Object (ReifiedProgram e) m
sequential = unfoldOM (@!)
sequentialT :: Monad m => Object e m -> Object (T.ReifiedProgramT e m) m
sequentialT = unfoldOM (@!!)
iterative :: Monad m => Object f m -> Object (Free f) m
iterative = unfoldOM iterObject
iterativeT :: Monad m => Object f m -> Object (T.FreeT f m) m
iterativeT = unfoldOM iterTObject
foldP :: Applicative f => (a -> r -> f r) -> r -> Object (PushPull a r) f
foldP f = go where
go r = Object $ \pp -> case pp of
Push a c -> fmap (\z -> (c, z `seq` go z)) (f a r)
Pull cont -> pure (cont r, go r)
foldP' :: Applicative f => (a -> r -> r) -> r -> Object (PushPull a r) f
foldP' f = go where
go r = Object $ \pp -> case pp of
Push a c -> let z = f a r in pure (c, z `seq` go z)
Pull cont -> pure (cont r, go r)
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
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)
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)
>>= \(x, obj') -> writer (obj', Endo (x:))) t
elevate (put t')
return (e [])
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 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 [])
newtype Process m a b = Process { unProcess :: Object (Request a b) m }
_Process :: (Profunctor p, Functor f) => p (Process m a b) (f (Process m a b)) -> p (Object (Request a b) m) (f (Object (Request a b) m))
_Process = dimap Process (fmap unProcess)
instance Functor f => Functor (Process f a) where
fmap f (Process o0) = Process $ go o0 where
go o = Object $ \(Request a cont) -> fmap (cont *** go) $ runObject o (Request a f)
instance Applicative f => Applicative (Process f a) where
pure a = Process go where
go = Object $ \(Request _ cont) -> pure (cont a, go)
Process f0 <*> Process a0 = Process $ go f0 a0 where
go mf ma = Object $ \(Request a cont) -> (\(f, mf') (x, ma') -> (cont (f x), go mf' ma'))
<$> runObject mf (Request a id)
<*> runObject ma (Request a id)
instance (Applicative f, Monoid b) => Monoid (Process f a b) where
mempty = pure mempty
mappend = liftA2 mappend
instance Monad m => C.Category (Process m) where
id = arr id
Process g0 . Process f0 = Process $ go f0 g0 where
go f g = Object $ \(Request a cont) -> runObject f (Request a id)
>>= \(b, f') -> liftM (\(c, g') -> (cont c, go f' g')) $ runObject g (Request b id)
instance Monad m => Arrow (Process m) where
arr f = Process go where
go = Object $ \(Request a cont) -> return (cont (f a), go)
first (Process f0) = Process $ go f0 where
go f = Object $ \(Request (a, c) cont) -> liftM (\(b, f') -> (cont (b, c), go f')) $ runObject f (Request a id)
second (Process f0) = Process $ go f0 where
go f = Object $ \(Request (a, c) cont) -> liftM (\(d, f') -> (cont (a, d), go f')) $ runObject f (Request c id)
instance Monad m => ArrowChoice (Process m) where
left (Process f0) = Process $ go f0 where
go f = Object $ \(Request e cont) -> case e of
Left a -> liftM (\(b, f') -> (cont (Left b), go f')) $ runObject f (Request a id)
Right c -> return (cont (Right c), go f)
right (Process f0) = Process $ go f0 where
go f = Object $ \(Request e cont) -> case e of
Right a -> liftM (\(b, f') -> (cont (Right b), go f')) $ runObject f (Request a id)
Left c -> return (cont (Left c), go f)
instance Monad m => Profunctor (Process m) where
dimap f g (Process f0) = Process (go f0) where
go m = Object $ \(Request a cont) -> liftM (\(b, m') -> (cont (g b), go m')) $ runObject m (Request (f a) id)
instance Monad m => Strong (Process m) where
first' = first
second' = second
instance Monad m => Choice (Process m) where
left' = A.left
right' = A.right
instance (Applicative m, Num o) => Num (Process m i o) where
(+) = liftA2 (+)
() = liftA2 ()
(*) = liftA2 (*)
abs = fmap abs
signum = fmap signum
fromInteger = pure . fromInteger
instance (Applicative m, Fractional o) => Fractional (Process m i o) where
(/) = liftA2 (/)
recip = fmap recip
fromRational = pure . fromRational
newtype Mortal f g a = Mortal { unMortal :: Object f (EitherT a g) }
instance (Functor m, Monad m) => Functor (Mortal f m) where
fmap f (Mortal obj) = Mortal (obj @>>^ bimapEitherT f id)
instance (Functor m, Monad m) => Applicative (Mortal f m) where
pure = return
(<*>) = 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))
runMortal :: Monad m => Mortal f m a -> f x -> m (Either a (x, Mortal f m a))
runMortal = unsafeCoerce runObject
($$) :: (Monad m, Adjunction f g) => Object g m -> Object f m -> m x
a $$ b = do
(x, a') <- runObject a askRep
((), b') <- runObject b (unit () `index` x)
a' $$ b'
infix 0 $$
($$!) :: (Monad m, Adjunction f g) => Object g m -> Mortal f m a -> m (Object g m, a)
o $$! m = do
(x, o') <- runObject o askRep
r <- runMortal m (unit () `index` x)
case r of
Left a -> return (o', a)
Right ((), m') -> o' $$! m'
infix 0 $$!
(!$$) :: (Monad m, Adjunction f g) => Mortal g m a -> Object f m -> m (a, Object f m)
m !$$ o = do
r <- runMortal m askRep
case r of
Left a -> return (a, o)
Right (x, m') -> do
((), o') <- runObject o (unit () `index` x)
m' !$$ o'
infix 0 !$$
(!$$!) :: (Monad m, Adjunction f g) => Mortal g m a -> Mortal f m b -> m (Either (a, Mortal f m b) (Mortal g m a, b))
m !$$! n = do
r <- runMortal m askRep
case r of
Left a -> return (Left (a, n))
Right (x, m') -> do
s <- runMortal n (unit () `index` x)
case s of
Left b -> return (Right (m', b))
Right ((), n') -> m' !$$! n'
infix 0 !$$!