summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--LICENSE30
-rw-r--r--Setup.hs2
-rw-r--r--boombox.cabal34
-rw-r--r--src/Data/Boombox.hs11
-rw-r--r--src/Data/Boombox/Async.hs23
-rw-r--r--src/Data/Boombox/Boombox.hs82
-rw-r--r--src/Data/Boombox/Combinators.hs17
-rw-r--r--src/Data/Boombox/Extra.hs38
-rw-r--r--src/Data/Boombox/Head.hs35
-rw-r--r--src/Data/Boombox/IO.hs25
-rw-r--r--src/Data/Boombox/Player.hs76
-rw-r--r--src/Data/Boombox/Tape.hs154
12 files changed, 527 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..06ae0c4
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2015, Fumiaki Kinoshita
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Fumiaki Kinoshita nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..833b4c6
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/boombox.cabal b/boombox.cabal
new file mode 100644
index 0000000..92a00de
--- /dev/null
+++ b/boombox.cabal
@@ -0,0 +1,34 @@
+-- Initial tapes.cabal generated by cabal init. For further documentation,
+-- see http://haskell.org/cabal/users-guide/
+
+name: boombox
+version: 0.0
+synopsis: Chronokinetic stream sources and incremental consumers
+-- description:
+homepage: https://github.com/fumieval/boombox
+license: BSD3
+license-file: LICENSE
+author: Fumiaki Kinoshita
+maintainer: fumiexcel@gmail.com
+-- copyright:
+category: Data
+build-type: Simple
+-- extra-source-files:
+cabal-version: >=1.10
+
+library
+ exposed-modules: Data.Boombox
+ , Data.Boombox.Async
+ , Data.Boombox.Boombox
+ , Data.Boombox.Combinators
+ , Data.Boombox.Extra
+ , Data.Boombox.Head
+ , Data.Boombox.IO
+ , Data.Boombox.Player
+ , Data.Boombox.Tape
+ -- other-modules:
+ other-extensions: BangPatterns, DeriveFunctor
+ build-depends: base == 4.*, comonad, semigroups, semigroupoids, bytestring, transformers
+ hs-source-dirs: src
+ ghc-options: -Wall -O2
+ default-language: Haskell2010
diff --git a/src/Data/Boombox.hs b/src/Data/Boombox.hs
new file mode 100644
index 0000000..f1e0296
--- /dev/null
+++ b/src/Data/Boombox.hs
@@ -0,0 +1,11 @@
+module Data.Boombox (
+ module Data.Boombox.Tape
+ , module Data.Boombox.Boombox
+ , module Data.Boombox.Player
+ , module Data.Boombox.Combinators
+ , module Data.Boombox.Async) where
+import Data.Boombox.Tape
+import Data.Boombox.Player
+import Data.Boombox.Async
+import Data.Boombox.Combinators
+import Data.Boombox.Boombox \ No newline at end of file
diff --git a/src/Data/Boombox/Async.hs b/src/Data/Boombox/Async.hs
new file mode 100644
index 0000000..c0c34dd
--- /dev/null
+++ b/src/Data/Boombox/Async.hs
@@ -0,0 +1,23 @@
+module Data.Boombox.Async where
+
+import Control.Concurrent
+import Data.Boombox.Tape
+import Data.Foldable
+import Data.Function
+
+-- \ Merge multiple tapes in an asynchronous manner.
+asyncMergeTapes :: Functor w => [Tape w IO a] -> Tape w IO a
+asyncMergeTapes ts = Tape $ do
+ v <- newChan
+ let go k t = do
+ (a, w) <- unconsTape t
+ writeChan v (a, w, k)
+ takeMVar k >>= go k
+ for_ ts $ \t -> do
+ k <- newEmptyMVar
+ forkIO $ go k t
+ fix $ \self -> do
+ (a, w, k) <- readChan v
+ return (a, fmap (\cont -> Tape $ do
+ putMVar k $! cont
+ self) w)
diff --git a/src/Data/Boombox/Boombox.hs b/src/Data/Boombox/Boombox.hs
new file mode 100644
index 0000000..3bf8b16
--- /dev/null
+++ b/src/Data/Boombox/Boombox.hs
@@ -0,0 +1,82 @@
+{-# LANGUAGE Rank2Types #-}
+module Data.Boombox.Boombox where
+
+import Control.Comonad
+import Data.Boombox.Tape
+import Data.Boombox.Player
+import Control.Monad.Trans.Class
+
+infix 6 @.$
+infix 6 @-$
+infixl 7 @->
+infixr 7 >-$
+infixl 8 >->
+
+-- | Feed a tape to a player and extract the final result.
+(@.$) :: (Comonad w, Monad m)
+ => Tape w m s
+ -> PlayerT w s m a
+ -> m a
+t0 @.$ p = connectDrive id (\_ _ -> return) [] t0 (runPlayerT p)
+{-# INLINE (@.$) #-}
+
+-- | Feed a tape to a player. It returns the leftover input, the remainder of the tape, and the result from the player.
+(@-$) :: (Comonad w, Monad m)
+ => Tape w m s
+ -> PlayerT w s m a
+ -> m ([s], Tape w m s, a)
+t0 @-$ p = connectDrive id (\a b c -> return (a, b, c)) [] t0 (runPlayerT p)
+{-# INLINE (@-$) #-}
+
+-- | @'Boombox' v w m a b@ is a transducer from @a@ to @b@ with monadic effect @m@, a comonadic control @v@ (outgoing) and @w@ (incoming).
+type Boombox v w m a = Tape w (PlayerT v a m)
+
+-- | Combine a tape with a boombox. The result will be synchronized with the boombox.
+(@->) :: (Comonad v, Functor w, Monad m) => Tape v m a -> Boombox v w m a b -> Tape w m b
+(@->) = composeWith id
+{-# INLINE (@->) #-}
+
+-- | Connect two boomboxes.
+(>->) :: (Comonad u, Comonad v, Functor w, Monad m)
+ => Boombox u v m a b
+ -> Boombox v w m b c
+ -> Boombox u w m a c
+(>->) = composeWith lift
+{-# INLINE (>->) #-}
+
+-- | Connect a boombox to a player.
+(>-$) :: (Comonad w, Monad m) => Boombox v w m a b -> PlayerT w b m r -> PlayerT v a m r
+t0 >-$ p0 = connectDrive lift (\_ _ -> return) [] t0 (runPlayerT p0)
+{-# INLINE (>-$) #-}
+
+composeWith :: (Comonad v, Functor w, Monad m, Functor n)
+ => (forall x. n x -> m x)
+ -> Tape v m a
+ -> Boombox v w n a b
+ -> Tape w m b
+composeWith trans = loop [] where
+ loop lo t (Tape m) = Tape $ connectDrive trans
+ (\lo' t' (a, w) -> return (a, loop lo' t' <$> w)) lo t (runPlayerT m)
+{-# INLINE composeWith #-}
+
+connectDrive :: (Comonad w, Monad m)
+ => (forall x. n x -> m x)
+ -> ([s] -> Tape w m s -> a -> m r)
+ -> [s]
+ -> Tape w m s
+ -> Drive w s n a
+ -> m r
+connectDrive td cont = loop where
+ loop lo t d = case d of
+ Done a -> cont lo t a
+ Partial f -> case lo of
+ [] -> do
+ (a, w) <- unconsTape t
+ loop [] (extract w) (f a)
+ (x:xs) -> loop xs t (f x)
+ Leftover s k -> loop (s : lo) t k
+ Eff m -> td m >>= loop lo t
+ Cont m -> do
+ (a, w) <- unconsTape t
+ m $ extend (loop lo . yield a) w
+{-# INLINE connectDrive #-}
diff --git a/src/Data/Boombox/Combinators.hs b/src/Data/Boombox/Combinators.hs
new file mode 100644
index 0000000..8b3f227
--- /dev/null
+++ b/src/Data/Boombox/Combinators.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE LambdaCase #-}
+module Data.Boombox.Combinators where
+
+foldMFrom :: Monad m => m (Maybe s) -> (r -> s -> m r) -> r -> m r
+foldMFrom m f r = m >>= \case
+ Just s -> f r s >>= foldMFrom m f
+ Nothing -> return r
+
+foldlFrom :: Monad m => m (Maybe s) -> (r -> s -> r) -> r -> m r
+foldlFrom m f r = m >>= \case
+ Just s -> foldlFrom m f $! f r s
+ Nothing -> return r
+
+traverseFrom_ :: Monad m => m (Maybe s) -> (s -> m r) -> m ()
+traverseFrom_ m k = m >>= \case
+ Just s -> k s >> traverseFrom_ m k
+ Nothing -> return () \ No newline at end of file
diff --git a/src/Data/Boombox/Extra.hs b/src/Data/Boombox/Extra.hs
new file mode 100644
index 0000000..1cc01f4
--- /dev/null
+++ b/src/Data/Boombox/Extra.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE LambdaCase #-}
+module Data.Boombox.Extra where
+import Data.Boombox
+import Prelude hiding (takeWhile, dropWhile, lines)
+import qualified Data.ByteString as BS
+import Control.Comonad
+import Data.Functor.Identity
+
+-- | @peek ≡ lookAhead await@
+peek :: PlayerT w a m a
+peek = await >>= \a -> a <$ leftover a
+
+takeWhile :: (a -> Bool) -> PlayerT w a m [a]
+takeWhile p = do
+ a <- await
+ if p a
+ then (a:) <$> takeWhile p
+ else leftover a >> return []
+
+dropWhile :: (a -> Bool) -> PlayerT w a m ()
+dropWhile p = do
+ a <- await
+ if p a
+ then dropWhile p
+ else leftover a
+
+lines :: Comonad w => Boombox w Identity IO (Maybe BS.ByteString) (Maybe BS.ByteString)
+lines = Tape (go []) where
+ go ls = await >>= \case
+ Just c -> do
+ let (l, r) = BS.break (==10) c
+ if BS.null r
+ then go (l : ls)
+ else return (Just $ BS.concat $ reverse $ l : ls, pure
+ $ Tape $ leftover (Just (BS.tail r)) >> go [])
+ Nothing -> return $ case ls of
+ [] -> (Nothing, pure $ Tape $ go [])
+ _ -> (Just (BS.concat (reverse ls)), pure $ Tape $ go [])
diff --git a/src/Data/Boombox/Head.hs b/src/Data/Boombox/Head.hs
new file mode 100644
index 0000000..f06fe0d
--- /dev/null
+++ b/src/Data/Boombox/Head.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE DeriveFunctor #-}
+module Data.Boombox.Head where
+import Data.Boombox.Player
+import Data.Boombox.Tape
+import Control.Comonad
+import Control.Applicative
+
+-- | 'Head' is a Store-like comonad which handles seeking.
+data Head i a = Head !i (Maybe i -> a) deriving Functor
+
+instance Comonad (Head i) where
+ extract (Head _ f) = f Nothing
+ extend k (Head i f) = Head i $ \m -> k $ Head (maybe i id m) f
+
+instance Ord i => Chronological (Head i) where
+ coincidence (Head i f) (Head j g) = case compare i j of
+ EQ -> Simultaneous (Head i (liftA2 (,) f g))
+ LT -> LeftFirst
+ GT -> RightFirst
+
+-- | Seek to an arbitrary position.
+seeksTape :: Monad m => (i -> Maybe i) -> Tape (Head i) m a -> Tape (Head i) m a
+seeksTape t (Tape m) = Tape $ m >>= \(_, Head i f) -> unconsTape (f (t i))
+
+-- | Get the current offset.
+posP :: PlayerT (Head i) s m i
+posP = control $ \(Head i f) -> (f Nothing, i)
+
+-- | Apply the given function to the current offset and jump to the resulting offset.
+seeksP :: (i -> Maybe i) -> PlayerT (Head i) s m ()
+seeksP t = control $ \(Head i f) -> (f (t i), ())
+
+-- | Seek to the given offset.
+seekP :: i -> PlayerT (Head i) s m ()
+seekP i = seeksP (const (Just i)) \ No newline at end of file
diff --git a/src/Data/Boombox/IO.hs b/src/Data/Boombox/IO.hs
new file mode 100644
index 0000000..32c8175
--- /dev/null
+++ b/src/Data/Boombox/IO.hs
@@ -0,0 +1,25 @@
+module Data.Boombox.IO where
+
+import Data.Boombox.Tape
+import Data.Boombox.Head
+import Control.Monad.IO.Class
+import qualified System.IO as IO
+import qualified Data.ByteString as BS
+import Data.Int
+
+hGetContentsN :: MonadIO m => Int -> IO.Handle -> Tape (Head Int64) m (Maybe BS.ByteString)
+hGetContentsN n h = go 0 where
+ go i = Tape $ do
+ c <- liftIO $ BS.hGetSome h n
+ let l = BS.length c
+ if l <= 0
+ then return (Nothing, Head i $ maybe (go i) go)
+ else return (Just c, Head i $ maybe
+ (go (i + fromIntegral l))
+ (\j -> Tape $ liftIO (IO.hSeek h IO.AbsoluteSeek (fromIntegral j)) >> unconsTape (go j)))
+
+hGetContents :: MonadIO m => IO.Handle -> Tape (Head Int64) m (Maybe BS.ByteString)
+hGetContents = hGetContentsN 4080
+
+readFile :: MonadIO m => FilePath -> Tape (Head Int64) m (Maybe BS.ByteString)
+readFile path = effect $ hGetContents <$> liftIO (IO.openFile path IO.ReadMode) \ No newline at end of file
diff --git a/src/Data/Boombox/Player.hs b/src/Data/Boombox/Player.hs
new file mode 100644
index 0000000..9dea09a
--- /dev/null
+++ b/src/Data/Boombox/Player.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE Rank2Types, LambdaCase, BangPatterns, DeriveFunctor, ExistentialQuantification #-}
+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleContexts, FlexibleInstances #-}
+module Data.Boombox.Player where
+import Control.Monad
+import Control.Monad.Trans.Class
+import Control.Monad.IO.Class
+import Control.Applicative
+
+data Drive w s m a = Done a
+ | Partial (s -> Drive w s m a)
+ | Leftover s (Drive w s m a)
+ | Eff (m (Drive w s m a))
+ | Cont (forall r. w (Drive w s m a -> r) -> r)
+
+-- | @'Player' w s m a@ is a monadic consumer of a stream of @s@.
+-- 'Player' may send a control signal parameterized by @w@; the control surface of the producer
+-- (usually 'Tape') should match it.
+newtype PlayerT w s m a = PlayerT { unPlayerT :: forall r. (a -> Drive w s m r) -> Drive w s m r }
+
+instance Functor (PlayerT w s m) where
+ fmap f m = PlayerT $ \cs -> unPlayerT m (cs . f)
+
+instance Applicative (PlayerT w s m) where
+ pure = return
+ {-# INLINE pure #-}
+ (<*>) = ap
+ {-# INLINE (<*>) #-}
+
+instance Monad (PlayerT w s m) where
+ return a = PlayerT $ \cs -> cs a
+ m >>= k = PlayerT $ \cs -> unPlayerT m $ \a -> unPlayerT (k a) cs
+
+instance MonadTrans (PlayerT w s) where
+ lift m = PlayerT $ \cs -> Eff $ fmap cs m
+
+instance (MonadIO m) => MonadIO (PlayerT w s m) where
+ liftIO m = PlayerT $ \cs -> Eff $ fmap cs (liftIO m)
+
+instance Monoid a => Monoid (PlayerT w s m a) where
+ mempty = pure mempty
+ {-# INLINE mempty #-}
+ mappend = liftA2 mappend
+ {-# INLINE mappend #-}
+
+runPlayerT :: PlayerT w s m a -> Drive w s m a
+runPlayerT m = unPlayerT m Done
+
+-- | Send a control signal.
+control :: (forall a. w a -> (a, b)) -> PlayerT w s m b
+control k = PlayerT $ \cs -> Cont $ \wcont -> case k wcont of
+ (cont, b) -> cont (cs b)
+
+-- | Consume a value.
+await :: PlayerT w s m s
+await = PlayerT Partial
+{-# INLINABLE await #-}
+
+-- | Push a leftover back.
+leftover :: s -> PlayerT w s m ()
+leftover s = PlayerT $ \cs -> Leftover s (cs ())
+{-# INLINABLE leftover #-}
+
+-- | Put some leftovers.
+leftovers :: Foldable f => f s -> PlayerT w s m ()
+leftovers xs = PlayerT $ \cs -> foldr Leftover (cs ()) xs
+{-# INLINE leftovers #-}
+
+-- | Run a 'PlayerT' action without consuming any input.
+lookAhead :: (Functor w, Functor m) => PlayerT w s m a -> PlayerT w s m a
+lookAhead pl = PlayerT $ \cs -> go cs [] [] (unPlayerT pl Done) where
+ go cs l (x:xs) (Partial f) = go cs l xs (f x)
+ go cs l [] (Partial f) = Partial $ \x -> go cs (x : l) [] (f x)
+ go cs l xs (Leftover x k) = go cs l (x:xs) k
+ go cs l _ (Done a) = foldr Leftover (cs a) l
+ go cs l xs (Eff m) = Eff $ fmap (go cs l xs) m
+ go cs l xs (Cont m) = Cont $ m . fmap (. go cs l xs)
diff --git a/src/Data/Boombox/Tape.hs b/src/Data/Boombox/Tape.hs
new file mode 100644
index 0000000..5297868
--- /dev/null
+++ b/src/Data/Boombox/Tape.hs
@@ -0,0 +1,154 @@
+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
+{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}
+module Data.Boombox.Tape (Tape(..)
+ -- * Consuming tapes
+ , headTape
+ , cueTape
+ -- * Constructing tapes
+ , yield
+ , yieldMany
+ , effect
+ , repeater
+ -- * Transforming tapes
+ , flattenTape
+ , filterTape
+ , foldTape
+ , hoistTransTape
+ , hoistTape
+ , transTape
+ , controlTape
+ , pushBack
+ , intercept
+ -- * Time series
+ , Chronological(..)
+ , EventOrder(..)
+ ) where
+
+import Control.Category
+import Control.Applicative
+import Data.Functor.Apply
+import Data.Functor.Identity
+import Prelude hiding (id, (.))
+import Control.Comonad.Env
+import Control.Comonad.Store
+import Control.Comonad.Traced hiding ((<>))
+import Data.Semigroup
+import Control.Arrow
+
+-- | @Tape w m a@ is a producer of values with a type @a@.
+-- It may cause effects @m@ and has a comonadic control @w@.
+newtype Tape w m a = Tape { unconsTape :: m (a, w (Tape w m a)) }
+ deriving (Functor)
+
+yield :: Applicative m => a -> w (Tape w m a) -> Tape w m a
+yield a w = Tape $ pure (a, w)
+{-# INLINE yield #-}
+
+effect :: Monad m => m (Tape w m a) -> Tape w m a
+effect m = Tape $ m >>= unconsTape
+{-# INLINE effect #-}
+
+-- | Build a tape that yields the same value, with the very same effect and exactly the same control.
+repeater :: (Functor m, Comonad w) => m (w a) -> Tape w m a
+repeater m = Tape $ fmap (\w -> (extract w, repeater m <$ w)) m
+
+-- | Take the first element of the tape.
+headTape :: Functor m => Tape w m a -> m a
+headTape = fmap fst . unconsTape
+
+-- | Denudate the control without dropping a value.
+cueTape :: (Comonad w, Applicative m) => Tape w m a -> m (w (Tape w m a))
+cueTape = fmap (\(a, w) -> extend (yield a) w) . unconsTape
+
+-- | Flatten a tape of 'Foldable' containers.
+flattenTape :: (Comonad w, Foldable f, Monad m) => Tape w m (f a) -> Tape w m a
+flattenTape = foldTape id
+{-# INLINE flattenTape #-}
+
+foldTape :: (Comonad w, Foldable f, Monad m) => (a -> f b) -> Tape w m a -> Tape w m b
+foldTape f = go where
+ go t = Tape $ unconsTape t >>= \(a, w) -> unconsTape $ yieldMany (f a) (fmap go w)
+{-# INLINE foldTape #-}
+
+filterTape :: (Comonad w, Monad m) => (a -> Bool) -> Tape w m a -> Tape w m a
+filterTape p = go where
+ go t = Tape $ unconsTape t >>= \(a, w) -> if p a then return (a, fmap go w) else unconsTape (go (extract w))
+
+yieldMany :: (Comonad w, Foldable f, Applicative m) => f a -> w (Tape w m a) -> Tape w m a
+yieldMany f w = extract $ foldr (extend . yield) w f
+{-# INLINE yieldMany #-}
+
+-- | Apply a monadic function to a tape.
+intercept :: (Functor w, Monad m) => (a -> m b) -> Tape w m a -> Tape w m b
+intercept k t = Tape $ unconsTape t >>= \(a, w) -> (\b -> (b, fmap (intercept k) w)) <$> k a
+
+hoistTransTape :: (Functor w, Functor n) => (forall x. v x -> w x) -> (forall x. m x -> n x) -> Tape v m a -> Tape w n a
+hoistTransTape s t = go where
+ go (Tape m) = Tape $ fmap (\(a, w) -> (a, fmap go (s w))) (t m)
+{-# INLINE hoistTransTape #-}
+
+-- | Apply natural transformation to the comonadic control surface.
+hoistTape :: (Functor w, Functor m) => (forall x. v x -> w x) -> Tape v m a -> Tape w m a
+hoistTape t = hoistTransTape t id
+{-# INLINE hoistTape #-}
+
+-- | Transform effects produced by the tape.
+transTape :: (Functor w, Functor n) => (forall x. m x -> n x) -> Tape w m a -> Tape w n a
+transTape = hoistTransTape id
+{-# INLINE transTape #-}
+
+-- | Operate on the control surface just once.
+controlTape :: Functor m => (w (Tape w m a) -> w (Tape w m a)) -> Tape w m a -> Tape w m a
+controlTape t (Tape m) = Tape $ fmap (second t) m
+
+-- | Push some values back to a tape.
+pushBack :: (Foldable f, Comonad w, Monad m) => f a -> Tape w m a -> Tape w m a
+pushBack f t = effect $ yieldMany f <$> cueTape t
+
+-- | 'Chronological' functor is like 'Apply', but the operation may fail due to a time lag.
+class Functor f => Chronological f where
+ coincidence :: f a -> f b -> EventOrder (f (a, b))
+
+data EventOrder a = Simultaneous a
+ | LeftFirst
+ | RightFirst
+ deriving Functor
+
+instance Chronological Identity where
+ coincidence (Identity a) (Identity b) = Simultaneous (Identity (a, b))
+
+instance Chronological ((->) i) where
+ coincidence f g = Simultaneous $ liftA2 (,) f g
+
+instance Ord i => Chronological ((,) i) where
+ coincidence (i, a) (j, b) = case compare i j of
+ EQ -> Simultaneous (i, (a, b))
+ LT -> LeftFirst
+ GT -> RightFirst
+
+instance (Ord i, Chronological w) => Chronological (EnvT i w) where
+ coincidence (EnvT i v) (EnvT j w) = case compare i j of
+ EQ -> EnvT i <$> coincidence v w
+ LT -> LeftFirst
+ GT -> RightFirst
+
+instance (Ord i, Chronological w) => Chronological (StoreT i w) where
+ coincidence (StoreT v i) (StoreT w j) = case compare i j of
+ EQ -> (\wfg -> StoreT (fmap (uncurry $ liftA2 (,)) wfg) i) <$> coincidence v w
+ LT -> LeftFirst
+ GT -> RightFirst
+
+instance Chronological w => Chronological (TracedT m w) where
+ coincidence (TracedT v) (TracedT w) = fmap (TracedT . fmap (uncurry $ liftA2 (,))) $ coincidence v w
+
+instance (Chronological w, Monad m, Semigroup a)
+ => Semigroup (Tape w m a) where
+ s <> t = Tape $ do
+ (a, v) <- unconsTape s
+ (b, w) <- unconsTape t
+ case coincidence v w of
+ Simultaneous u -> return (a <> b, fmap (uncurry (<>)) u)
+ LeftFirst -> return (a, fmap (<> t) v)
+ RightFirst -> return (b, fmap (s <>) w)