-- Copyright 2016 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

-- | Offline sampler.
module Synth.Sampler.SamplerIm (main) where
import qualified Control.Concurrent.Async as Async
import qualified Control.Exception as Exception
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.IO as Text.IO

import qualified System.Console.GetOpt as GetOpt
import qualified System.Directory as Directory
import qualified System.Environment as Environment
import qualified System.Exit as Exit
import qualified System.FilePath as FilePath
import           System.FilePath ((</>))
import qualified System.Process as Process

import qualified Text.Read as Read

import qualified Util.Audio.Audio as Audio
import qualified Util.Audio.Resample as Resample
import qualified Util.Limit as Limit
import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.PPrint as PPrint
import qualified Util.Pretty as Pretty
import qualified Util.Texts as Texts
import qualified Util.Thread as Thread

import qualified Cmd.Instrument.ImInst as ImInst
import qualified Derive.Attrs as Attrs
import qualified Derive.ScoreT as ScoreT
import qualified Perform.RealTime as RealTime
import qualified Synth.Faust.Effect as Effect
import qualified Synth.Faust.EffectC as EffectC
import qualified Synth.Lib.AUtil as AUtil
import qualified Synth.Lib.Checkpoint as Checkpoint
import qualified Synth.Sampler.Calibrate as Calibrate
import qualified Synth.Sampler.Patch as Patch
import qualified Synth.Sampler.Patch.Rambat as Rambat
import qualified Synth.Sampler.Patch.Wayang as Wayang
import qualified Synth.Sampler.PatchDb as PatchDb
import qualified Synth.Sampler.Render as Render
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


main :: IO ()
main :: IO ()
main = do
    -- There will be one open file per overlapping sample, and instruments
    -- render in parallel.
    Resource -> Integer -> IO ()
Limit.set Resource
Limit.ResourceOpenFiles Integer
4096
    [NonNull Char]
args <- IO [NonNull Char]
Environment.getArgs
    ([Flag]
flags, [NonNull Char]
args) <- case forall a.
ArgOrder a
-> [OptDescr a]
-> [NonNull Char]
-> ([a], [NonNull Char], [NonNull Char])
GetOpt.getOpt forall a. ArgOrder a
GetOpt.Permute [OptDescr Flag]
options [NonNull Char]
args of
        ([Flag]
flags, [NonNull Char]
args, []) -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Flag]
flags, [NonNull Char]
args)
        ([Flag]
_, [NonNull Char]
_, [NonNull Char]
errs) -> forall {b}. NonNull Char -> IO b
usage forall a b. (a -> b) -> a -> b
$ NonNull Char
"flag errors:\n" forall a. [a] -> [a] -> [a]
++ forall a. Monoid a => a -> [a] -> a
Lists.join NonNull Char
", " [NonNull Char]
errs
    NonNull Char
logFname <- NonNull Char -> IO (NonNull Char)
Config.getLogFilename NonNull Char
"sampler.log"
    Handle
logHdl <- NonNull Char -> IO Handle
Log.rotate NonNull Char
logFname
    (State -> State) -> IO ()
Log.configure forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Log.State
        { state_write_msg :: Msg -> IO ()
state_write_msg = Handle -> Msg -> IO ()
Log.write_formatted Handle
logHdl
        , state_priority :: Priority
state_priority = if Flag
Debug forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags then Priority
Log.Debug else Priority
Log.Notice
        }
    let quality :: Quality
quality = forall a. a -> Maybe a -> a
fromMaybe Quality
defaultQuality forall a b. (a -> b) -> a -> b
$
            forall a. [a] -> Maybe a
Lists.last [Quality
quality | Quality Quality
quality <- [Flag]
flags]
        dumpRange :: Maybe (X, X)
dumpRange = forall a. [a] -> Maybe a
Lists.head [(X
start, X
end) | DumpRange X
start X
end <- [Flag]
flags]
        dumpTracks :: Maybe (Set TrackId)
dumpTracks = forall a. [a] -> Maybe a
Lists.head [Set TrackId
tracks | DumpTracks Set TrackId
tracks <- [Flag]
flags]
        emitProgress :: Bool
emitProgress = Flag
Progress forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags
    NonNull Char
imDir <- Config -> NonNull Char
Config.imDir forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Config
Config.getConfig
    let calibrateDir :: NonNull Char
calibrateDir = NonNull Char
imDir NonNull Char -> NonNull Char -> NonNull Char
</> NonNull Char
"calibrate"
    case [NonNull Char]
args of
        -- Listen for samples that have silence at the beginning.
        [NonNull Char
"calibrate-starts"] -> do
            let (Sample
reference, [[Sample]]
samples) = (Sample, [[Sample]])
Wayang.checkStarts
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (NonNull Char -> [Sample] -> IO ()
Calibrate.renderStarts NonNull Char
calibrateDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++[Sample
reference]))
                [[Sample]]
samples
        -- Play notes in a dynamic range to calibrate relative dynamics.
        NonNull Char
"calibrate-by" : NonNull Char
by : NonNull Char
patch : NonNull Char
attrs : [NonNull Char]
pitches -> do
            let dur :: X
dur = X
1
            let vars :: Y
vars = Y
4
            let dyns :: Y
dyns = Y
16
            let notes :: [Note]
notes = By -> Text -> X -> [Attributes] -> [Text] -> Y -> Y -> [Note]
Calibrate.sequence (NonNull Char -> By
parseBy NonNull Char
by) (NonNull Char -> Text
txt NonNull Char
patch) X
dur
                    (Text -> [Attributes]
parseAttrs (NonNull Char -> Text
txt NonNull Char
attrs)) (forall a b. (a -> b) -> [a] -> [b]
map NonNull Char -> Text
txt [NonNull Char]
pitches) Y
vars Y
dyns
            Db -> [Note] -> IO ()
