{-# LANGUAGE RebindableSyntax #-}
module Synthesizer.ALSA.EventList where

import qualified Sound.ALSA.Sequencer.Address as Addr
import qualified Sound.ALSA.Sequencer.Client as Client
import qualified Sound.ALSA.Sequencer.Port as Port
import qualified Sound.ALSA.Sequencer.Port.InfoMonad as PortInfo
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Sound.ALSA.Sequencer.Queue as Queue
import qualified Sound.ALSA.Sequencer.Time as Time
import qualified Sound.ALSA.Sequencer.RealTime as RealTime
import qualified Sound.ALSA.Sequencer as SndSeq
import qualified Sound.ALSA.Exception as AlsaExc

import qualified Data.EventList.Relative.TimeBody  as EventList
import qualified Data.EventList.Relative.TimeTime  as EventListTT
import qualified Data.EventList.Relative.MixedBody as EventListMB
import qualified Data.EventList.Relative.TimeMixed as EventListTM
import qualified Data.EventList.Absolute.TimeBody  as AbsEventList

import Sound.MIDI.ALSA.Construct ()
import Sound.MIDI.ALSA.Check ()
import Sound.MIDI.ALSA.Query ()

import System.IO.Unsafe (unsafeInterleaveIO, )
import Control.Concurrent (threadDelay)
import System.Time (ClockTime(TOD), getClockTime, )

import Control.Monad.Trans.State
          (evalState, modify, get, )

import qualified Numeric.NonNegative.Class   as NonNeg
import qualified Numeric.NonNegative.Wrapper as NonNegW

import qualified Algebra.RealField  as RealField
import qualified Algebra.Field      as Field

import Data.Tuple.HT (mapPair, mapSnd, )
import Data.Ord.HT (limit, )
import Control.Monad (liftM, liftM2, )

import NumericPrelude.Numeric
import NumericPrelude.Base


{- |
The @time@ type needs high precision,
so you will certainly have to instantiate it with 'Double'.
'Float' has definitely not enough bits.
-}
getTimeSeconds :: Field.C time => IO time
getTimeSeconds :: IO time
getTimeSeconds =
   (ClockTime -> time) -> IO ClockTime -> IO time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ClockTime -> time
forall time. C time => ClockTime -> time
clockTimeToSeconds IO ClockTime
getClockTime

clockTimeToSeconds :: Field.C time => ClockTime -> time
clockTimeToSeconds :: ClockTime -> time
clockTimeToSeconds (TOD Integer
secs Integer
picos) =
   Integer -> time
forall a. C a => Integer -> a
fromInteger Integer
secs time -> time -> time
forall a. C a => a -> a -> a
+ Integer -> time
forall a. C a => Integer -> a
fromInteger Integer
picos time -> time -> time
forall a. C a => a -> a -> a
* time
1e-12

wait :: RealField.C time => time -> IO ()
wait :: time -> IO ()
wait time
t1 =
   do time
t0 <- IO time
forall time. C time => IO time
getTimeSeconds
      Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ time -> Int
forall a b. (C a, C b) => a -> b
floor (time -> Int) -> time -> Int
forall a b. (a -> b) -> a -> b
$ time
1e6time -> time -> time
forall a. C a => a -> a -> a
*(time
t1time -> time -> time
forall a. C a => a -> a -> a
-time
t0)


{-
We cannot easily turn this into a custom type,
since we need Maybe Event.T sometimes.
-}
type StampedEvent time = (time, Event.T)


{- |
only use it for non-blocking sequencers

We ignore ALSA time stamps and use the time of fetching the event,
because I don't know whether the ALSA time stamps are in sync with getClockTime.
-}
getStampedEvent ::
   (Field.C time, SndSeq.AllowInput mode) =>
   SndSeq.T mode -> IO (StampedEvent time)
getStampedEvent :: T mode -> IO (StampedEvent time)
getStampedEvent T mode
h =
   (time -> T -> StampedEvent time)
-> IO time -> IO T -> IO (StampedEvent time)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,)
      IO time
forall time. C time => IO time
getTimeSeconds
      (T mode -> IO T
forall mode. AllowInput mode => T mode -> IO T
Event.input T mode
h)

{- | only use it for non-blocking sequencers -}
getWaitingStampedEvents ::
   (Field.C time, SndSeq.AllowInput mode) =>
   SndSeq.T mode -> IO [StampedEvent time]
getWaitingStampedEvents :: T mode -> IO [StampedEvent time]
getWaitingStampedEvents T mode
h =
   let loop :: IO [StampedEvent time]
loop =
          IO [StampedEvent time]
-> (T -> IO [StampedEvent time]) -> IO [StampedEvent time]
forall a. IO a -> (T -> IO a) -> IO a
AlsaExc.catch
             ((StampedEvent time -> [StampedEvent time] -> [StampedEvent time])
-> IO (StampedEvent time)
-> IO [StampedEvent time]
-> IO [StampedEvent time]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:) (T mode -> IO (StampedEvent time)
forall time mode.
(C time, AllowInput mode) =>
T mode -> IO (StampedEvent time)
getStampedEvent T mode
h) IO [StampedEvent time]
loop)
             (IO [StampedEvent time] -> T -> IO [StampedEvent time]
forall a b. a -> b -> a
const (IO [StampedEvent time] -> T -> IO [StampedEvent time])
-> IO [StampedEvent time] -> T -> IO [StampedEvent time]
forall a b. (a -> b) -> a -> b
$ [StampedEvent time] -> IO [StampedEvent time]
forall (m :: * -> *) a. Monad m => a -> m a
return [])
   in  IO [StampedEvent time]
loop

{- |
RealTime.toFractional for NumericPrelude.
-}
realTimeToField :: (Field.C a) => RealTime.T -> a
realTimeToField :: T -> a
realTimeToField (RealTime.Cons Word32
s Word32
n) =
   Word32 -> a
forall a b. (C a, C b) => a -> b
fromIntegral Word32
s a -> a -> a
forall a. C a => a -> a -> a
+ Word32 -> a
forall a b. (C a, C b) => a -> b
fromIntegral Word32
n a -> a -> a
forall a. C a => a -> a -> a
/ (a
10a -> Integer -> a
forall a. C a => a -> Integer -> a
^Integer
9)

addStamp ::
   (RealField.C time) =>
   Event.T -> StampedEvent time
addStamp :: T -> StampedEvent time
addStamp T
ev =
   (case T -> T
Event.time T
ev of
      Time.Cons Mode
Time.Absolute (Time.Real T
t) -> T -> time
forall a. C a => T -> a
realTimeToField T
t
      T
_ -> [Char] -> time
forall a. HasCallStack => [Char] -> a
error [Char]
"unsupported time stamp type",
    T
ev)

