-- Copyright 2017 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 synthesizer that uses FAUST.
module Synth.Faust.FaustIm (main) where
import qualified Control.Concurrent as Concurrent
import qualified Control.Concurrent.Async as Async
import qualified Control.Exception as Exception

import qualified Data.Either as Either
import qualified Data.Map as Map
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           System.FilePath ((</>))
import qualified System.IO as IO
import qualified System.Posix.Signals as Signals

import qualified Util.Lists as Lists
import qualified Util.Log as Log
import qualified Util.Num as Num
import qualified Util.Thread as Thread

import qualified Derive.ScoreT as ScoreT
import qualified Synth.Faust.EffectC as EffectC
import qualified Synth.Faust.InstrumentC as InstrumentC
import qualified Synth.Faust.Preview as Preview
import qualified Synth.Faust.Render as Render
import qualified Synth.Shared.Config as Config
import qualified Synth.Shared.Note as Note

import           Global


main :: IO ()
main :: IO ()
main = do
    [[Char]]
args <- IO [[Char]]
Environment.getArgs
    ([Flag]
flags, [[Char]]
args) <- case forall a.
ArgOrder a -> [OptDescr a] -> [[Char]] -> ([a], [[Char]], [[Char]])
GetOpt.getOpt forall a. ArgOrder a
GetOpt.Permute [OptDescr Flag]
options [[Char]]
args of
        ([Flag]
flags, [[Char]]
args, []) -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Flag]
flags, [[Char]]
args)
        ([Flag]
_, [[Char]]
_, [[Char]]
errs) -> forall a. [Char] -> IO a
usage forall a b. (a -> b) -> a -> b
$ [Char]
"flag errors:\n" forall a. [a] -> [a] -> [a]
++ forall a. Monoid a => a -> [a] -> a
Lists.join [Char]
", " [[Char]]
errs
    [Char]
logFname <- [Char] -> IO [Char]
Config.getLogFilename [Char]
"faust.log"
    Handle
logHdl <- [Char] -> IO Handle
Log.rotate [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 = Priority
Log.Notice
        }
    Map Text (Either Text Patch)
patches <- IO (Map Text (Either Text Patch))
InstrumentC.getPatches
    ThreadId
thread <- IO ThreadId
Concurrent.myThreadId
    -- Make sure I get some output if the process is killed.
    Signal -> Handler -> Maybe SignalSet -> IO Handler
Signals.installHandler Signal
Signals.sigTERM
        (IO () -> Handler
Signals.CatchOnce (ThreadId -> IO ()
Concurrent.killThread ThreadId
thread)) forall a. Maybe a
Nothing
    case [[Char]]
args of
        [[Char]
"print-effects"] ->
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList Map Text (Either Text Patch)
EffectC.patches) forall a b. (a -> b) -> a -> b
$ \(Text
name, Either Text Patch
epatch) -> do
                Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"=== " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" ==="
                case Either Text Patch
epatch of
                    Left Text
err -> Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"ERROR: " forall a. Semigroup a => a -> a -> a
<> Text
err
                    Right Patch
patch -> forall {ptr} {cptr}. EffectT ptr cptr -> IO ()
printEffect Patch
patch
                [Char] -> IO ()
putStrLn [Char]
""
        [[Char]
"print-patches"] -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList Map Text (Either Text Patch)
patches) forall a b. (a -> b) -> a -> b
$ \(Text
name, Either Text Patch
epatch) -> do
            Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"=== " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
" ==="
            case Either Text Patch
epatch of
                Left Text
err -> Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"ERROR: " forall a. Semigroup a => a -> a -> a
<> Text
err
                Right Patch
patch -> forall {ptr} {cptr}. PatchT ptr cptr -> IO ()
printPatch Patch
patch
            [Char] -> IO ()
putStrLn [Char]
""
        [[Char]
"print-patches", [Char]
patch] -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ([Char] -> Text
txt [Char]
patch) Map Text (Either Text Patch)
patches of
            Maybe (Either Text Patch)
