{-# LANGUAGE ExistentialQuantification #-}
module Synthesizer.CausalIO.Process (
T(Cons),
fromCausal,
mapAccum,
Synthesizer.CausalIO.Process.traverse,
runCont,
runStorableChunkyCont,
zip,
continue,
continueChunk,
) where
import qualified Synthesizer.Causal.Process as Causal
import qualified Synthesizer.Generic.Signal as SigG
import qualified Synthesizer.Generic.Cut as CutG
import qualified Synthesizer.Zip as Zip
import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector as SV
import Foreign.Storable (Storable, )
import qualified Control.Monad.Trans.State as MS
import qualified Control.Arrow as Arr
import qualified Control.Category as Cat
import Control.Arrow ((^<<), (&&&), )
import Control.Monad (mplus, )
import Data.Monoid (Monoid, mempty, mappend, )
import Data.Semigroup (Semigroup, (<>), )
import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, )
import Prelude hiding (zip, )
data T a b =
forall state.
Cons
(a -> state -> IO (b, state))
(IO state)
(state -> IO ())
instance Cat.Category T where
id :: forall a. T a a
id = (a -> a) -> T a a
forall b c. (b -> c) -> T b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
Arr.arr a -> a
forall a. a -> a
id
(Cons b -> state -> IO (c, state)
nextB IO state
createB state -> IO ()
deleteB) . :: forall b c a. T b c -> T a b -> T a c
.
(Cons a -> state -> IO (b, state)
nextA IO state
createA state -> IO ()
deleteA) = (a -> (state, state) -> IO (c, (state, state)))
-> IO (state, state) -> ((state, state) -> IO ()) -> T a c
forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\a
a (state
sa0,state
sb0) -> do
(b
b,state
sa1) <- a -> state -> IO (b, state)
nextA a
a state
sa0
(c
c,state
sb1) <- b -> state -> IO (c, state)
nextB b
b state
sb0
(c, (state, state)) -> IO (c, (state, state))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (c
c,(state
sa1,state
sb1)))
(do
state
sa <- IO state
createA
state
sb <- IO state
createB
(state, state) -> IO (state, state)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (state
sa,state
sb))
(\(state
sa,state
sb) ->
state -> IO ()
deleteA state
sa IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> state -> IO ()
deleteB state
sb)
instance Arr.Arrow T where
arr :: forall b c. (b -> c) -> T b c
arr b -> c
f = (b -> () -> IO (c, ())) -> IO () -> (() -> IO ()) -> T b c
forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\ b
a () -> (c, ()) -> IO (c, ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> c
f b
a, ()))
(() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
(\ () -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
first :: forall b c d. T b c -> T (b, d) (c, d)
first (Cons b -> state -> IO (c, state)
next IO state
create state -> IO ()
delete) = ((b, d) -> state -> IO ((c, d), state))
-> IO state -> (state -> IO ()) -> T (b, d) (c, d)
forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\(b
b,d
d) state
sa0 ->
do (c
c,state
sa1) <- b -> state -> IO (c, state)
next b
b state
sa0
((c, d), state) -> IO ((c, d), state)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((c
c,d
d), state
sa1))
IO state
create
state -> IO ()
delete
fromCausal ::
(Monoid b) =>
Causal.T a b -> T a b
fromCausal :: forall b a. Monoid b => T a b -> T a b
fromCausal (Causal.Cons a -> StateT s Maybe b
next s
start) = (a -> s -> IO (b, s)) -> IO s -> (s -> IO ()) -> T a b
forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\a
a s
s0 ->
(b, s) -> IO (b, s)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((b, s) -> IO (b, s)) -> (b, s) -> IO (b, s)
forall a b. (a -> b) -> a -> b
$
case StateT s Maybe b -> s -> Maybe (b, s)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
MS.runStateT (a -> StateT s Maybe b
next a
a) s
s0 of
Maybe (b, s)
Nothing -> (b
forall a. Monoid a => a
mempty, s
s0)
Just (b
b,s
s1) -> (b
b,s
s1))
(s -> IO s
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (s -> IO s) -> s -> IO s
forall a b. (a -> b) -> a -> b
$ s
start)
(\ s
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
mapAccum ::
(a -> state -> (b, state)) ->
state ->
T a b
mapAccum :: forall a state b. (a -> state -> (b, state)) -> state -> T a b
mapAccum a -> state -> (b, state)
next state
start =
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\a
a state
s -> (b, state) -> IO (b, state)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((b, state) -> IO (b, state)) -> (b, state) -> IO (b, state)
forall a b. (a -> b) -> a -> b
$ a -> state -> (b, state)
next a
a state
s)
(state -> IO state
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return state
start)
(\ state
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
traverse ::
state ->
(a -> MS.State state b) ->
T a b
traverse :: forall state a b. state -> (a -> State state b) -> T a b
traverse state
start a -> State state b
next =
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\a
a state
s -> (b, state) -> IO (b, state)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((b, state) -> IO (b, state)) -> (b, state) -> IO (b, state)
forall a b. (a -> b) -> a -> b
$ State state b -> state -> (b, state)
forall s a. State s a -> s -> (a, s)
MS.runState (a -> State state b
next a
a) state
s)
(state -> IO state
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return state
start)
(\ state
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
runCont ::
(CutG.Transform a, CutG.Transform b) =>
T a b -> IO (([a] -> [b]) -> [a] -> [b])
runCont :: forall a b.
(Transform a, Transform b) =>
T a b -> IO (([a] -> [b]) -> [a] -> [b])
runCont (Cons a -> state -> IO (b, state)
next IO state
create state -> IO ()
delete) =
(([a] -> [b]) -> [a] -> [b]) -> IO (([a] -> [b]) -> [a] -> [b])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((([a] -> [b]) -> [a] -> [b]) -> IO (([a] -> [b]) -> [a] -> [b]))
-> (([a] -> [b]) -> [a] -> [b]) -> IO (([a] -> [b]) -> [a] -> [b])
forall a b. (a -> b) -> a -> b
$
\ [a] -> [b]
procRest [a]
sig ->
IO [b] -> [b]
forall a. IO a -> a
unsafePerformIO (IO [b] -> [b]) -> IO [b] -> [b]
forall a b. (a -> b) -> a -> b
$ do
let go :: [a] -> state -> IO [b]
go [a]
xt state
s0 =
IO [b] -> IO [b]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [b] -> IO [b]) -> IO [b] -> IO [b]
forall a b. (a -> b) -> a -> b
$
case [a]
xt of
[] -> state -> IO ()
delete state
s0 IO () -> IO [b] -> IO [b]
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [b] -> IO [b]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
a
x:[a]
xs -> do
(b
y,state
s1) <- a -> state -> IO (b, state)
next a
x state
s0
(if b -> Int
forall sig. Read sig => sig -> Int
CutG.length b
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
then ([b] -> [b]) -> IO [b] -> IO [b]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b
yb -> [b] -> [b]
forall a. a -> [a] -> [a]
:)
else IO [b] -> IO [b]
forall a. a -> a
id) (IO [b] -> IO [b]) -> IO [b] -> IO [b]
forall a b. (a -> b) -> a -> b
$
(if b -> Int
forall sig. Read sig => sig -> Int
CutG.length b
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< a -> Int
forall sig. Read sig => sig -> Int
CutG.length a
x
then [b] -> IO [b]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([b] -> IO [b]) -> [b] -> IO [b]
forall a b. (a -> b) -> a -> b
$ [a] -> [b]
procRest ([a] -> [b]) -> [a] -> [b]
forall a b. (a -> b) -> a -> b
$
Int -> a -> a
forall sig. Transform sig => Int -> sig -> sig
CutG.drop (b -> Int
forall sig. Read sig => sig -> Int
CutG.length b
y) a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs
else [a] -> state -> IO [b]
go [a]
xs state
s1)
[a] -> state -> IO [b]
go [a]
sig (state -> IO [b]) -> IO state -> IO [b]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO state
create
runStorableChunkyCont ::
(Storable a, Storable b) =>
T (SV.Vector a) (SV.Vector b) ->
IO ((SVL.Vector a -> SVL.Vector b) ->
SVL.Vector a -> SVL.Vector b)
runStorableChunkyCont :: forall a b.
(Storable a, Storable b) =>
T (Vector a) (Vector b)
-> IO ((Vector a -> Vector b) -> Vector a -> Vector b)
runStorableChunkyCont T (Vector a) (Vector b)
proc =
(((([Vector a] -> [Vector b]) -> [Vector a] -> [Vector b])
-> (Vector a -> Vector b) -> Vector a -> Vector b)
-> IO (([Vector a] -> [Vector b]) -> [Vector a] -> [Vector b])
-> IO ((Vector a -> Vector b) -> Vector a -> Vector b))
-> IO (([Vector a] -> [Vector b]) -> [Vector a] -> [Vector b])
-> ((([Vector a] -> [Vector b]) -> [Vector a] -> [Vector b])
-> (Vector a -> Vector b) -> Vector a -> Vector b)
-> IO ((Vector a -> Vector b) -> Vector a -> Vector b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((([Vector a] -> [Vector b]) -> [Vector a] -> [Vector b])
-> (Vector a -> Vector b) -> Vector a -> Vector b)
-> IO (([Vector a] -> [Vector b]) -> [Vector a] -> [Vector b])
-> IO ((Vector a -> Vector b) -> Vector a -> Vector b)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (T (Vector a) (Vector b)
-> IO (([Vector a] -> [Vector b]) -> [Vector a] -> [Vector b])
forall a b.
(Transform a, Transform b) =>
T a b -> IO (([a] -> [b]) -> [a] -> [b])
runCont T (Vector a) (Vector b)
proc) (((([Vector a] -> [Vector b]) -> [Vector a] -> [Vector b])
-> (Vector a -> Vector b) -> Vector a -> Vector b)
-> IO ((Vector a -> Vector b) -> Vector a -> Vector b))
-> ((([Vector a] -> [Vector b]) -> [Vector a] -> [Vector b])
-> (Vector a -> Vector b) -> Vector a -> Vector b)
-> IO ((Vector a -> Vector b) -> Vector a -> Vector b)
forall a b. (a -> b) -> a -> b
$ \([Vector a] -> [Vector b]) -> [Vector a] -> [Vector b]
f Vector a -> Vector b
cont ->
[Vector b] -> Vector b
forall a. Storable a => [Vector a] -> Vector a
SVL.fromChunks ([Vector b] -> Vector b)
-> (Vector a -> [Vector b]) -> Vector a -> Vector b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
([Vector a] -> [Vector b]) -> [Vector a] -> [Vector b]
f (Vector b -> [Vector b]
forall a. Vector a -> [Vector a]
SVL.chunks (Vector b -> [Vector b])
-> ([Vector a] -> Vector b) -> [Vector a] -> [Vector b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector a -> Vector b
cont (Vector a -> Vector b)
-> ([Vector a] -> Vector a) -> [Vector a] -> Vector b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Vector a] -> Vector a
forall a. Storable a => [Vector a] -> Vector a
SVL.fromChunks) ([Vector a] -> [Vector b])
-> (Vector a -> [Vector a]) -> Vector a -> [Vector b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Vector a -> [Vector a]
forall a. Vector a -> [Vector a]
SVL.chunks
zip ::
(Arr.Arrow arrow) =>
arrow a b -> arrow a c -> arrow a (Zip.T b c)
zip :: forall (arrow :: * -> * -> *) a b c.
Arrow arrow =>
arrow a b -> arrow a c -> arrow a (T b c)
zip arrow a b
ab arrow a c
ac =
(b -> c -> T b c) -> (b, c) -> T b c
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry b -> c -> T b c
forall a b. a -> b -> T a b
Zip.Cons ((b, c) -> T b c) -> arrow a (b, c) -> arrow a (T b c)
forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<< arrow a b
ab arrow a b -> arrow a c -> arrow a (b, c)
forall b c c'. arrow b c -> arrow b c' -> arrow b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& arrow a c
ac
instance (CutG.Transform a, CutG.Read b, Semigroup b) => Semigroup (T a b) where
<> :: T a b -> T a b -> T a b
(<>) = (b -> b -> b) -> T a b -> T a b -> T a b
forall a b.
(Transform a, Read b) =>
(b -> b -> b) -> T a b -> T a b -> T a b
append b -> b -> b
forall a. Semigroup a => a -> a -> a
(<>)
instance (CutG.Transform a, CutG.Read b, Monoid b) => Monoid (T a b) where
mempty :: T a b
mempty = (a -> () -> IO (b, ())) -> IO () -> (() -> IO ()) -> T a b
forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\ a
_a () -> (b, ()) -> IO (b, ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (b
forall a. Monoid a => a
mempty, ()))
(() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
(\() -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
mappend :: T a b -> T a b -> T a b
mappend = (b -> b -> b) -> T a b -> T a b -> T a b
forall a b.
(Transform a, Read b) =>
(b -> b -> b) -> T a b -> T a b -> T a b
append b -> b -> b
forall a. Monoid a => a -> a -> a
mappend
append ::
(CutG.Transform a, CutG.Read b) =>
(b -> b -> b) -> T a b -> T a b -> T a b
append :: forall a b.
(Transform a, Read b) =>
(b -> b -> b) -> T a b -> T a b -> T a b
append b -> b -> b
app
(Cons a -> state -> IO (b, state)
nextX IO state
createX state -> IO ()
deleteX)
(Cons a -> state -> IO (b, state)
nextY IO state
createY state -> IO ()
deleteY) = (a -> Either state state -> IO (b, Either state state))
-> IO (Either state state)
-> (Either state state -> IO ())
-> T a b
forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\a
a Either state state
s ->
case Either state state
s of
Left state
s0 -> do
(b
b1,state
s1) <- a -> state -> IO (b, state)
nextX a
a state
s0
let lenA :: Int
lenA = a -> Int
forall sig. Read sig => sig -> Int
CutG.length a
a
lenB :: Int
lenB = b -> Int
forall sig. Read sig => sig -> Int
CutG.length b
b1
case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
lenA Int
lenB of
Ordering
LT -> [Char] -> IO (b, Either state state)
forall a. HasCallStack => [Char] -> a
error [Char]
"CausalIO.Process.mappend: output chunk is larger than input chunk"
Ordering
EQ -> (b, Either state state) -> IO (b, Either state state)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b1, state -> Either state state
forall a b. a -> Either a b
Left state
s1)
Ordering
GT -> do
state -> IO ()
deleteX state
s1
(b
b2,state
s2) <- a -> state -> IO (b, state)
nextY (Int -> a -> a
forall sig. Transform sig => Int -> sig -> sig
CutG.drop Int
lenB a
a) (state -> IO (b, state)) -> IO state -> IO (b, state)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO state
createY
(b, Either state state) -> IO (b, Either state state)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> b -> b
app b
b1 b
b2, state -> Either state state
forall a b. b -> Either a b
Right state
s2)
Right state
s0 -> do
(b
b1,state
s1) <- a -> state -> IO (b, state)
nextY a
a state
s0
(b, Either state state) -> IO (b, Either state state)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b1, state -> Either state state
forall a b. b -> Either a b
Right state
s1))
((state -> Either state state)
-> IO state -> IO (Either state state)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap state -> Either state state
forall a b. a -> Either a b
Left IO state
createX)
((state -> IO ()) -> (state -> IO ()) -> Either state state -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either state -> IO ()
deleteX state -> IO ()
deleteY)
data State a b =
forall state.
State
(a -> state -> IO (b, state))
(state -> IO ())
state
forceMaybe :: (Maybe a -> b) -> Maybe a -> b
forceMaybe :: forall a b. (Maybe a -> b) -> Maybe a -> b
forceMaybe Maybe a -> b
f Maybe a
ma =
case Maybe a
ma of
Maybe a
Nothing -> Maybe a -> b
f Maybe a
forall a. Maybe a
Nothing
Just a
a -> Maybe a -> b
f (Maybe a -> b) -> Maybe a -> b
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
a
continue ::
(CutG.Transform a, SigG.Transform sig b) =>
T a (sig b) -> (b -> T a (sig b)) -> T a (sig b)
continue :: forall a (sig :: * -> *) b.
(Transform a, Transform sig b) =>
T a (sig b) -> (b -> T a (sig b)) -> T a (sig b)
continue (Cons a -> state -> IO (sig b, state)
nextX IO state
createX state -> IO ()
deleteX) b -> T a (sig b)
procY = (a
-> Either (Maybe b, state) (State a (sig b))
-> IO (sig b, Either (Maybe b, state) (State a (sig b))))
-> IO (Either (Maybe b, state) (State a (sig b)))
-> (Either (Maybe b, state) (State a (sig b)) -> IO ())
-> T a (sig b)
forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\a
a Either (Maybe b, state) (State a (sig b))
s ->
case Either (Maybe b, state) (State a (sig b))
s of
Left (Maybe b
lastB0, state
s0) -> do
(sig b
b1,state
s1) <- a -> state -> IO (sig b, state)
nextX a
a state
s0
let lenA :: Int
lenA = a -> Int
forall sig. Read sig => sig -> Int
CutG.length a
a
lenB :: Int
lenB = sig b -> Int
forall sig. Read sig => sig -> Int
CutG.length sig b
b1
lastB1 :: Maybe b
lastB1 =
Maybe b -> Maybe b -> Maybe b
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus (((sig b, b) -> b) -> Maybe (sig b, b) -> Maybe b
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (sig b, b) -> b
forall a b. (a, b) -> b
snd (Maybe (sig b, b) -> Maybe b) -> Maybe (sig b, b) -> Maybe b
forall a b. (a -> b) -> a -> b
$ sig b -> Maybe (sig b, b)
forall y. Storage (sig y) => sig y -> Maybe (sig y, y)
forall (sig :: * -> *) y.
(Transform0 sig, Storage (sig y)) =>
sig y -> Maybe (sig y, y)
SigG.viewR sig b
b1) Maybe b
lastB0
cont :: a -> (sig b, Either (a, state) b)
cont a
lastB = (sig b
b1, (a, state) -> Either (a, state) b
forall a b. a -> Either a b
Left (a
lastB,state
s1))
case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
lenA Int
lenB of
Ordering
LT -> [Char] -> IO (sig b, Either (Maybe b, state) (State a (sig b)))
forall a. HasCallStack => [Char] -> a
error [Char]
"CausalIO.Process.continue: output chunk is larger than input chunk"
Ordering
EQ -> (sig b, Either (Maybe b, state) (State a (sig b)))
-> IO (sig b, Either (Maybe b, state) (State a (sig b)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((sig b, Either (Maybe b, state) (State a (sig b)))
-> IO (sig b, Either (Maybe b, state) (State a (sig b))))
-> (sig b, Either (Maybe b, state) (State a (sig b)))
-> IO (sig b, Either (Maybe b, state) (State a (sig b)))
forall a b. (a -> b) -> a -> b
$ (Maybe b -> (sig b, Either (Maybe b, state) (State a (sig b))))
-> Maybe b -> (sig b, Either (Maybe b, state) (State a (sig b)))
forall a b. (Maybe a -> b) -> Maybe a -> b
forceMaybe Maybe b -> (sig b, Either (Maybe b, state) (State a (sig b)))
forall {a} {b}. a -> (sig b, Either (a, state) b)
cont Maybe b
lastB1
Ordering
GT ->
case Maybe b
lastB1 of
Maybe b
Nothing -> (sig b, Either (Maybe b, state) (State a (sig b)))
-> IO (sig b, Either (Maybe b, state) (State a (sig b)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (sig b
forall a. Monoid a => a
mempty, (Maybe b, state) -> Either (Maybe b, state) (State a (sig b))
forall a b. a -> Either a b
Left (Maybe b
lastB1,state
s1))
Just b
lastB ->
case b -> T a (sig b)
procY b
lastB of
Cons a -> state -> IO (sig b, state)
nextY IO state
createY state -> IO ()
deleteY -> do
state -> IO ()
deleteX state
s1
(sig b
b2,state
s2) <- a -> state -> IO (sig b, state)
nextY (Int -> a -> a
forall sig. Transform sig => Int -> sig -> sig
CutG.drop Int
lenB a
a) (state -> IO (sig b, state)) -> IO state -> IO (sig b, state)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO state
createY
(sig b, Either (Maybe b, state) (State a (sig b)))
-> IO (sig b, Either (Maybe b, state) (State a (sig b)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (sig b -> sig b -> sig b
forall a. Monoid a => a -> a -> a
mappend sig b
b1 sig b
b2, State a (sig b) -> Either (Maybe b, state) (State a (sig b))
forall a b. b -> Either a b
Right ((a -> state -> IO (sig b, state))
-> (state -> IO ()) -> state -> State a (sig b)
forall a b state.
(a -> state -> IO (b, state))
-> (state -> IO ()) -> state -> State a b
State a -> state -> IO (sig b, state)
nextY state -> IO ()
deleteY state
s2))
Right (State a -> state -> IO (sig b, state)
nextY state -> IO ()
deleteY state
s0) -> do
(sig b
b1,state
s1) <- a -> state -> IO (sig b, state)
nextY a
a state
s0
(sig b, Either (Maybe b, state) (State a (sig b)))
-> IO (sig b, Either (Maybe b, state) (State a (sig b)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (sig b
b1, State a (sig b) -> Either (Maybe b, state) (State a (sig b))
forall a b. b -> Either a b
Right ((a -> state -> IO (sig b, state))
-> (state -> IO ()) -> state -> State a (sig b)
forall a b state.
(a -> state -> IO (b, state))
-> (state -> IO ()) -> state -> State a b
State a -> state -> IO (sig b, state)
nextY state -> IO ()
deleteY state
s1)))
(do
state
sa <- IO state
createX
Either (Maybe b, state) (State a (sig b))
-> IO (Either (Maybe b, state) (State a (sig b)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe b, state) -> Either (Maybe b, state) (State a (sig b))
forall a b. a -> Either a b
Left (Maybe b
forall a. Maybe a
Nothing, state
sa)))
(\Either (Maybe b, state) (State a (sig b))
s ->
case Either (Maybe b, state) (State a (sig b))
s of
Left (Maybe b
_lastB,state
s0) -> state -> IO ()
deleteX state
s0
Right (State a -> state -> IO (sig b, state)
_ state -> IO ()
deleteY state
s0) -> state -> IO ()
deleteY state
s0)
continueChunk ::
(CutG.Transform a, CutG.Transform b) =>
T a b -> (b -> T a b) -> T a b
continueChunk :: forall a b.
(Transform a, Transform b) =>
T a b -> (b -> T a b) -> T a b
continueChunk (Cons a -> state -> IO (b, state)
nextX IO state
createX state -> IO ()
deleteX) b -> T a b
procY = (a
-> Either (b, state) (State a b)
-> IO (b, Either (b, state) (State a b)))
-> IO (Either (b, state) (State a b))
-> (Either (b, state) (State a b) -> IO ())
-> T a b
forall a b state.
(a -> state -> IO (b, state))
-> IO state -> (state -> IO ()) -> T a b
Cons
(\a
a Either (b, state) (State a b)
s ->
case Either (b, state) (State a b)
s of
Left (b
lastB0, state
s0) -> do
(b
b1,state
s1) <- a -> state -> IO (b, state)
nextX a
a state
s0
let lenA :: Int
lenA = a -> Int
forall sig. Read sig => sig -> Int
CutG.length a
a
lenB :: Int
lenB = b -> Int
forall sig. Read sig => sig -> Int
CutG.length b
b1
cont :: a -> (b, Either (a, state) b)
cont a
lastB = (b
b1, (a, state) -> Either (a, state) b
forall a b. a -> Either a b
Left (a
lastB,state
s1))
case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
lenA Int
lenB of
Ordering
LT -> [Char] -> IO (b, Either (b, state) (State a b))
forall a. HasCallStack => [Char] -> a
error [Char]
"CausalIO.Process.continueChunk: output chunk is larger than input chunk"
Ordering
EQ ->
(b, Either (b, state) (State a b))
-> IO (b, Either (b, state) (State a b))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((b, Either (b, state) (State a b))
-> IO (b, Either (b, state) (State a b)))
-> (b, Either (b, state) (State a b))
-> IO (b, Either (b, state) (State a b))
forall a b. (a -> b) -> a -> b
$ if Int
lenBInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 then b -> (b, Either (b, state) (State a b))
forall {a} {b}. a -> (b, Either (a, state) b)
cont b
lastB0 else b -> (b, Either (b, state) (State a b))
forall {a} {b}. a -> (b, Either (a, state) b)
cont b
b1
Ordering
GT ->
if Int
lenBInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0
then (b, Either (b, state) (State a b))
-> IO (b, Either (b, state) (State a b))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((b, Either (b, state) (State a b))
-> IO (b, Either (b, state) (State a b)))
-> (b, Either (b, state) (State a b))
-> IO (b, Either (b, state) (State a b))
forall a b. (a -> b) -> a -> b
$ b -> (b, Either (b, state) (State a b))
forall {a} {b}. a -> (b, Either (a, state) b)
cont b
lastB0
else
case b -> T a b
procY b
b1 of
Cons a -> state -> IO (b, state)
nextY IO state
createY state -> IO ()
deleteY -> do
state -> IO ()
deleteX state
s1
(b
b2,state
s2) <- a -> state -> IO (b, state)
nextY (Int -> a -> a
forall sig. Transform sig => Int -> sig -> sig
CutG.drop Int
lenB a
a) (state -> IO (b, state)) -> IO state -> IO (b, state)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO state
createY
(b, Either (b, state) (State a b))
-> IO (b, Either (b, state) (State a b))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> b -> b
forall a. Monoid a => a -> a -> a
mappend b
b1 b
b2, State a b -> Either (b, state) (State a b)
forall a b. b -> Either a b
Right ((a -> state -> IO (b, state))
-> (state -> IO ()) -> state -> State a b
forall a b state.
(a -> state -> IO (b, state))
-> (state -> IO ()) -> state -> State a b
State a -> state -> IO (b, state)
nextY state -> IO ()
deleteY state
s2))
Right (State a -> state -> IO (b, state)
nextY state -> IO ()
deleteY state
s0) -> do
(b
b1,state
s1) <- a -> state -> IO (b, state)
nextY a
a state
s0
(b, Either (b, state) (State a b))
-> IO (b, Either (b, state) (State a b))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b1, State a b -> Either (b, state) (State a b)
forall a b. b -> Either a b
Right ((a -> state -> IO (b, state))
-> (state -> IO ()) -> state -> State a b
forall a b state.
(a -> state -> IO (b, state))
-> (state -> IO ()) -> state -> State a b
State a -> state -> IO (b, state)
nextY state -> IO ()
deleteY state
s1)))
(do
state
sa <- IO state
createX
Either (b, state) (State a b) -> IO (Either (b, state) (State a b))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((b, state) -> Either (b, state) (State a b)
forall a b. a -> Either a b
Left (b
forall a. Monoid a => a
mempty, state
sa)))
(\Either (b, state) (State a b)
s ->
case Either (b, state) (State a b)
s of
Left (b
_lastB,state
s0) -> state -> IO ()
deleteX state
s0
Right (State a -> state -> IO (b, state)
_ state -> IO ()
deleteY state
s0) -> state -> IO ()
deleteY state
s0)