dumpSamples Db
PatchDb.db [Note]
notes
            Bool -> Db -> Quality -> [Note] -> NonNull Char -> IO ()
process Bool
emitProgress Db
PatchDb.db Quality
quality [Note]
notes NonNull Char
calibrateDir
            NonNull Char -> IO ()
Process.callCommand forall a b. (a -> b) -> a -> b
$ [NonNull Char] -> NonNull Char
unwords
                [ NonNull Char
"sox", NonNull Char
"-V1", NonNull Char
calibrateDir NonNull Char -> NonNull Char -> NonNull Char
</> NonNull Char
"inst/*.wav"
                , NonNull Char
calibrateDir NonNull Char -> NonNull Char -> NonNull Char
</> NonNull Char
"out.wav"
                ]
        [NonNull Char
"calibrate-dyn-raw"] -> do
            -- Directly play the underlying samples.
            [NonNull Char]
fnames <- forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(NonNull Char, Map Text Text)]
calibrateFnames
            let dur :: X
dur = X
1
            NonNull Char -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ [NonNull Char] -> NonNull Char
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(X
t, NonNull Char
fn) -> forall a. Pretty a => a -> NonNull Char
prettys X
t forall a. Semigroup a => a -> a -> a
<> NonNull Char
" - " forall a. Semigroup a => a -> a -> a
<> NonNull Char
fn) forall a b. (a -> b) -> a -> b
$
                forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Num a => a -> a -> [a]
Lists.range_ X
0 X
dur) (forall a b. (a -> b) -> [a] -> [b]
map NonNull Char -> NonNull Char
sampleName [NonNull Char]
fnames)
            NonNull Char -> X -> [NonNull Char] -> IO ()
Calibrate.renderSequence NonNull Char
calibrateDir X
dur [NonNull Char]
fnames
        [NonNull Char
"dump", NonNull Char
notesFilename] ->
            Bool
-> Maybe (X, X) -> Maybe (Set TrackId) -> NonNull Char -> IO ()
dumpNotes Bool
False Maybe (X, X)
dumpRange Maybe (Set TrackId)
dumpTracks NonNull Char
notesFilename
        [NonNull Char
"dumps", NonNull Char
notesFilename] ->
            Bool
-> Maybe (X, X) -> Maybe (Set TrackId) -> NonNull Char -> IO ()
dumpNotes Bool
True Maybe (X, X)
dumpRange Maybe (Set TrackId)
dumpTracks NonNull Char
notesFilename
        [NonNull Char
notesFilename, NonNull Char
outputDir] -> do
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords
                [Text
"sampler-im", NonNull Char -> Text
txt NonNull Char
notesFilename, NonNull Char -> Text
txt NonNull Char
outputDir]
            [Note]
notes <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Text
pretty) forall (m :: * -> *) a. Monad m => a -> m a
return
                forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NonNull Char -> IO (Either UnserializeError [Note])
Note.unserialize NonNull Char
notesFilename
            Bool -> Db -> Quality -> [Note] -> NonNull Char -> IO ()
process Bool
emitProgress Db
PatchDb.db Quality
quality [Note]
notes NonNull Char
outputDir
        [NonNull Char]
_ -> forall {b}. NonNull Char -> IO b
usage NonNull Char
""
    where
    dumpNotes :: Bool
-> Maybe (X, X) -> Maybe (Set TrackId) -> NonNull Char -> IO ()
dumpNotes Bool
useShow Maybe (X, X)
range Maybe (Set TrackId)
tracks NonNull Char
notesFilename =
        Bool
-> Maybe (X, X) -> Maybe (Set TrackId) -> Db -> [Note] -> IO ()
dump Bool
useShow Maybe (X, X)
range Maybe (Set TrackId)
tracks Db
PatchDb.db
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Text
pretty) forall (m :: * -> *) a. Monad m => a -> m a
return
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NonNull Char -> IO (Either UnserializeError [Note])
Note.unserialize NonNull Char
notesFilename
    usage :: NonNull Char -> IO b
usage NonNull Char
msg = do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null NonNull Char
msg) forall a b. (a -> b) -> a -> b
$
            NonNull Char -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ NonNull Char
"ERROR: " forall a. [a] -> [a] -> [a]
++ NonNull Char
msg
        NonNull Char -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ forall a. NonNull Char -> [OptDescr a] -> NonNull Char
GetOpt.usageInfo
            ([NonNull Char] -> NonNull Char
unlines
                [ NonNull Char
"sampler-im [ flags ] path/to/notes path/to/output/dir"
                , NonNull Char
"sampler-im [ flags ] dump[s] path/to/notes"
                , NonNull Char
"sampler-im calibrate-by (Pitch|Dyn) reyong +open 4e 4u 4a 5i"
                ])
            [OptDescr Flag]
options
        forall a. IO a
Exit.exitFailure

parseAttrs :: Text -> [Attrs.Attributes]
parseAttrs :: Text -> [Attributes]
parseAttrs =
    forall a b. (a -> b) -> [a] -> [b]
map ([Text] -> Attributes
Attrs.attrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=Text
"") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack => Text -> Text -> [Text]
Text.splitOn Text
"+") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack => Text -> Text -> [Text]
Text.splitOn Text
","

parseBy :: String -> Calibrate.By
parseBy :: NonNull Char -> By
parseBy NonNull Char
str = forall a. a -> Maybe a -> a
fromMaybe (forall a. Stack => NonNull Char -> a
error (NonNull Char
"not a By: " forall a. Semigroup a => a -> a -> a
<> NonNull Char
str)) (forall a. Read a => NonNull Char -> Maybe a
Read.readMaybe NonNull Char
str)

calibrateFnames :: IO [(FilePath, Map Calibrate.Axis Text)]
calibrateFnames :: IO [(NonNull Char, Map Text Text)]
calibrateFnames =
    -- Calibrate.select [("pitch", "3a"), ("art", "Calung"), ("dyn", "PP")] <$>
    forall b a.
