-- Copyright 2018 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE TypeApplications, DataKinds #-}
-- | Render 'Sample.Note's down to audio.
module Synth.Sampler.Render where
import qualified Control.Exception as Exception
import qualified Control.Monad.Trans.Resource as Resource
import qualified Data.IORef as IORef
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Text as Text

import qualified Sound.File.Sndfile as Sndfile
import qualified Streaming.Prelude as S
import qualified System.FilePath as FilePath
import qualified System.IO.Error as IO.Error

import qualified Util.Audio.Audio as Audio
import qualified Util.Audio.Resample as Resample
import qualified Util.Control
import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Pretty as Pretty
import qualified Util.Serialize as Serialize
import qualified Util.Thread as Thread

import qualified Synth.Faust.Effect as Effect
import qualified Synth.Faust.EffectC as EffectC
import qualified Synth.Faust.RenderUtil as RenderUtil
import qualified Synth.Lib.AUtil as AUtil
import qualified Synth.Lib.Checkpoint as Checkpoint
import qualified Synth.Sampler.Patch as Patch
import qualified Synth.Sampler.RenderSample as RenderSample
import qualified Synth.Sampler.Sample as Sample
import qualified Synth.Shared.Config as Config
import qualified Synth.Shared.Control as Control
import qualified Synth.Shared.Note as Note
import qualified Synth.Shared.Signal as Signal

import qualified Ui.Id as Id

import           Global
import           Synth.Types


data Config = Config {
    Config -> Quality
_quality :: !Resample.Quality
    , Config -> Frames
_chunkSize :: !Audio.Frames
    , Config -> Frames
_blockSize :: !Audio.Frames
    , Config -> Frames
_controlsPerBlock :: !Audio.Frames
    -- | Optionally suppress structured progress messages, used by karya.
    , Config -> Bool
_emitProgress :: !Bool
    }

type Error = Text

defaultConfig :: Resample.Quality -> Config
defaultConfig :: Quality -> Config
defaultConfig Quality
quality = Config
    { _quality :: Quality
_quality = Quality
quality
    , _chunkSize :: Frames
_chunkSize = Frames
Config.chunkSize
    , _blockSize :: Frames
_blockSize = Frames
Config.blockSize
    , _controlsPerBlock :: Frames
_controlsPerBlock = Frames
75 -- from Faust.Render
    , _emitProgress :: Bool
_emitProgress = Bool
True
    }

-- | An instrument level faust processor.
data InstrumentEffect = InstrumentEffect {
    InstrumentEffect -> Patch
_effectPatch :: !Effect.Patch
    , InstrumentEffect -> EffectConfig
_effectConfig :: !Patch.EffectConfig
    }

-- TODO lots of this is duplicated with Faust.Render.write, factor out the
-- repeated parts.
write :: Config -> FilePath -> Set Id.TrackId -> Maybe InstrumentEffect
    -> [Sample.Note] -> IO (Either Error (Config.ChunkNum, Config.ChunkNum))
    -- ^ (writtenChunks, totalChunks)
write :: Config
-> SamplePath
-> Set TrackId
-> Maybe InstrumentEffect
-> [Note]
-> IO (Either Text (Int, Int))
write Config
config SamplePath
outputDir Set TrackId
trackIds Maybe InstrumentEffect
mbEffect [Note]
notes = forall {b}. IO (Either Text b) -> IO (Either Text b)
catch forall a b. (a -> b) -> a -> b
$ do
    ([SamplePath]
skipped, [(Int, Hash)]
hashes, Maybe State
mbState) <-
        SamplePath
-> State
-> [(Int, Hash)]
-> IO ([SamplePath], [(Int, Hash)], Maybe State)
Checkpoint.skipCheckpoints SamplePath
outputDir (State -> State
serializeState State
emptyState) forall a b. (a -> b) -> a -> b
$
        Frames -> [Span] -> [(Int, Hash)]
Checkpoint.noteHashes (Config -> Frames
_chunkSize Config
config) forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map Note -> Span
toSpan [Note]
notes
    let startFrame :: Frames
startFrame = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SamplePath]
skipped) forall a. Num a => a -> a -> a
* Config -> Frames
_chunkSize Config
config
        start :: RealTime
start = Frames -> RealTime
AUtil.toSeconds Frames
startFrame
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> SamplePath -> SamplePath -> IO Int
Checkpoint.linkOutput Bool
True SamplePath
outputDir) [SamplePath]
skipped
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
_emitProgress Config
config Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SamplePath]
skipped)) forall a b. (a -> b) -> a -> b
$
        HasCallStack => Message -> IO ()
Config.emitMessage forall a b. (a -> b) -> a -> b
$ Config.Message
            { _blockId :: BlockId
_blockId = SamplePath -> BlockId
Config.pathToBlockId SamplePath
outputDir
            , _trackIds :: Set TrackId
_trackIds = Set TrackId
trackIds
            , _instrument :: Instrument
_instrument = SamplePath -> Instrument
Config.dirToInstrument SamplePath
outputDir
            , _payload :: Payload
_payload = [Int] -> Payload
Config.WaveformsCompleted [Int
0 .. forall (t :: * -> *) a. Foldable t => t a -> Int
length [SamplePath]
skipped forall a. Num a => a -> a -> a
- Int
1]
            }

    case forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. b -> Either a b
Right State
emptyState) State -> Either Text State
unserializeState Maybe State
mbState of
        Left Text
err -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
            Text
"unserializing " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Maybe State
mbState forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
err
        Right State
initialState -> do
            forall (m :: * -> *). (HasCallStack, LogMonad m) => Text -> m ()
Log.debug forall a b. (a -> b) -> a -> b
$ SamplePath -> Text
txt SamplePath
outputDir forall a. Semigroup a => a -> a -> a
<> Text
": skipped " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [SamplePath]
skipped
                forall a. Semigroup a => a -> a -> a
<> Text
", resume at " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall a. Int -> [a] -> [a]
take Int
1 [(Int, Hash)]
hashes)
                forall a. Semigroup a => a -> a -> a
<> Text
" states: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty State
initialState
                forall a. Semigroup a => a -> a -> a
<> Text
" start: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty RealTime
start
            -- See NOTE [audio-state].
            IORef State
stateRef <- forall a. a -> IO (IORef a)
IORef.newIORef State
initialState
            let getState :: IO State
getState = State -> State
serializeState forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
IORef.readIORef IORef State
stateRef
            Either Text (Int, Int)