Nothing -> Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"no patch: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
patch
            Just (Left Text
err) -> Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"ERROR: " forall a. Semigroup a => a -> a -> a
<> Text
err
            Just (Right Patch
patch) -> forall {ptr} {cptr}. PatchT ptr cptr -> IO ()
printPatch Patch
patch
        [[Char]
"render-preview", [Char]
patch] -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ([Char] -> Text
txt [Char]
patch) Map Text (Either Text Patch)
patches of
            Maybe (Either Text Patch)
Nothing -> forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO forall a b. (a -> b) -> a -> b
$ Text
"no such patch: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
patch
            Just (Left Text
err) -> forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO forall a b. (a -> b) -> a -> b
$ Text
"loading patch " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
patch forall a. Semigroup a => a -> a -> a
<> Text
": "
                forall a. Semigroup a => a -> a -> a
<> Text
err
            Just (Right Patch
patch) -> Patch -> IO ()
Preview.render Patch
patch
        [[Char]
"render-preview"] -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Patch -> IO ()
Preview.render forall a b. (a -> b) -> a -> b
$
            forall a b. [Either a b] -> [b]
Either.rights (forall k a. Map k a -> [a]
Map.elems Map Text (Either Text Patch)
patches)
        [[Char]
"dump", [Char]
notesFilename] -> do
            [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
=<< [Char] -> IO (Either UnserializeError [Note])
Note.unserialize [Char]
notesFilename
            Map Text Patch
patches <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO forall (f :: * -> *) a. Applicative f => a -> f a
pure) Map Text (Either Text Patch)
patches
            Map Text Patch -> [Note] -> IO ()
dump Map Text Patch
patches [Note]
notes
        [[Char]
notesFilename, [Char]
outputDir] -> do
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ [Text] -> Text
Text.unwords
                [Text
"faust-im", [Char] -> Text
txt [Char]
notesFilename, [Char] -> Text
txt [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
=<< [Char] -> IO (Either UnserializeError [Note])
Note.unserialize [Char]
notesFilename
            Map Text Patch
patches <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. (Stack, MonadIO m) => Text -> m a
errorIO forall (f :: * -> *) a. Applicative f => a -> f a
pure) Map Text (Either Text Patch)
patches
            Bool -> Map Text Patch -> [Note] -> [Char] -> IO ()
process (Flag
Progress forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Flag]
flags) Map Text Patch
patches [Note]
notes [Char]
outputDir
        [[Char]]
_ -> forall a. [Char] -> IO a
usage [Char]
""
    where
    printPatch :: PatchT ptr cptr -> IO ()
printPatch PatchT ptr cptr
patch = do
        Text -> IO ()
put forall a b. (a -> b) -> a -> b
$ forall ptr cptr. PatchT ptr cptr -> Text
InstrumentC._doc PatchT ptr cptr
patch
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall ptr cptr. PatchT ptr cptr -> Bool
InstrumentC._impulseGate PatchT ptr cptr
patch) forall a b. (a -> b) -> a -> b
$
            Text -> IO ()
put Text
"flags: impulse-gate"
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall ptr cptr. PatchT ptr cptr -> [(Control, ControlConfig)]
InstrumentC._inputControls PatchT ptr cptr
patch) forall a b. (a -> b) -> a -> b
$ \(Control
c, ControlConfig
config) ->
            Text -> IO ()
put forall a b. (a -> b) -> a -> b
$ Text
"input: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Control
c forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty ControlConfig
config
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList (forall ptr cptr.
PatchT ptr cptr -> Map Control (cptr, ControlConfig)
InstrumentC._controls PatchT ptr cptr
patch)) forall a b. (a -> b) -> a -> b
$ \(Control
c, (cptr
_, ControlConfig
config)) ->
            Text -> IO ()
put forall a b. (a -> b) -> a -> b
$ Text
"control: " forall a. Semigroup a => a -> a -> a
<> Control -> Text
showControl Control
c forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty ControlConfig
config
    printEffect :: EffectT ptr cptr -> IO ()
printEffect EffectT ptr cptr
patch = do
        Text -> IO ()
