module RSAGL.FRP.FactoryArrow
(FactoryArrow(..))
where
import Prelude hiding ((.),id)
import Control.Arrow
import Control.Monad
import Control.Monad.Fix
import Control.Category
newtype FactoryArrow m n i o = FactoryArrow { runFactory :: m (Kleisli n i o) }
instance (Monad m,Monad n) => Category (FactoryArrow m n) where
(FactoryArrow a) . (FactoryArrow b) = FactoryArrow $
do b' <- b
a' <- a
return $ a' . b'
id = FactoryArrow $ return id
instance (Monad m,Monad n) => Arrow (FactoryArrow m n) where
arr = FactoryArrow . return . arr
first = FactoryArrow . liftM first . runFactory
second = FactoryArrow . liftM second . runFactory
instance (Monad m,MonadFix n) => ArrowLoop (FactoryArrow m n) where
loop = FactoryArrow . liftM loop . runFactory
instance (Monad m) => ArrowApply (FactoryArrow m m) where
app = factoryApp id
factoryApp :: (Monad m,Monad n) => (forall a. m a -> n a) -> FactoryArrow m n (FactoryArrow m n i o,i) o
factoryApp liftM2N = FactoryArrow $ return $ Kleisli $ \(FactoryArrow m,i) ->
do (Kleisli n) <- liftM2N m
n i
instance (Monad m,Monad n) => ArrowChoice (FactoryArrow m n) where
left = FactoryArrow . liftM left . runFactory
right = FactoryArrow . liftM right . runFactory
instance (Monad m,MonadPlus n) => ArrowZero (FactoryArrow m n) where
zeroArrow = FactoryArrow $ return zeroArrow
instance (Monad m,MonadPlus n) => ArrowPlus (FactoryArrow m n) where
a <+> b = FactoryArrow $ liftM2 (<+>) (runFactory a) (runFactory b)