-- 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:. -}