Eq b =>
[(Text, b)] -> [(a, Map Text b)] -> [(a, Map Text b)]
Calibrate.select [(Text
"pitch", Text
"3a"), (Text
"art", Text
"Calung")] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    IO [(NonNull Char, Map Text Text)]
Rambat.getVariations

data Flag =
    Quality Resample.Quality
    | Debug
    | DumpRange !RealTime !RealTime
    | DumpTracks !(Set Id.TrackId)
    | Progress
    deriving (Flag -> Flag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flag -> Flag -> Bool
$c/= :: Flag -> Flag -> Bool
== :: Flag -> Flag -> Bool
$c== :: Flag -> Flag -> Bool
Eq, ChunkNum -> Flag -> NonNull Char -> NonNull Char
[Flag] -> NonNull Char -> NonNull Char
Flag -> NonNull Char
forall a.
(ChunkNum -> a -> NonNull Char -> NonNull Char)
-> (a -> NonNull Char)
-> ([a] -> NonNull Char -> NonNull Char)
-> Show a
showList :: [Flag] -> NonNull Char -> NonNull Char
$cshowList :: [Flag] -> NonNull Char -> NonNull Char
show :: Flag -> NonNull Char
$cshow :: Flag -> NonNull Char
showsPrec :: ChunkNum -> Flag -> NonNull Char -> NonNull Char
$cshowsPrec :: ChunkNum -> Flag -> NonNull Char -> NonNull Char
Show)

readEnum :: (Show a, Enum a, Bounded a) => String -> a
readEnum :: forall a. (Show a, Enum a, Bounded a) => NonNull Char -> a
readEnum NonNull Char
str =
    forall a. a -> Maybe a -> a
fromMaybe (forall a. Stack => NonNull Char -> a
error (forall a. Show a => a -> NonNull Char
show NonNull Char
str forall a. Semigroup a => a -> a -> a
<> NonNull Char
" not in: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> NonNull Char
show (forall k a. Map k a -> [k]
Map.keys Map (NonNull Char) a
toVal))) forall a b. (a -> b) -> a -> b
$
        forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NonNull Char
str Map (NonNull Char) a
toVal
    where
    toVal :: Map (NonNull Char) a
toVal = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a k. (a -> k) -> [a] -> [(k, a)]
Lists.keyOn forall a. Show a => a -> NonNull Char
show [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound]

defaultQuality :: Resample.Quality
defaultQuality :: Quality
defaultQuality = Quality
Resample.SincMediumQuality

options :: [GetOpt.OptDescr Flag]
options :: [OptDescr Flag]
options =
    [ forall a.
NonNull Char
-> [NonNull Char] -> ArgDescr a -> NonNull Char -> OptDescr a
GetOpt.Option [] [NonNull Char
"quality"]
        (forall a. (NonNull Char -> a) -> NonNull Char -> ArgDescr a
GetOpt.ReqArg (Quality -> Flag
Quality forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Show a, Enum a, Bounded a) => NonNull Char -> a
readEnum) (forall a. Show a => a -> NonNull Char
show Quality
defaultQuality))
        (NonNull Char
"resample quality: "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> NonNull Char
show [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound :: Resample.Quality])
    , forall a.
NonNull Char
-> [NonNull Char] -> ArgDescr a -> NonNull Char -> OptDescr a
GetOpt.Option [] [NonNull Char
"range"] (forall a. (NonNull Char -> a) -> NonNull Char -> ArgDescr a
GetOpt.ReqArg NonNull Char -> Flag
readDumpRange NonNull Char
"start,end")
        NonNull Char
"dump events in this time range"
    , forall a.
NonNull Char
-> [NonNull Char] -> ArgDescr a -> NonNull Char -> OptDescr a
GetOpt.Option [] [NonNull Char
"tracks"]
        (forall a. (NonNull Char -> a) -> NonNull Char -> ArgDescr a
GetOpt.ReqArg NonNull Char -> Flag
readTracks NonNull Char
"track-id,track-id,...")
        NonNull Char
"dump events in from these tracks, by stack"
    , forall a.
NonNull Char
-> [NonNull Char] -> ArgDescr a -> NonNull Char -> OptDescr a
GetOpt.Option [] [NonNull Char
"progress"] (forall a. a -> ArgDescr a
GetOpt.NoArg Flag
Progress) NonNull Char
"emit json progress"
    , forall a.
NonNull Char
-> [NonNull Char] -> ArgDescr a -> NonNull Char -> OptDescr a
GetOpt.Option [] [NonNull Char
"debug"] (forall a. a -> ArgDescr a
GetOpt.NoArg Flag
Debug) NonNull Char
"debug logging"
    ]

readDumpRange :: String -> Flag
readDumpRange :: NonNull Char -> Flag
readDumpRange NonNull Char
s = case forall a. Eq a => NonNull a -> NonNull a -> NonNull (NonNull a)
Lists.split NonNull Char
"," NonNull Char
s of
    [NonNull Char
start, NonNull Char
end]
        | Just X
start <- forall a. Read a => NonNull Char -> Maybe a
Read.readMaybe NonNull Char
start, Just X
end <- forall a. Read a => NonNull Char -> Maybe a
Read.readMaybe NonNull Char
end ->
            X -> X -> Flag
DumpRange X
start X
end
    [NonNull Char]
_ -> forall a. Stack => NonNull Char -> a
error forall a b. (a -> b) -> a -> b
$ NonNull Char
"can't parse: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> NonNull Char
show NonNull Char
s

readTracks :: String -> Flag
readTracks :: NonNull Char -> Flag
readTracks NonNull Char
s =
    Set TrackId -> Flag