put forall a b. (a -> b) -> a -> b
$ forall ptr cptr. EffectT ptr cptr -> Text
EffectC._doc EffectT ptr cptr
patch
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
Map.toList (forall ptr cptr. EffectT ptr cptr -> Map Control (cptr, Text)
EffectC._controls EffectT ptr cptr
patch)) forall a b. (a -> b) -> a -> b
$ \(Control
c, (cptr
_, Text
doc)) ->
            Text -> IO ()
put forall a b. (a -> b) -> a -> b
$ Text
"control: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Control
c forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
doc
    put :: Text -> IO ()
put = Text -> IO ()
Text.IO.putStrLn

usage :: String -> IO a
usage :: forall a. [Char] -> IO a
usage [Char]
msg = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
msg) forall a b. (a -> b) -> a -> b
$
        [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"ERROR: " forall a. [a] -> [a] -> [a]
++ [Char]
msg
    [Char] -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> [OptDescr a] -> [Char]
GetOpt.usageInfo [Char]
"faust-im [ flags ] <cmd>" [OptDescr Flag]
options
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Char] -> IO ()
putStrLn
        [ [Char]
"  print-effects"
        , [Char]
"  print_patches [ <patch-name> ]"
        , [Char]
"  render-preview [ <patch-name> ]"
        , [Char]
"  dump <filename>"
        , [Char]
"  <notes-filename> <output-dir>"
        ]
    forall a. IO a
Exit.exitFailure

data Flag = 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, Int -> Flag -> ShowS
[Flag] -> ShowS
Flag -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Flag] -> ShowS
$cshowList :: [Flag] -> ShowS
show :: Flag -> [Char]
$cshow :: Flag -> [Char]
showsPrec :: Int -> Flag -> ShowS
$cshowsPrec :: Int -> Flag -> ShowS
Show)

options :: [GetOpt.OptDescr Flag]
options :: [OptDescr Flag]
options =
    [ forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
GetOpt.Option [] [[Char]
"progress"] (forall a. a -> ArgDescr a
GetOpt.NoArg Flag
Progress) [Char]
"emit json progress"
    ]

showControl :: InstrumentC.Control -> Text
showControl :: Control -> Text
showControl (Text
"", Control
c) = forall a. Pretty a => a -> Text
pretty Control
c
showControl (Text
elt, Control
c) = Text
elt forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Control
c

dump :: Map Note.PatchName InstrumentC.Patch -> [Note.Note] -> IO ()
dump :: Map Text Patch -> [Note] -> IO ()
dump Map Text Patch
patches [Note]
notes = do
    let ([Text]
notFound, [(Patch, [(Instrument, [Note])])]
patchInstNotes) = forall patch.
Map Text patch
-> [Note] -> ([Text], [(patch, [(Instrument, [Note])])])
lookupPatches Map Text Patch
patches [Note]
notes
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
notFound) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"patches not found: " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords [Text]
notFound
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(Patch, Instrument, [Note])]
-> [(Instrument, [(Text, [(Double, Double)])])]
extractBreakpoints forall a b. (a -> b) -> a -> b
$ forall {a} {b} {c}. [(a, [(b, c)])] -> [(a, b, c)]
flatten [(Patch, [(Instrument, [Note])])]
patchInstNotes) forall a b. (a -> b) -> a -> b
$ \(Instrument
inst, [(Text, [(Double, Double)])]
cbps) -> do
        Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"=== " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
pretty Instrument
inst forall a. Semigroup a => a -> a -> a
<> Text
":"
        -- TODO implement Texts.wrappedColumns to make it readable?  Or just
        -- use a wide window.
        -- mapM_ Text.IO.putStrLn $ Texts.columns 2 $
        --     map (map (fromMaybe "")) $ Lists.rotate2
        --         [ name : map showBp bps
        --         | (name, bps) <- cbps
        --         ]

        let maxlen :: Int
maxlen = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ Int
1 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Text -> Int
Text.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Text, [(Double, Double)])]
cbps
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, [(Double, Double)])]
cbps forall a b. (a -> b) -> a -> b
$ \(Text
control, [(Double, Double)]
bps) -> do
            Text -> IO ()
