module Control.Arrow.Transformer.Stream(
StreamArrow,
runStream,
StreamMap,
StreamMapST, runStreamST,
ArrowAddStream(..),
) where
import Control.Monad.ST
import Control.Arrow
import Control.Arrow.Internals
import Control.Arrow.Operations
import Control.Arrow.Transformer
import Data.Stream
newtype StreamArrow a b c = Str (a (Stream b) (Stream c))
instance Arrow a => Arrow (StreamArrow a) where
arr f = Str (arr (fmap f))
Str f >>> Str g = Str (f >>> g)
first (Str f) =
Str (arr unzipStream >>> first f >>> arr (uncurry zipStream))
genmap :: Arrow a => a b c -> a (Stream b) (Stream c)
genmap f = arr (\xs -> (shd xs, stl xs)) >>>
f *** genmap f >>> arr (uncurry Cons)
instance Arrow a => ArrowTransformer (StreamArrow) a where
lift f = Str (genmap f)
instance ArrowZero a => ArrowZero (StreamArrow a) where
zeroArrow = lift zeroArrow
instance ArrowState s a => ArrowState s (StreamArrow a) where
fetch = lift fetch
store = lift store
instance ArrowWriter w a => ArrowWriter w (StreamArrow a) where
write = lift write
newWriter (Str f) = Str (newWriter f >>> arr strength)
where strength :: Functor w' => (w' a',b) -> w' (a',b)
strength (v, y) = fmap (\x -> (x, y)) v
instance Arrow a => ArrowChoice (StreamArrow a) where
left (Str f) = Str ((arr getLeft >>> f) &&& arr id >>> arr replace)
where getLeft (Cons (Left x) xs) = Cons x (getLeft xs)
getLeft (Cons (Right _) xs) = getLeft xs
replace (~(Cons x xs), Cons (Left _) ys) =
Cons (Left x) (replace (xs, ys))
replace (xs, Cons (Right y) ys) =
Cons (Right y) (replace (xs, ys))
instance ArrowLoop a => ArrowLoop (StreamArrow a) where
loop (Str f) =
Str (loop (arr (uncurry zipStream) >>> f >>> arr unzipStream))
instance ArrowPlus a => ArrowPlus (StreamArrow a) where
Str f <+> Str g = Str (f <+> g)
instance ArrowLoop a => ArrowCircuit (StreamArrow a) where
delay x = Str (arr (Cons x))
runStream :: ArrowLoop a => StreamArrow a (e,b) c -> a (e,Stream b) (Stream c)
runStream (Str f) = arr (\(e, xs) -> fmap (\x -> (e, x)) xs) >>> f
instance ArrowLoop a => ArrowAddStream (StreamArrow a) a where
liftStream = lift
elimStream = runStream
type StreamMap = StreamArrow (->)
type StreamMapST s = StreamArrow (Kleisli (ST s))
runStreamST :: (forall s. StreamMapST s e c) -> StreamMap e c
runStreamST cf = Str $ \ input -> runST (let Str (Kleisli f) = cf in f input)