DumpTracks forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Ident a => Text -> a
readId forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack => Text -> Text -> [Text]
Text.splitOn Text
"," forall a b. (a -> b) -> a -> b
$ NonNull Char -> Text
Text.pack NonNull Char
s
    where
    readId :: Text -> a
readId Text
w = forall a. a -> Maybe a -> a
fromMaybe (forall a. Stack => NonNull Char -> a
error forall a b. (a -> b) -> a -> b
$ NonNull Char
"can't parse TrackId: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> NonNull Char
show Text
w) forall a b. (a -> b) -> a -> b
$
        forall a. Ident a => Text -> Maybe a
Id.text_ident Text
w

type Error = Text

-- * dump

-- | Show the final Sample.Notes, which would have been rendered.
dump :: Bool -> Maybe (RealTime, RealTime) -> Maybe (Set Id.TrackId)
    -> Patch.Db -> [Note.Note] -> IO ()
dump :: Bool
-> Maybe (X, X) -> Maybe (Set TrackId) -> Db -> [Note] -> IO ()
dump Bool
useShow Maybe (X, X)
range Maybe (Set TrackId)
tracks Db
db [Note]
notes = do
    [(Patch, (Instrument, [(Note, Note)]))]
samples <- Db -> [Note] -> IO [(Patch, (Instrument, [(Note, Note)]))]
convertNotes Db
db [Note]
notes
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Patch, (Instrument, [(Note, Note)]))]
samples forall a b. (a -> b) -> a -> b
$ \(Patch
patch, (Instrument
inst, [(Note, Note)]
sampleNotes)) -> do
        Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"patch: " forall a. Semigroup a => a -> a -> a
<> Patch -> Text
Patch._name Patch
patch
            forall a. Semigroup a => a -> a -> a
<> Text
", inst: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Instrument
inst forall a. Semigroup a => a -> a -> a
<> Text
":"
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
False forall a b. (a -> b) -> a -> b
$ -- maybe I'll want this again someday
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {a} {a} {a} {a}.
(Pretty a, Pretty a, Pretty a, Pretty a) =>
(a, a, (a, a)) -> IO ()
putHash forall a b. (a -> b) -> a -> b
$ [Note] -> [(X, X, (Hash, [Hash]))]
dumpHashes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Note, Note)]
sampleNotes
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Note, Note) -> IO ()
putNote forall a b. (a -> b) -> a -> b
$
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall a. Set TrackId -> [(Note, a)] -> [(Note, a)]
inTracks Maybe (Set TrackId)
tracks forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall a. (X, X) -> [(Note, a)] -> [(Note, a)]
inRange Maybe (X, X)
range [(Note, Note)]
sampleNotes
    where
    putNote :: (Note, Note) -> IO ()
putNote (Note
note, Note
sample)
        | Bool
useShow = forall a. Show a => a -> IO ()
PPrint.pprint Note
sample
        | Bool
otherwise = Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$
            forall a. (a -> a) -> [a] -> [a]
Lists.mapTail (ChunkNum -> Text -> Text
Text.drop ChunkNum
4) forall a b. (a -> b) -> a -> b
$ -- dedent
            forall a. (a -> a) -> [a] -> [a]
Lists.mapHead (Note -> Note -> Text -> Text
annotate Note
note Note
sample) forall a b. (a -> b) -> a -> b
$ Text -> [Text]
Text.lines forall a b. (a -> b) -> a -> b
$
            forall a. Pretty a => a -> Text
Pretty.formatted Note
sample
    annotate :: Note -> Note -> Text -> Text
annotate Note
note Note
sample Text
line = [Text] -> Text
Text.unwords
        [ Text
line, forall a. Pretty a => a -> Text
pretty X
s, Text
"+", forall a. Pretty a => a -> Text
pretty X
dur, Text
"=>", forall a. Pretty a => a -> Text
pretty (X
sforall a. Num a => a -> a -> a
+X
dur)
        , Text
"[orig:", forall a. Pretty a => a -> Text
pretty (Note -> X
Note.start Note
note, Note -> X
Note.duration Note
note)
        , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"<no-track>" forall a. Ident a => a -> Text
Id.ident_text (Note -> Maybe TrackId
Note.trackId Note
note)
        , forall a. Pretty a => a -> Text
pretty (Note -> Instrument
Note.instrument Note
note) forall a. Semigroup a => a -> a -> a
<> Text
"]"
        ]
        where
        s :: X
s = Frames -> X
AUtil.toSeconds forall a b. (a -> b) -> a -> b
$ Note -> Frames
Sample.start Note
sample
        dur :: X
dur = Frames -> X
AUtil.toSeconds forall a b. (a -> b) -> a -> b
$ Note -> Frames
Sample.duration Note
sample
    putHash :: (a, a, (a, a)) -> IO ()
putHash (a
start, a
end, (a
hash, a
hashes)) = Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$
        forall a. Pretty a => a -> Text
pretty a
start forall a. Semigroup a => a -> a -> a
<> Text
"--" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty a
end forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty a
hash forall a. Semigroup a => a -> a -> a
<> Text
" "
        forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty a
hashes

-- | Version of 'dump' with just start and sample filename.
dumpSamples :: Patch.Db -> [Note.Note] -> IO ()
dumpSamples :: Db -> [Note] -> IO ()
dumpSamples Db
db [Note]
notes = do
    [(Patch, (Instrument, [(Note, Note)]))]
samples <- Db -> [Note] -> IO [(Patch, (Instrument, [(Note, Note)]))]
convertNotes Db
db [Note]
notes
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Patch, (Instrument, [(Note, Note)]))]
samples forall a b. (a -> b) -> a -> b
$ \(Patch
_, (Instrument
_, [(Note, Note)]
sampleNotes)) ->
        Text -> IO ()
