Process.hs

{-# LANGUAGE ExistentialQuantification #-}
{- |
Process chunks of data in the IO monad.
Typical inputs are strict storable vectors and piecewise constant values,
and typical outputs are strict storable vectors.
You may also combine several of these types using the Zip type constructor.

We may substitute IO by ST in the future, but I am uncertain about that.
-}
module Synthesizer.CausalIO.Process 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 Control.Monad.Trans.State (runStateT, )

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.Tuple.HT (mapSnd, )

import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO, )


data T p a b =
   forall state context.
   Cons
      {-
      If the transition function returns a chunk
      that is shorter than the input,
      then this is the last chunk.
      This way we do not need a MaybeT IO.
      -}
      (a -> state -> IO (b, state))
      (p -> IO state)
      {-
      The delete function must not do anything serious,
      e.g. close files,
      because it might not be called.
      Something like 'touchForeignPtr' is reasonable.
      -}
      (state -> IO ())


instance Cat.Category (T p) where
   id = Arr.arr id
   (Cons nextB createB deleteB) .
          (Cons nextA createA deleteA) = Cons
      (\a (sa0,sb0) -> do
         (b,sa1) <- nextA a sa0
         (c,sb1) <- nextB b sb0
         return (c,(sa1,sb1)))
      (\p -> do
         sa <- createA p
         sb <- createB p
         return (sa,sb))
      (\(sa,sb) ->
         deleteA sa >> deleteB sb)

instance Arr.Arrow (T p) where
   arr f = Cons
      (\ a () -> return (f a, ()))
      (\ _p -> return ())
      (\ () -> return ())
   first (Cons next create delete) = Cons
      (\(b,d) sa0 ->
         do (c,sa1) <- next b sa0
            return ((c,d), sa1))
      create
      delete

fromCausal ::
   (Monoid b) =>
   Causal.T a b -> T p a b
fromCausal (Causal.Cons next start) = Cons
   (\a s0 ->
      return $
      case runStateT (next a) s0 of
         Nothing -> (mempty, s0)
         Just (b,s1) -> (b,s1))
   (\ _p -> return $ start)
   (\ _ -> return ())

mapAccum ::
   (p -> a -> state -> (b, state)) ->
   (p -> state) ->
   T p a b
mapAccum next start =
   Cons
      (\a (p,s) -> return $ mapSnd ((,) p) $ next p a s)
      (\p -> return (p, start p))
      (\ _p -> return ())


runStorableChunkyCont ::
   (Storable a, Storable b) =>
   T p (SV.Vector a) (SV.Vector b) ->
   IO ((SVL.Vector a -> SVL.Vector b) ->
       p ->
       SVL.Vector a -> SVL.Vector b)
runStorableChunkyCont (Cons next create delete) =
   return $
      \ procRest p sig ->
      SVL.fromChunks $ unsafePerformIO $ do
         state <- create p

         let go xt s0 =
               unsafeInterleaveIO $
               case xt of
                  [] -> delete s0 >> return []
                  x:xs -> do
                     (y,s1) <- next x s0
                     (if SV.length y > 0
                        then fmap (y:)
                        else id) $
                        (if SV.length y < SV.length x
                           then return $ SVL.chunks $
                                procRest $ SVL.fromChunks $
                                SV.drop (SV.length y) x : xs
                           else go xs s1)
         go (SVL.chunks sig) state


zip ::
   (Arr.Arrow arrow) =>
   arrow a b -> arrow a c -> arrow a (Zip.T b c)
zip ab ac =
   uncurry Zip.Cons ^<< ab &&& ac


{- |
@mappend@ should be used sparingly.
In a loop it will have to construct types at runtime
which is rather expensive.
-}
instance (CutG.Transform a, CutG.Read b, Monoid b) => Monoid (T p a b) where
   mempty = Cons
      (\ _a () -> return (mempty, ()))
      (\ _p -> return ())
      (\() -> return ())
   mappend
         (Cons nextB createB deleteB)
         (Cons nextA createA deleteA) = Cons
      (\a s ->
         case s of
            Left (p,s0) -> do
               (b1,s1) <- nextA a s0
               let lenA = CutG.length a
                   lenB = CutG.length b1
               case compare lenA lenB of
                  LT -> error "CausalIO.Process.mappend: output chunk is larger than input chunk"
                  EQ -> return (b1, Left (p,s1))
                  GT -> do
                     deleteA s1
                     s2 <- createB p
                     (b3,s3) <- nextB (CutG.drop lenB a) s2
                     return (b3, Right s3)
            Right s0 -> do
               (b1,s1) <- nextB a s0
               return (b1, Right s1))
      (\p -> do
         sa <- createA p
         return (Left (p,sa)))
      (\s ->
         case s of
            Left (_p,s0) -> deleteA s0
            Right s0 -> deleteB s0)


continue ::
   (CutG.Transform a, SigG.Transform sig b) =>
   T p a (sig b) -> T (p,b) a (sig b) -> T p a (sig b)
continue
      (Cons nextA createA deleteA)
      (Cons nextB createB deleteB) = Cons
   (\a s ->
      case s of
         Left (p, lastB0, s0) -> do
            (b1,s1) <- nextA a s0
            let lenA = CutG.length a
                lenB = CutG.length b1
                lastB1 =
                   mplus (fmap snd $ SigG.viewR b1) lastB0
            case compare lenA lenB of
               LT -> error "CausalIO.Process.mappend: output chunk is larger than input chunk"
               EQ -> return (b1, Left (p,lastB1,s1))
               GT ->
                  case lastB1 of
                     Nothing -> return (mempty, Left (p,lastB1,s1))
                     Just lastB -> do
                        deleteA s1
                        s2 <- createB (p, lastB)
                        (b3,s3) <- nextB (CutG.drop lenB a) s2
                        return (b3, Right s3)
         Right s0 -> do
            (b1,s1) <- nextB a s0
            return (b1, Right s1))
   (\p -> do
      sa <- createA p
      return (Left (p, Nothing, sa)))
   (\s ->
      case s of
         Left (_p,_lastB,s0) -> deleteA s0
         Right s0 -> deleteB s0)