{- | only use it for blocking sequencers -}
getStampedEventsUntilTime ::
   (RealField.C time,
    SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>
   SndSeq.T mode ->
   Queue.T -> Port.T -> time ->
   IO [StampedEvent time]
getStampedEventsUntilTime :: T mode -> T -> T -> time -> IO [StampedEvent time]
getStampedEventsUntilTime T mode
h T
q T
p time
t =
   ([T] -> [StampedEvent time]) -> IO [T] -> IO [StampedEvent time]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((T -> StampedEvent time) -> [T] -> [StampedEvent time]
forall a b. (a -> b) -> [a] -> [b]
map T -> StampedEvent time
forall time. C time => T -> StampedEvent time
addStamp) (IO [T] -> IO [StampedEvent time])
-> IO [T] -> IO [StampedEvent time]
forall a b. (a -> b) -> a -> b
$ T mode -> T -> T -> time -> IO [T]
forall time mode.
(C time, AllowInput mode, AllowOutput mode) =>
T mode -> T -> T -> time -> IO [T]
getEventsUntilTime T mode
h T
q T
p time
t


{- |
The client id may differ from the receiving sequencer.
I do not know, whether there are circumstances, where this is useful.
-}
getEventsUntilEcho ::
   (SndSeq.AllowInput mode) =>
   Client.T -> SndSeq.T mode -> IO [Event.T]
getEventsUntilEcho :: T -> T mode -> IO [T]
getEventsUntilEcho T
c T mode
h =
   let loop :: IO [T]
loop = do
          T
ev <- T mode -> IO T
forall mode. AllowInput mode => T mode -> IO T
Event.input T mode
h
          let abort :: Bool
abort =
                 case T -> Data
Event.body T
ev of
                    Event.CustomEv CustomEv
Event.Echo Custom
_ ->
                       T
c T -> T -> Bool
forall a. Eq a => a -> a -> Bool
== T -> T
Addr.client (T -> T
Event.source T
ev)
                    Data
_ -> Bool
False
          if Bool
abort
            then [T] -> IO [T]
forall (m :: * -> *) a. Monad m => a -> m a
return []
            else ([T] -> [T]) -> IO [T] -> IO [T]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (T
evT -> [T] -> [T]
forall a. a -> [a] -> [a]
:) IO [T]
loop
   in  IO [T]
loop

{- |
Get events until a certain point in time.
It sends itself an Echo event in order to measure time.
-}
getEventsUntilTime ::
   (RealField.C time,
    SndSeq.AllowInput mode, SndSeq.AllowOutput mode) =>
   SndSeq.T mode ->
   Queue.T -> Port.T -> time ->
   IO [Event.T]
getEventsUntilTime :: T mode -> T -> T -> time -> IO [T]
getEventsUntilTime T mode
h T
q T
p time
t = do
   T
c <- T mode -> IO T
forall mode. T mode -> IO T
Client.getId T mode
h
   Word
_ <- T mode -> T -> IO Word
forall mode. AllowOutput mode => T mode -> T -> IO Word
Event.output T mode
h (T -> IO Word) -> T -> IO Word
forall a b. (a -> b) -> a -> b
$
           T -> T -> T -> time -> Custom -> T
forall time. C time => T -> T -> T -> time -> Custom -> T
makeEcho T
c T
q T
p time
t (Word32 -> Word32 -> Word32 -> Custom
Event.Custom Word32
0 Word32
0 Word32
0)
   Word
_ <- T mode -> IO Word
forall mode. AllowOutput mode => T mode -> IO Word
Event.drainOutput T mode
h
   T -> T mode -> IO [T]
forall mode. AllowInput mode => T -> T mode -> IO [T]
getEventsUntilEcho T
c T mode
h


getWaitingEvents ::
   (SndSeq.AllowInput mode) =>
   SndSeq.T mode -> IO [Event.T]
getWaitingEvents :: T mode -> IO [T]
getWaitingEvents T mode
h =
   let loop :: IO [T]
loop =
          IO [T] -> (T -> IO [T]) -> IO [T]
forall a. IO a -> (T -> IO a) -> IO a
AlsaExc.catch
             ((T -> [T] -> [T]) -> IO T -> IO [T] -> IO [T]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:) (T mode -> IO T
forall mode. AllowInput mode => T mode -> IO T
Event.input T mode
h) IO [T]
loop)
             (IO [T] -> T -> IO [T]
forall a b. a -> b -> a
const (IO [T] -> T -> IO [T]) -> IO [T] -> T -> IO [T]
forall a b. (a -> b) -> a -> b
$ [T] -> IO [T]
forall (m :: * -> *) a. Monad m => a -> m a
return [])
   in  IO [T]
loop



type StrictTime = NonNegW.Integer
newtype ClientName = ClientName String
   deriving (Int -> ClientName -> ShowS
[ClientName] -> ShowS
ClientName -> [Char]
(Int -> ClientName -> ShowS)
-> (ClientName -> [Char])
-> ([ClientName] -> ShowS)
-> Show ClientName
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ClientName] -> ShowS
$cshowList :: [ClientName] -> ShowS
show :: ClientName -> [Char]
$cshow :: ClientName -> [Char]
showsPrec :: Int -> ClientName -> ShowS
$cshowsPrec :: Int -> ClientName -> ShowS
Show)

{-
ghc -i:src -e 'withMIDIEvents 44100 print' src/Synthesizer/Storable/ALSA/MIDI.hs
-}
{-
Maybe it is better to not use type variable for sample rate,
because ALSA supports only integers,
and if ALSA sample rate and sample rate do not match due to rounding errors,
then play and event fetching get out of sync over the time.
-}
withMIDIEvents :: (RealField.C time) =>
   ClientName -> time -> time ->
   (EventList.T StrictTime [Event.T] -> IO a) -> IO a
withMIDIEvents :: ClientName -> time -> time -> (T StrictTime [T] -> IO a) -> IO a
withMIDIEvents =
   ClientName -> time -> time -> (T StrictTime [T] -> IO a) -> IO a
forall time a.
C time =>
ClientName -> time -> time -> (T StrictTime [T] -> IO a) -> IO a
withMIDIEventsBlockEcho


{-
as a quick hack, we neglect the ALSA time stamp and use getTime or so
-}
withMIDIEventsNonblockWaitGrouped :: (RealField.C time) =>
   ClientName -> time -> time ->
   (EventList.T StrictTime [Event.T] -> IO a) -> IO a
withMIDIEventsNonblockWaitGrouped :: ClientName -> time -> time -> (T StrictTime [T] -> IO a) -> IO a
withMIDIEventsNonblockWaitGrouped ClientName
name time
beat time
rate T StrictTime [T] -> IO a
proc =
   ClientName -> BlockMode -> (T DuplexMode -> T -> IO a) -> IO a