result <- Bool
-> SamplePath
-> Set TrackId
-> Int
-> Frames
-> [(Int, Hash)]
-> IO State
-> Audio
-> IO (Either Text (Int, Int))
Checkpoint.write (Config -> Bool
_emitProgress Config
config) SamplePath
outputDir
                    Set TrackId
trackIds (forall (t :: * -> *) a. Foldable t => t a -> Int
length [SamplePath]
skipped) (Config -> Frames
_chunkSize Config
config) [(Int, Hash)]
hashes
                    IO State
getState forall a b. (a -> b) -> a -> b
$
                Config
-> SamplePath
-> State
-> IORef State
-> Set TrackId
-> Maybe InstrumentEffect
-> Frames
-> [Note]
-> Audio
renderAll Config
config SamplePath
outputDir State
initialState IORef State
stateRef Set TrackId
trackIds
                    Maybe InstrumentEffect
mbEffect Frames
startFrame [Note]
notes
            case Either Text (Int, Int)
result of
                Right (Int
_, Int
total) ->
                    SamplePath -> Int -> IO ()
Checkpoint.clearRemainingOutput SamplePath
outputDir Int
total
                Either Text (Int, Int)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            forall (m :: * -> *) a. Monad m => a -> m a
return Either Text (Int, Int)
result
    where
    catch :: IO (Either Text b) -> IO (Either Text b)
catch IO (Either Text b)
io = forall a. IO a -> [Handler a] -> IO a
Exception.catches IO (Either Text b)
io
        -- Exceptions in haskell are really disorganized.
        [ forall a e. Exception e => (e -> IO a) -> Handler a
Exception.Handler forall a b. (a -> b) -> a -> b
$ \(Audio.Exception Text
err) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Text
err
        , forall a e. Exception e => (e -> IO a) -> Handler a
Exception.Handler forall a b. (a -> b) -> a -> b
$ \(IOError
exc :: IO.Error.IOError) ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ SamplePath -> Text
txt forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SamplePath
Exception.displayException IOError
exc
        , forall a e. Exception e => (e -> IO a) -> Handler a
Exception.Handler forall a b. (a -> b) -> a -> b
$ \Exception
exc ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ SamplePath -> Text
txt forall a b. (a -> b) -> a -> b
$ Exception -> SamplePath
Sndfile.errorString Exception
exc
        , forall a e. Exception e => (e -> IO a) -> Handler a
Exception.Handler forall a b. (a -> b) -> a -> b
$ \(Resource.ResourceCleanupException Maybe SomeException
origExc
                SomeException
firstExc [SomeException]
_) ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ SamplePath -> Text
txt forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SamplePath
Exception.displayException
                (forall a. a -> Maybe a -> a
fromMaybe SomeException
firstExc Maybe SomeException
origExc)
        ]

toSpan :: Sample.Note -> Checkpoint.Span
toSpan :: Note -> Span
toSpan Note
note = Checkpoint.Span
    { _start :: RealTime
_start = Frames -> RealTime
AUtil.toSeconds forall a b. (a -> b) -> a -> b
$ Note -> Frames
Sample.start Note
note
    , _duration :: RealTime
_duration = Frames -> RealTime
AUtil.toSeconds forall a b. (a -> b) -> a -> b
$ Note -> Frames
Sample.duration Note
note
    , _hash :: Hash
_hash = Note -> Hash
Sample.hash Note
note
    }

-- | A currently playing sample.
data Playing = Playing {
    Playing -> Hash
_noteHash :: !Note.Hash
    -- | Get the current state of the resample.  NOTE [audio-state]
    , Playing -> IO PlayState
_getState :: IO PlayState
    , Playing -> Audio
_audio :: !AUtil.Audio
    , Playing -> (Frames, Frames)
_noteRange :: !(Audio.Frames, Audio.Frames)
    }

instance Pretty Playing where
    pretty :: Playing -> Text
pretty Playing
p =
        Text
"Playing:" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Playing -> Hash
_noteHash Playing
p)
            forall a. Semigroup a => a -> a -> a
<> Text
"(" forall a. Semigroup a => a -> a -> a
<> Frames -> Text
prettyF Frames
s forall a. Semigroup a => a -> a -> a
<> Text
"--" forall a. Semigroup a => a -> a -> a
<> Frames -> Text
prettyF Frames
e forall a. Semigroup a => a -> a -> a
<> Text
")"
        where (Frames
s, Frames
e) = Playing -> (Frames, Frames)
_noteRange Playing
p

renderAll :: Config -> FilePath -> State -> IORef.IORef State
    -> Set Id.TrackId -> Maybe InstrumentEffect
    -> Audio.Frames -> [Sample.Note] -> AUtil.Audio
renderAll :: Config
-> SamplePath
-> State
-> IORef State
-> Set TrackId
-> Maybe InstrumentEffect
-> Frames
-> [Note]
-> Audio
renderAll Config
config SamplePath
outputDir (State [PlayState]
playStates Maybe State
mbEffectState) IORef State
stateRef
        Set TrackId
trackIds Maybe InstrumentEffect
mbEffect Frames
start [Note]
notes =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (Config
-> Frames
-> Maybe State
-> (State -> IO ())
-> [Note]
-> InstrumentEffect
-> Audio
-> Audio
applyEffect Config
config Frames
start Maybe State
mbEffectState State -> IO ()
notifyEffect [Note]
notesHere)
            Maybe InstrumentEffect
mbEffect forall a b. (a -> b) -> a -> b
$
        Config
-> SamplePath
-> [PlayState]
-> ([PlayState] -> IO ())
-> Set TrackId
-> Frames
-> [Note]
-> [Note]
-> [Note]
-> Audio
renderNotes Config
config SamplePath
outputDir [PlayState]
playStates [PlayState] -> IO ()
notifyPlay Set TrackId
trackIds Frames
start
            [Note]
overlappingStart [Note]
overlappingChunk [Note]
futureNotes
    where
    notesHere :: [Note]
notesHere = [Note]
overlappingStart forall a. [a] -> [a] -> [a]
++ [Note]
overlappingChunk forall a. [a] -> [a] -> [a]
++ [Note]
futureNotes
    ([Note]
overlappingStart, [Note]
overlappingChunk, [Note]
futureNotes) =
        Frames -> Frames -> [Note] -> ([Note], [Note], [Note])
overlappingNotes Frames
start (Config -> Frames
_blockSize Config
config) [Note]
notes
    -- The streaming should be single threaded so I shouldn't need
    -- atomicModifyIORef, but since I'm relying on write->read ordering,
    -- this makes me feel a bit better anyway.
    notifyPlay :: [PlayState] -> IO ()
