module Control.Artery (Artery(..)
, runArtery
, effectful
, stateful
, scan
, scanM
, fromList
, runList
, feedback
, delay1
, delay
, cartridge
, module Control.Arrow) where
import qualified Control.Category
import Control.Arrow
import Control.Applicative
import qualified Data.Sequence as Seq
import Data.Monoid
import Data.Profunctor
import Control.Monad.Trans.State
import Control.Concurrent
import Control.Monad.IO.Class
newtype Artery m i o = Artery { unArtery :: forall r. i -> (o -> Artery m i o -> m r) -> m r }
instance Control.Category.Category (Artery m) where
id = Artery $ \x cont -> cont x Control.Category.id
Artery f . Artery g = Artery $ \x cont -> g x $ \y g' -> f y $ \z f' -> cont z (f' Control.Category.. g')
instance Arrow (Artery m) where
arr f = let a = Artery $ \x cont -> cont (f x) a in a
Artery f *** Artery g = Artery $ \(x, y) cont -> f x $ \x' f' -> g y $ \y' g' -> cont (x', y') (f' *** g')
Artery f &&& Artery g = Artery $ \i cont -> f i $ \x f' -> g i $ \y g' -> cont (x, y) (f' &&& g')
first (Artery f) = Artery $ \(x, y) cont -> f x $ \x' f' -> cont (x', y) (first f')
second (Artery f) = Artery $ \(y, x) cont -> f x $ \x' f' -> cont (y, x') (second f')
instance ArrowChoice (Artery m) where
left f = f +++ Control.Category.id
right f = Control.Category.id +++ f
f +++ g = Left <$> f ||| Right <$> g
f ||| g = Artery $ \e cont -> case e of
Left x -> unArtery f x $ \o f' -> cont o (f' ||| g)
Right x -> unArtery g x $ \o g' -> cont o (f ||| g')
instance Functor (Artery m i) where
fmap f = go where
go (Artery v) = Artery $ \x cont -> v x $ \a v' -> cont (f a) (go v')
instance Applicative (Artery m i) where
pure x = go where
go = Artery $ \_ cont -> cont x go
Artery ff <*> Artery fx = Artery $ \i cont -> ff i $ \f ff' -> fx i $ \x fx' -> cont (f x) (ff' <*> fx')
instance Profunctor (Artery m) where
dimap f g = go where
go (Artery v) = Artery $ \i cont -> v (f i) $ \o v' -> cont (g o) (go v')
instance Strong (Artery m) where
first' = first
second' = second
instance Choice (Artery m) where
left' = left
right' = right
instance Num o => Num (Artery m i o) where
(+) = liftA2 (+)
() = liftA2 ()
(*) = liftA2 (*)
abs = fmap abs
signum = fmap signum
fromInteger = pure . fromInteger
instance Fractional o => Fractional (Artery m i o) where
(/) = liftA2 (/)
recip = fmap recip
fromRational = pure . fromRational
instance Monoid o => Monoid (Artery m i o) where
mempty = pure mempty
mappend = liftA2 mappend
effectful :: Monad m => (i -> m o) -> Artery m i o
effectful m = go where
go = Artery $ \i cont -> m i >>= \o -> cont o go
stateful :: Monad m => (i -> StateT s m o) -> s -> Artery m i o
stateful m = go where
go s = Artery $ \i cont -> runStateT (m i) s >>= \(o, s') -> cont o (go s')
scan :: (i -> a -> a) -> a -> Artery m i a
scan f = go where
go x = Artery $ \i cont -> cont x (go (f i x))
scanM :: Monad m => (i -> a -> m a) -> a -> Artery m i a
scanM f = go where
go x = Artery $ \i cont -> f i x >>= \a -> cont x (go a)
runArtery :: Monad m => Artery m i o -> i -> m (o, Artery m i o)
runArtery (Artery v) i = v i (curry return)
feedback :: r -> Artery m (i, r) (o, r) -> Artery m i o
feedback r (Artery v) = Artery $ \i cont -> v (i, r) $ \(o, r') v' -> cont o (feedback r' v')
delay1 :: a -> Artery m a a
delay1 = scan const
delay :: Int -> a -> Artery m a a
delay n d = go (Seq.replicate n d) where
go buf = Artery $ \i cont -> case Seq.viewl buf of
a Seq.:< buf' -> cont a $ go $ buf' Seq.|> i
fromList :: [a] -> Artery m b a
fromList seq = go seq where
go (x:xs) = Artery $ \_ cont -> cont x (go xs)
go [] = go seq
runList :: Applicative m => Artery m a b -> [a] -> m [b]
runList ar (x:xs) = unArtery ar x $ \y cont -> (y:) <$> runList cont xs
runList _ [] = pure []
cartridge :: MonadIO m => MVar (Artery m i o) -> Artery m i o
cartridge ref = go where
go = Artery $ \i cont -> liftIO (takeMVar ref)
>>= \a -> unArtery a i $ \o a' -> liftIO (putMVar ref a') >> cont o go