Text.IO.putStrLn forall a b. (a -> b) -> a -> b
$
                Int -> Char -> Text -> Text
Text.justifyLeft (Int
maxlenforall a. Num a => a -> a -> a
+Int
2) Char
' ' (Text
control forall a. Semigroup a => a -> a -> a
<> Text
":")
                forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords (forall a b. (a -> b) -> [a] -> [b]
map (Double, Double) -> Text
showBp [(Double, Double)]
bps)
    where
    showBp :: (Double, Double) -> Text
showBp (Double
x, Double
y) = Text
"(" forall a. Semigroup a => a -> a -> a
<> Double -> Text
showNum Double
x forall a. Semigroup a => a -> a -> a
<> Text
"," forall a. Semigroup a => a -> a -> a
<> Double -> Text
showNum Double
y forall a. Semigroup a => a -> a -> a
<> Text
")"
    showNum :: Double -> Text
showNum = forall a. RealFloat a => Int -> a -> Text
Num.showFloat Int
2
    flatten :: [(a, [(b, c)])] -> [(a, b, c)]
flatten [(a, [(b, c)])]
patchInstNotes =
        [ (a
patch, b
inst, c
notes)
        | (a
patch, [(b, c)]
instNotes) <- [(a, [(b, c)])]
patchInstNotes
        , (b
inst, c
notes) <- [(b, c)]
instNotes
        ]

extractBreakpoints
    :: [(InstrumentC.Patch, ScoreT.Instrument, [Note.Note])]
    -> [(ScoreT.Instrument, [(Text, [(Double, Double)])])]
extractBreakpoints :: [(Patch, Instrument, [Note])]
-> [(Instrument, [(Text, [(Double, Double)])])]
extractBreakpoints [(Patch, Instrument, [Note])]
patchInstNotes = 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)
    [(Instrument
inst, forall {ptr} {cptr}.
PatchT ptr cptr -> [Note] -> [(Text, [(Double, Double)])]
extract Patch
patch [Note]
notes) | (Patch
patch, Instrument
inst, [Note]
notes) <- [(Patch, Instrument, [Note])]
patchInstNotes]
    where
    extract :: PatchT ptr cptr -> [Note] -> [(Text, [(Double, Double)])]
extract PatchT ptr cptr
patch [Note]
notes =
        forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Text
pretty [Control]
inputNames) [[(Double, Double)]]
inputs
            forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Control -> Text
showControl) (forall k a. Map k a -> [(k, a)]
Map.toList Map Control [(Double, Double)]
controls)
        where
        inputs :: [[(Double, Double)]]
inputs = forall ptr cptr. PatchT ptr cptr -> [Note] -> [[(Double, Double)]]
Render.inputsBreakpoints PatchT ptr cptr
patch [Note]
notes
        controls :: Map Control [(Double, Double)]
controls = forall ptr cptr.
Frames
-> PatchT ptr cptr -> [Note] -> Map Control [(Double, Double)]
Render.controlsBreakpoints
            (Config -> Frames
Render._controlSize Config
Render.defaultConfig) PatchT ptr cptr
patch [Note]
notes
        inputNames :: [Control]
inputNames = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall ptr cptr. PatchT ptr cptr -> [(Control, ControlConfig)]
InstrumentC._inputControls PatchT ptr cptr
patch

process :: Bool -> Map Note.PatchName InstrumentC.Patch -> [Note.Note]
    -> FilePath -> IO ()
process :: Bool -> Map Text Patch -> [Note] -> [Char] -> IO ()
process Bool
emitProgress Map Text Patch
patches [Note]
notes [Char]
outputDir = do
    forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ Text
"processing " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Note]
notes) forall a. Semigroup a => a -> a -> a
<> Text
" notes"
    let ([Text]
notFound, [(Patch, [(Instrument, [Note])])]
patchInstNotes) = forall patch.
Map Text patch
-> [Note] -> ([Text], [(patch, [(Instrument, [Note])])])
lookupPatches Map Text Patch
patches [Note]
notes
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
notFound) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.warn forall a b. (a -> b) -> a -> b
$ Text
"patches not found: " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unwords [Text]
notFound
    -- Signals.installHandler above will make SIGINT throw.
    let async :: Exception.AsyncException -> IO ()
        async :: AsyncException -> IO ()
