module Data.Functor.Request where
import Data.Typeable
import Data.Monoid
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
handles :: Functor m => (a -> m (b, Object (Request a b) m)) -> Object (Request a b) m
handles 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 = Object $ \(Request k cont) -> case HM.lookup k m of
Just a -> pure (cont a, go m)
Nothing -> (\a -> (cont a, go $ HM.insert k a m)) <$> f k
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 = animate go where
go t
| t >= len = empty
| otherwise = f (t / len)