module Data.Functor.Request where
import Data.Typeable
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
#endif
import Control.Applicative
import Data.Profunctor
import Control.Object.Object
import qualified Data.HashMap.Strict as HM
import Data.Hashable
import Control.Arrow
data Request a b r = Request a (b -> r) deriving (Functor, Typeable)
mapRequest :: (a -> a') -> Request a b r -> Request a' b r
mapRequest f (Request a br) = Request (f a) br
instance Profunctor (Request a) where
dimap f g (Request a br) = Request a (dimap f g br)
instance Monoid a => Applicative (Request a b) where
pure a = Request mempty (const a)
Request a c <*> Request b d = Request (mappend a b) (c <*> d)
request :: a -> Request a b b
request a = Request a id
accept :: Functor m => (a -> m b) -> Request a b r -> m r
accept f = \(Request a cont) -> cont <$> f a
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
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
Just a -> pure (a, go m)
Nothing -> (\a -> (a, go $ HM.insert k a m)) <$> f k
(>~~>) :: Monad m => Object (Request a b) m -> Object (Request b c) m -> Object (Request a c) m
p >~~> q = Object $ \(Request a cont) -> do
(b, p') <- runObject p (Request a id)
(r, q') <- runObject q (Request b cont)
return (r, p' >~~> q')
accumulator :: Applicative m => (b -> a -> b) -> b -> Object (Request a b) m
accumulator f = go where
go b = mealy $ \a -> pure (b, go (f b a))
animate :: (Applicative m, Num t) => (t -> m a) -> Object (Request t a) m
animate f = go 0 where
go t = mealy $ \dt -> flip (,) (go (t + dt)) <$> f t
transit :: (Alternative m, Fractional t, Ord t) => t -> (t -> m a) -> Object (Request t a) m
transit len f = animate go where
go t
| t >= len = empty
| otherwise = f (t / len)