async AsyncException
exc = forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.error forall a b. (a -> b) -> a -> b
$ Text
"exception: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt AsyncException
exc
    forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Exception.handle AsyncException -> IO ()
async forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Foldable f => f a -> (a -> IO b) -> IO ()
Async.forConcurrently_ (forall {a} {b} {c}. [(a, [(b, c)])] -> [(a, b, c)]
flatten [(Patch, [(Instrument, [Note])])]
patchInstNotes) forall a b. (a -> b) -> a -> b
$
        \(Patch
patch, Instrument
inst, [Note]
notes) -> do
            let output :: [Char]
output = [Char]
outputDir [Char] -> ShowS
</> Instrument -> [Char]
Config.instrumentToDir Instrument
inst
            forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
pretty Instrument
inst forall a. Semigroup a => a -> a -> a
<> Text
" notes: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt (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
<> [Char] -> Text
txt [Char]
output
            Bool -> [Char] -> IO ()
Directory.createDirectoryIfMissing Bool
True [Char]
output
            -- Record the patch associated with this instrument.
            -- tools/clear_faust will use this to clear checkpoints whose patch
            -- has changed.  If the patch has changed but the instrument is the
            -- same, there will be multiple such files, but it's ok because
            -- clear_faust will just clear if any of them change.  Previously I
            -- encoded it into the directory name, but that prevents
            -- Config.clearUnusedInstruments from working when the instrument
            -- name remains the same but the patch name changed.
            [Char] -> IO ()
touch forall a b. (a -> b) -> a -> b
$ [Char]
output [Char] -> ShowS
</> Text -> [Char]
untxt (forall ptr cptr. PatchT ptr cptr -> Text
InstrumentC._name Patch
patch)
            (Either Text (Int, Int)
result, Text
elapsed) <- forall (m :: * -> *) a. MonadIO m => m a -> m (a, Text)
Thread.timeActionText forall a b. (a -> b) -> a -> b
$
                Config
-> [Char]
-> Set TrackId
-> Patch
-> [Note]
-> IO (Either Text (Int, Int))
Render.write Config
config [Char]
output
                    (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Note -> Maybe TrackId
Note.trackId [Note]
notes) Patch
patch [Note]
notes
            case Either Text (Int, Int)
result of
                Left Text
err -> forall (m :: * -> *). (Stack, LogMonad m) => Text -> m ()
Log.notice forall a b. (a -> b) -> a -> b
$
                    forall a. Pretty a => a -> Text
pretty Instrument
inst forall a. Semigroup a => a -> a -> a
<> Text
" writing " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
output forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
err
                Right (Int
rendered, Int
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
inst forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
rendered forall a. Semigroup a => a -> a -> a
<> Text
"/"
                        forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
showt Int
total forall a. Semigroup a => a -> a -> a
<> Text
" chunks: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
txt [Char]
output
                        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
")"
    where
    config :: Config
config = Config
Render.defaultConfig
        { _emitProgress :: Bool
Render._emitProgress = Bool
emitProgress }
    flatten :: [(a, [(b, c)])] -> [(a, b, c)]
flatten [(a, [(b, c)])]
patchInstNotes =
        [ (a
patch, b
inst, c
notes)
        | (a
patch, [(b, c)]
instNotes) <- [(a, [(b, c)])]
patchInstNotes
        , (b
inst, c
notes) <- [(b, c)]
instNotes
        ]

touch :: FilePath -> IO ()
touch :: [Char] -> IO ()
touch [Char]
fname = forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
IO.withFile [Char]
fname IOMode
IO.WriteMode (forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ()))

lookupPatches :: Map Note.PatchName patch -> [Note.Note]
    -> ([Note.PatchName], [(patch, [(ScoreT.Instrument, [Note.Note])])])
