module Data.MonadicStreamFunction
( module Control.Arrow
, module Data.MonadicStreamFunction
, module X
)
where
import Control.Applicative
import Control.Arrow
import Control.Category (Category(..))
import Control.Monad
import Control.Monad.Base
import Data.Monoid
import Prelude hiding ((.), id, sum)
import Data.VectorSpace
import Data.VectorSpace.Instances()
import Data.MonadicStreamFunction.Core as X
import Data.MonadicStreamFunction.ArrowChoice as X
import Data.MonadicStreamFunction.ArrowLoop as X
import Data.MonadicStreamFunction.ArrowPlus as X
instance Functor m => Functor (MStreamF m r)
where
fmap f as = MStreamF $ \r -> fTuple <$> unMStreamF as r
where
fTuple (a, as') = (f a, f <$> as')
instance Applicative m => Applicative (MStreamF m r) where
pure a = MStreamF $ \_ -> pure (a, pure a)
fs <*> as = MStreamF $ \r -> applyTuple <$> unMStreamF fs r <*> unMStreamF as r
where
applyTuple (f, fs') (a, as') = (f a, fs' <*> as')
insert :: Monad m => MStreamF m (m a) a
insert = liftMStreamF id
liftMStreamF_ :: Monad m => m b -> MStreamF m a b
liftMStreamF_ = liftMStreamF . const
(^>>>) :: MonadBase m1 m2 => MStreamF m1 a b -> MStreamF m2 b c -> MStreamF m2 a c
sf1 ^>>> sf2 = (liftMStreamFBase sf1) >>> sf2
(>>>^) :: MonadBase m1 m2 => MStreamF m2 a b -> MStreamF m1 b c -> MStreamF m2 a c
sf1 >>>^ sf2 = sf1 >>> (liftMStreamFBase sf2)
iPost :: Monad m => b -> MStreamF m a b -> MStreamF m a b
iPost b sf = MStreamF $ \_ -> return (b, sf)
next :: Monad m => b -> MStreamF m a b -> MStreamF m a b
next b sf = MStreamF $ \a -> do
(b', sf') <- unMStreamF sf a
return (b, next b' sf')
untilS :: Monad m => MStreamF m a b -> MStreamF m b Bool -> MStreamF m a (b, Maybe ())
untilS sf1 sf2 = sf1 >>> (arr id &&& (sf2 >>> arr boolToMaybe))
where boolToMaybe x = if x then Just () else Nothing
andThen :: Monad m => MStreamF m a (b, Maybe ()) -> MStreamF m a b -> MStreamF m a b
andThen sf1 sf2 = switch sf1 $ const sf2
withSideEffect :: Monad m => (a -> m b) -> MStreamF m a a
withSideEffect method = (id &&& liftMStreamF method) >>> arr fst
withSideEffect_ :: Monad m => m b -> MStreamF m a a
withSideEffect_ method = withSideEffect $ const method
traceGeneral :: (Monad m, Show a) => (String -> m ()) -> String -> MStreamF m a a
traceGeneral method msg =
withSideEffect (method . (msg ++) . show)
trace :: Show a => String -> MStreamF IO a a
trace = traceGeneral putStrLn
pauseOnGeneral :: (Monad m, Show a) => (a -> Bool) -> (String -> m ()) -> String -> MStreamF m a a
pauseOnGeneral cond method msg = withSideEffect $ \a ->
when (cond a) $ method $ msg ++ show a
pauseOn :: Show a => (a -> Bool) -> String -> MStreamF IO a a
pauseOn cond = pauseOnGeneral cond $ \s -> print s >> getLine >> return ()
sum :: (Monoid n, Monad m) => MStreamF m n n
sum = sumFrom mempty
sumFrom :: (Monoid n, Monad m) => n -> MStreamF m n n
sumFrom n0 = MStreamF $ \n -> let acc = n0 `mappend` n
in return (acc, sumFrom acc)
count :: (Num n, Monad m) => MStreamF m () n
count = arr (const (Sum 1)) >>> sum >>> arr getSum
unfold :: Monad m => (a -> (b,a)) -> a -> MStreamF m () b
unfold f a = MStreamF $ \_ -> let (b,a') = f a in b `seq` return (b, unfold f a')
repeatedly :: Monad m => (a -> a) -> a -> MStreamF m () a
repeatedly f = repeatedly'
where repeatedly' a = MStreamF $ \() -> let a' = f a in a' `seq` return (a, repeatedly' a')
mapMStreamF :: Monad m => MStreamF m a b -> MStreamF m [a] [b]
mapMStreamF sf = MStreamF $ consume sf
where
consume :: Monad m => MStreamF m a t -> [a] -> m ([t], MStreamF m [a] [t])
consume sf [] = return ([], mapMStreamF sf)
consume sf (a:as) = do
(b, sf') <- unMStreamF sf a
(bs, sf'') <- consume sf' as
b `seq` return (b:bs, sf'')
type MStream m a = MStreamF m () a