Text.IO.putStr forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$ ChunkNum -> [[Text]] -> [Text]
Texts.columns ChunkNum
2 forall a b. (a -> b) -> a -> b
$
            [Text
"time", Text
"sample", Text
"env"] forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Note -> [Text]
fmt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Note, Note)]
sampleNotes
    where
    fmt :: Note -> [Text]
fmt Note
note =
        [ X -> Text
RealTime.show_units forall a b. (a -> b) -> a -> b
$ Frames -> X
AUtil.toSeconds (Note -> Frames
Sample.start Note
note)
        , NonNull Char -> Text
txt forall a b. (a -> b) -> a -> b
$ NonNull Char -> NonNull Char
sampleName (Sample -> NonNull Char
Sample.filename Sample
sample)
        , forall a. Pretty a => a -> Text
pretty forall a b. (a -> b) -> a -> b
$ forall {k} (kind :: k). Signal kind -> X -> Y
Signal.at (Sample -> Signal
Sample.envelope Sample
sample) X
start
        ]
        where
        start :: X
start = Frames -> X
AUtil.toSeconds (Note -> Frames
Sample.start Note
note)
        sample :: Sample
sample = Note -> Sample
Sample.sample Note
note

sampleName :: FilePath -> FilePath
sampleName :: NonNull Char -> NonNull Char
sampleName = [NonNull Char] -> NonNull Char
FilePath.joinPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ChunkNum -> [a] -> [a]
Lists.takeEnd ChunkNum
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonNull Char -> [NonNull Char]
FilePath.splitPath

convertNotes :: Patch.Db -> [Note.Note]
    -> IO [(Patch.Patch, (ScoreT.Instrument, [(Note.Note, Sample.Note)]))]
convertNotes :: Db -> [Note] -> IO [(Patch, (Instrument, [(Note, Note)]))]
convertNotes Db
db [Note]
notes =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Note] -> [(Text, [(Instrument, [Note])])]
byPatchInst [Note]
notes) forall a b. (a -> b) -> a -> b
$ \(Text
patchName, [(Instrument, [Note])]
notes) ->
    Db -> Text -> IO (Maybe (Patch, Maybe InstrumentEffect))
getPatch Db
db Text
patchName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe (Patch, Maybe InstrumentEffect)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just (Patch
patch, Maybe InstrumentEffect
mbEffect) -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map (Patch
patch,)) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Instrument, [Note])]
notes forall a b. (a -> b) -> a -> b
$
            \(Instrument
inst, [Note]
notes) -> do
                let converted :: [(Either Text Sample, [Msg], Note)]
converted = Db -> Patch -> [Note] -> [(Either Text Sample, [Msg], Note)]
convert Db
db Patch
patch [Note]
notes
                [Maybe Note]
sampleNotes <- (Payload -> IO ())
-> Maybe InstrumentEffect
-> [(Either Text Sample, [Msg], Note)]
-> IO [Maybe Note]
makeSampleNotes Payload -> IO ()
emit Maybe InstrumentEffect
mbEffect [(Either Text Sample, [Msg], Note)]
converted
                forall (m :: * -> *) a. Monad m => a -> m a
return
                    ( Instrument
inst
                    , [ (Note
note, Note
snote)
                      | ((Either Text Sample
_, [Msg]
_, Note
note), Just Note
snote) <- forall a b. [a] -> [b] -> [(a, b)]
zip [(Either Text Sample, [Msg], Note)]
converted [Maybe Note]
sampleNotes
                      ]
                    )
    where
    emit :: Payload -> IO ()
emit = \case
        Config.Warn Stack
_ Text
err -> Text -> IO ()
put Text
err
        Config.Failure Text
err -> Text -> IO ()
put Text
err
        Payload
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        where put :: Text -> IO ()
put = Text -> IO ()
Text.IO.putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"warning while converting: "<>)

inRange :: (RealTime, RealTime) -> [(Note.Note, a)] -> [(Note.Note, a)]
inRange :: forall a. (X, X) -> [(Note, a)] -> [(Note, a)]
inRange (X
start, X
end) = forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a -> b) -> a -> b
$ \(Note
n, a
_) ->
    Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Note -> X
Note.start Note
n forall a. Ord a => a -> a -> Bool
< X
start Bool -> Bool -> Bool
|| Note -> X
Note.start Note
n forall a. Ord a => a -> a -> Bool
>= X
end
    -- This checks if the note start is in the range, not the note extent,
    -- because that's how LPerf works.

inTracks :: Set Id.TrackId -> [(Note.Note, a)] -> [(Note.Note, a)]
inTracks :: forall a. Set TrackId -> [(Note, a)] -> [(Note, a)]
inTracks Set TrackId
tracks = forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a -> b) -> a -> b
$ \(Note
n, a
_) ->
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Ord a => a -> Set a -> Bool
`Set.member` Set TrackId
tracks) (Note -> Maybe TrackId
Note.trackId Note
n)

dumpHashes :: [Sample.Note] -> [(RealTime, RealTime, (Note.Hash, [Note.Hash]))]
dumpHashes :: [Note] -> [(X, X, (Hash, [Hash]))]
dumpHashes [Note]
notes =
    forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 (forall a. Num a => a -> a -> [a]
Lists.range_ X
0 X
size) (forall a. ChunkNum -> [a] -> [a]
drop ChunkNum
1 (forall a. Num a => a -> a -> [a]
Lists.range_ X
0 X
size)) [(Hash, [Hash])]
hashes
    where
    size :: X
size = Frames -> X
AUtil.toSeconds Frames
Config.chunkSize
    hashes :: [(Hash, [Hash])]
hashes = forall a k. (a -> k) -> [a] -> [(k, a)]
Lists.keyOn forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
        X -> X -> [Span] -> [[Hash]]
Checkpoint.overlappingHashes X
0 X
size forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map Note -> Span
Render.toSpan [Note]
notes


-- * process

process :: Bool -> Patch.Db -> Resample.Quality -> [Note.Note] -> FilePath
    -> IO ()