notifyPlay [PlayState]
playStates = forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef State
stateRef forall a b. (a -> b) -> a -> b
$ \State
state ->
        (State
state { _playStates :: [PlayState]
_playStates = [PlayState]
playStates }, ())
    notifyEffect :: State -> IO ()
notifyEffect State
st = forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef State
stateRef forall a b. (a -> b) -> a -> b
$ \State
state ->
        (State
state { _effectState :: Maybe State
_effectState = forall a. a -> Maybe a
Just State
st }, ())

renderNotes :: Config -> FilePath -> [PlayState] -> ([PlayState] -> IO ())
    -> Set Id.TrackId -> Audio.Frames
    -> [Sample.Note] -> [Sample.Note] -> [Sample.Note]
    -> AUtil.Audio
renderNotes :: Config
-> SamplePath
-> [PlayState]
-> ([PlayState] -> IO ())
-> Set TrackId
-> Frames
-> [Note]
-> [Note]
-> [Note]
-> Audio
renderNotes Config
config SamplePath
outputDir [PlayState]
initialStates [PlayState] -> IO ()
notifyState Set TrackId
trackIds Frames
start
        [Note]
overlappingStart [Note]
overlappingChunk [Note]
futureNotes =
    forall (m :: * -> *) (rate :: Nat) (chan :: Nat).
Stream (Of Block) m () -> Audio m rate chan
Audio.Audio forall a b. (a -> b) -> a -> b
$ do
        -- The first chunk is different because I have to resume already
        -- playing samples.
        [Playing]
playing <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
            Config -> Frames -> [PlayState] -> [Note] -> IO [Playing]
resumeSamples Config
config Frames
start [PlayState]
initialStates [Note]
overlappingStart
        ([Playing]
playing, (Metric UTCTime, Int)
metric) <- Maybe (Metric UTCTime, Int)
-> Frames
-> [Playing]
-> [Note]
-> Bool
-> Stream
     (Of Block) (ResourceT IO) ([Playing], (Metric UTCTime, Int))
renderBlock forall a. Maybe a
Nothing Frames
start [Playing]
playing [Note]
overlappingChunk
            (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note]
futureNotes)
        forall state a. state -> ((state -> a) -> state -> a) -> a
Util.Control.loop1 ((Metric UTCTime, Int)
metric, Frames
start forall a. Num a => a -> a -> a
+ Frames
blockSize, [Playing]
playing, [Note]
futureNotes) forall a b. (a -> b) -> a -> b
$
            \((Metric UTCTime, Int), Frames, [Playing], [Note])
-> Stream (Of Block) (ResourceT IO) ()
loop ((Metric UTCTime, Int)
metric, Frames
now, [Playing]
playing, [Note]
notes) ->
                -- Quit when nothing is playing and nothing will play.
                if (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Playing]
playing Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note]
notes) then forall {m :: * -> *} {a} {a}.
(MonadIO m, Pretty a) =>
(a, a) -> m ()
complete (Metric UTCTime, Int)
metric
                else do
                    let ([Note]
overlappingStart, [Note]
overlappingChunk, [Note]
futureNotes) =
                            Frames -> Frames -> [Note] -> ([Note], [Note], [Note])
overlappingNotes Frames
now Frames
blockSize [Note]
notes
                    -- If notes started in the past, they should already be
                    -- 'playing'.  The input notes should have been sorted prior
                    -- to serialization, and convert should have checked
                    -- post-preprocess.
                    forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Bool -> Text -> m ()
Audio.assert (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note]
overlappingStart) forall a b. (a -> b) -> a -> b
$
                        Text
"notes out of order, I'm at " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Frames
now
                        forall a. Semigroup a => a -> a -> a
<> Text
" but saw notes at: "
                        forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords (forall a b. (a -> b) -> [a] -> [b]
map Note -> Text
Sample.prettyNote [Note]
overlappingStart)
                    ([Playing]
playing, (Metric UTCTime, Int)
metric) <- Maybe (Metric UTCTime, Int)
-> Frames
-> [Playing]
-> [Note]
-> Bool
-> Stream
     (Of Block) (ResourceT IO) ([Playing], (Metric UTCTime, Int))
renderBlock (forall a. a -> Maybe a
Just (Metric UTCTime, Int)
metric) Frames
now [Playing]
playing
                        [Note]
overlappingChunk (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Note]
futureNotes)
                    ((Metric UTCTime, Int), Frames, [Playing], [Note])
-> Stream (Of Block) (ResourceT IO) ()
loop ((Metric UTCTime, Int)
metric, Frames
now forall a. Num a => a -> a -> a
+ Frames
blockSize, [Playing]
playing, [Note]
futureNotes)
    where
    blockSize :: Frames
blockSize = Config -> Frames
_blockSize Config
config
    renderBlock :: Maybe (Metric UTCTime, Int)
-> Frames
-> [Playing]
-> [Note]
-> Bool
-> Stream
     (Of Block) (ResourceT IO) ([Playing], (Metric UTCTime, Int))
renderBlock Maybe (Metric UTCTime, Int)
prevMetric Frames
now [Playing]
playing [Note]
overlappingChunk Bool
noFuture = do
        [Playing]
starting <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
            forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Config -> Frames -> Maybe PlayState -> Note -> IO Playing
startSample Config
config Frames
now forall a. Maybe a
Nothing) [Note]
overlappingChunk
        (Metric UTCTime, Int)
metric <- forall {m :: * -> *} {t :: * -> *} {t :: * -> *} {a} {a}.
(MonadIO m, Foldable t, Foldable t) =>
Maybe (Metric UTCTime, Int)
-> Frames -> t a -> t a -> m (Metric UTCTime, Int)
progress Maybe (Metric UTCTime, Int)
prevMetric Frames
now [Playing]
playing [Playing]
starting
        ([Block]
blocks, [Playing]
playing) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Frames -> Frames -> [Playing] -> ResourceT IO ([Block], [Playing])
pull Frames
blockSize Frames
now ([Playing]
playing forall a. [a] -> [a] -> [a]
++ [Playing]
starting)
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [PlayState] -> IO ()
notifyState forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Playing] -> IO [PlayState]
getPlayStates [Playing]
playing
        -- Record playing states for the start of the next chunk.
        let playingTooLong :: [Playing]
playingTooLong = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> a -> Bool
<Frames
now) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Playing -> (Frames, Frames)
_noteRange) [Playing]
playing
        -- This means RenderSample.predictFileDuration was wrong.
        forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Bool -> Text -> m ()
Audio.assert (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Playing]
playingTooLong) forall a b. (a -> b) -> a -> b
$
            Text
