boombox (empty) → 0.0

raw patch · 12 files changed

+527/−0 lines, 12 filesdep +basedep +bytestringdep +comonadsetup-changed

Dependencies added: base, bytestring, comonad, semigroupoids, semigroups, transformers

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• boombox.cabal +34/−0
• src/Data/Boombox.hs +11/−0
• src/Data/Boombox/Async.hs +23/−0
• src/Data/Boombox/Boombox.hs +82/−0
• src/Data/Boombox/Combinators.hs +17/−0
• src/Data/Boombox/Extra.hs +38/−0
• src/Data/Boombox/Head.hs +35/−0
• src/Data/Boombox/IO.hs +25/−0
• src/Data/Boombox/Player.hs +76/−0
• src/Data/Boombox/Tape.hs +154/−0

@@ -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.

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

@@ -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

@@ -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

@@ -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)

@@ -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 #-}

@@ -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 ()

@@ -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 [])

@@ -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))

@@ -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)

@@ -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)

@@ -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)