process :: Bool -> Db -> Quality -> [Note] -> NonNull Char -> IO ()
process Bool
emitProgress Db
db Quality
quality [Note]
allNotes NonNull Char
outputDir
    | Note
n : [Note]
_ <- [Note]
allNotes, Note -> X
Note.start Note
n forall a. Ord a => a -> a -> Bool
< X
0 =
        forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO forall a b. (a -> b) -> a -> b
$ Text
"notes start <0: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Note
n
    | Bool
otherwise = forall (f :: * -> *) a b. Foldable f => f a -> (a -> IO b) -> IO ()
Async.forConcurrently_ ([Note] -> [(Text, [(Instrument, [Note])])]
byPatchInst [Note]
allNotes) forall a b. (a -> b) -> a -> b
$
        \(Text
patchName, [(Instrument, [Note])]
instNotes) ->
            forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM (Db -> Text -> IO (Maybe (Patch, Maybe InstrumentEffect))
getPatch Db
db Text
patchName) forall a b. (a -> b) -> a -> b
$ \(Patch
patch, Maybe InstrumentEffect
mbEffect) ->
                forall (f :: * -> *) a b. Foldable f => f a -> (a -> IO b) -> IO ()
Async.forConcurrently_ [(Instrument, [Note])]
instNotes forall a b. (a -> b) -> a -> b
$ \(Instrument
inst, [Note]
notes) ->
                    Patch -> Instrument -> Maybe InstrumentEffect -> [Note] -> IO ()
processInst Patch
patch Instrument
inst Maybe InstrumentEffect
mbEffect [Note]
notes
    where
    processInst :: Patch -> Instrument -> Maybe InstrumentEffect -> [Note] -> IO ()
processInst Patch
patch Instrument
inst Maybe InstrumentEffect
mbEffect [Note]
notes =
        (Payload -> IO ())
-> Set TrackId
-> Config
-> NonNull Char
-> Instrument
-> Maybe InstrumentEffect
-> [Note]
-> IO ()
realize Payload -> IO ()
emit Set TrackId
trackIds Config
config NonNull Char
outputDir Instrument
inst Maybe InstrumentEffect
mbEffect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
Maybe.catMaybes
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Payload -> IO ())
-> Maybe InstrumentEffect
-> [(Either Text Sample, [Msg], Note)]
-> IO [Maybe Note]
makeSampleNotes Payload -> IO ()
emit Maybe InstrumentEffect
mbEffect (Db -> Patch -> [Note] -> [(Either Text Sample, [Msg], Note)]
convert Db
db Patch
patch [Note]
notes)
        where
        trackIds :: Set TrackId
trackIds = [Note] -> Set TrackId
trackIdsOf [Note]
notes
        emit :: Payload -> IO ()
emit = Set TrackId -> Instrument -> Payload -> IO ()
emitMessage Set TrackId
trackIds Instrument
inst
    config :: Config
config = (Quality -> Config
Render.defaultConfig Quality
quality)
        { _emitProgress :: Bool
Render._emitProgress = Bool
emitProgress }
    emitMessage :: Set TrackId -> Instrument -> Payload -> IO ()
emitMessage Set TrackId
trackIds Instrument
inst Payload
payload
        | Bool
emitProgress = Stack => Message -> IO ()
Config.emitMessage forall a b. (a -> b) -> a -> b
$ Config.Message
            { _blockId :: BlockId
_blockId = NonNull Char -> BlockId
Config.pathToBlockId (NonNull Char
outputDir NonNull Char -> NonNull Char -> NonNull Char
</> NonNull Char
"dummy")
            , _trackIds :: Set TrackId
_trackIds = Set TrackId
trackIds
            , _instrument :: Instrument
_instrument = Instrument
inst
            , _payload :: Payload
_payload = Payload
payload
            }
        | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    trackIdsOf :: [Note] -> Set TrackId
trackIdsOf = forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Note -> Maybe TrackId
Note.trackId


getPatch :: Patch.Db -> Note.PatchName
    -> IO (Maybe (Patch.Patch, Maybe Render.InstrumentEffect))
getPatch :: Db -> Text -> IO (Maybe (Patch, Maybe InstrumentEffect))
getPatch Db
db Text
name = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name (Db -> Map Text Patch
Patch._patches Db
db) of
    Maybe Patch
Nothing -> do
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"patch not found: " forall a. Semigroup a => a -> a -> a
<> Text
name
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Just Patch
patch | Just {} <- Patch -> Maybe Text
ImInst.patch_dummy (Patch -> Patch
Patch._karyaPatch Patch
patch) -> do
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"dummy patch: " forall a. Semigroup a => a -> a -> a
<> Text
name
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Just Patch
patch -> case Patch -> Maybe EffectConfig
Patch._effect Patch
patch of
        Maybe EffectConfig
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Patch
patch, forall a. Maybe a
Nothing)
        Just EffectConfig
effectConf -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
ename Map Text (Either Text Patch)
EffectC.patches of
            Maybe (Either Text Patch)
Nothing -> do
                forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
name forall a. Semigroup a => a -> a -> a
<> Text
": effect not found: " forall a. Semigroup a => a -> a -> a
<> Text
ename
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just (Left Text
err) -> do
                forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
name forall a. Semigroup a => a -> a -> a
<> Text
": effect " forall a. Semigroup a => a -> a -> a
<> Text
ename forall a. Semigroup a => a -> a -> a
<> Text
" error: " forall a. Semigroup a => a -> a -> a
<> Text
err
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
            Just (Right Patch
effect)
                | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
warnings) -> do
                    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text
name forall a. Semigroup a => a -> a -> a
<> Text
": ") <>)) [Text]
warnings
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just
                    ( Patch
patch
                    , forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Render.InstrumentEffect
                        { _effectPatch :: Patch
_effectPatch = Patch
effect
                        , _effectConfig :: EffectConfig
_effectConfig = EffectConfig
effectConf
                        }
                    )
                where
                warnings :: [Text]