"notes still playing at " forall a. Semigroup a => a -> a -> a
<> Frames -> Text
prettyF Frames
now forall a. Semigroup a => a -> a -> a
<> Text
": "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [Playing]
playingTooLong
        forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Bool -> Text -> m ()
Audio.assert (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((forall a. Ord a => a -> a -> Bool
<=Frames
blockSize) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Frames
AUtil.blockFrames2) [Block]
blocks) forall a b. (a -> b) -> a -> b
$
            Text
"chunk was >" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Frames
blockSize forall a. Semigroup a => a -> a -> a
<> Text
": "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall a b. (a -> b) -> [a] -> [b]
map Block -> Frames
AUtil.blockFrames2 [Block]
blocks)
            forall a. Semigroup a => a -> a -> a
<> Text
" of " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [Playing]
playing
        -- If there's no output and no chance to be any more output, don't
        -- emit anything.
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block]
blocks Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Playing]
playing Bool -> Bool -> Bool
&& Bool
noFuture) forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block]
blocks
            -- Since I'm inside Audio.Audio, I don't have srate available, so
            -- I have to set it for Audio.silence.
            then forall (m :: * -> *) a. Monad m => a -> Stream (Of a) m ()
S.yield forall a b. (a -> b) -> a -> b
$ Int -> Sample -> Block
Audio.Constant (Frames -> Int
AUtil.framesCount2 Frames
blockSize) Sample
0
            else forall (m :: * -> *) a. Monad m => a -> Stream (Of a) m ()
S.yield forall a b. (a -> b) -> a -> b
$ Vector Sample -> Block
Audio.Block forall a b. (a -> b) -> a -> b
$
                Int -> [Vector Sample] -> Vector Sample
Audio.mixV (Frames -> Int
AUtil.framesCount2 Frames
blockSize)
                    (forall a b. (a -> b) -> [a] -> [b]
map Block -> Vector Sample
Audio.blockVector [Block]
blocks)
                    -- I could use an Audio.mixB in case there are Constants in
                    -- there, but resample will never produce Constants so
                    -- don't bother.
        forall (m :: * -> *) a. Monad m => a -> m a
return ([Playing]
playing, (Metric UTCTime, Int)
metric)
    complete :: (a, a) -> m ()
complete (a
_, a
maxVoices) =
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (HasCallStack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ SamplePath -> Text
txt (SamplePath -> SamplePath
FilePath.takeFileName SamplePath
outputDir)
            forall a. Semigroup a => a -> a -> a
<> Text
" max voices: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty a
maxVoices

    progress :: Maybe (Metric UTCTime, Int)
-> Frames -> t a -> t a -> m (Metric UTCTime, Int)
progress Maybe (Metric UTCTime, Int)
prevMetric Frames
now t a
playing t a
starting = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Metric UTCTime
metric <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Metric UTCTime)
Thread.metric
        forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe (Metric UTCTime, Int)
prevMetric forall a b. (a -> b) -> a -> b
$ \(Metric UTCTime
prev, Int
_) ->
            forall (m :: * -> *). (HasCallStack, LogMonad m) => Text -> m ()
Log.debug forall a b. (a -> b) -> a -> b
$ Text
"chunk "
                forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Frames -> RealTime
AUtil.toSeconds (Frames
nowforall a. Num a => a -> a -> a
-Frames
blockSize)) forall a. Semigroup a => a -> a -> a
<> Text
"--"
                forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Frames -> RealTime
AUtil.toSeconds Frames
now)
                forall a. Semigroup a => a -> a -> a
<> Text
": elapsed: "
                forall a. Semigroup a => a -> a -> a
<> Metric Seconds -> Text
Thread.showMetric (Metric UTCTime -> Metric UTCTime -> Metric Seconds
Thread.diffMetric Metric UTCTime
prev Metric UTCTime
metric)
                forall a. Semigroup a => a -> a -> a
<> Text
" voices:" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
playing) forall a. Semigroup a => a -> a -> a
<> Text
"+"
                forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
starting)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
_emitProgress Config
config) forall a b. (a -> b) -> a -> b
$ HasCallStack => Message -> IO ()
Config.emitMessage forall a b. (a -> b) -> a -> b
$ Config.Message
            { _blockId :: BlockId
_blockId = SamplePath -> BlockId
Config.pathToBlockId SamplePath
outputDir
            , _trackIds :: Set TrackId
_trackIds = Set TrackId
trackIds
            , _instrument :: Instrument
_instrument = SamplePath -> Instrument
Config.dirToInstrument SamplePath
outputDir
            , _payload :: Payload
_payload = RealTime -> RealTime -> Payload
Config.RenderingRange
                (Frames -> RealTime
AUtil.toSeconds Frames
now) (Frames -> RealTime
AUtil.toSeconds (Frames
now forall a. Num a => a -> a -> a
+ Frames
blockSize))
            }
        let !voices :: Int
voices = forall a. Ord a => a -> a -> a
max (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall a b. (a, b) -> b
snd Maybe (Metric UTCTime, Int)
prevMetric)
                (forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
playing forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
starting)
        forall (m :: * -> *) a. Monad m => a -> m a
return (Metric UTCTime
metric, Int
voices)

-- | Get chunkSize from each Playing, and remove Playings which no longer are.
pull :: Audio.Frames -> Audio.Frames -> [Playing]
    -> Resource.ResourceT IO ([Audio.Block], [Playing])
pull :: Frames -> Frames -> [Playing] -> ResourceT IO ([Block], [Playing])
pull Frames
blockSize Frames
now = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall {a}. ([Block], [Maybe a]) -> ([Block], [a])
trim forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Playing -> ResourceT IO (Block, Maybe Playing)
get
    -- TODO This mapM could be concurrent, which would make concurrent notes
    -- evaluate concurrently.
    where
    trim :: ([Block], [Maybe a]) -> ([Block], [a])
trim ([Block]
chunks, [Maybe a]
playing) =
        ( forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> Bool
Audio.isEmptyBlock) [Block]
chunks
        , forall a. [Maybe a] -> [a]
Maybe.catMaybes [Maybe a]
playing
        )
    get :: Playing -> ResourceT IO (Block, Maybe Playing)
get Playing
playing = do
        (Block
chunk, Audio
audio) <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            forall (m :: * -> *) (rate :: Nat) (chan :: Nat).
(Monad m, KnownNat chan) =>
Frames -> Audio m rate chan -> m ([Block], Audio m rate chan)
Audio.takeFramesGE Frames
blockSize (Playing -> Audio
_audio Playing
playing)
        -- Previously I checked if the stream was complete with AUtil.next.
        -- But since I'm using IORefs for the state, this is unsafe, since it
        -- advances the resampler state too far.
        -- TODO But now this approach can be wrong if the sample happens to end
        -- exactly on a chunk boundary.  Or the _noteRange is slightly wrong,
        -- which happens too.  I should make sure it's harmless.
        let end :: Frames
