{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module Synthesizer.LLVM.CausalParameterized.Process (
   T, simple,
   fromSignal, toSignal,
   mapAccum, map, mapSimple, zipWith, zipWithSimple,
   apply, compose, first,
   feedFst, feedSnd,
   loop, loopZero, take, takeWhile, integrate,

   ($<), ($>), ($*),
   applyFst, applySnd,

   reparameterize,

   mapAccumSimple,

   replicateControlled,
   replicateParallel,
   replicateControlledParam,
   feedbackControlled,
   Causal.feedbackControlledZero,
   Causal.fromModifier,
   fromInitializedModifier,
   stereoFromMono,
   stereoFromMonoControlled,
   stereoFromMonoParameterized,
   Causal.stereoFromVector,
   Causal.vectorize,
   Causal.replaceChannel,
   Causal.arrayElement,
   Causal.element,
   Causal.mix,
   raise,
   Causal.envelope,
   Causal.envelopeStereo,
   amplify,
   amplifyStereo,
   mapLinear,
   mapExponential,
   quantizeLift,
   osciSimple,
   Causal.osciCore,
   Causal.osciCoreSync,
   Causal.shapeModOsci,
   delay,
   delayZero,
   delay1,
   Causal.delay1Zero,
   delayControlled,
   delayControlledInterpolated,
   differentiate,
   comb,
   combStereo,
   reverbSimple,
   reverb,
   Causal.pipeline,
   Causal.skip,
   Causal.frequencyModulation,
   frequencyModulationLinear,
   trigger,

   runStorable,
   applyStorable,
   runStorableChunky,
   runStorableChunkyCont,
   applyStorableChunky,

   processIO,
   processIOCore,
   ) where

import Synthesizer.LLVM.CausalParameterized.ProcessPrivate
import Synthesizer.LLVM.Causal.ProcessPrivate
         (feedbackControlledAux, reverbParams)
import Synthesizer.LLVM.Causal.Process (loopZero, mix)
import qualified Synthesizer.LLVM.Causal.ProcessPrivate as CausalPriv
import qualified Synthesizer.LLVM.Causal.Process as Causal
import qualified Synthesizer.LLVM.Plug.Input as PIn
import qualified Synthesizer.LLVM.Plug.Output as POut
import qualified Synthesizer.CausalIO.Process as PIO

import qualified Synthesizer.LLVM.CausalParameterized.RingBuffer as RingBuffer
import qualified Synthesizer.LLVM.Parameterized.SignalPrivate as SigPPriv
import qualified Synthesizer.LLVM.Parameterized.Signal as SigP
import qualified Synthesizer.LLVM.Simple.SignalPrivate as SigPriv
import qualified Synthesizer.LLVM.Simple.Value as Value
import qualified Synthesizer.LLVM.Interpolation as Interpolation
import qualified Synthesizer.LLVM.Frame.Stereo as Stereo
import qualified Synthesizer.LLVM.Frame as Frame
import qualified Synthesizer.LLVM.ForeignPtr as ForeignPtr

import qualified Synthesizer.Causal.Class as CausalClass
import qualified Synthesizer.Generic.Cut as Cut
import qualified Synthesizer.Plain.Modifier as Modifier

import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector as SV
import qualified Data.StorableVector.Base as SVB

import qualified LLVM.DSL.Execution as Exec
import qualified LLVM.DSL.Parameter as Param
import LLVM.DSL.Parameter (($#))

import qualified LLVM.Extra.ScalarOrVector as SoV
import qualified LLVM.Extra.Tuple as Tuple
import qualified LLVM.Extra.MaybeContinuation as MaybeCont
import qualified LLVM.Extra.Maybe as Maybe
import qualified LLVM.Extra.Storable as Storable
import qualified LLVM.Extra.Memory as Memory
import qualified LLVM.Extra.Marshal as Marshal
import qualified LLVM.Extra.Control as C
import qualified LLVM.Extra.Arithmetic as A

import qualified LLVM.Core as LLVM
import LLVM.Core
          (CodeGenFunction, ret, Value, valueOf,
           IsSized, IsConst, IsArithmetic, IsFloating)

import qualified Type.Data.Num.Decimal as TypeNum

import qualified Control.Category as Cat
import Control.Monad.Trans.State (runState)
import Control.Arrow (arr, first, second, (<<<), (<<^), (>>>), (&&&))
import Control.Monad (liftM, when)
import Control.Applicative (liftA2, liftA3, pure, (<*>))
import Control.Functor.HT (void, unzip)
import Control.Exception (bracket)

import qualified Data.List as List
import Data.Traversable (traverse)
import Data.Foldable (sequence_)
import Data.Tuple.HT (swap, mapFst, mapSnd, uncurry3, snd3)
import Data.Word (Word)
import Data.Int (Int8)

import System.Random (Random, RandomGen)

import Foreign.StablePtr
          (StablePtr, newStablePtr, freeStablePtr, deRefStablePtr)
import Foreign.ForeignPtr (touchForeignPtr)
import Foreign.Ptr (FunPtr, Ptr, freeHaskellFunPtr)

import qualified System.Unsafe as Unsafe

import qualified LLVM.DSL.Debug.Marshal as DebugSt
import qualified LLVM.DSL.Debug.Counter as DebugCnt

import qualified Algebra.Transcendental as Trans

import NumericPrelude.Numeric
import NumericPrelude.Base hiding
          (and, iterate, map, unzip, zip, zipWith, take, takeWhile, sequence_)


infixl 0 $<, $>, $*
-- infixr 0 $:*   -- can be used together with $

applyFst, ($<) :: T p (a,b) c -> SigP.T p a -> T p b c
applyFst = CausalClass.applyFst

applySnd, ($>) :: T p (a,b) c -> SigP.T p b -> T p a c
applySnd = CausalClass.applySnd

{-
These infix operators may become methods of a type class
that can also have synthesizer-core:Causal.Process as instance.
-}
($*) :: T p a b -> SigP.T p a -> SigP.T p b
($*) = apply
($<) = applyFst
($>) = applySnd


reparameterize :: Param.T q p -> T p a b -> T q a b
reparameterize p (Cons start alloca stop next create delete) =
   Cons start alloca stop next (create . Param.get p) delete


mapAccumSimple ::
   (Memory.C s) =>
   (forall r. a -> s -> CodeGenFunction r (b,s)) ->
   (forall r. CodeGenFunction r s) ->
   T p a b
mapAccumSimple f s =
   mapAccum (\() -> f) (\() -> s) (return ()) (return ())

fromInitializedModifier ::
   (Value.Flatten ah, Value.Registers ah ~ al,
    Value.Flatten bh, Value.Registers bh ~ bl,
    Value.Flatten ch, Value.Registers ch ~ cl,
    Value.Flatten sh, Value.Registers sh ~ sl, Memory.C sl,
    Value.Flatten ih, Value.Registers ih ~ il, Memory.C il,
    Marshal.C i, Tuple.ValueOf i ~ il) =>
   Modifier.Initialized sh ih ch ah bh -> Param.T p i -> T p (cl,al) bl
fromInitializedModifier (Modifier.Initialized initF step) =
   mapAccum
      (\() (c,a) s ->
         Value.flatten $
         runState
            (step (Value.unfold c) (Value.unfold a))
            (Value.unfold s))
      (Value.flattenFunction initF)
      (return ())


replicateParallel ::
   (Tuple.Undefined b, Tuple.Phi b) =>
   Param.T p Int -> SigP.T p b -> T p (b,b) b -> T p a b -> T p a b
replicateParallel n z cum p =
   replicateControlled n (first p >>> cum) $> z

{-
There are several problems:

 * We have to call f on every parameter in the list,
   but we have to assume that the generated code is always the same.

 * createIOContext may return different types for every element in the list.
   If types are different, the LLVM code cannot be the same, though.
-}
replicateControlledParam ::
   (Tuple.Undefined x, Tuple.Phi x) =>
   (forall q. Param.T q p -> Param.T q a -> T q (c,x) x) ->
   Param.T p [a] -> T p (c,x) x
replicateControlledParam f ps =
   case f (arr fst) (arr snd) of
      Cons next alloca start stop createIOContext deleteIOContext -> Cons
         (replicateControlledNext next stop)
--         (_replicateControlledNext next)
         alloca
         (replicateControlledStart start)
         (replicateControlledStop stop)
         (\p ->
            replicateControlledCreate $
               mapM
                  (\a -> createIOContext (p,a))
                  (Param.get ps p))
         (replicateControlledDelete deleteIOContext)


-- cf. synthesizer-core:Causal.Process
feedbackControlled ::
   (Marshal.C ch, Tuple.ValueOf ch ~ c) =>
   Param.T p ch ->
   T p ((ctrl,a),c) b -> T p (ctrl,b) c -> T p (ctrl,a) b
feedbackControlled initial forth back =
   loop initial (feedbackControlledAux forth back)


{- |
Run a causal process independently on each stereo channel.
-}
stereoFromMono ::
   (Tuple.Phi a, Tuple.Phi b, Tuple.Undefined b) =>
   T p a b -> T p (Stereo.T a) (Stereo.T b)
stereoFromMono
      (Cons next alloca start stop createIOContext deleteIOContext) = Cons
   (stereoNext stop next)
   alloca
   (stereoStart start)
   (stereoStop stop)
   (stereoCreate createIOContext createIOContext)
   (composeDelete deleteIOContext deleteIOContext)

stereoFromMonoControlled ::
   (Tuple.Phi a, Tuple.Phi b, Tuple.Phi c, Tuple.Undefined b) =>
   T p (c,a) b -> T p (c, Stereo.T a) (Stereo.T b)
stereoFromMonoControlled proc =
   stereoFromMono proc <<^ (\(c,sa) -> fmap ((,) c) sa)

stereoFromMonoParameterized ::
   (Tuple.Phi a, Tuple.Phi b, Tuple.Undefined b) =>
   (forall q. Param.T q p -> Param.T q x -> T q a b) ->
   Param.T p (Stereo.T x) -> T p (Stereo.T a) (Stereo.T b)
stereoFromMonoParameterized f ps =
   case f (arr fst) (arr snd) of
      Cons next alloca start stop createIOContext deleteIOContext -> Cons
         (stereoNext stop next)
         alloca
         (stereoStart start)
         (stereoStop stop)
         (stereoCreate
            (\p -> createIOContext (p, Stereo.left  $ Param.get ps p))
            (\p -> createIOContext (p, Stereo.right $ Param.get ps p)))
         (composeDelete deleteIOContext deleteIOContext)

stereoCreate ::
   Monad m =>
   (p -> m (ioContextA, context)) ->
   (p -> m (ioContextB, context)) ->
   p -> m ((ioContextA, ioContextB), Stereo.T context)
stereoCreate l r =
   liftM (mapSnd $ uncurry Stereo.cons) . composeCreate l r


stereoNext ::
   (Tuple.Phi a, Tuple.Phi b, Tuple.Phi c, Tuple.Phi s, Tuple.Phi context,
    Tuple.Undefined b, Tuple.Undefined s) =>
   (context -> s -> CodeGenFunction r ()) ->
   (forall z. (Tuple.Phi z) => context -> local -> a -> s -> MaybeCont.T r z (b, s)) ->
   Stereo.T context ->
   local ->
   Stereo.T a ->
   Stereo.T s ->
   MaybeCont.T r c (Stereo.T b, Stereo.T s)
stereoNext stop next context local a s0 = MaybeCont.fromMaybe $ do
   mbs1 <-
      twiceStereo
         (MaybeCont.toMaybe . uncurry3 (flip next local))
         (liftA3 (,,) context a s0)

   mbs2 <-
      if True
        then Maybe.lift2 Stereo.cons (Stereo.left mbs1) (Stereo.right mbs1)
        else MaybeCont.toMaybe $ traverse (MaybeCont.fromMaybe . return) mbs1

   end <- Maybe.getIsNothing mbs2
   C.ifThen end () $
      sequence_ $
      liftA2
         (\mbsi c -> Maybe.for mbsi (stop c . snd))
         mbs1 context

   return $ fmap unzip mbs2

stereoStart ::
   (Tuple.Phi a, Tuple.Phi b, Tuple.Phi c, Tuple.Undefined b, Tuple.Undefined c) =>
   (a -> CodeGenFunction r (c, b)) ->
   Stereo.T a -> CodeGenFunction r (Stereo.T c, Stereo.T b)
stereoStart code a =
   fmap unzip $ twiceStereo code a

stereoStop ::
   (Tuple.Phi context, Tuple.Phi state) =>
   (context -> state -> CodeGenFunction r ()) ->
   Stereo.T context -> Stereo.T state -> CodeGenFunction r ()
stereoStop code c s = void $ twiceStereo (uncurry code) (liftA2 (,) c s)

twiceStereo ::
   (Tuple.Phi a, Tuple.Phi b, Tuple.Undefined b) =>
   (a -> CodeGenFunction r b) ->
   Stereo.T a -> CodeGenFunction r (Stereo.T b)
twiceStereo code a =
   fmap (uncurry Stereo.cons) $
   twice code (Stereo.left a, Stereo.right a)

twice ::
   (Tuple.Phi a, Tuple.Phi b, Tuple.Undefined b) =>
   (a -> CodeGenFunction r b) ->
   (a,a) -> CodeGenFunction r (b,b)
twice code a =
   fmap snd $
   C.fixedLengthLoop (valueOf (2::Int8)) (a, Tuple.undef) $
      \((a0,a1), (_,b1)) -> do
         b0 <- code a0
         return ((a1,a0), (b1,b0))


{- |
You may also use '(+)' and a 'SigP.constant' signal or a number literal.
-}
raise ::
   (A.Additive al, Marshal.C a, Tuple.ValueOf a ~ al) =>
   Param.T p a -> T p al al
raise =
   map Frame.mix


{- |
You may also use '(*)' and a 'SigP.constant' signal or a number literal.
-}
amplify ::
   (A.PseudoRing al, Marshal.C a, Tuple.ValueOf a ~ al) =>
   Param.T p a -> T p al al
amplify =
   map Frame.amplifyMono

amplifyStereo ::
   (A.PseudoRing al, Marshal.C a, Tuple.ValueOf a ~ al) =>
   Param.T p a -> T p (Stereo.T al) (Stereo.T al)
amplifyStereo =
   map Frame.amplifyStereo



mapLinear ::
   (IsArithmetic a, Marshal.C a, Tuple.ValueOf a ~ Value a) =>
   Param.T p a -> Param.T p a -> T p (Value a) (Value a)
mapLinear depth center =
   map
      (\(d,c) x -> A.add c =<< A.mul d x)
      (depth&&&center)

mapExponential ::
   (Trans.C a, Marshal.C a, IsFloating a, IsConst a,
    SoV.TranscendentalConstant a, Tuple.ValueOf a ~ Value a) =>
   Param.T p a -> Param.T p a -> T p (Value a) (Value a)
mapExponential depth center =
   map
      (\(d,c) x ->
         A.mul c =<< A.exp =<< A.mul d x)
      (log depth &&& center)


{- |
@quantizeLift k f@ applies the process @f@ to every @k@th sample
and repeats the result @k@ times.

Like 'SigP.interpolateConstant' this function can be used
for computation of filter parameters at a lower rate.
This can be useful, if you have a frequency control signal at sample rate
that shall be used both for an oscillator and a frequency filter.
-}
quantizeLift ::
   (Memory.C b,
    Marshal.C c, Tuple.ValueOf c ~ Value cl,
    SoV.IntegerConstant cl, IsFloating cl,
    LLVM.CmpRet cl, LLVM.CmpResult cl ~ Bool) =>
   Param.T p c ->
   T p a b ->
   T p a b
quantizeLift k causal =
   Causal.quantizeLift causal $< SigP.constant k


-- for backwards compatibility
osciSimple ::
   (SoV.Fraction t, IsSized t) =>
   (forall r. Value t -> CodeGenFunction r y) ->
   T p (Value t, Value t) y
osciSimple = Causal.osci


{- |
Delay time must be non-negative.

The initial value is needed in order to determine the ring buffer element type.
-}
delay ::
   (Marshal.C a, Tuple.ValueOf a ~ al) =>
   Param.T p a -> Param.T p Int -> T p al al
delay initial time =
   mapSimple RingBuffer.oldest
   <<<
   RingBuffer.track initial time

delayZero ::
   (Memory.C a, A.Additive a) =>
   Param.T p Int -> T p a a
delayZero time =
   mapSimple RingBuffer.oldest
   <<<
   RingBuffer.trackConst A.zero time


{- |
Delay by one sample.
For very small delay times (say up to 8)
it may be more efficient to apply 'delay1' several times
or to use a pipeline,
e.g. @pipeline (id :: T (Vector D4 Float) (Vector D4 Float))@
delays by 4 samples in an efficient way.
In principle it would be also possible to use
@unpack (delay1 (pure $ consVector 0 0 0 0))@
but 'unpack' causes an additional delay.
Thus @unpack (id :: T (Vector D4 Float) (Vector D4 Float))@ may do,
what you want.
-}
delay1 ::
   (Marshal.C a, Tuple.ValueOf a ~ al) =>
   Param.T p a -> T p al al
delay1 initial = loop initial (arr swap)


{- |
Delay by a variable amount of samples.
The momentum delay must be between @0@ and @maxTime@, inclusively.
-}
delayControlled ::
   (Marshal.C a, Tuple.ValueOf a ~ al) =>
   Param.T p a -> Param.T p Int -> T p (Value Word, al) al
delayControlled initial maxTime =
   zipWithSimple RingBuffer.index
   <<<
   second (RingBuffer.track initial maxTime)

{- |
Delay by a variable fractional amount of samples.
Non-integer delays are achieved by linear interpolation.
The momentum delay must be between @0@ and @maxTime@, inclusively.
-}
delayControlledInterpolated ::
   (Interpolation.C nodes,
    Marshal.C vh, Tuple.ValueOf vh ~ v,
    IsFloating a, LLVM.ShapeOf a ~ LLVM.ScalarShape) =>
   (forall r. Interpolation.T r nodes (Value a) v) ->
   Param.T p vh -> Param.T p Int -> T p (Value a, v) v
delayControlledInterpolated ip initial maxTime =
   let margin = Interpolation.toMargin ip
   in  zipWithSimple
          (\del buf -> do
             let offset =
                    A.fromInteger' $ fromIntegral $
                    Interpolation.marginOffset margin
             n <- A.max offset =<< LLVM.fptoint del
             k <- A.sub del =<< LLVM.inttofp n
             m <- A.sub n offset
             ip k =<<
                Interpolation.indexNodes (flip RingBuffer.index buf) A.one m)
       <<<
       second
          (RingBuffer.track initial
              (fmap (Interpolation.marginNumber margin +) maxTime))


differentiate ::
   (A.Additive al, Marshal.C a, Tuple.ValueOf a ~ al) =>
   Param.T p a -> T p al al
differentiate initial =
   Cat.id - delay1 initial

{- |
Delay time must be greater than zero!
-}
comb ::
   (A.PseudoRing al, Marshal.C a, Tuple.ValueOf a ~ al) =>
   Param.T p a -> Param.T p Int ->
   T p al al
comb gain time =
   loopZero (mix >>> (Cat.id &&&
      (delayZero (time-1) >>> amplify gain)))

combStereo ::
   (A.PseudoRing al, Marshal.C a, Tuple.ValueOf a ~ al) =>
   Param.T p a -> Param.T p Int ->
   T p (Stereo.T al) (Stereo.T al)
combStereo gain time =
   loopZero (mix >>> (Cat.id &&&
      (delayZero (time-1) >>> amplifyStereo gain)))

{- |
Example: apply a stereo reverb to a mono sound.

> traverse
>    (\seed -> reverbSimple (Random.mkStdGen seed) 16 (0.92,0.98) (200,1000))
>    (Stereo.cons 42 23)

There is a serious problem:
The parameters are not of type 'Param.T',
thus they cannot depend e.g. on a dynamic sample rate as required by JACK.
-}
reverbSimple ::
   (Random a, IsArithmetic a, SoV.RationalConstant a,
    Marshal.C a, Tuple.ValueOf a ~ Value a,
    RandomGen g) =>
   g -> Int -> (a,a) -> (Int,Int) ->
   T p (Value a) (Value a)
reverbSimple rnd num gainRange timeRange =
   mapSimple (A.mul (A.fromRational' $ recip $ fromIntegral num)) <<<
   (foldl (+) zero $
    List.map (\(g,t) -> comb $# g $# t) $
    reverbParams rnd num gainRange timeRange)

reverb ::
   (Random a, Marshal.C a, Tuple.ValueOf a ~ Value a,
    SoV.PseudoModule a, SoV.Scalar a ~ s,
    IsFloating s, SoV.IntegerConstant s, LLVM.IsPrimitive s,
    RandomGen g) =>
   Param.T p g -> Param.T p Int -> Param.T p (a,a) -> Param.T p (Int,Int) ->
   T p (Value a) (Value a)
reverb rnd num gainRange timeRange =
   map
      (\n x -> flip A.scale x =<< A.fdiv A.one =<< LLVM.inttofp n)
      (Param.wordInt num)
   <<<
   replicateControlledParam
      (\_p p -> first (comb (fmap fst p) (fmap snd p)) >>> mix)
      (pure reverbParams <*> rnd <*> num <*> gainRange <*> timeRange)
   <<^
   (\a -> (a,a))


{- |
Like 'skip' but does not require @Memory@ constraint on the result type.
This way it can be used on a stream of ring buffer states.
The downside is that the result is recomputed (from the previous state)
at every step.

Warning:
This process is actually unsafe.
It fails on signal generators that use mutable variables,
like Signal.storableVectorLazy.
-}
_skipVolatile ::
   (Causal.C process, CausalClass.SignalOf process ~ signal) =>
   signal v -> process (Value Word) v
_skipVolatile =
   CausalPriv.alterSignal
      (\(SigPriv.Core next start stop) -> CausalPriv.Core
         (\context n state0 -> do
            y <- fmap fst $ next context state0
            state1 <-
               MaybeCont.fromMaybe $ fmap snd $
               MaybeCont.fixedLengthLoop n state0 $
               fmap snd . next context
            return (y, state1))
         start
         stop)


{- |
> frequencyModulationLinear signal

is a causal process mapping from a shrinking factor
to the modulated input @signal@.
Similar to 'Sig.interpolateConstant'
but the factor is reciprocal and controllable
and we use linear interpolation.
The shrinking factor must be non-negative.
-}
frequencyModulationLinear ::
   (SoV.IntegerConstant a, IsFloating a,
    LLVM.CmpRet a, LLVM.CmpResult a ~ Bool, IsSized a) =>
   SigP.T p (Value a) -> T p (Value a) (Value a)
frequencyModulationLinear =
   Causal.frequencyModulation Interpolation.linear . SigP.adjacentNodes02


type Exporter f = f -> IO (FunPtr f)

foreign import ccall safe "wrapper" callbackCreate ::
   Exporter (LLVM.Ptr lparam -> LLVM.Ptr init -> IO (StablePtr ioContext))

foreign import ccall safe "wrapper" callbackDelete ::
   Exporter (StablePtr ioContext -> IO ())

stopAndDelete ::
   LLVM.Function (StablePtr ioContext -> IO ()) ->
   (context -> state -> CodeGenFunction r ()) ->
   Maybe.T ((context, state), Value (StablePtr ioContext)) ->
   CodeGenFunction r ()
stopAndDelete eraser stop mcsio =
   Maybe.for mcsio $ \(cs, io) -> do
      uncurry stop cs
      void $ LLVM.call eraser io


{- |
@trigger fill signal@ send @signal@ to the output
and restart it whenever the Boolean process input is 'True'.
Before the first occurrence of 'True'
and between instances of the signal the output is filled with 'Maybe.nothing'.

Every restart of the signal needs a call into Haskell code.
Thus it is certainly a good idea, not to trigger the signal too frequently.
-}
{-
Are exceptions handled correctly?
-}
trigger ::
   (Marshal.C a, Tuple.ValueOf a ~ al, Tuple.Undefined b, Tuple.Phi b) =>
   (forall q. Param.T q p -> Param.T q a -> SigP.T q b) ->
   T p (Maybe.T al) (Maybe.T b)
trigger sig =
   triggerAux (sig (arr fst) (arr snd))

triggerAux ::
   (Marshal.C a, Tuple.ValueOf a ~ al, Tuple.Undefined b, Tuple.Phi b) =>
   SigP.T (p,a) b ->
   T p (Maybe.T al) (Maybe.T b)
triggerAux
   (SigPPriv.Cons next alloca start stop createIOContext deleteIOContext) = Cons
   (\(creator, eraser) (local, (param, xPtr)) mx mcsio0 -> MaybeCont.lift $ do
      mcsio1 <-
         Maybe.run mx
            (return mcsio0)
            (\x ->
               stopAndDelete eraser stop mcsio0
               >>
               do
                  Memory.store x xPtr
                  io <- LLVM.call creator param xPtr
                  cs <- start =<< Memory.load param
                  return $ Maybe.just (cs, io))
      mcasio2 <-
         Maybe.run mcsio1 (return Maybe.nothing) $ \((c1,s1), io1) ->
            MaybeCont.toMaybe $ fmap (flip (,) io1 . (,) c1) $ next c1 local s1
      return (fmap (fst.snd.fst) mcasio2, fmap (mapFst (mapSnd snd)) mcasio2))
   (liftA2 (,) alloca $ liftA2 (,) LLVM.alloca LLVM.alloca)
   (\ce -> return (ce, Maybe.nothing))
   (\(_creator, eraser) mcsio -> stopAndDelete eraser stop mcsio)
   (\p -> do
      creator <- callbackCreate $ \paramPtr xPtr -> do
         x <- Marshal.peek xPtr
         (context, param) <- createIOContext (p,x)
         Marshal.poke paramPtr param
         newStablePtr context
      eraser <- callbackDelete $ \contextPtr -> do
         deleteIOContext =<< deRefStablePtr contextPtr
         freeStablePtr contextPtr
      let ce = (creator, eraser)
      return (ce, ce))
   (\(creator, eraser) ->
      freeHaskellFunPtr creator >>
      freeHaskellFunPtr eraser)


{- |
On each restart the parameters of type @b@ are passed to the signal.

triggerParam ::
   (Tuple.Value a, Tuple.ValueOf a ~ al,
    Tuple.Value b, Tuple.ValueOf b ~ bl) =>
   Param.T p a ->
   (Param.T p b -> SigP.T p a) ->
   T p (Value Bool, bl) al
triggerParam fill sig =
-}



foreign import ccall safe "dynamic" derefFillPtr ::
   Exec.Importer (LLVM.Ptr param -> Word -> Ptr a -> Ptr b -> IO Word)

runStorable ::
   (Storable.C a, Tuple.ValueOf a ~ valueA,
    Storable.C b, Tuple.ValueOf b ~ valueB) =>
   T p valueA valueB ->
   IO (p -> SV.Vector a -> SV.Vector b)
runStorable (Cons next alloca start stop createIOContext deleteIOContext) = do
   fill <-
      Exec.compile "process" $
      Exec.createFunction derefFillPtr "fillprocessblock" $
      \paramPtr size alPtr blPtr -> do
         param <- Memory.load paramPtr
         (c,s) <- start param
         local <- alloca
         (pos,msExit) <-
            Storable.arrayLoopMaybeCont2 size alPtr blPtr s $
               \ aPtri bPtri s0 -> do
            a <- MaybeCont.lift $ Storable.load aPtri
            (b,s1) <- next c local a s0
            MaybeCont.lift $ Storable.store b bPtri
            return s1
         Maybe.for msExit $ stop c
         ret pos

   return $ \p as ->
      Unsafe.performIO $
      bracket (createIOContext p) (deleteIOContext . fst) $
      \ (_,params) ->
         SVB.withStartPtr as $ \ aPtr len ->
         SVB.createAndTrim len $ \ bPtr ->
         Marshal.with params $ \paramPtr ->
         fmap fromIntegral $
            fill paramPtr (fromIntegral len) aPtr bPtr

applyStorable ::
   (Storable.C a, Tuple.ValueOf a ~ valueA,
    Storable.C b, Tuple.ValueOf b ~ valueB) =>
   T p valueA valueB ->
   p -> SV.Vector a -> SV.Vector b
applyStorable gen = Unsafe.performIO $ runStorable gen



foreign import ccall safe "dynamic" derefChunkPtr ::
   Exec.Importer
      (LLVM.Ptr contextStateStruct -> Word -> Ptr a -> Ptr b -> IO Word)


compileChunky ::
   (Storable.C a, Tuple.ValueOf a ~ valueA,
    Storable.C b, Tuple.ValueOf b ~ valueB,
    Memory.C parameters, Memory.Struct parameters ~ paramStruct,
    Memory.C context, Memory.C state,
    Memory.Struct (context, Maybe.T state) ~ contextStateStruct) =>
   (forall r z.
    (Tuple.Phi z) =>
    context -> local ->
    valueA -> state ->
    MaybeCont.T r z (valueB, state)) ->
   (forall r. CodeGenFunction r local) ->
   (forall r.
    parameters ->
    CodeGenFunction r (context, state)) ->
   (forall r.
    context -> state ->
    CodeGenFunction r ()) ->
   IO (LLVM.Ptr paramStruct -> IO (LLVM.Ptr contextStateStruct),
       Exec.Finalizer contextStateStruct,
       LLVM.Ptr contextStateStruct -> Word -> Ptr a -> Ptr b -> IO Word)
compileChunky next alloca start stop =
   Exec.compile "process-chunky" $
      liftA3 (,,)
         (Exec.createFunction derefStartPtr "startprocess" $
          \paramPtr -> do
             pptr <- LLVM.malloc
             flip Memory.store pptr . mapSnd Maybe.just
                =<< start =<< Memory.load paramPtr
             ret pptr)
         (Exec.createFinalizer derefStopPtr "stopprocess" $
          \ contextStatePtr -> do
             (c,ms) <- Memory.load contextStatePtr
             Maybe.for ms $ stop c
             LLVM.free contextStatePtr
             ret ())
         (Exec.createFunction derefChunkPtr "fillprocess" $
          \ contextStatePtr loopLen aPtr bPtr -> do
             (param, msInit) <- Memory.load contextStatePtr
             local <- alloca
             (pos,msExit) <-
                Maybe.run msInit (return (A.zero, Maybe.nothing)) $ \sInit ->
                   Storable.arrayLoopMaybeCont2 loopLen aPtr bPtr sInit $
                   \ aPtri bPtri s0 -> do
                a <- MaybeCont.lift $ Storable.load aPtri
                (b,s1) <- next param local a s0
                MaybeCont.lift $ Storable.store b bPtri
                return s1
             sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ())
             Memory.store msExit sptr
             ret pos)


foreign import ccall safe "dynamic" derefStartPtr ::
   Exec.Importer (LLVM.Ptr paramStruct -> IO (LLVM.Ptr contextStateStruct))

foreign import ccall safe "dynamic" derefStopPtr ::
   Exec.Importer (LLVM.Ptr contextStateStruct -> IO ())

foreign import ccall safe "dynamic" derefChunkPluggedPtr ::
   Exec.Importer
      (LLVM.Ptr contextStateStruct -> Word ->
       LLVM.Ptr inp -> LLVM.Ptr out -> IO Word)

compilePlugged ::
   (Memory.C parameters, Memory.Struct parameters ~ paramStruct,
    Memory.C context, Memory.C state,
    Memory.Struct (context, Maybe.T state) ~ contextStateStruct,
    Tuple.Undefined stateIn,  Tuple.Phi stateIn,
    Tuple.Undefined stateOut, Tuple.Phi stateOut,
    Memory.C paramValueIn,  Memory.Struct paramValueIn  ~ paramStructIn,
    Memory.C paramValueOut, Memory.Struct paramValueOut ~ paramStructOut) =>
   (forall r.
    paramValueIn ->
    stateIn -> LLVM.CodeGenFunction r (valueA, stateIn)) ->
   (forall r.
    paramValueIn ->
    LLVM.CodeGenFunction r stateIn) ->
   (forall r z.
    (Tuple.Phi z) =>
    context -> local ->
    valueA -> state ->
    MaybeCont.T r z (valueB, state)) ->
   (forall r. CodeGenFunction r local) ->
   (forall r.
    parameters ->
    CodeGenFunction r (context, state)) ->
   (forall r.
    context -> state ->
    CodeGenFunction r ()) ->
   (forall r.
    paramValueOut ->
    valueB -> stateOut -> LLVM.CodeGenFunction r stateOut) ->
   (forall r.
    paramValueOut ->
    LLVM.CodeGenFunction r stateOut) ->
   IO (LLVM.Ptr paramStruct -> IO (LLVM.Ptr contextStateStruct),
       LLVM.Ptr contextStateStruct -> IO (),
       LLVM.Ptr contextStateStruct -> Word ->
         LLVM.Ptr paramStructIn -> LLVM.Ptr paramStructOut -> IO Word)
compilePlugged nextIn startIn next alloca start stop nextOut startOut =
   Exec.compile "process-plugged" $
      liftA3 (,,)
         (Exec.createFunction derefStartPtr "startprocess" $
          \paramPtr -> do
             pptr <- LLVM.malloc
             flip Memory.store pptr . mapSnd Maybe.just
                =<< start =<< Memory.load paramPtr
             ret pptr)
         (Exec.createFunction derefStopPtr "stopprocess" $
          \ contextStatePtr -> do
             (c,ms) <- Memory.load contextStatePtr
             Maybe.for ms $ stop c
             LLVM.free contextStatePtr
             ret ())
         (Exec.createFunction derefChunkPluggedPtr "fillprocess" $
          \ contextStatePtr loopLen inPtr outPtr -> do
             (param, msInit) <- Memory.load contextStatePtr
             inParam  <- Memory.load inPtr
             outParam <- Memory.load outPtr
             inInit  <- startIn  inParam
             outInit <- startOut outParam
             local <- alloca
             (pos,msExit) <-
                Maybe.run msInit (return (A.zero, Maybe.nothing)) $ \sInit ->
                   MaybeCont.fixedLengthLoop loopLen (inInit, sInit, outInit) $
                      \ (in0,s0,out0) -> do
                (a,in1) <- MaybeCont.lift $ nextIn inParam in0
                (b,s1) <- next param local a s0
                out1 <- MaybeCont.lift $ nextOut outParam b out0
                return (in1, s1, out1)
             sptr <- LLVM.getElementPtr0 contextStatePtr (TypeNum.d1, ())
             Memory.store (fmap snd3 msExit) sptr
             ret pos)


runStorableChunky ::
   (Storable.C a, Tuple.ValueOf a ~ valueA,
    Storable.C b, Tuple.ValueOf b ~ valueB) =>
   T p valueA valueB ->
   IO (p -> SVL.Vector a -> SVL.Vector b)
runStorableChunky proc =
   fmap ($ const SVL.empty) $
   runStorableChunkyCont proc

{- |
This function should be used
instead of @StorableVector.Lazy.Pattern.splitAt@ and subsequent @append@,
because it does not have the risk of a memory leak.
-}
runStorableChunkyCont ::
   (Storable.C a, Tuple.ValueOf a ~ valueA,
    Storable.C b, Tuple.ValueOf b ~ valueB) =>
   T p valueA valueB ->
   IO ((SVL.Vector a -> SVL.Vector b) ->
       p -> SVL.Vector a -> SVL.Vector b)
runStorableChunkyCont
      (Cons next alloca start stop createIOContext deleteIOContext) = do
   (startFunc, stopFunc, fill) <- compileChunky next alloca start stop
   return $
      \ procRest p sig ->
      SVL.fromChunks $ Unsafe.performIO $ do
         (ioContext, param) <- createIOContext p

         when False $
            DebugCnt.next DebugSt.dumpCounter >>=
            DebugSt.dump "param" param

         statePtr <- ForeignPtr.newParam stopFunc startFunc param
         ioContextPtr <- ForeignPtr.newAux (deleteIOContext ioContext)

         let go xt =
               Unsafe.interleaveIO $
               case xt of
                  [] -> return []
                  x:xs -> SVB.withStartPtr x $ \aPtr size -> do
                     v <-
                        ForeignPtr.with statePtr $ \sptr ->
                        SVB.createAndTrim size $
                        fmap fromIntegral .
                        fill sptr (fromIntegral size) aPtr
                     touchForeignPtr ioContextPtr
                     (if SV.length v > 0
                        then fmap (v:)
                        else id) $
                        (if SV.length v < size
                           then return $ SVL.chunks $
                                procRest $ SVL.fromChunks $
                                SV.drop (SV.length v) x : xs
                           else go xs)
         go (SVL.chunks sig)

applyStorableChunky ::
   (Storable.C a, Tuple.ValueOf a ~ valueA,
    Storable.C b, Tuple.ValueOf b ~ valueB) =>
   T p valueA valueB ->
   p -> SVL.Vector a -> SVL.Vector b
applyStorableChunky gen =
   Unsafe.performIO (runStorableChunky gen)


{-
I liked to write something with signature

> import qualified Synthesizer.Causal.Process as Causal
>
> liftStorableChunk ::
>    T p valueA valueB ->
>    IO (p -> Causal.T (SV.Vector a) (SV.Vector b))

but it does not quite work this way.
@Causal.T@ from @synthesizer-core@ uses an immutable state internally,
whereas @T@ uses mutable states.
In principle the immutable state of @Causal.T@
could be used for breaking the processing of a stream
and continue it on two different streams in parallel.
I have no function that makes use of this feature,
and thus an @ST@ monad might be a way out.

With this function we can convert an LLVM causal process to an causal IO arrow.
We also need the plugs in order
to read and write LLVM values from and to Haskell data chunks.

In a second step we could convert this to a processor of lazy lists,
and thus to a processor of chunky storable vectors.
-}
processIOCore ::
   (Cut.Read a) =>
   PIn.T a b ->
   T p b c ->
   POut.T c d ->
   IO (p -> PIO.T a d)
processIOCore
      (PIn.Cons nextIn startIn createIn deleteIn)
      (Cons next alloca start stop createIOContext deleteIOContext)
      (POut.Cons nextOut startOut createOut deleteOut) = do
   (startFunc, stopFunc, fill) <-
      compilePlugged nextIn startIn next alloca start stop nextOut startOut
   return $ \p -> PIO.Cons
      (\a s@(_, paramPtr) -> do
         let maximumSize = Cut.length a
         (contextIn, paramIn)  <- createIn a
         (contextOut,paramOut) <- createOut maximumSize
         actualSize <-
            Marshal.with paramIn $ \inptr ->
            Marshal.with paramOut $ \outptr ->
            fill paramPtr (fromIntegral maximumSize) inptr outptr
         deleteIn contextIn
         b <- deleteOut (fromIntegral actualSize) contextOut
         return (b, s))
      (do
         (ioContext, param) <- createIOContext p

         when False $
            DebugCnt.next DebugSt.dumpCounter >>=
            DebugSt.dump "param" param
         contextStatePtr <- Marshal.with param startFunc

         return (ioContext, contextStatePtr))
      (\(ioContext, contextStatePtr) -> do
         stopFunc contextStatePtr
         deleteIOContext ioContext)

processIO ::
   (Cut.Read a, PIn.Default a, POut.Default d) =>
   T p (PIn.Element a) (POut.Element d) ->
   IO (p -> PIO.T a d)
processIO proc =
   processIOCore PIn.deflt proc POut.deflt