warnings = Patch -> Set Control -> EffectConfig -> [Text]
Patch.checkControls Patch
patch
                    (forall k a. Map k a -> Set k
Map.keysSet (forall ptr cptr. EffectT ptr cptr -> Map Control (cptr, Text)
Effect._controls Patch
effect)) EffectConfig
effectConf
            where ename :: Text
ename = EffectConfig -> Text
Patch._effectName EffectConfig
effectConf

byPatchInst :: [Note.Note]
    -> [(Note.PatchName, [(ScoreT.Instrument, [Note.Note])])]
byPatchInst :: [Note] -> [(Text, [(Instrument, [Note])])]
byPatchInst = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Lists.keyedGroupSort Note -> Instrument
Note.instrument))
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Lists.keyedGroupSort Note -> Text
Note.patch

convert :: Patch.Db -> Patch.Patch -> [Note.Note]
    -> [(Either Error Sample.Sample, [Log.Msg], Note.Note)]
convert :: Db -> Patch -> [Note] -> [(Either Text Sample, [Msg], Note)]
convert Db
db Patch
patch =
    forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a} {c}.
(Either a (Sample, [a]), c) -> (Either a Sample, [a], c)
update forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k. (a -> k) -> [a] -> [(k, a)]
Lists.keyOn (Patch -> Note -> Either Text (Sample, [Msg])
Patch.convert Patch
patch) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Patch -> [Note] -> [Note]
Patch._preprocess Patch
patch
    where
    update :: (Either a (Sample, [a]), c) -> (Either a Sample, [a], c)
update (Right (Sample
sample, [a]
logs), c
note) =
        ( forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ (NonNull Char -> NonNull Char) -> Sample -> Sample
Sample.modifyFilename (NonNull Char
patchDir</>) Sample
sample
        , [a]
logs
        , c
note
        )
    update (Left a
err, c
note) = (forall a b. a -> Either a b
Left a
err, [], c
note)
    patchDir :: NonNull Char
patchDir = Db -> NonNull Char
Patch._rootDir Db
db NonNull Char -> NonNull Char -> NonNull Char
</> Patch -> NonNull Char
Patch._dir Patch
patch

makeSampleNotes :: (Config.Payload -> IO ())
    -> Maybe Render.InstrumentEffect
    -> [(Either Error Sample.Sample, [Log.Msg], Note.Note)]
    -> IO [Maybe Sample.Note]
makeSampleNotes :: (Payload -> IO ())
-> Maybe InstrumentEffect
-> [(Either Text Sample, [Msg], Note)]
-> IO [Maybe Note]
makeSampleNotes Payload -> IO ()
emitMessage Maybe InstrumentEffect
mbEffect [(Either Text Sample, [Msg], Note)]
converted =
    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 ((Payload -> IO ())
-> Maybe InstrumentEffect
-> X
-> (Either Text Sample, [Msg], Note)
-> IO (Maybe Note)
makeSampleNote Payload -> IO ()
emitMessage Maybe InstrumentEffect
mbEffect))
        (forall a b. [a] -> [b] -> [(a, b)]
zip (X
0 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b}. (a, b, Note) -> X
start [(Either Text Sample, [Msg], Note)]
converted) [(Either Text Sample, [Msg], Note)]
converted)
    where start :: (a, b, Note) -> X
start (a
_, b
_, Note
note) = Note -> X
Note.start Note
note

-- TODO do this incrementally?  A stream?
makeSampleNote :: (Config.Payload -> IO ())
    -> Maybe Render.InstrumentEffect
    -> RealTime
    -> (Either Error Sample.Sample, [Log.Msg], Note.Note)
    -> IO (Maybe Sample.Note)
makeSampleNote :: (Payload -> IO ())
-> Maybe InstrumentEffect
-> X
-> (Either Text Sample, [Msg], Note)
-> IO (Maybe Note)
makeSampleNote Payload -> IO ()
emitMessage Maybe InstrumentEffect
_ X
_ (Left Text
err, [Msg]
logs, Note
note) = do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
    Payload -> IO ()
emitMessage forall a b. (a -> b) -> a -> b
$ Stack -> Text -> Payload
Config.Warn (Note -> Stack
Note.stack Note
note) Text
err
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
makeSampleNote Payload -> IO ()
emitMessage Maybe InstrumentEffect
mbEffect X
prevStart (Right Sample
sample, [Msg]
logs, Note
note) = do
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). LogMonad m => Msg -> m ()
Log.write [Msg]
logs
    forall e a. Exception e => IO a -> IO (Either e a)
Exception.try (X -> Sample -> IO Frames
actualDuration (Note -> X
Note.start Note
note) Sample
sample) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left Exception
exc -> do
            Payload -> IO ()
emitMessage forall a b. (a -> b) -> a -> b
$
                Stack -> Text -> Payload
Config.Warn (Note -> Stack
Note.stack Note
note) (Exception -> Text
Audio.exceptionText Exception
exc)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Right Frames
dur | Frames
dur forall a. Ord a => a -> a -> Bool
<= Frames
0 -> do
            -- Omit samples with 0 duration.  This can happen naturally if they
            -- have 0 volume.
            Payload -> IO ()
emitMessage forall a b. (a -> b) -> a -> b
$ Stack -> Text -> Payload
Config.Warn (Note -> Stack
Note.stack Note
note)
                Text
"sample with <=0 duration"
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        -- The notes should have been sorted prior to serialization.
        Either Exception Frames
_ | Note -> X
Note.start Note
note forall a. Ord a => a -> a -> Bool
< X
prevStart -> do
            Payload -> IO ()