end = Frames
now forall a. Num a => a -> a -> a
+ Block -> Frames
AUtil.blockFrames2 Block
chunk
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Block -> Frames
AUtil.blockFrames2 Block
chunk forall a. Ord a => a -> a -> Bool
< Frames
blockSize) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (HasCallStack, LogMonad m) => Text -> m ()
Log.debug forall a b. (a -> b) -> a -> b
$
            let diff :: Frames
diff = forall a b. (a, b) -> b
snd (Playing -> (Frames, Frames)
_noteRange Playing
playing) forall a. Num a => a -> a -> a
- Frames
end in
            forall a. Pretty a => a -> Text
pretty (Playing -> Hash
_noteHash Playing
playing) forall a. Semigroup a => a -> a -> a
<> Text
": expected "
            forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Playing -> (Frames, Frames)
_noteRange Playing
playing)
            forall a. Semigroup a => a -> a -> a
<> Text
" diff: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Frames
diff
            forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Frames -> RealTime
AUtil.toSeconds Frames
diff)
        forall (m :: * -> *) a. Monad m => a -> m a
return
            ( Block
chunk
            , if Block -> Frames
AUtil.blockFrames2 Block
chunk forall a. Ord a => a -> a -> Bool
< Frames
blockSize
                then forall a. Maybe a
Nothing
                else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Playing
playing { _audio :: Audio
_audio = Audio
audio }
            )

resumeSamples :: Config -> Audio.Frames -> [PlayState] -> [Sample.Note]
    -> IO [Playing]
resumeSamples :: Config -> Frames -> [PlayState] -> [Note] -> IO [Playing]
resumeSamples Config
config Frames
now [PlayState]
states [Note]
notes = do
    forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Bool -> Text -> m ()
Audio.assert (forall (t :: * -> *) a. Foldable t => t a -> Int
length [PlayState]
states forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [Note]
notes) forall a b. (a -> b) -> a -> b
$
        Text
"at " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Frames
now forall a. Semigroup a => a -> a -> a
<> Text
": len states " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall (t :: * -> *) a. Foldable t => t a -> Int
length [PlayState]
states)
        forall a. Semigroup a => a -> a -> a
<> Text
" /= len notes " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Note]
notes) forall a. Semigroup a => a -> a -> a
<> Text
": "
        forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty [PlayState]
states forall a. Semigroup a => a -> a -> a
<> Text
" /= " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (forall a b. (a -> b) -> [a] -> [b]
map Note -> (Text, Text, Signal, SamplePath)
eNote [Note]
notes)
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Config -> Frames -> Maybe PlayState -> Note -> IO Playing
startSample Config
config Frames
now forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just))
        (forall a b. [a] -> [b] -> [(a, b)]
zip [PlayState]
states (forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn Note -> Hash
Sample.hash [Note]
notes))

-- | Extract from Note for pretty-printing.
eNote :: Sample.Note -> (Text, Text, Signal.Signal, FilePath)
eNote :: Note -> (Text, Text, Signal, SamplePath)
eNote Note
n =
    ( Frames -> Text
prettyF forall a b. (a -> b) -> a -> b
$ Note -> Frames
Sample.start Note
n
    , Frames -> Text
prettyF forall a b. (a -> b) -> a -> b
$ Note -> Frames
Sample.duration Note
n
    , Sample -> Signal
Sample.ratios forall a b. (a -> b) -> a -> b
$ Note -> Sample
Sample.sample Note
n
    , [SamplePath] -> SamplePath
FilePath.joinPath forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
Lists.takeEnd Int
3 forall a b. (a -> b) -> a -> b
$ SamplePath -> [SamplePath]
FilePath.splitPath forall a b. (a -> b) -> a -> b
$
        Sample -> SamplePath
Sample.filename forall a b. (a -> b) -> a -> b
$ Note -> Sample
Sample.sample Note
n
    )

-- | Convert 'Sample.Note' to a 'Playing'.
startSample :: Config -> Audio.Frames -> Maybe PlayState
    -- ^ If Just Just, resume a playing sample which should have started <=now,
    -- otherwise start a new one which should start >= now.  If Just NoResample,
    -- this is a resuming sample, but it wasn't resampled, so there's no
    -- resampler state.
    -> Sample.Note -> IO Playing
startSample :: Config -> Frames -> Maybe PlayState -> Note -> IO Playing
startSample Config
config Frames
now Maybe PlayState
mbState Note
note = do
    let start :: Frames
start = Note -> Frames
Sample.start Note
note
    let sample :: Sample
sample = Note -> Sample
Sample.sample Note
note
    -- NOTE [audio-state]
    IORef PlayState
sampleStateRef <- forall a. a -> IO (IORef a)
IORef.newIORef PlayState
NoResample
    let mkConfig :: Maybe ResampleState -> Config
mkConfig Maybe ResampleState
mbState = Resample.Config
            { _quality :: Quality
_quality = Config -> Quality
_quality Config
config
            , _state :: Maybe SavedState
_state = ResampleState -> SavedState
_resampleState forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ResampleState
mbState
            -- The streaming should be single threaded so I shouldn't need
            -- atomicWriteIORef, but since I'm relying on write->read ordering,
            -- this makes me feel a bit better anyway.
            , _notifyState :: Maybe (Frames, SavedState) -> IO ()
_notifyState = forall a. IORef a -> a -> IO ()
IORef.atomicWriteIORef IORef PlayState
sampleStateRef forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Frames, SavedState) -> PlayState
mkState
            , _blockSize :: Frames
_blockSize = Config -> Frames
_blockSize Config
config
            , _now :: Frames
_now = Frames
now
            , _name :: SamplePath
_name = SamplePath -> SamplePath
FilePath.takeFileName forall a b. (a -> b) -> a -> b
$ Sample -> SamplePath
Sample.filename Sample
sample
            }
        -- This is the offset the state had when I saved it.  Since I'm
        -- resuming at that point, add it to resample's further used samples.
        -- Resample doesn't have a notion of its absolute position in the input
        -- file and always starts at 0.
        initialOffset :: Frames
initialOffset = case Maybe PlayState
mbState of
            Just (Resample ResampleState
state) -> ResampleState -> Frames
_offset ResampleState
state
            Maybe PlayState