forall t.
ClientName -> BlockMode -> (T DuplexMode -> T -> IO t) -> IO t
withInPort ClientName
name BlockMode
SndSeq.Nonblock ((T DuplexMode -> T -> IO a) -> IO a)
-> (T DuplexMode -> T -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ T DuplexMode
h T
_p ->
   do time
start <- IO time
forall time. C time => IO time
getTimeSeconds
      [(time, [T])]
l <- [IO (time, [T])] -> IO [(time, [T])]
forall a. [IO a] -> IO [a]
lazySequence ([IO (time, [T])] -> IO [(time, [T])])
-> [IO (time, [T])] -> IO [(time, [T])]
forall a b. (a -> b) -> a -> b
$
              ((time -> IO (time, [T])) -> [time] -> [IO (time, [T])])
-> [time] -> (time -> IO (time, [T])) -> [IO (time, [T])]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (time -> IO (time, [T])) -> [time] -> [IO (time, [T])]
forall a b. (a -> b) -> [a] -> [b]
map ((time -> time) -> time -> [time]
forall a. (a -> a) -> a -> [a]
iterate (time
beattime -> time -> time
forall a. C a => a -> a -> a
+) time
start) ((time -> IO (time, [T])) -> [IO (time, [T])])
-> (time -> IO (time, [T])) -> [IO (time, [T])]
forall a b. (a -> b) -> a -> b
$ \time
t ->
                 time -> IO ()
forall time. C time => time -> IO ()
wait time
t IO () -> IO (time, [T]) -> IO (time, [T])
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                 ([T] -> (time, [T])) -> IO [T] -> IO (time, [T])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
                    (\[T]
evs -> (time
t, [T]
evs))
                    (T DuplexMode -> IO [T]
forall mode. AllowInput mode => T mode -> IO [T]
getWaitingEvents T DuplexMode
h)
{-
                 liftM2 (,)
                    getTimeSeconds
                    (getWaitingEvents h)
-}
      T StrictTime [T] -> IO a
proc (T StrictTime [T] -> IO a) -> T StrictTime [T] -> IO a
forall a b. (a -> b) -> a -> b
$
         time -> T time [T] -> T StrictTime [T]
forall time a. C time => time -> T time a -> T StrictTime a
discretizeTime time
rate (T time [T] -> T StrictTime [T]) -> T time [T] -> T StrictTime [T]
forall a b. (a -> b) -> a -> b
$
         [(time, [T])] -> T time [T]
forall a b. [(a, b)] -> T a b
AbsEventList.fromPairList [(time, [T])]
l

{-
With this function latency becomes longer and longer if xruns occur,
but the latency is not just adapted,
but ones xruns occur, this implies more and more xruns.
-}
withMIDIEventsNonblockWaitDefer :: (RealField.C time) =>
   ClientName -> time -> time ->
   (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a
withMIDIEventsNonblockWaitDefer :: ClientName
-> time -> time -> (T StrictTime (Maybe T) -> IO a) -> IO a
withMIDIEventsNonblockWaitDefer ClientName
name time
beat time
rate T StrictTime (Maybe T) -> IO a
proc =
   ClientName -> BlockMode -> (T DuplexMode -> T -> IO a) -> IO a
forall t.
ClientName -> BlockMode -> (T DuplexMode -> T -> IO t) -> IO t
withInPort ClientName
name BlockMode
SndSeq.Nonblock ((T DuplexMode -> T -> IO a) -> IO a)
-> (T DuplexMode -> T -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ T DuplexMode
h T
_p ->
   do time
start <- IO time
forall time. C time => IO time
getTimeSeconds
      [[(time, Maybe T)]]
l <- [IO [(time, Maybe T)]] -> IO [[(time, Maybe T)]]
forall a. [IO a] -> IO [a]
lazySequence ([IO [(time, Maybe T)]] -> IO [[(time, Maybe T)]])
-> [IO [(time, Maybe T)]] -> IO [[(time, Maybe T)]]
forall a b. (a -> b) -> a -> b
$
              ((time -> IO [(time, Maybe T)])
 -> [time] -> [IO [(time, Maybe T)]])
-> [time]
-> (time -> IO [(time, Maybe T)])
-> [IO [(time, Maybe T)]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (time -> IO [(time, Maybe T)]) -> [time] -> [IO [(time, Maybe T)]]
forall a b. (a -> b) -> [a] -> [b]
map ((time -> time) -> time -> [time]
forall a. (a -> a) -> a -> [a]
iterate (time
beattime -> time -> time
forall a. C a => a -> a -> a
+) time
start) ((time -> IO [(time, Maybe T)]) -> [IO [(time, Maybe T)]])
-> (time -> IO [(time, Maybe T)]) -> [IO [(time, Maybe T)]]
forall a b. (a -> b) -> a -> b
$ \time
t ->
                 time -> IO ()
forall time. C time => time -> IO ()
wait time
t IO () -> IO [(time, Maybe T)] -> IO [(time, Maybe T)]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                 ([(time, T)] -> [(time, Maybe T)])
-> IO [(time, T)] -> IO [(time, Maybe T)]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
                    (\ [(time, T)]
es -> (time
t, Maybe T
forall a. Maybe a
Nothing) (time, Maybe T) -> [(time, Maybe T)] -> [(time, Maybe T)]
forall a. a -> [a] -> [a]
: ((time, T) -> (time, Maybe T)) -> [(time, T)] -> [(time, Maybe T)]
forall a b. (a -> b) -> [a] -> [b]
map ((T -> Maybe T) -> (time, T) -> (time, Maybe T)
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd T -> Maybe T
forall a. a -> Maybe a
Just) [(time, T)]
es)
                    (T DuplexMode -> IO [(time, T)]
forall time mode.
(C time, AllowInput mode) =>
T mode -> IO [StampedEvent time]
getWaitingStampedEvents T DuplexMode
h)
      T StrictTime (Maybe T) -> IO a
proc (T StrictTime (Maybe T) -> IO a) -> T StrictTime (Maybe T) -> IO a
forall a b. (a -> b) -> a -> b
$
         time -> T time (Maybe T) -> T StrictTime (Maybe T)
forall time a. C time => time -> T time a -> T StrictTime a
discretizeTime time
rate (T time (Maybe T) -> T StrictTime (Maybe T))
-> T time (Maybe T) -> T StrictTime (Maybe T)
forall a b. (a -> b) -> a -> b
$
         {-
         delay events that are in wrong order
         disadvantage: we cannot guarantee a beat with a minimal period
         -}
         (State time (T time (Maybe T)) -> time -> T time (Maybe T))
-> time -> State time (T time (Maybe T)) -> T time (Maybe T)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State time (T time (Maybe T)) -> time -> T time (Maybe T)
forall s a. State s a -> s -> a
evalState time
start (State time (T time (Maybe T)) -> T time (Maybe T))
-> State time (T time (Maybe T)) -> T time (Maybe T)
forall a b. (a -> b) -> a -> b
$
         (time -> StateT time Identity time)
-> T time (Maybe T) -> State time (T time (Maybe T))
forall (m :: * -> *) time0 time1 body.
Monad m =>
(time0 -> m time1) -> T time0 body -> m (T time1 body)
AbsEventList.mapTimeM (\time
t -> (time -> time) -> StateT time Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (time -> time -> time
forall a. Ord a => a -> a -> a
max time
t) StateT time Identity ()
-> StateT time Identity time -> StateT time Identity time
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT time Identity time
forall (m :: * -> *) s. Monad m => StateT s m s
get) (T time (Maybe T) -> State time (T time (Maybe T)))
-> T time (Maybe T) -> State time (T time (Maybe T))
forall a b. (a -> b) -> a -> b
$
         [(time, Maybe T)] -> T time (Maybe T)
forall a b. [(a, b)] -> T a b
AbsEventList.fromPairList ([(time, Maybe T)] -> T time (Maybe T))
-> [(time, Maybe T)] -> T time (Maybe T)
forall a b. (a -> b) -> a -> b
$ [[(time, Maybe T)]] -> [(time, Maybe T)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(time, Maybe T)]]
l

{-
We risk and endless skipping when the beat is too short.
(Or debug output slows down processing.)
-}
withMIDIEventsNonblockWaitSkip :: (RealField.C time) =>
   ClientName -> time -> time ->
   (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a
withMIDIEventsNonblockWaitSkip :: ClientName
-> time -> time -> (T StrictTime (Maybe T) -> IO a) -> IO a
withMIDIEventsNonblockWaitSkip ClientName
name time
beat time
rate T StrictTime (Maybe T) -> IO a
proc =
   ClientName -> BlockMode -> (T DuplexMode -> T -> IO a) -> IO a
forall t.
ClientName -> BlockMode -> (T DuplexMode -> T -> IO t) -> IO t
withInPort ClientName
name BlockMode
SndSeq.Nonblock ((T DuplexMode -> T -> IO a) -> IO a)
-> (T DuplexMode -> T -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ T DuplexMode
h T
_p ->
   do time
start <- IO time
forall time. C time => IO time
getTimeSeconds
      [[(time, Maybe T)]]
l <- [IO [(time, Maybe T)]] -> IO [[(time, Maybe T)]]
forall a. [IO a] -> IO [a]
lazySequence ([IO [(time, Maybe T)]] -> IO [[(time, Maybe T)]])
-> [IO [(time, Maybe T)]] -> IO [[(time, Maybe T)]]
forall a b. (a -> b) -> a -> b
$
           ((time -> IO [(time, Maybe T)])
 -> [time] -> [IO [(time, Maybe T)]])
-> [time]
-> (time -> IO [(time, Maybe T)])
-> [IO [(time, Maybe T)]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (time -> IO [(time, Maybe T)]) -> [time] -> [IO [(time, Maybe T)]]
forall a b. (a -> b) -> [a] -> [b]
map ((time -> time) -> time -> [time]
forall a. (a -> a) -> a -> [a]
iterate (time
beattime -> time -> time
forall a. C a => a -> a -> a
+) time
start) ((time -> IO [(time, Maybe T)]) -> [IO [(time, Maybe T)]])
-> (time -> IO [(time, Maybe T)]) -> [IO [(time, Maybe T)]]
forall a b. (a -> b) -> a -> b
$ \time
t ->
              do time -> IO ()
forall time. C time => time -> IO ()
wait time
t
                 time
t0 <- IO time
forall time. C time => IO time
getTimeSeconds
                 -- print (t-start,t0-start)
                 [StampedEvent time]
es <-
                    if time
t0time -> time -> Bool
forall a. Ord a => a -> a -> Bool
>=time
ttime -> time -> time
forall a. C a => a -> a -> a
+time
beat
                      then [StampedEvent time] -> IO [StampedEvent time]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                      else T DuplexMode -> IO [StampedEvent time]
forall time mode.
(C time, AllowInput mode) =>
T mode -> IO [StampedEvent time]
getWaitingStampedEvents T DuplexMode
h
                 [(time, Maybe T)] -> IO [(time, Maybe T)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(time, Maybe T)] -> IO [(time, Maybe T)])
-> [(time, Maybe T)] -> IO [(time, Maybe T)]
forall a b. (a -> b) -> a -> b
$
                    (time
t0, Maybe T
forall a. Maybe a
Nothing) (time, Maybe T) -> [(time, Maybe T)] -> [(time, Maybe T)]
forall a. a -> [a] -> [a]
:
                    (StampedEvent time -> (time, Maybe T))
-> [StampedEvent time] -> [(time, Maybe T)]
forall a b. (a -> b) -> [a] -> [b]
map ((T -> Maybe T) -> StampedEvent time -> (time, Maybe T)
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd T -> Maybe T
forall a. a -> Maybe a
Just) [StampedEvent time]
es
      T StrictTime (Maybe T) -> IO a
proc (T StrictTime (Maybe T) -> IO a) -> T StrictTime (Maybe T) -> IO a
forall a b. (a -> b) -> a -> b
$
         time -> T time (Maybe T) -> T StrictTime (Maybe T)
forall time a. C time => time -> T time a -> T StrictTime a
discretizeTime time
rate (T time (Maybe T) -> T StrictTime (Maybe T))
-> T time (Maybe T) -> T StrictTime (Maybe T)
forall a b. (a -> b) -> a -> b
$
         [(time, Maybe T)] -> T time (Maybe T)
forall a b. [(a, b)] -> T a b
AbsEventList.fromPairList ([(time, Maybe T)] -> T time (Maybe T))
-> [(time, Maybe T)] -> T time (Maybe T)
forall a b. (a -> b) -> a -> b
$ [[(time, Maybe T)]] -> [(time, Maybe T)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(time, Maybe T)]]
l

withMIDIEventsNonblockWaitMin :: (RealField.C time) =>
   ClientName -> time -> time ->
   (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a
withMIDIEventsNonblockWaitMin :: ClientName
-> time -> time -> (T StrictTime (Maybe T) -> IO a) -> IO a
withMIDIEventsNonblockWaitMin ClientName
name time
beat time
rate T StrictTime (Maybe T) -> IO a
proc =
   ClientName -> BlockMode -> (T DuplexMode -> T -> IO a) -> IO a
forall t.
ClientName -> BlockMode -> (T DuplexMode -> T -> IO t) -> IO t
withInPort ClientName
name BlockMode
SndSeq.Nonblock ((T DuplexMode -> T -> IO a) -> IO a)
-> (T DuplexMode -> T -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ T DuplexMode
h T
_p ->
   do time
start <- IO time
forall time. C time => IO time
getTimeSeconds
      [[(time, Maybe T)]]
l <- [IO [(time, Maybe T)]] -> IO [[(time, Maybe T)]]
forall a. [IO a] -> IO [a]
lazySequence ([IO [(time, Maybe T)]] -> IO [[(time, Maybe T)]])
-> [IO [(time, Maybe T)]] -> IO [[(time, Maybe T)]]
forall a b. (a -> b) -> a -> b
$
              ((time -> IO [(time, Maybe T)])
 -> [time] -> [IO [(time, Maybe T)]])
-> [time]
-> (time -> IO [(time, Maybe T)])
-> [IO [(time, Maybe T)]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (time -> IO [(time, Maybe T)]) -> [time] -> [IO [(time, Maybe T)]]
forall a b. (a -> b) -> [a] -> [b]
map ((time -> time) -> time -> [time]
forall a. (a -> a) -> a -> [a]
iterate (time
beattime -> time -> time
forall a. C a => a -> a -> a
+) time
start) ((time -> IO [(time, Maybe T)]) -> [IO [(time, Maybe T)]])
-> (time -> IO [(time, Maybe T)]) -> [IO [(time, Maybe T)]]
forall a b. (a -> b) -> a -> b
$ \time
t ->
                 time -> IO ()
forall time. C time => time -> IO ()
wait time
t IO () -> IO [(time, Maybe T)] -> IO [(time, Maybe T)]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                 ([(time, T)] -> [(time, Maybe T)])
-> IO [(time, T)] -> IO [(time, Maybe T)]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
                    (\ [(time, T)]
es ->
                       ([time] -> time
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([time] -> time) -> [time] -> time
forall a b. (a -> b) -> a -> b
$ time
t time -> [time] -> [time]
forall a. a -> [a] -> [a]
: ((time, T) -> time) -> [(time, T)] -> [time]
forall a b. (a -> b) -> [a] -> [b]
map (time, T) -> time
forall a b. (a, b) -> a
fst [(time, T)]
es, Maybe T
forall a. Maybe a
Nothing) (time, Maybe T) -> [(time, Maybe T)] -> [(time, Maybe T)]
forall a. a -> [a] -> [a]
:
                       ((time, T) -> (time, Maybe T)) -> [(time, T)] -> [(time, Maybe T)]
forall a b. (a -> b) -> [a] -> [b]
map ((T -> Maybe T) -> (time, T) -> (time, Maybe T)
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd T -> Maybe T
forall a. a -> Maybe a
Just) [(time, T)]
es)
                    (T DuplexMode -> IO [(time, T)]
forall time mode.
(C time, AllowInput mode) =>
T mode -> IO [StampedEvent time]
getWaitingStampedEvents T DuplexMode
h)
{-
      mapM_ print $ EventList.toPairList $
         discretizeTime rate $
         AbsEventList.fromPairList $ concat l
      proc undefined
-}
      T StrictTime (Maybe T) -> IO a
proc (T StrictTime (Maybe T) -> IO a) -> T StrictTime (Maybe T) -> IO a
forall a b. (a -> b) -> a -> b
$
         time -> T time (Maybe T) -> T StrictTime (Maybe T)
forall time a. C time => time -> T time a -> T StrictTime a
discretizeTime time
rate (T time (Maybe T) -> T StrictTime (Maybe T))
-> T time (Maybe T) -> T StrictTime (Maybe T)
forall a b. (a -> b) -> a -> b
$
         [(time, Maybe T)] -> T time (Maybe T)
forall a b. [(a, b)] -> T a b
AbsEventList.fromPairList ([(time, Maybe T)] -> T time (Maybe T))
-> [(time, Maybe T)] -> T time (Maybe T)
forall a b. (a -> b) -> a -> b
$ [[(time, Maybe T)]] -> [(time, Maybe T)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(time, Maybe T)]]
l

withMIDIEventsNonblockConstantPause :: (RealField.C time) =>
   ClientName -> time -> time ->
   (EventList.T StrictTime (Maybe Event.T) -> IO a) -> IO a
withMIDIEventsNonblockConstantPause :: ClientName
-> time -> time -> (T StrictTime (Maybe T) -> IO a) -> IO a
withMIDIEventsNonblockConstantPause ClientName
name time
beat time
rate T StrictTime (Maybe T) -> IO a
proc =
   ClientName -> BlockMode -> (T DuplexMode -> T -> IO a) -> IO a
forall t.
ClientName -> BlockMode -> (T DuplexMode -> T -> IO t) -> IO t
withInPort ClientName
name BlockMode
SndSeq.Nonblock ((T DuplexMode -> T -> IO a) -> IO a)
-> (T DuplexMode -> T -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ T DuplexMode
h T
_p ->
   do [[(time, Maybe T)]]
l <- IO [(time, Maybe T)] -> IO [[(time, Maybe T)]]
forall a. IO a -> IO [a]
ioToLazyList (IO [(time, Maybe T)] -> IO [[(time, Maybe T)]])
-> IO [(time, Maybe T)] -> IO [[(time, Maybe T)]]
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay (time -> Int
forall a b. (C a, C b) => a -> b
round (time -> Int) -> time -> Int
forall a b. (a -> b) -> a -> b
$ (time -> time -> time) -> time -> time -> time
forall a b c. (a -> b -> c) -> b -> a -> c
flip time -> time -> time
forall a. a -> a -> a
asTypeOf time
rate (time -> time) -> time -> time
forall a b. (a -> b) -> a -> b
$ time
beattime -> time -> time
forall a. C a => a -> a -> a
*time
1e6) IO () -> IO [(time, Maybe T)] -> IO [(time, Maybe T)]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              ((time, Maybe T) -> [(time, Maybe T)] -> [(time, Maybe T)])
-> IO (time, Maybe T)
-> IO [(time, Maybe T)]
-> IO [(time, Maybe T)]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:)
                 ((time -> (time, Maybe T)) -> IO time -> IO (time, Maybe T)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\time
t->(time
t,Maybe T
forall a. Maybe a
Nothing)) IO time
forall time. C time => IO time
getTimeSeconds)
                 (([(time, T)] -> [(time, Maybe T)])
-> IO [(time, T)] -> IO [(time, Maybe T)]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (((time, T) -> (time, Maybe T)) -> [(time, T)] -> [(time, Maybe T)]
forall a b. (a -> b) -> [a] -> [b]
map ((T -> Maybe T) -> (time, T) -> (time, Maybe T)
forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd T -> Maybe T
forall a. a -> Maybe a
Just)) (T DuplexMode -> IO [(time, T)]
forall time mode.
(C time, AllowInput mode) =>
T mode -> IO [StampedEvent time]
getWaitingStampedEvents T DuplexMode
h))
      T StrictTime (Maybe T) -> IO a
proc (T StrictTime (Maybe T) -> IO a) -> T StrictTime (Maybe T) -> IO a
forall a b. (a -> b) -> a -> b
$
         time -> T time (Maybe T) -> T StrictTime (Maybe T)
forall time a. C time => time -> T time a -> T StrictTime a
discretizeTime time
rate (T time (Maybe T) -> T StrictTime (Maybe T))
-> T time (Maybe T) -> T StrictTime (Maybe T)
forall a b. (a -> b) -> a -> b
$
         [(time, Maybe T)] -> T time (Maybe T)
forall a b. [(a, b)] -> T a b
AbsEventList.fromPairList ([(time, Maybe T)] -> T time (Maybe T))
-> [(time, Maybe T)] -> T time (Maybe T)
forall a b. (a -> b) -> a -> b
$ [[(time, Maybe T)]] -> [(time, Maybe T)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(time, Maybe T)]]
l

withMIDIEventsNonblockSimple :: (RealField.C time) =>
   ClientName -> time -> time ->
   (EventList.T StrictTime Event.T -> IO a) -> IO a
withMIDIEventsNonblockSimple :: ClientName -> time -> time -> (T StrictTime T -> IO a) -> IO a
withMIDIEventsNonblockSimple ClientName
name time
beat time
rate T StrictTime T -> IO a
proc =
   ClientName -> BlockMode -> (T DuplexMode -> T -> IO a) -> IO a
forall t.
ClientName -> BlockMode -> (T DuplexMode -> T -> IO t) -> IO t
withInPort ClientName
name BlockMode
SndSeq.Nonblock ((T DuplexMode -> T -> IO a) -> IO a)
-> (T DuplexMode -> T -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ T DuplexMode
h T
_p ->
   do [[StampedEvent time]]
l <- IO [StampedEvent time] -> IO [[StampedEvent time]]
forall a. IO a -> IO [a]
ioToLazyList (IO [StampedEvent time] -> IO [[StampedEvent time]])
-> IO [StampedEvent time] -> IO [[StampedEvent time]]
forall a b. (a -> b) -> a -> b
$
              Int -> IO ()
threadDelay (time -> Int
forall a b. (C a, C b) => a -> b
round (time -> Int) -> time -> Int
forall a b. (a -> b) -> a -> b
$ (time -> time -> time) -> time -> time -> time
forall a b c. (a -> b -> c) -> b -> a -> c
flip time -> time -> time
forall a. a -> a -> a
asTypeOf time
rate (time -> time) -> time -> time
forall a b. (a -> b) -> a -> b
$ time
beattime -> time -> time
forall a. C a => a -> a -> a
*time
1e6) IO () -> IO [StampedEvent time] -> IO [StampedEvent time]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
              T DuplexMode -> IO [StampedEvent time]
forall time mode.
(C time, AllowInput mode) =>
T mode -> IO [StampedEvent time]
getWaitingStampedEvents T DuplexMode
h
      T StrictTime T -> IO a
proc (T StrictTime T -> IO a) -> T StrictTime T -> IO a
forall a b. (a -> b) -> a -> b
$
         time -> T time T -> T StrictTime T
forall time a. C time => time -> T time a -> T StrictTime a
discretizeTime time
rate (T time T -> T StrictTime T) -> T time T -> T StrictTime T
forall a b. (a -> b) -> a -> b
$
         [StampedEvent time] -> T time T
forall a b. [(a, b)] -> T a b
AbsEventList.fromPairList ([StampedEvent time] -> T time T)
-> [StampedEvent time] -> T time T
forall a b. (a -> b) -> a -> b
$ [[StampedEvent time]] -> [StampedEvent time]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[StampedEvent time]]
l


setTimestamping ::
   SndSeq.T mode -> Port.T -> Queue.T -> IO ()
setTimestamping :: T mode -> T -> T -> IO ()
setTimestamping T mode
h T
p T
q =
   T mode -> T -> T () -> IO ()
forall mode a. T mode -> T -> T a -> IO a
PortInfo.modify T mode
h T
p (T () -> IO ()) -> T () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Bool -> T ()
PortInfo.setTimestamping Bool
True
      Bool -> T ()
PortInfo.setTimestampReal Bool
True
      T -> T ()
PortInfo.setTimestampQueue T
q

withMIDIEventsBlockEcho :: (RealField.C time) =>
   ClientName -> time -> time ->
   (EventList.T StrictTime [Event.T] -> IO a) -> IO a
withMIDIEventsBlockEcho :: ClientName -> time -> time -> (T StrictTime [T] -> IO a) -> IO a
withMIDIEventsBlockEcho ClientName
name time
beat time
rate T StrictTime [T] -> IO a
proc =
   ClientName -> BlockMode -> (T DuplexMode -> T -> IO a) -> IO a
forall t.
ClientName -> BlockMode -> (T DuplexMode -> T -> IO t) -> IO t
withInPort ClientName
name BlockMode
SndSeq.Block ((T DuplexMode -> T -> IO a) -> IO a)
-> (T DuplexMode -> T -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ T DuplexMode
h T
p ->
   T DuplexMode -> (T -> IO a) -> IO a
forall mode a. T mode -> (T -> IO a) -> IO a
Queue.with T DuplexMode
h ((T -> IO a) -> IO a) -> (T -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ T
q ->
   do T DuplexMode -> T -> T -> IO ()
forall mode. T mode -> T -> T -> IO ()
setTimestamping T DuplexMode
h T
p T
q
      T DuplexMode -> T -> QueueEv -> Maybe T -> IO ()
forall mode. T mode -> T -> QueueEv -> Maybe T -> IO ()
Queue.control T DuplexMode
h T
q QueueEv
Event.QueueStart Maybe T
forall a. Maybe a
Nothing
      Word
_ <- T DuplexMode -> IO Word
forall mode. AllowOutput mode => T mode -> IO Word
Event.drainOutput T DuplexMode
h

      T StrictTime [T] -> IO a
proc (T StrictTime [T] -> IO a)
-> ([[(time, [T])]] -> T StrictTime [T]) -> [[(time, [T])]] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
         time -> T time [T] -> T StrictTime [T]
forall time a. C time => time -> T time a -> T StrictTime a
discretizeTime time
rate (T time [T] -> T StrictTime [T])
-> ([[(time, [T])]] -> T time [T])
-> [[(time, [T])]]
-> T StrictTime [T]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
         [(time, [T])] -> T time [T]
forall a b. [(a, b)] -> T a b
AbsEventList.fromPairList ([(time, [T])] -> T time [T])
-> ([[(time, [T])]] -> [(time, [T])])
-> [[(time, [T])]]
-> T time [T]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
         [[(time, [T])]] -> [(time, [T])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(time, [T])]] -> IO a) -> IO [[(time, [T])]] -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
         ([IO [(time, [T])]] -> IO [[(time, [T])]]
forall a. [IO a] -> IO [a]
lazySequence ([IO [(time, [T])]] -> IO [[(time, [T])]])
-> [IO [(time, [T])]] -> IO [[(time, [T])]]
forall a b. (a -> b) -> a -> b
$
          ((time -> IO [(time, [T])]) -> [time] -> [IO [(time, [T])]])
-> [time] -> (time -> IO [(time, [T])]) -> [IO [(time, [T])]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (time -> IO [(time, [T])]) -> [time] -> [IO [(time, [T])]]
forall a b. (a -> b) -> [a] -> [b]
map ((time -> time) -> time -> [time]
forall a. (a -> a) -> a -> [a]
iterate (time
beattime -> time -> time
forall a. C a => a -> a -> a
+) time
0) ((time -> IO [(time, [T])]) -> [IO [(time, [T])]])
-> (time -> IO [(time, [T])]) -> [IO [(time, [T])]]
forall a b. (a -> b) -> a -> b
$ \time
t ->
             let end :: time
end = time
ttime -> time -> time
forall a. C a => a -> a -> a
+time
beat
             in  -- (\act -> do evs <- act; print evs; return evs) $
                 -- add a laziness break
                 ([(time, [T])] -> [(time, [T])])
-> IO [(time, [T])] -> IO [(time, [T])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((time
t,[]) (time, [T]) -> [(time, [T])] -> [(time, [T])]
forall a. a -> [a] -> [a]
:) (IO [(time, [T])] -> IO [(time, [T])])
-> IO [(time, [T])] -> IO [(time, [T])]
forall a b. (a -> b) -> a -> b
$
                 ([(time, T)] -> [(time, [T])])
-> IO [(time, T)] -> IO [(time, [T])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((time, T) -> (time, [T])) -> [(time, T)] -> [(time, [T])]
forall a b. (a -> b) -> [a] -> [b]
map ((time -> time, T -> [T]) -> (time, T) -> (time, [T])
forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair ((time, time) -> time -> time
forall a. Ord a => (a, a) -> a -> a
limit (time
t,time
end), (T -> [T] -> [T]
forall a. a -> [a] -> [a]
:[])))) (IO [(time, T)] -> IO [(time, [T])])
-> IO [(time, T)] -> IO [(time, [T])]
forall a b. (a -> b) -> a -> b
$
                 T DuplexMode -> T -> T -> time -> IO [(time, T)]
forall time mode.
(C time, AllowInput mode, AllowOutput mode) =>
T mode -> T -> T -> time -> IO [StampedEvent time]
getStampedEventsUntilTime T DuplexMode
h T
q T
p time
end)

{- |
This is like withMIDIEventsBlockEcho
but collects all events at the beginning of the beats.
This way, further processing steps may collapse
all controller events within one beat to one event.
-}
withMIDIEventsBlockEchoQuantised :: (RealField.C time) =>
   ClientName -> time -> time ->
   (EventList.T StrictTime [Event.T] -> IO a) -> IO a
withMIDIEventsBlockEchoQuantised :: ClientName -> time -> time -> (T StrictTime [T] -> IO a) -> IO a
withMIDIEventsBlockEchoQuantised ClientName
name time
beat time
rate T StrictTime [T] -> IO a
proc =
   ClientName -> BlockMode -> (T DuplexMode -> T -> IO a) -> IO a
forall t.
ClientName -> BlockMode -> (T DuplexMode -> T -> IO t) -> IO t
withInPort ClientName
name BlockMode
SndSeq.Block ((T DuplexMode -> T -> IO a) -> IO a)
-> (T DuplexMode -> T -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ T DuplexMode
h T
p ->
   T DuplexMode -> (T -> IO a) -> IO a
forall mode a. T mode -> (T -> IO a) -> IO a
Queue.with T DuplexMode
h ((T -> IO a) -> IO a) -> (T -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ T
q ->
   do T DuplexMode -> T -> QueueEv -> Maybe T -> IO ()
forall mode. T mode -> T -> QueueEv -> Maybe T -> IO ()
Queue.control T DuplexMode
h T
q QueueEv
Event.QueueStart Maybe T
forall a. Maybe a
Nothing
      Word
_ <- T DuplexMode -> IO Word
forall mode. AllowOutput mode => T mode -> IO Word
Event.drainOutput T DuplexMode
h

      T StrictTime [T] -> IO a
proc (T StrictTime [T] -> IO a)
-> ([(time, [T])] -> T StrictTime [T]) -> [(time, [T])] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
         time -> T time [T] -> T StrictTime [T]
forall time a. C time => time -> T time a -> T StrictTime a
discretizeTime time
rate (T time [T] -> T StrictTime [T])
-> ([(time, [T])] -> T time [T])
-> [(time, [T])]
-> T StrictTime [T]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
         [(time, [T])] -> T time [T]
forall a b. [(a, b)] -> T a b
AbsEventList.fromPairList ([(time, [T])] -> IO a) -> IO [(time, [T])] -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
         ([IO (time, [T])] -> IO [(time, [T])]
forall a. [IO a] -> IO [a]
lazySequence ([IO (time, [T])] -> IO [(time, [T])])
-> [IO (time, [T])] -> IO [(time, [T])]
forall a b. (a -> b) -> a -> b
$
          ((time -> IO (time, [T])) -> [time] -> [IO (time, [T])])
-> [time] -> (time -> IO (time, [T])) -> [IO (time, [T])]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (time -> IO (time, [T])) -> [time] -> [IO (time, [T])]
forall a b. (a -> b) -> [a] -> [b]
map ((time -> time) -> time -> [time]
forall a. (a -> a) -> a -> [a]
iterate (time
beattime -> time -> time
forall a. C a => a -> a -> a
+) time
0) ((time -> IO (time, [T])) -> [IO (time, [T])])
-> (time -> IO (time, [T])) -> [IO (time, [T])]
forall a b. (a -> b) -> a -> b
$ \time
t ->
            ([T] -> (time, [T])) -> IO [T] -> IO (time, [T])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
               (\[T]
evs -> (time
t, [T]
evs))
               (T DuplexMode -> T -> T -> time -> IO [T]
forall time mode.
(C time, AllowInput mode, AllowOutput mode) =>
T mode -> T -> T -> time -> IO [T]
getEventsUntilTime T DuplexMode
h T
q T
p (time
ttime -> time -> time
forall a. C a => a -> a -> a
+time
beat)))

{- |
Make sure, that @beat@ is an integer multiple of @recip rate@.
Since we round time within each chunk,
we would otherwise accumulate rounding errors over time.
-}
withMIDIEventsChunked ::
   (RealField.C time) =>
   ClientName -> time -> time ->
   ([IO (EventListTT.T StrictTime [Event.T])] -> IO a) ->
   IO a
withMIDIEventsChunked :: ClientName
-> time -> time -> ([IO (T StrictTime [T])] -> IO a) -> IO a
withMIDIEventsChunked ClientName
name time
beat time
rate [IO (T StrictTime [T])] -> IO a
proc =
   ClientName -> BlockMode -> (T DuplexMode -> T -> IO a) -> IO a
forall t.
ClientName -> BlockMode -> (T DuplexMode -> T -> IO t) -> IO t
withInPort ClientName
name BlockMode
SndSeq.Block ((T DuplexMode -> T -> IO a) -> IO a)
-> (T DuplexMode -> T -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ T DuplexMode
h T
p ->
   T DuplexMode -> (T -> IO a) -> IO a
forall mode a. T mode -> (T -> IO a) -> IO a
Queue.with T DuplexMode
h ((T -> IO a) -> IO a) -> (T -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ T
q ->
   do T DuplexMode -> T -> T -> IO ()
forall mode. T mode -> T -> T -> IO ()
setTimestamping T DuplexMode
h T
p T
q
      T DuplexMode -> T -> QueueEv -> Maybe T -> IO ()
forall mode. T mode -> T -> QueueEv -> Maybe T -> IO ()
Queue.control T DuplexMode
h T
q QueueEv
Event.QueueStart Maybe T
forall a. Maybe a
Nothing
      Word
_ <- T DuplexMode -> IO Word
forall mode. AllowOutput mode => T mode -> IO Word
Event.drainOutput T DuplexMode
h

      [IO (T StrictTime [T])] -> IO a
proc ([IO (T StrictTime [T])] -> IO a)
-> [IO (T StrictTime [T])] -> IO a
forall a b. (a -> b) -> a -> b
$
         (time -> IO (T StrictTime [T]))
-> [time] -> [IO (T StrictTime [T])]
forall a b. (a -> b) -> [a] -> [b]
map
            (\time
t ->
               let end :: time
end = time
ttime -> time -> time
forall a. C a => a -> a -> a
+time
beat
               in  ([(time, T)] -> T StrictTime [T])
-> IO [(time, T)] -> IO (T StrictTime [T])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
                      (\[(time, T)]
evs ->
                         T StrictTime [T]
-> (T StrictTime [T] -> [T] -> T StrictTime [T])
-> T StrictTime [T]
-> T StrictTime [T]
forall a time body.
a -> (T time body -> body -> a) -> T time body -> a
EventListTM.switchBodyR
                            ([Char] -> T StrictTime [T]
forall a. HasCallStack => [Char] -> a
error [Char]
"withMIDIEventsChunked: empty list, but there must be at least the end event")
                            T StrictTime [T] -> [T] -> T StrictTime [T]
forall a b. a -> b -> a
const (T StrictTime [T] -> T StrictTime [T])
-> T StrictTime [T] -> T StrictTime [T]
forall a b. (a -> b) -> a -> b
$
                         time -> T time [T] -> T StrictTime [T]
forall time a. C time => time -> T time a -> T StrictTime a
discretizeTime time
rate (T time [T] -> T StrictTime [T]) -> T time [T] -> T StrictTime [T]
forall a b. (a -> b) -> a -> b
$
                         [(time, [T])] -> T time [T]
forall a b. [(a, b)] -> T a b
AbsEventList.fromPairList ([(time, [T])] -> T time [T]) -> [(time, [T])] -> T time [T]
forall a b. (a -> b) -> a -> b
$
                         (time
t,[]) (time, [T]) -> [(time, [T])] -> [(time, [T])]
forall a. a -> [a] -> [a]
:
                         {-
                         FIXME: This is a quick hack in order to assert
                         that all events are within one chunk
                         and do not lie on the boundary.
                         -}
                         ((time, T) -> (time, [T])) -> [(time, T)] -> [(time, [T])]
forall a b. (a -> b) -> [a] -> [b]
map ((time -> time, T -> [T]) -> (time, T) -> (time, [T])
forall a c b d. (a -> c, b -> d) -> (a, b) -> (c, d)
mapPair ((time, time) -> time -> time
forall a. Ord a => (a, a) -> a -> a
limit (time
t , time
end time -> time -> time
forall a. C a => a -> a -> a
- time -> time
forall a. C a => a -> a
recip time
rate), (T -> [T] -> [T]
forall a. a -> [a] -> [a]
:[]))) [(time, T)]
evs [(time, [T])] -> [(time, [T])] -> [(time, [T])]
forall a. [a] -> [a] -> [a]
++
                         (time
end, []) (time, [T]) -> [(time, [T])] -> [(time, [T])]
forall a. a -> [a] -> [a]
:
                         [])
                      (T DuplexMode -> T -> T -> time -> IO [(time, T)]
forall time mode.
(C time, AllowInput mode, AllowOutput mode) =>
T mode -> T -> T -> time -> IO [StampedEvent time]
getStampedEventsUntilTime T DuplexMode
h T
q T
p time
end))
            ((time -> time) -> time -> [time]
forall a. (a -> a) -> a -> [a]
iterate (time
beattime -> time -> time
forall a. C a => a -> a -> a
+) time
0)

withMIDIEventsChunkedQuantised ::
   (RealField.C time) =>
   ClientName -> time -> time ->
   ([IO (EventList.T StrictTime [Event.T])] -> IO a) ->
   IO a
withMIDIEventsChunkedQuantised :: ClientName
-> time -> time -> ([IO (T StrictTime [T])] -> IO a) -> IO a
withMIDIEventsChunkedQuantised ClientName
name time
beat time
rate [IO (T StrictTime [T])] -> IO a
proc =
   ClientName -> BlockMode -> (T DuplexMode -> T -> IO a) -> IO a
forall t.
ClientName -> BlockMode -> (T DuplexMode -> T -> IO t) -> IO t
withInPort ClientName
name BlockMode
SndSeq.Block ((T DuplexMode -> T -> IO a) -> IO a)
-> (T DuplexMode -> T -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ T DuplexMode
h T
p ->
   T DuplexMode -> (T -> IO a) -> IO a
forall mode a. T mode -> (T -> IO a) -> IO a
Queue.with T DuplexMode
h ((T -> IO a) -> IO a) -> (T -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ T
q ->
   do T DuplexMode -> T -> QueueEv -> Maybe T -> IO ()
forall mode. T mode -> T -> QueueEv -> Maybe T -> IO ()
Queue.control T DuplexMode
h T
q QueueEv
Event.QueueStart Maybe T
forall a. Maybe a
Nothing
      Word
_ <- T DuplexMode -> IO Word
forall mode. AllowOutput mode => T mode -> IO Word
Event.drainOutput T DuplexMode
h

      [IO (T StrictTime [T])] -> IO a
proc ([IO (T StrictTime [T])] -> IO a)
-> [IO (T StrictTime [T])] -> IO a
forall a b. (a -> b) -> a -> b
$
         (time -> IO (T StrictTime [T]))
-> [time] -> [IO (T StrictTime [T])]
forall a b. (a -> b) -> [a] -> [b]
map
            (\time
t ->
               ([T] -> T StrictTime [T]) -> IO [T] -> IO (T StrictTime [T])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
                  (\[T]
evs ->
                     StrictTime -> [T] -> T StrictTime [T] -> T StrictTime [T]
forall time body. time -> body -> T time body -> T time body
EventList.cons StrictTime
forall a. C a => a
NonNeg.zero [T]
evs (T StrictTime [T] -> T StrictTime [T])
-> T StrictTime [T] -> T StrictTime [T]
forall a b. (a -> b) -> a -> b
$
                     StrictTime -> [T] -> T StrictTime [T]
forall time body. time -> body -> T time body
EventList.singleton
                        ([Char] -> Integer -> StrictTime
forall a. (Ord a, Num a) => [Char] -> a -> T a
NonNegW.fromNumberMsg [Char]
"chunked time conversion" (Integer -> StrictTime) -> Integer -> StrictTime
forall a b. (a -> b) -> a -> b
$
                         time -> Integer
forall a b. (C a, C b) => a -> b
round (time
beattime -> time -> time
forall a. C a => a -> a -> a
*time
rate)) [])
                  (T DuplexMode -> T -> T -> time -> IO [T]
forall time mode.
(C time, AllowInput mode, AllowOutput mode) =>
T mode -> T -> T -> time -> IO [T]
getEventsUntilTime T DuplexMode
h T
q T
p (time
ttime -> time -> time
forall a. C a => a -> a -> a
+time
beat)))
            ((time -> time) -> time -> [time]
forall a. (a -> a) -> a -> [a]
iterate (time
beattime -> time -> time
forall a. C a => a -> a -> a
+) time
0)

makeEcho ::
   RealField.C time =>
   Client.T -> Queue.T -> Port.T ->
   time -> Event.Custom -> Event.T
makeEcho :: T -> T -> T -> time -> Custom -> T
makeEcho T
c T
q T
p time
t Custom
dat =
   (T -> Data -> T
Event.simple
      (Cons :: T -> T -> T
Addr.Cons {
           client :: T
Addr.client = T
c,
           port :: T
Addr.port = T
Port.unknown
        })
      (CustomEv -> Custom -> Data
Event.CustomEv CustomEv
Event.Echo Custom
dat))
      { queue :: T
Event.queue = T
q
      , time :: T
Event.time =
           Stamp -> T
Time.consAbs (Stamp -> T) -> Stamp -> T
forall a b. (a -> b) -> a -> b
$ T -> Stamp
Time.Real (T -> Stamp) -> T -> Stamp
forall a b. (a -> b) -> a -> b
$ Integer -> T
RealTime.fromInteger (Integer -> T) -> Integer -> T
forall a b. (a -> b) -> a -> b
$
           time -> Integer
forall a b. (C a, C b) => a -> b
floor (time
10time -> Integer -> time
forall a. C a => a -> Integer -> a
^Integer
9 time -> time -> time
forall a. C a => a -> a -> a
* time
t)
      , dest :: T
Event.dest = Cons :: T -> T -> T
Addr.Cons {
           client :: T
Addr.client = T
c,
           port :: T
Addr.port = T
p
        }
      }

withMIDIEventsBlock :: (RealField.C time) =>
   ClientName -> time ->
   (EventList.T StrictTime Event.T -> IO a) -> IO a
withMIDIEventsBlock :: ClientName -> time -> (T StrictTime T -> IO a) -> IO a
withMIDIEventsBlock ClientName
name time
rate T StrictTime T -> IO a
proc =
   ClientName -> BlockMode -> (T DuplexMode -> T -> IO a) -> IO a
forall t.
ClientName -> BlockMode -> (T DuplexMode -> T -> IO t) -> IO t
withInPort ClientName
name BlockMode
SndSeq.Block ((T DuplexMode -> T -> IO a) -> IO a)
-> (T DuplexMode -> T -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ T DuplexMode
h T
_p ->
   do [StampedEvent time]
l <- IO (StampedEvent time) -> IO [StampedEvent time]
forall a. IO a -> IO [a]
ioToLazyList (IO (StampedEvent time) -> IO [StampedEvent time])
-> IO (StampedEvent time) -> IO [StampedEvent time]
forall a b. (a -> b) -> a -> b
$ T DuplexMode -> IO (StampedEvent time)
forall time mode.
(C time, AllowInput mode) =>
T mode -> IO (StampedEvent time)
getStampedEvent T DuplexMode
h
      T StrictTime T -> IO a
proc (T StrictTime T -> IO a) -> T StrictTime T -> IO a
forall a b. (a -> b) -> a -> b
$
         time -> T time T -> T StrictTime T
forall time a. C time => time -> T time a -> T StrictTime a
discretizeTime time
rate (T time T -> T StrictTime T) -> T time T -> T StrictTime T
forall a b. (a -> b) -> a -> b
$
         [StampedEvent time] -> T time T
forall a b. [(a, b)] -> T a b
AbsEventList.fromPairList [StampedEvent time]
l

withInPort ::
   ClientName ->
   SndSeq.BlockMode ->
   (SndSeq.T SndSeq.DuplexMode -> Port.T -> IO t) -> IO t
withInPort :: ClientName -> BlockMode -> (T DuplexMode -> T -> IO t) -> IO t
withInPort (ClientName [Char]
name) BlockMode
blockMode T DuplexMode -> T -> IO t
act =
   [Char] -> BlockMode -> (T DuplexMode -> IO t) -> IO t
forall mode a.
OpenMode mode =>
[Char] -> BlockMode -> (T mode -> IO a) -> IO a
SndSeq.with [Char]
SndSeq.defaultName BlockMode
blockMode ((T DuplexMode -> IO t) -> IO t) -> (T DuplexMode -> IO t) -> IO t
forall a b. (a -> b) -> a -> b
$ \T DuplexMode
h ->
   T DuplexMode -> [Char] -> IO ()
forall mode. T mode -> [Char] -> IO ()
Client.setName T DuplexMode
h [Char]
name IO () -> IO t -> IO t
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
   T DuplexMode -> [Char] -> Cap -> Type -> (T -> IO t) -> IO t
forall mode a.
T mode -> [Char] -> Cap -> Type -> (T -> IO a) -> IO a
Port.withSimple T DuplexMode
h [Char]
"input"
      ([Cap] -> Cap
Port.caps [Cap
Port.capWrite, Cap
Port.capSubsWrite])
      Type
Port.typeMidiGeneric
      (T DuplexMode -> T -> IO t
act T DuplexMode
h)

{- |
We first discretize the absolute time values,
then we compute differences,
in order to avoid rounding errors in further computations.
-}
discretizeTime :: (RealField.C time) =>
   time -> AbsEventList.T time a -> EventList.T StrictTime a
discretizeTime :: time -> T time a -> T StrictTime a
discretizeTime time
sampleRate =
   (StrictTime -> StrictTime) -> T StrictTime a -> T StrictTime a
forall time body. (time -> time) -> T time body -> T time body
EventListMB.mapTimeHead (StrictTime -> StrictTime -> StrictTime
forall a b. a -> b -> a
const (StrictTime -> StrictTime -> StrictTime)
-> StrictTime -> StrictTime -> StrictTime
forall a b. (a -> b) -> a -> b
$ Integer -> StrictTime
forall a. (Ord a, Num a) => a -> T a
NonNegW.fromNumber Integer
forall a. C a => a
zero) (T StrictTime a -> T StrictTime a)
-> (T time a -> T StrictTime a) -> T time a -> T StrictTime a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. -- clear first time since it is an absolute system time stamp
   T StrictTime a -> T StrictTime a
forall time body. Num time => T time body -> T time body
EventList.fromAbsoluteEventList (T StrictTime a -> T StrictTime a)
-> (T time a -> T StrictTime a) -> T time a -> T StrictTime a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (time -> StrictTime) -> T time a -> T StrictTime a
forall time0 time1 body.
(time0 -> time1) -> T time0 body -> T time1 body
AbsEventList.mapTime
      ([Char] -> Integer -> StrictTime
forall a. (Ord a, Num a) => [Char] -> a -> T a
NonNegW.fromNumberMsg [Char]
"time conversion" (Integer -> StrictTime) -> (time -> Integer) -> time -> StrictTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. time -> Integer
forall a b. (C a, C b) => a -> b
round (time -> Integer) -> (time -> time) -> time -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (time
sampleRatetime -> time -> time
forall a. C a => a -> a -> a
*))



ioToLazyList :: IO a -> IO [a]
ioToLazyList :: IO a -> IO [a]
ioToLazyList IO a
m =
   let go :: IO [a]
go = IO [a] -> IO [a]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [a] -> IO [a]) -> IO [a] -> IO [a]
forall a b. (a -> b) -> a -> b
$ (a -> [a] -> [a]) -> IO a -> IO [a] -> IO [a]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:) IO a
m IO [a]
go
   in  IO [a]
go

lazySequence :: [IO a] -> IO [a]
lazySequence :: [IO a] -> IO [a]
lazySequence [] = [a] -> IO [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
lazySequence (IO a
m:[IO a]
ms) =
   IO [a] -> IO [a]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [a] -> IO [a]) -> IO [a] -> IO [a]
forall a b. (a -> b) -> a -> b
$ (a -> [a] -> [a]) -> IO a -> IO [a] -> IO [a]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:) IO a
m (IO [a] -> IO [a]) -> IO [a] -> IO [a]
forall a b. (a -> b) -> a -> b
$ [IO a] -> IO [a]
forall a. [IO a] -> IO [a]
lazySequence [IO a]
ms