lookupPatches :: forall patch.
Map Text patch
-> [Note] -> ([Text], [(patch, [(Instrument, [Note])])])
lookupPatches Map Text patch
patches [Note]
notes =
    forall a b. [Either a b] -> ([a], [b])
Either.partitionEithers forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (\(Text
patch, [(Instrument, [Note])]
instNotes) -> (, [(Instrument, [Note])]
instNotes) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text patch
find Text
patch) forall a b. (a -> b) -> a -> b
$
        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 a b. (a -> b) -> a -> b
$
        forall key a. Ord key => (a -> key) -> [a] -> [(key, [a])]
Lists.keyedGroupSort Note -> Text
Note.patch [Note]
notes
    where
    find :: Text -> Either Text patch
find Text
patch = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left Text
patch) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
patch Map Text patch
patches


{- NOTE [merge-sampler-faust]

    I decided against doing this and instead augment sampler-im with faust
    effects.  Here are the old notes:

    / First extend faust-im to be an Audio processor, so it can take inputs.
      . I wind up with separate generator and transformers.
      . A generator goes until env goes to 0 and the signal decays to -96dB
      . A transformer goes until the source signal runs out and the signal
        decays to -96dB.
      . Or they all go forever, and the consumer stops when the score runs out
        and -96dB.  But then I don't stop instruments that actually do stop,
        so let's not.
      . So in the transformer I need to keep the audio inputs separate, since
        the control inputs are zero padded out forever.
      . Or I can zero-pad only controls, and when I run out inputs flip
        a switch to watch for -96dB.
      . No that doesn't work, because it's one NAudio, so they all end
        together.  And I can't make controls end with the input signal.
        I need some explicit signal.
      . If the input is a sample, it has a definite end.  In fact, I could
        supply it ahead of time.
      . So transformer render gets an explicit end.
    . Integrate sampler-im's multiple voice ability with faust.
    . Patches now have to define a signal network, but it can probably be
      hardcoded to 'sampler -> faust' or just 'faust'.
    . I'd need some routing so I can get signals to those processors.
    . Later I'll want to integrate my own synth as well.  I guess as long as
      it produces an audio stream it's fine.
    . Does this mean everything goes into one binary?  I think so, unless
      I want to reinvent plugins.
    . In that case, do I still want to divide up notes files?  I think
      I should, because then I get better caching.  That also implies
      running multiple copies of im?  Actually there's no need, just have it
      read all the note files in the directory.
    . In that case, should I split up by instrument?  I think I already have
      to do the work when I split im from non-im events.
    Actually, merge faust and sampler before doing audio transformer.
      . How does multiple vs. single voice stuff work?
      . Multiple means it allocates a new instrument for each note, which is
        how the sampler does it.  Mono mode for sampler wouldn't make so much
        sense because each note can be a different sample, at which point the
        resample state no longer applies.
      . For faust, I could just build it into instruments.  Do all-mono for
        now.
      . Should I serialize to different files, or split them up in the
        sampler?  How about split by patch?
      . I guess there isn't any big reason to split into separate files, but
        I have to split anyway to separate im from non-im, and since there
        will be only one synth, I might as well split by instrument.  Then the
        synth doesn't have to split, it just evaluates everything in the
        directory in parallel.  I have to delete the existing contents
        though... at least with a single file I can replace it atomically.
        But I already have this problem with synth-per-file, I just haven't
        noticed it because I don't really use faust.  And deleting seems like
        not a huge problem.
    . Another reason is to unify Render.write.
    . Another is to have a per-note allocation mode for faust.
    Minimal necessary to merge:
      . One binary with one PatchDb has to have both kinds of patches.
        Ultimately I want to merge to one patch, and faust and the sampler
        become signal generators.
      . They should both use the same Render.write loop.
    Differences:
      . Faust has only one audio generator per instrument, and voices are
        implemented as Note.element.  The audio generator runs constantly, so
        all notes are merged into a set of signals.  There is only one state.
      . Meanwhile, the sampler has a separate audio generator for each note.
        Each one has its own state and independent set of controls.
-}