_ -> Frames
0
        mkState :: Maybe (Frames, SavedState) -> PlayState
mkState Maybe (Frames, SavedState)
Nothing = PlayState
Complete
        mkState (Just (Frames
used, SavedState
rState)) = ResampleState -> PlayState
Resample forall a b. (a -> b) -> a -> b
$ ResampleState
            { _filename :: SamplePath
_filename = Sample -> SamplePath
Sample.filename Sample
sample
            , _offset :: Frames
_offset = Frames
initialOffset forall a. Num a => a -> a -> a
+ Frames
used
            , _resampleState :: SavedState
_resampleState = SavedState
rState
            }
    case Maybe PlayState
mbState of
        Maybe PlayState
Nothing -> forall {m :: * -> *}. MonadIO m => Bool -> Text -> m ()
assert (Frames
start forall a. Ord a => a -> a -> Bool
>= Frames
now Bool -> Bool -> Bool
&& Frames
now forall a. Num a => a -> a -> a
- Frames
start forall a. Ord a => a -> a -> Bool
< Config -> Frames
_blockSize Config
config) forall a b. (a -> b) -> a -> b
$
            Text
"note should have started between " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Frames
now forall a. Semigroup a => a -> a -> a
<> Text
"--"
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (Frames
now forall a. Num a => a -> a -> a
+ Config -> Frames
_blockSize Config
config) forall a. Semigroup a => a -> a -> a
<> Text
" but started at "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Frames
start
        Just PlayState
state -> do
            forall {m :: * -> *}. MonadIO m => Bool -> Text -> m ()
assert (Frames
start forall a. Ord a => a -> a -> Bool
< Frames
now) forall a b. (a -> b) -> a -> b
$
                Text
"resume sample should start before " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Frames
now
                forall a. Semigroup a => a -> a -> a
<> Text
" but started at " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Frames
start
            case PlayState
state of
                Resample ResampleState
rstate ->
                    forall {m :: * -> *}. MonadIO m => Bool -> Text -> m ()
assert (Sample -> SamplePath
Sample.filename Sample
sample forall a. Eq a => a -> a -> Bool
== ResampleState -> SamplePath
_filename ResampleState
rstate) forall a b. (a -> b) -> a -> b
$
                        Text
"starting " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Sample
sample forall a. Semigroup a => a -> a -> a
<> Text
" but state was for "
                        forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty ResampleState
rstate
                -- 'pull' should have filtered out this Playing.
                PlayState
Complete -> forall {m :: * -> *}. MonadIO m => Bool -> Text -> m ()
assert Bool
False Text
"Complete sample still Playing"
                PlayState
NoResample ->
                    forall {m :: * -> *}. MonadIO m => Bool -> Text -> m ()
assert (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Y -> Bool
RenderSample.ratioCloseEnough Maybe Y
ratio) forall a b. (a -> b) -> a -> b
$
                        Text
"no resample state, but ratios is not 1-ish: "
                        forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Sample -> Signal
Sample.ratios Sample
sample)
                    where
                    ratio :: Maybe Y
ratio = forall {k} (kind :: k). RealTime -> Signal kind -> Maybe Y
Signal.constant_val_from
                        (Frames -> RealTime
AUtil.toSeconds Frames
start) (Sample -> Signal
Sample.ratios Sample
sample)
    let offset :: Frames
offset = case Maybe PlayState
mbState of
            Just (Resample ResampleState
state) -> ResampleState -> Frames
_offset ResampleState
state
            -- If start < now, then this is a resume.  I don't have
            -- the offset because I'm not resampling and that Resample
            -- produces that with ResampleState, but I don't need it.  I'm not
            -- resampling so frames are 1:1.
            Maybe PlayState
_ -> forall a. Ord a => a -> a -> a
max Frames
0 forall a b. (a -> b) -> a -> b
$ Frames
now forall a. Num a => a -> a -> a
- Frames
start
    Audio
audio <- Config -> RealTime -> Sample -> IO Audio
RenderSample.render
        (Maybe ResampleState -> Config
mkConfig forall a b. (a -> b) -> a -> b
$ case Maybe PlayState
mbState of
            Maybe PlayState
Nothing -> forall a. Maybe a
Nothing
            Just PlayState
NoResample -> forall a. Maybe a
Nothing
            Just PlayState
Complete -> forall a. Maybe a
Nothing
            Just (Resample ResampleState
state) -> forall a. a -> Maybe a
Just ResampleState
state)
        (Frames -> RealTime
AUtil.toSeconds Frames
start)
        (Sample
sample { offset :: Frames
Sample.offset = Frames
offset forall a. Num a => a -> a -> a
+ Sample -> Frames
Sample.offset Sample
sample })
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Playing
        { _noteHash :: Hash
_noteHash = Note -> Hash
Sample.hash Note
note
        , _getState :: IO PlayState
_getState = forall a. IORef a -> IO a
IORef.readIORef IORef PlayState
sampleStateRef
        , _audio :: Audio
_audio = Audio
audio
        , _noteRange :: (Frames, Frames)
_noteRange = (Frames
start, Frames
start forall a. Num a => a -> a -> a
+ Note -> Frames
Sample.duration Note
note)
        }
    where
    assert :: Bool -> Text -> m ()
assert Bool
check Text
msg = forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Bool -> Text -> m ()
Audio.assert Bool
check forall a b. (a -> b) -> a -> b
$ Text
msg forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Note
note

-- | This is similar to 'Checkpoint.splitOverlapping', but it differentiates
-- notes that overlap the starting time.
overlappingNotes :: Audio.Frames -> Audio.Frames -> [Sample.Note]
    -> ([Sample.Note], [Sample.Note], [Sample.Note])
