module Data.Functor.Request where
import Data.Typeable
import Control.Elevator
import Control.Monad
import Data.Monoid
import Control.Applicative
import Data.OpenUnion1.Clean
import Data.Profunctor
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)
instance Tower (Request a b) where
type Floors (Request a b) = Empty
toLoft = exhaust
request :: (Elevate (Request a b) f) => a -> f b
request a = elevate (Request a id)
accept :: Functor f => (a -> f b) -> Request a b r -> f r
accept f (Request a br) = fmap br (f a)
acceptM :: Monad m => (a -> m b) -> Request a b r -> m r
acceptM f (Request a br) = liftM br (f a)