emitMessage forall a b. (a -> b) -> a -> b
$ Stack -> Text -> Payload
Config.Warn (Note -> Stack
Note.stack Note
note) forall a b. (a -> b) -> a -> b
$
                Text
"note start " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty (Note -> X
Note.start Note
note)
                forall a. Semigroup a => a -> a -> a
<> Text
" < previous " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty X
prevStart
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Right Frames
dur -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            Frames -> Frames -> Map Control Signal -> Sample -> Note
Sample.note Frames
start Frames
dur (Maybe InstrumentEffect -> Note -> Map Control Signal
effectControls Maybe InstrumentEffect
mbEffect Note
note) Sample
sample
            where
            -- Round the frame up.  Otherwise, since frames are integral, I
            -- might round a note to start before its signal, at which point I
            -- get an extraneous 0.
            start :: Frames
start = ChunkNum -> Y -> Frames
Audio.secondsToFramesCeil ChunkNum
Config.samplingRate
                (X -> Y
RealTime.to_seconds (Note -> X
Note.start Note
note))

effectControls :: Maybe Render.InstrumentEffect -> Note.Note
    -> Map Control.Control Signal.Signal
effectControls :: Maybe InstrumentEffect -> Note -> Map Control Signal
effectControls Maybe InstrumentEffect
Nothing Note
_ = forall a. Monoid a => a
mempty
effectControls (Just (Render.InstrumentEffect Patch
effect EffectConfig
config)) Note
note =
    forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.intersection (forall {a}. Map Control a -> Map Control a
rename (Note -> Map Control Signal
Note.controls Note
note)) (forall ptr cptr. EffectT ptr cptr -> Map Control (cptr, Text)
EffectC._controls Patch
effect)
    where
    rename :: Map Control a -> Map Control a
rename
        | forall k a. Map k a -> Bool
Map.null (EffectConfig -> Map Control Control
Patch._toEffectControl EffectConfig
config) = forall a. a -> a
id
        | Bool
otherwise = forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys forall a b. (a -> b) -> a -> b
$ \Control
c ->
            forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Control
c Control
c (EffectConfig -> Map Control Control
Patch._toEffectControl EffectConfig
config)

-- | It's important to get an accurate duration, because that determines
-- overlap, which affects caching.
actualDuration :: RealTime -> Sample.Sample -> IO Audio.Frames
actualDuration :: X -> Sample -> IO Frames
actualDuration X
start Sample
sample = do
    Frames
fileDur <- Y -> Signal -> NonNull Char -> IO Frames
RenderSample.predictFileDuration
        (Stretch -> Y
Sample.timeRatio (Sample -> Stretch
Sample.stretch Sample
sample))
        (forall {k} (kind :: k). X -> Signal kind -> Signal kind
Signal.shift (-X
start) (Sample -> Signal
Sample.ratios Sample
sample))
        (Sample -> NonNull Char
Sample.filename Sample
sample)
    let envDur :: Maybe Frames
envDur = X -> Frames
AUtil.toFrames forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            X -> Signal -> Maybe X
RenderSample.envelopeDuration X
start (Sample -> Signal
Sample.envelope Sample
sample)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe Frames
envDur of
        Just Frames
dur -> forall a. Ord a => a -> a -> a
min Frames
fileDur Frames
dur
        Maybe Frames
Nothing -> Frames
fileDur

realize :: (Config.Payload -> IO ()) -> Set Id.TrackId -> Render.Config
    -> FilePath -> ScoreT.Instrument -> Maybe Render.InstrumentEffect
    -> [Sample.Note] -> IO ()
realize :: (Payload -> IO ())
-> Set TrackId
-> Config
-> NonNull Char
-> Instrument
-> Maybe InstrumentEffect
-> [Note]
-> IO ()
realize Payload -> IO ()
emitMessage Set TrackId
trackIds Config
config NonNull Char
outputDir Instrument
instrument Maybe InstrumentEffect
mbEffect [Note]
notes = do
    let instDir :: NonNull Char
instDir = NonNull Char
outputDir NonNull Char -> NonNull Char -> NonNull Char
</> Instrument -> NonNull Char
Config.instrumentToDir Instrument
instrument
    Bool -> NonNull Char -> IO ()
Directory.createDirectoryIfMissing Bool
True NonNull Char
instDir
    (Either Text (ChunkNum, ChunkNum)
result, Text
elapsed) <- forall (m :: * -> *) a. MonadIO m => m a -> m (a, Text)
Thread.timeActionText forall a b. (a -> b) -> a -> b
$
        Config
-> NonNull Char
-> Set TrackId
-> Maybe InstrumentEffect
-> [Note]
-> IO (Either Text (ChunkNum, ChunkNum))
Render.write Config
config NonNull Char
instDir Set TrackId
trackIds Maybe InstrumentEffect
mbEffect [Note]
notes
    case Either Text (ChunkNum, ChunkNum)
result of
        Left Text
err -> do
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.error forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
pretty Instrument
instrument forall a. Semigroup a => a -> a -> a
<> Text
": writing " forall a. Semigroup a => a -> a -> a
<> NonNull Char -> Text
txt NonNull Char
instDir
                forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
err
            Payload -> IO ()
emitMessage forall a b. (a -> b) -> a -> b
$ Text -> Payload
Config.Failure Text
err
        Right (ChunkNum
rendered, ChunkNum
total) ->
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
pretty Instrument
instrument forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt ChunkNum
rendered forall a. Semigroup a => a -> a -> a
<> Text
"/"
                forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt ChunkNum
total forall a. Semigroup a => a -> a -> a
<> Text
" chunks: " forall a. Semigroup a => a -> a -> a
<> NonNull Char -> Text
txt NonNull Char
instDir
                forall a. Semigroup a => a -> a -> a
<> Text
" (" forall a. Semigroup a => a -> a -> a
<> Text
elapsed forall a. Semigroup a => a -> a -> a
<> Text
")"