overlappingNotes :: Frames -> Frames -> [Note] -> ([Note], [Note], [Note])
overlappingNotes Frames
start Frames
blockSize [Note]
notes =
    ([Note]
overlappingStart, [Note]
overlappingChunk, [Note]
rest)
    where
    ([Note]
overlappingStart, [Note]
overlappingChunk) =
        forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition ((forall a. Ord a => a -> a -> Bool
<Frames
start) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Frames
Sample.start) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Bool
passed) [Note]
here
    ([Note]
here, [Note]
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((forall a. Ord a => a -> a -> Bool
<Frames
end) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Note -> Frames
Sample.start) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile Note -> Bool
passed [Note]
notes
    -- end < start means that overlappingStart includes notes that end exactly
    -- at the start time, which is inconsistent with the usual half-open rule.
    -- The reason is that I can't tell if an audio stream has completed until
    -- I pull samples and there are none, but if I do that, I've already
    -- advanced the resample state too far.  So I save the state anyway for
    -- samples which are exactly used up, which in turn means I have to
    -- consider those notes "still playing" on resume, which in turn means
    -- that overlappingStart has to be inclusive.
    passed :: Note -> Bool
passed Note
n = Note -> Frames
Sample.end Note
n forall a. Ord a => a -> a -> Bool
< Frames
start Bool -> Bool -> Bool
&& Note -> Frames
Sample.start Note
n forall a. Ord a => a -> a -> Bool
< Frames
start
    end :: Frames
end = Frames
start forall a. Num a => a -> a -> a
+ Frames
blockSize

-- * State

data State = State {
    -- | These must be sorted in _noteHash order, since the resume will then
    -- sort again by Sample.hash to match them back up.  This is because I
    -- don't enforce invariants on the order of simultaneous notes, so they may
    -- vary across renders.  'getPlayStates' does this.
    State -> [PlayState]
_playStates :: [PlayState]
    , State -> Maybe State
_effectState :: Maybe EffectC.State
    }

emptyState :: State
emptyState :: State
emptyState = [PlayState] -> Maybe State -> State
State [] forall a. Maybe a
Nothing

serializeState :: State -> Checkpoint.State
serializeState :: State -> State
serializeState = ByteString -> State
Checkpoint.State forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Serialize a => a -> ByteString
Serialize.encode

unserializeState :: Checkpoint.State -> Either Error State
unserializeState :: State -> Either Text State
unserializeState (Checkpoint.State ByteString
bytes) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first SamplePath -> Text
txt forall a b. (a -> b) -> a -> b
$ forall a. Serialize a => ByteString -> Either SamplePath a
Serialize.decode ByteString
bytes

getPlayStates :: [Playing] -> IO [PlayState]
getPlayStates :: [Playing] -> IO [PlayState]
getPlayStates = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Playing -> IO PlayState
_getState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn Playing -> Hash
_noteHash

instance Pretty State where
    format :: State -> Doc
format (State [PlayState]
play Maybe State
effect) = Doc -> [(Text, Doc)] -> Doc
Pretty.record Doc
"State"
        [ (Text
"playStates", forall a. Pretty a => a -> Doc
Pretty.format [PlayState]
play)
        , (Text
"effectState", forall a. Pretty a => a -> Doc
Pretty.format Maybe State
effect)
        ]

instance Serialize.Serialize State where
    put :: Putter State
put (State [PlayState]
plays Maybe State
effect) = forall a. Serialize a => Putter a
Serialize.put [PlayState]
plays forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
Serialize.put Maybe State
effect
    get :: Get State
get = [PlayState] -> Maybe State -> State
State forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
Serialize.get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
Serialize.get

data PlayState =
    -- | If there is no resampling, the state will be NoResample.  It's
    -- necessary to save that explicitly, so I can still line up notes with
    -- states in 'resumeSamples'.
    NoResample
    | Resample !ResampleState
    -- | There was a resample, but it's complete.  If this shows up, something
    -- is wrong, because 'pull' should have filtered out the Playing when
    -- it turned up short samples.
    | Complete
    deriving (PlayState -> PlayState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PlayState -> PlayState -> Bool
$c/= :: PlayState -> PlayState -> Bool
== :: PlayState -> PlayState -> Bool
$c== :: PlayState -> PlayState -> Bool
Eq, Int -> PlayState -> SamplePath -> SamplePath
[PlayState] -> SamplePath -> SamplePath
PlayState -> SamplePath
forall a.
(Int -> a -> SamplePath -> SamplePath)
-> (a -> SamplePath) -> ([a] -> SamplePath -> SamplePath) -> Show a
showList :: [PlayState] -> SamplePath -> SamplePath
$cshowList :: [PlayState] -> SamplePath -> SamplePath
show :: PlayState -> SamplePath
$cshow :: PlayState -> SamplePath
showsPrec :: Int -> PlayState -> SamplePath -> SamplePath
$cshowsPrec :: Int -> PlayState -> SamplePath -> SamplePath
Show)

instance Pretty PlayState where
    pretty :: PlayState -> Text
pretty PlayState
NoResample = Text
"NoResample"
    pretty PlayState
Complete = Text
"Complete"
    pretty (Resample ResampleState
state) = forall a. Pretty a => a -> Text
pretty ResampleState
state

instance Serialize.Serialize PlayState where
    put :: Putter PlayState
put PlayState
NoResample = Word8 -> PutM ()
Serialize.put_tag Word8
0
    put (Resample ResampleState
state) = Word8 -> PutM ()
Serialize.put_tag Word8
1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
Serialize.put ResampleState
state
    put PlayState
Complete = Word8 -> PutM ()
Serialize.put_tag Word8
2
    get :: Get PlayState
get = Get Word8
Serialize.get_tag forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Word8
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return PlayState
NoResample
        Word8
1 -> ResampleState -> PlayState
Resample forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
Serialize.get
        Word8
2 -> forall (m :: * -> *) a. Monad m => a -> m a
return PlayState
Complete
        Word8
n -> forall a. SamplePath -> Word8 -> Get a
Serialize.bad_tag SamplePath
"Render.PlayState" Word8
n

-- | The saved state of a note that had to resample.
data ResampleState = ResampleState {
    -- | I don't actually need this, but it makes the Pretty instance easier to
    -- read.
    ResampleState -> SamplePath
_filename :: !Sample.SamplePath
    -- | This is the position in the sample where the state was saved.
    , ResampleState -> Frames
_offset :: !Audio.Frames
    , ResampleState -> SavedState
_resampleState :: !Resample.SavedState
    } deriving (ResampleState -> ResampleState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResampleState -> ResampleState -> Bool
$c/= :: ResampleState -> ResampleState -> Bool
== :: ResampleState -> ResampleState -> Bool
$c== :: ResampleState -> ResampleState -> Bool
Eq, Int -> ResampleState -> SamplePath -> SamplePath
[ResampleState] -> SamplePath -> SamplePath
ResampleState -> SamplePath
forall a.
(Int -> a -> SamplePath -> SamplePath)
-> (a -> SamplePath) -> ([a] -> SamplePath -> SamplePath) -> Show a
showList :: [ResampleState] -> SamplePath -> SamplePath
$cshowList :: [ResampleState] -> SamplePath -> SamplePath
show :: ResampleState -> SamplePath
$cshow :: ResampleState -> SamplePath
showsPrec :: Int -> ResampleState -> SamplePath -> SamplePath
$cshowsPrec :: Int -> ResampleState -> SamplePath -> SamplePath
Show)

instance Pretty ResampleState where
    pretty :: ResampleState -> Text
pretty (ResampleState SamplePath
fname Frames
offset SavedState
state) =
        forall a. Pretty a => a -> Text
pretty (SamplePath -> SamplePath
FilePath.takeFileName SamplePath
fname) forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Frames
offset
            forall a. Semigroup a => a -> a -> a
<> Text
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty SavedState
state forall a. Semigroup a => a -> a -> a
<> Text
")"

instance Serialize.Serialize ResampleState where
    put :: Putter ResampleState
put (ResampleState SamplePath
a Frames
b SavedState
c) =
        forall a. Serialize a => Putter a
Serialize.put SamplePath
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
Serialize.put Frames
b forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Serialize a => Putter a
Serialize.put SavedState
c
    get :: Get ResampleState
get = SamplePath -> Frames -> SavedState -> ResampleState
ResampleState forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Serialize a => Get a
Serialize.get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
Serialize.get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Serialize a => Get a
Serialize.get


-- * effect

applyEffect :: Config -> Audio.Frames -> Maybe EffectC.State
    -> (EffectC.State -> IO ()) -> [Sample.Note]
    -> InstrumentEffect -> AUtil.Audio -> AUtil.Audio
applyEffect :: Config
-> Frames
-> Maybe State
-> (State -> IO ())
-> [Note]
-> InstrumentEffect
-> Audio
-> Audio
applyEffect Config
config Frames
start Maybe State
mbState State -> IO ()
notifyState [Note]
notes InstrumentEffect
effect =
    -- TODO warn if mbState is Nothing!
    Config
-> Patch
-> Maybe State
-> (State -> IO ())
-> Map Control Audio1
-> Audio
-> Audio
Effect.process Config
econfig (InstrumentEffect -> Patch
_effectPatch InstrumentEffect
effect) Maybe State
mbState State -> IO ()
notifyState forall {rate :: Nat}. Map Control (Audio (ResourceT IO) rate 1)
controls
    where
    econfig :: Config
econfig = Frames -> Frames -> Config
Effect.config (Config -> Frames
_blockSize Config
config) (Config -> Frames
_controlsPerBlock Config
config)
    controls :: Map Control (Audio (ResourceT IO) rate 1)
controls = forall (m :: * -> *) (rate :: Nat).
Monad m =>
Config
-> [Control] -> RealTime -> [Note] -> Map Control (Audio m rate 1)
renderControls Config
econfig
        (forall k a. Map k a -> [k]
Map.keys (forall ptr cptr. EffectT ptr cptr -> Map Control (cptr, Text)
Effect._controls (InstrumentEffect -> Patch
_effectPatch InstrumentEffect
effect)))
        (Frames -> RealTime
AUtil.toSeconds Frames
start)
        [Note]
notes

renderControls :: Monad m => Effect.Config -> [Control.Control] -> RealTime
    -> [Sample.Note] -> Map Control.Control (Audio.Audio m rate 1)
renderControls :: forall (m :: * -> *) (rate :: Nat).
Monad m =>
Config
-> [Control] -> RealTime -> [Note] -> Map Control (Audio m rate 1)
renderControls Config
config [Control]
controls RealTime
start [Note]
notes =
    forall (m :: * -> *) (rate :: Nat).
Monad m =>
Int -> RealTime -> [(Y, Y)] -> Audio m rate 1
RenderUtil.renderControl (Config -> Int
Effect.controlRate Config
config) RealTime
start forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    Frames -> [Control] -> [Note] -> Map Control [(Y, Y)]
extractControls (Config -> Frames
Effect._controlSize Config
config) [Control]
controls [Note]
notes

extractControls :: Audio.Frames -> [Control.Control] -> [Sample.Note]
    -> Map Control.Control [(Double, Double)]
extractControls :: Frames -> [Control] -> [Note] -> Map Control [(Y, Y)]
extractControls Frames
controlSize [Control]
controls [Note]
notes =
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Control]
controls (forall a b. (a -> b) -> [a] -> [b]
map Control -> [(Y, Y)]
get [Control]
controls)
    where
    get :: Control -> [(Y, Y)]
get Control
control = Frames -> Control -> [(RealTime, Map Control Signal)] -> [(Y, Y)]
RenderUtil.controlBreakpoints Frames
controlSize Control
control
        [ (Frames -> RealTime
AUtil.toSeconds (Note -> Frames
Sample.start Note
n), Note -> Map Control Signal
Sample.effectControls Note
n)
        | Note
n <- [Note]
notes
        ]


-- * util

prettyF :: Audio.Frames -> Text
prettyF :: Frames -> Text
prettyF Frames
frame = forall a. Pretty a => a -> Text
pretty Frames
frame forall a. Semigroup a => a -> a -> a
<> Text
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Frames -> RealTime
AUtil.toSeconds Frames
frame) forall a. Semigroup a => a -> a -> a
<> Text
")"


{- NOTE [audio-state]

    Whne I write an audio checkpoint, I have to write the state of the audio
    generators and processors.  I do this via @notifyState@ and @getState@
    functions, which are just wrappers around IORef.

    This is pretty indirect and confusing, but the reason I have to do it is an
    Audio.Audio stream is only an effectful lazy list of audio chunks, with no
    way to query its internal state.  So it would have to either return a
    "query state" callback (a "pull" model), or take an IORef pointer, which it
    will update with new state on each audio chunk (a "push" model).

    However, I think even the "query state" callback will turn into the IORef,
    because it will need to get the current state of the audio processing loop,
    which means someone in there will need to be a mutable pointer, updated
    each time through the loop.

    But IORefs, like all mutable variables, are hard to understand and don't
    compose well.  In the sampler case, Resample gets
    a 'Resample._notifyState', which the loop in 'render' reads via the
    '_getState' fields, and merges to a 'Checkpoint.State' (via
    'getPlayStates').  Then 'Checkpoint.write' reads that at the end of
    each chunk, in the callback from 'File.writeCheckpoints'.  Since this is
    the push model, I get a state for each block, but only use it on each
    chunk.  That's probably ok, since state is (dangerously) copy-free, and
    'State' is lazy.

    A way to get away from these IORefs entirely would be that Audio streams
    (IO (Maybe State), Vector Sample).  It would complicate all of the audio
    processing functions.  Many could just fmap over the vector though.  In
    fact, maybe it's safer, because it's accurately representing that if you
    split the block, you have to put the state on the first one, but not the
    second, or if you drop that part of the block, you no longer have its
    state.  See TODO non-copying state:.
-}